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.