File Coverage

blib/lib/Digest/ssdeep.pm

Criterion	Covered	Total	%
statement	135	144	93.7
branch	31	36	86.1
condition	12	17	70.5
subroutine	22	23	95.6
pod	4	4	100.0
total	204	224	91.0

package Digest::ssdeep;

use warnings;
use strict;
use Carp;
use Text::WagnerFischer qw/distance/;
use List::Util qw/max/;

use version;
our $VERSION = qv('0.9.3');

BEGIN {
    require Exporter;
    use vars qw(@ISA @EXPORT_OK);
    @ISA       = qw(Exporter);
    @EXPORT_OK = qw(
      ssdeep_hash
      ssdeep_hash_file
      ssdeep_compare
      ssdeep_dump_last
    );
}

use constant FNV_PRIME  => 0x01000193;
use constant FNV_INIT   => 0x28021967;
use constant MAX_LENGTH => 64;

# Weights:
#  same                = 0
#  insertion/deletion  = 1
#  mismatch            = 2
#  swap                = N/A (should be 5)
$Text::WagnerFischer::REFC = [ 0, 1, 2 ];

my @b64 = split '',
  "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/";
my @DEBUG_LAST;

my @last7chars;    # will use character 7 places before
{                  # begin rolling hash internals

    my $roll_h1;    # rolling hash internal
    my $roll_h2;    # rolling hash internal
    my $roll_h3;    # rolling hash internal

    # Resets the roll hash internal status
    sub _reset_rollhash {
        @last7chars =
          ( 0, 0, 0, 0, 0, 0, 0 );    # will use character 7 places before
        $roll_h1 = 0;
        $roll_h2 = 0;
        $roll_h3 = 0;
    }

    # Updates rolling_hash's internal state and return the rolling_hash value.
    # Parameters: the next character.
    # Returns: the actual rolling hash value
    sub _roll_hash {
        my $char    = shift;
        my $char7bf = shift @last7chars;

        push @last7chars, $char;

        $roll_h2 += 7 * $char - $roll_h1;
        $roll_h1 += $char - $char7bf;

        $roll_h3 <<= 5;    # 5*7 = 35 (so it vanish after 7 iterations)
        $roll_h3 &= 0xffffffff;
        $roll_h3 ^= $char;

        #printf("c=%d  cAnt=%d    H1=%u  H2=%u  H3=%u\n",
        #	$char, $char7bf,
        #	$roll_h1, $roll_h2, $roll_h3);

        return $roll_h1 + $roll_h2 + $roll_h3;
    }

}    # end rolling hash internals

# In-place updates the FNV hash using the new character
# _update_fnv($fnvhash, $newchar);
sub _update_fnv {
    use integer;    # we need integer overflow in multiplication
    $_[0] *= FNV_PRIME;
    $_[0] &= 0xffffffff;
    $_[0] ^= $_[1];
    no integer;
}

# Calculates initial blocksize
# Parameter: the length of the whole data
sub _calc_initbs {
    my $length = shift;

    # MAX_LENGTH * bs < length
    # MAX_LENGTH * 3 * 2 * 2 * 2 * ... < length
    #my $n = int(log($length / (MAX_LENGTH * 3)) / log(2));
    #my $bs = 3 * 2**$n;
    my $bs = 3;
    $bs *= 2 while ( $bs * MAX_LENGTH < $length );

    return $bs > 3 ? $bs : 3;
}

# Calculates the ssdeep fuzzy hash of a string
# Parameters: the string
# Returns: the fuzzy hash in string or array
sub ssdeep_hash {
    my $string = shift;

    return unless defined $string;

    my $bs = _calc_initbs( length $string );
    @DEBUG_LAST = ();

    my $hash1;
    my $hash2;

    while (1) {
        _reset_rollhash();
        my $fnv1 = FNV_INIT;    # traditional hash blocksize
        my $fnv2 = FNV_INIT;    # traditional hash 2*blocksize

        $hash1 = '';
        $hash2 = '';

        for my $i ( 0 .. length($string) - 1 ) {
            my $c = ord( substr( $string, $i, 1 ) );

            #printf("c: %u, H1=%x\tH2=%x\n", $c, $fnv1, $fnv2);

            my $h = _roll_hash($c);
            _update_fnv( $fnv1, $c );    # blocksize FNV hash
            _update_fnv( $fnv2, $c );    # 2* blocksize FNV hash

            if ( $h % $bs == ( $bs - 1 ) and length $hash1 < MAX_LENGTH - 1 ) {

                #printf "Hash $h Trigger 1 at $i\n";
                my $b64char = $b64[ $fnv1 & 63 ];
                $hash1 .= $b64char;

                push @DEBUG_LAST,
                  [ 1, $i + 1, join( '|', @last7chars ), $fnv1, $b64char ];

                $fnv1 = FNV_INIT;

            }

            if ( $h % ( 2 * $bs ) == ( 2 * $bs - 1 )
                and length $hash2 < MAX_LENGTH / 2 - 1 )
            {

                #printf "Hash $h Trigger 2 at $i\n";
                my $b64char = $b64[ $fnv2 & 63 ];
                $hash2 .= $b64char;

                push @DEBUG_LAST,
                  [ 2, $i + 1, join( '|', @last7chars ), $fnv2, $b64char ];

                $fnv2 = FNV_INIT;
            }

        }

        $hash1 .= $b64[ $fnv1 & 63 ];
        $hash2 .= $b64[ $fnv2 & 63 ];

        push @DEBUG_LAST,
          [
            1, length($string),
            join( '|', @last7chars ), $fnv1,
            $b64[ $fnv1 & 63 ]
          ];

        push @DEBUG_LAST,
          [
            2, length($string),
            join( '|', @last7chars ), $fnv2,
            $b64[ $fnv2 & 63 ]
          ];

        last if $bs <= 3 or length $hash1 >= MAX_LENGTH / 2;

        $bs = int( $bs / 2 ); # repeat with half blocksize if no enough triggers
        $bs > 3 or $bs = 3;
    }

    my @outarray = ( $bs, $hash1, $hash2 );
    return wantarray ? @outarray : join ':', @outarray;
}

# Convenient function. Slurps file. You should not use it for long files.
# You should not use pure perl implementation for long files anyway.
# Parameter: filename
# Returns: ssdeep hash in string or array format
sub ssdeep_hash_file {
    my $file = shift;

    # Slurp the file (we can also use File::Slurp
    local ($/);
    open( my $fh, '<', $file ) or return;
    my $string = <$fh>;
    close $fh;

    return ssdeep_hash($string);
}

# Determines the longest common substring
sub _lcss {
    my $strings = join "\0", @_;
    my $lcs = '';

    for my $n ( 1 .. length $strings ) {
        my $re = "(.{$n})" . '.*\0.*\1' x ( @_ - 1 );
        last unless $strings =~ $re;
        $lcs = $1;
    }

    return $lcs;
}

# Calculates how similar two strings are using the Wagner-Fischer package.
# Parameters: min_lcs, string A, string B
# Returns: the likeliness being 0 totally dissimilar and 100 same string
# Returns 0 also if the longest common substring is shorter than min_lcs
sub _likeliness {
    my ( $min_lcs, $a, $b ) = @_;

    return 0 unless length( _lcss( $a, $b ) ) >= $min_lcs;

    my $dist = distance( $a, $b );

    #$DB::single = 2;

    # Must follow ssdeep original's code for compatibility
    #  $dist = 100 * $dist / (length($a) + length($b));
    $dist = int( $dist * MAX_LENGTH / ( length($a) + length($b) ) );
    $dist = int( 100 * $dist / 64 );

    $dist > 100 and $dist = 100;
    return 100 - $dist;
}

# We accept hash in both array and scalar format
# Parameters: $hashA, $hashB, [$min_lcs]
# Parameters: \@hashA, \@hashB, [$min_lcs]
# Returns: file matching in %
sub ssdeep_compare {
    my @hashA;    # hash = bs:hash1:hash2
    my @hashB;    # hash = bs:hash1:hash2
    @hashA = ref( $_[0] ) eq 'ARRAY' ? @{ $_[0] } : split ':', $_[0];
    @hashB = ref( $_[1] ) eq 'ARRAY' ? @{ $_[1] } : split ':', $_[1];
    my $min_lcs = $_[2] || 7;

    if ( @hashA != 3 or $hashA[0] !~ /\d+/ ) {
        carp "Argument 1 is not a ssdeep hash.";
        return;
    }

    if ( @hashB != 3 or $hashB[0] !~ /\d+/ ) {
        carp "Argument 2 is not a ssdeep hash.";
        return;
    }

    # Remove sequences of more than three repeated character
    s/(.)\1{3,}/$1/gi for @hashA;
    s/(.)\1{3,}/$1/gi for @hashB;

    # Remove trailing newlines
    s/\s+$//gi for @hashA;
    s/\s+$//gi for @hashB;

    #$DB::single = 2;

    my $like;

    # Blocksize comparison
    # bsA:hash_bsA:hash_2*bsA
    # bsB:hash_bsB:hash_2*bsB
    if ( $hashA[0] == $hashB[0] ) {

        # Compare both hashes
        my $like1 = _likeliness( $min_lcs, $hashA[1], $hashB[1] );
        my $like2 = _likeliness( $min_lcs, $hashA[2], $hashB[2] );
        $like = max( $like1, $like2 );
    }
    elsif ( $hashA[0] == 2 * $hashB[0] ) {

        # Compare hash_bsA with hash_2*bsB
        $like = _likeliness( $min_lcs, $hashA[1], $hashB[2] );
    }
    elsif ( 2 * $hashA[0] == $hashB[0] ) {

        # Compare hash_2*bsA with hash_bsB
        $like = _likeliness( $min_lcs, $hashA[2], $hashB[1] );
    }
    else {

        # Nothing suitable to compare, sorry
        return 0;
    }

    return $like;
}

# Dump internals information. See help.
sub ssdeep_dump_last {
    my @result;
    for (@DEBUG_LAST) {
        push @result, join ",", @{$_};
    }
    return @result;
}

1;    # Magic true value required at end of module
__END__