unit uPassStrength;
interface
type
TPassphraseStrength = ( psVeryWeak, psWeak, psGood, psStrong, psVeryStrong );
TPassphraseInfo = record
Length : integer;
AlphaUC : integer;
AlphaLC : integer;
Number : integer;
Symbol : integer;
MidChar : integer;
Requirements : integer;
AlphasOnly : integer;
NumbersOnly : integer;
UnqChar : integer;
RepChar : integer;
RepInc : Extended;
ConsecAlphaUC : integer;
ConsecAlphaLC : integer;
ConsecNumber : integer;
ConsecSymbol : integer;
ConsecCharType : integer;
SeqAlpha : integer;
SeqNumber : integer;
SeqSymbol : integer;
SeqChar : integer;
ReqChar : integer;
MultConsecCharType : integer;
function Score : integer;
function ScoreStr : string;
function Strength : TPassphraseStrength;
procedure Clear;
end;
procedure PassphraseAnalyseEx( const Password : string; out PassphraseInfo : TPassphraseInfo );
function PassphraseScore( const Password : string ) : integer;
function PassphraseStrength( const Password : string ) : TPassphraseStrength;
implementation
uses
SysUtils, Math;
function StringReverse( const Str : string ) : string;
var
idx : integer;
begin
Result := '';
for idx := 1 to Length( Str ) do
Result := Str[ idx ] + Result;
end;
procedure PassphraseAnalyseEx( const Password : string; out PassphraseInfo : TPassphraseInfo );
const
AlphasUC = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ';
AlphasLC = 'abcdefghijklmnopqrstuvwxyz';
Alphas = 'abcdefghijklmnopqrstuvwxyz';
Numerics = '0123456789';
Symbols = ')!@#$%^&*()';
MinLength = 8;
MinAlphaUC = 1;
MinAlphaLC = 1;
MinNumber = 1;
MinSymbol = 1;
var
a : integer;
TmpAlphaUC, TmpAlphaLC, TmpNumber, TmpSymbol : integer;
b : integer;
CharExists : Boolean;
S : integer;
Fwd, Rev : string;
pwd : string;
begin
// Initialisierung
TmpAlphaUC := 0;
TmpAlphaLC := 0;
TmpNumber := 0;
TmpSymbol := 0;
pwd := StringReplace( Password, ' ', '', [ rfReplaceAll ] );
PassphraseInfo.Clear;
PassphraseInfo.Length := Length( pwd );
// Durchsuche das Passwort nach Symbolen, Nummern, Groß- und Kleinschreibung
for a := 1 to Length( pwd ) do
begin
// Großbuchstaben
if Pos( pwd[ a ], AlphasUC ) >= 1 then
begin
if ( TmpAlphaUC > 0 ) then
begin
if ( TmpAlphaUC + 1 = a ) then
begin
inc( PassphraseInfo.ConsecAlphaUC );
inc( PassphraseInfo.ConsecCharType );
end;
end;
TmpAlphaUC := a;
inc( PassphraseInfo.AlphaUC );
end
// Kleinbuchstaben
else if Pos( pwd[ a ], AlphasLC ) >= 1 then
begin
if ( TmpAlphaLC > 0 ) then
begin
if ( TmpAlphaLC + 1 = a ) then
begin
inc( PassphraseInfo.ConsecAlphaLC );
inc( PassphraseInfo.ConsecCharType );
end;
end;
TmpAlphaLC := a;
inc( PassphraseInfo.AlphaLC );
end
// Ziffern
else if Pos( pwd[ a ], Numerics ) >= 1 then
begin
if ( a > 1 ) and ( a < Length( pwd ) ) then
inc( PassphraseInfo.MidChar );
if ( TmpNumber > 0 ) then
begin
if ( TmpNumber + 1 = a ) then
begin
inc( PassphraseInfo.ConsecNumber );
inc( PassphraseInfo.ConsecCharType );
end;
end;
TmpNumber := a;
inc( PassphraseInfo.Number );
end
// Symbole
else if Pos( pwd[ a ], AlphasLC + AlphasUC + Numerics ) < 1 then
begin
if ( a > 1 ) and ( a < Length( pwd ) ) then
inc( PassphraseInfo.MidChar );
if ( TmpSymbol > 0 ) then
begin
if ( TmpSymbol + 1 = a ) then
begin
inc( PassphraseInfo.ConsecSymbol );
inc( PassphraseInfo.ConsecCharType );
end;
end;
TmpSymbol := a;
inc( PassphraseInfo.Symbol );
end;
// Doppelte Zeichen prüfen
CharExists := False;
for b := 1 to Length( pwd ) do
if ( a <> b ) and ( pwd[ a ] = pwd[ b ] ) then
begin
CharExists := true;
PassphraseInfo.RepInc := PassphraseInfo.RepInc + ( Length( pwd ) / Abs( b - a ) );
end;
if CharExists then
begin
inc( PassphraseInfo.RepChar );
PassphraseInfo.UnqChar := Length( pwd ) - PassphraseInfo.RepChar;
if PassphraseInfo.UnqChar <> 0 then
PassphraseInfo.RepInc := Ceil( PassphraseInfo.RepInc / PassphraseInfo.UnqChar )
else
PassphraseInfo.RepInc := Ceil( PassphraseInfo.RepInc );
end;
end; // for a := 1 to Length( pwd ) do
for S := 1 to Length( Alphas ) - 2 do
begin
Fwd := Copy( Alphas, S, 3 );
Rev := StringReverse( Fwd );
if ( Pos( Fwd, LowerCase( pwd ) ) >= 1 ) or ( Pos( Rev, LowerCase( pwd ) ) >= 1 ) then
begin
inc( PassphraseInfo.SeqAlpha );
inc( PassphraseInfo.SeqChar );
end;
end;
for S := 1 to Length( Numerics ) - 2 do
begin
Fwd := Copy( Numerics, S, 3 );
Rev := StringReverse( Fwd );
if ( Pos( Fwd, LowerCase( pwd ) ) >= 1 ) or ( Pos( Rev, LowerCase( pwd ) ) >= 1 ) then
begin
inc( PassphraseInfo.SeqNumber );
inc( PassphraseInfo.SeqChar );
end;
end;
for S := 1 to Length( Symbols ) - 2 do
begin
Fwd := Copy( Symbols, S, 3 );
Rev := StringReverse( Fwd );
if ( Pos( Fwd, LowerCase( pwd ) ) >= 1 ) or ( Pos( Rev, LowerCase( pwd ) ) >= 1 ) then
begin
inc( PassphraseInfo.SeqSymbol );
inc( PassphraseInfo.SeqChar );
end;
end;
if ( PassphraseInfo.AlphaLC + PassphraseInfo.AlphaUC > 0 ) and ( PassphraseInfo.Symbol = 0 ) and
( PassphraseInfo.Number = 0 ) then
PassphraseInfo.AlphasOnly := Length( pwd );
if ( PassphraseInfo.AlphaLC + PassphraseInfo.AlphaUC = 0 ) and ( PassphraseInfo.Symbol = 0 ) and
( PassphraseInfo.Number > 0 ) then
PassphraseInfo.NumbersOnly := Length( pwd );
if ( PassphraseInfo.Length > 0 ) and ( PassphraseInfo.Length >= MinLength ) then
inc( PassphraseInfo.ReqChar );
if ( PassphraseInfo.AlphaUC > 0 ) and ( PassphraseInfo.AlphaUC >= MinAlphaUC ) then
inc( PassphraseInfo.ReqChar );
if ( PassphraseInfo.AlphaLC > 0 ) and ( PassphraseInfo.AlphaLC >= MinAlphaLC ) then
inc( PassphraseInfo.ReqChar );
if ( PassphraseInfo.Number > 0 ) and ( PassphraseInfo.Number >= MinNumber ) then
inc( PassphraseInfo.ReqChar );
if ( PassphraseInfo.Symbol > 0 ) and ( PassphraseInfo.Symbol >= MinSymbol ) then
inc( PassphraseInfo.ReqChar );
PassphraseInfo.Requirements := PassphraseInfo.ReqChar;
end;
function PassphraseScore( const Password : string ) : integer;
var
pi : TPassphraseInfo;
begin
PassphraseAnalyseEx( Password, pi );
Result := pi.Score;
end;
function PassphraseStrength( const Password : string ) : TPassphraseStrength;
var
pi : TPassphraseInfo;
begin
PassphraseAnalyseEx( Password, pi );
Result := pi.Strength;
end;
{ TPassphraseInfo }
procedure TPassphraseInfo.Clear;
begin
Length := 0;
AlphaUC := 0;
AlphaLC := 0;
Number := 0;
Symbol := 0;
MidChar := 0;
Requirements := 0;
AlphasOnly := 0;
NumbersOnly := 0;
UnqChar := 0;
RepChar := 0;
RepInc := 0;
ConsecAlphaUC := 0;
ConsecAlphaLC := 0;
ConsecNumber := 0;
ConsecSymbol := 0;
ConsecCharType := 0;
SeqAlpha := 0;
SeqNumber := 0;
SeqSymbol := 0;
SeqChar := 0;
ReqChar := 0;
MultConsecCharType := 0;
end;
function TPassphraseInfo.Score : integer;
const
MultLength = 4;
MultRepChar = 1;
MultMidChar = 2;
MultRequirements = 2;
MultConsecAlphaUC = 2;
MultConsecAlphaLC = 2;
MultConsecNumber = 2;
MultConsecCharType = 0;
MultConsecSymbol = 1;
MultAlphaUC = 2;
MultAlphaLC = 2;
MultSeqAlpha = 3;
MultSeqNumber = 3;
MultSeqSymbol = 3;
MultNumber = 4;
MultSymbol = 6;
begin
Result := 0;
// Additions
Result := Result + Length * MultLength;
if ( AlphaUC > 0 ) and ( AlphaUC < Length ) then
Result := Result + ( Length - AlphaUC ) * MultAlphaUC;
if ( AlphaLC > 0 ) and ( AlphaLC < Length ) then
Result := Result + ( Length - AlphaLC ) * MultAlphaLC;
if ( Number > 0 ) and ( Number < Length ) then
Result := Result + Number * MultNumber;
Result := Result + Symbol * MultSymbol;
Result := Result + MidChar * MultMidChar;
if Requirements > 3 then
Result := Result + Requirements * MultRequirements;
// Deducations
Result := Result - AlphasOnly;
Result := Result - NumbersOnly;
Result := Result - Trunc( RepInc );
Result := Result - ConsecAlphaUC * MultConsecAlphaUC;
Result := Result - ConsecAlphaLC * MultConsecAlphaLC;
Result := Result - ConsecNumber * MultConsecNumber;
Result := Result - SeqAlpha * MultSeqAlpha;
Result := Result - SeqNumber * MultSeqNumber;
Result := Result - SeqSymbol * MultSeqSymbol;
if Result > 100 then
Result := 100
else if Result < 0 then
Result := 0;
end;
function TPassphraseInfo.ScoreStr : string;
begin
case Strength of
psVeryWeak :
Result := 'sehr schwach';
psWeak :
Result := 'schwach';
psGood :
Result := 'gut';
psStrong :
Result := 'stark';
psVeryStrong :
Result := 'sehr stark';
end;
end;
function TPassphraseInfo.Strength : TPassphraseStrength;
var
sc : integer;
begin
sc := Score;
if sc >= 80 then
Result := psVeryStrong
else if sc >= 60 then
Result := psStrong
else if sc >= 40 then
Result := psGood
else if sc >= 20 then
Result := psWeak
else
Result := psVeryWeak;
end;
end.