File Coverage

blib/lib/Code/DRY.pm

Criterion	Covered	Total	%
statement	175	194	90.2
branch	61	78	78.2
condition	34	51	66.6
subroutine	17	21	80.9
pod	13	13	100.0
total	300	357	84.0

package Code::DRY;

use 5.008000;
use strict;
use warnings;
use integer;

require Exporter;

our @ISA = qw(Exporter);

our %EXPORT_TAGS = (
    'all' => [
        qw(

            )
    ]
);

our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );

our @EXPORT = qw(

);

our $VERSION = '0.03';

require XSLoader;
XSLoader::load( 'Code::DRY', $VERSION );

# Preloaded methods go here.

my @files;
our ( @fileoffsets, @file_lineoffsets );

my $codetotal;
my $verbose = 0;

# reporting
# $minlength is the filter criterion for duplicates to report
# $units is currently either 'bytes' or 'lines'.
# $rDups point to an array with an entry for duplication
# The entry is an array with the following entries
#  [
#  0: filename,
#  1: offset of start of file,
#  2: line number of start,
#  3: line number of end,
#  4: offset of line start,
#  5: offset of line end,
#  6: offset start,
#  7: offset end
#  ]
my $default_callback = sub {
    my ( $minlength, $units, $rDups ) = @_;

    # show dupes
    my $copies               = scalar @{$rDups} - 1;
    my $myamountlines        = $rDups->[0]->[3] - $rDups->[0]->[2] + 1;
    my $myamountbytesclipped = $rDups->[0]->[5] - $rDups->[0]->[4] + 1;
    my $myamountbytes        = $rDups->[0]->[7] - $rDups->[0]->[6] + 1;
    my $lengthstring
        = $units eq 'bytes'
        ? "$myamountbytes (>= $minlength $units) and $myamountlines complete lines"
        : "$myamountlines (>= $minlength $units) and $myamountbytesclipped bytes reduced to complete lines";
    print "$copies duplicate(s) found with a length of $lengthstring:\n";

    my $cnt = 1;
    for my $dup ( @{$rDups} ) {
        print "$cnt.  File: $dup->[0] in lines $dup->[2]..$dup->[3] (offsets ",
            $dup->[4] - $dup->[1], "..", $dup->[5] - $dup->[1], ")\n";
        ++$cnt;
    }

    $cnt = 1;
    for my $dup ( @{$rDups} ) {
        if (0) {
            print
                "offsets: clipped $dup->[4]--$dup->[5], raw $dup->[6]--$dup->[7]\n";
            print "lineends at: ";
            for my $j ( $dup->[2] - 1 .. $dup->[3] ) {
                print $dup->[1]
                    + $file_lineoffsets[ offset2fileindex( $dup->[6] ) ]
                    ->[ $j - 1 ], ' ';
            }
        }
        print "=================\n";

        my $offsetLineEnd;
        if ( $units eq 'bytes' ) {

            # begin at start of line
            my $linenumber      = offset2line( $dup->[6] );
            my $fileindex       = offset2fileindex( $dup->[6] );
            my $file_lineoffset = $file_lineoffsets[$fileindex];
            my $offsetLineBegin
                = $linenumber <= 1
                ? $dup->[1]
                : $dup->[1] + $file_lineoffset->[ $linenumber - 2 ] + 1;
            $offsetLineEnd
                = $dup->[1]
                + $file_lineoffset->[ $dup->[3]
                + ( $dup->[5] == $dup->[7] ? 0 : 1 ) ];

            if (   $offsetLineBegin > $dup->[6]
                || $dup->[6] > $dup->[7]
                || $dup->[7] > $offsetLineEnd )
            {
                warn
                    "\n\ninternal error: $offsetLineBegin, $dup->[4], $dup->[5], $offsetLineEnd, Zeilennummer $linenumber";
            }

            print substr( $codetotal, $offsetLineBegin,
                $dup->[6] - $offsetLineBegin );
            print " ==>>" if ( $units eq 'bytes' );
        }

        print substr( $codetotal, $dup->[4], $dup->[5] - $dup->[4] + 1 );
        print "<<== " if ( $units eq 'bytes' );

        if ( $units eq 'bytes' ) {
            print substr(
                $codetotal,
                $dup->[7] + 1,
                $offsetLineEnd - $dup->[7]
            ) if ( $dup->[7] + 1 < $offsetLineEnd );
        }

        # end at end of line
        print "\n=================\n";
        ++$cnt;
        last;    # makes not much sense to repeat identical parts
    }
};

my $callback = $default_callback;

sub set_default_reporter {
    $callback = $default_callback;
}

sub set_reporter {
    ($callback) = @_;
}

sub clearData {
    @files            = undef;
    $codetotal        = undef;
    @fileoffsets      = ();
    @file_lineoffsets = ();

    #  $SA = undef;
    #  $LCP = undef;
    __free_all();
}

sub report_dupes {
    my ( $minlength, $dups, $length, $matchentry ) = @_;

    my $units;
    if ( $minlength >= 0 ) {
        $units = 'lines';
    }
    else {
        $minlength = abs($minlength);
        $units     = 'bytes';
    }

    # get position info
    # and report via callback
    my @dups;
    for my $entry ( $matchentry .. $matchentry + $dups - 1 ) {
        my $offset_start = get_offset_at($entry);
        my $offset_end   = $offset_start + $length - 1;
        my $file_index   = offset2fileindex($offset_start);
        my $file_start
            = $file_index == 0 ? 0 : $fileoffsets[ $file_index - 1 ] + 1;

#print "$offset_start -> $offset_end => length ", $offset_end - $offset_start + 1, "\n";
        my ( $upLine, $downLine );
        offsetAndFileindex2line( $offset_start, $file_index, \$upLine );
        offsetAndFileindex2line( $offset_end, $file_index, undef,
            \$downLine );

        # in line mode clip to line start and line end
        my ( $offset_start_clipped, $offset_end_clipped );
        if ( $units eq 'lines' ) {
            $offset_start_clipped
                = $file_start
                + ( $upLine < 2
                ? 0
                : $file_lineoffsets[$file_index]->[ $upLine - 2 ] + 1 );
            $offset_end_clipped = $file_start
                + $file_lineoffsets[$file_index]->[ $downLine - 1 ];
        }
        else {
            $offset_start_clipped = $offset_start;
            $offset_end_clipped   = $offset_end;
        }
        push @dups,
            [
            offset2filename($offset_start), $file_start,
            $upLine,                        $downLine,
            $offset_start_clipped,          $offset_end_clipped,
            $offset_start,                  $offset_end
            ];
    }

    # sort by offset
    @dups = map { $_->[1] }
        sort { $a->[0] <=> $b->[0] } map { [ $_->[2], $_ ] } @dups;

    #print "\n";

    $callback->( $minlength, $units, \@dups );
}

# position to file and line number mapping
sub offset2filename {
    my $offset = shift;
    my $fi     = offset2fileindex($offset);
    if ( !defined $fi ) {
        return;
    }

    # support memory files
    if ( 'SCALAR' eq ref $files[$fi] ) {
        return "memfile$fi";
    }
    else {
        return $files[$fi];
    }
}

# file index is 0 based
sub offset2fileindex {
    my $offset = shift;
    my ( $l, $r ) = ( 0, $#fileoffsets );
    return 0 if ( 0 == $r );

    my $file = int( ( $r + $l ) / 2 );
    while ( $l < $r ) {

   #print "m=$file, l=$l, r=$r, fileoffset=$fileoffsets[$file] >= $offset?\n";

        return $file
            if (
            (   ( $file > 0 && $fileoffsets[ $file - 1 ] < $offset )
                || $file == 0
            )
            && $offset <= $fileoffsets[$file]
            );

        if ( $file > 0 && $fileoffsets[ $file - 1 ] >= $offset ) {
            $r = $file;
            $file = int( ( $r + $l ) / 2 );
        }
        else {
            $l = $file;
            $file = int( ( $r + $l + 1 ) / 2 );
        }
    }

    return undef;
}

#line number is 1 based
sub offsetAndFileindex2line {
    my ( $offset, $fileindex, $rRoundedUp_line, $rRoundedDown_line ) = @_;
    return if ( !defined $fileindex );

    my $base = $fileindex == 0 ? 0 : $fileoffsets[ $fileindex - 1 ] + 1;
    $offset -= $base;

    my $lineoffsets = $file_lineoffsets[$fileindex];
    my ( $l, $r ) = ( 0, $#{$lineoffsets} );
    if ( 0 == $r ) {
        if ( defined($rRoundedUp_line) ) {
            ${$rRoundedUp_line} = 0;
        }
        if ( defined($rRoundedDown_line) ) {
            ${$rRoundedDown_line} = 0;
        }
        return 0;
    }
    return 0 if ( 0 == $r );
    my $line = int( ( $r + $l ) / 2 );

    while ( $l < $r ) {
        if ((   ( $line > 0 && $lineoffsets->[ $line - 1 ] < $offset )
                || $line == 0
            )
            && $offset <= $lineoffsets->[$line]
            )
        {
            if ( defined($rRoundedDown_line) ) {
                ${$rRoundedDown_line}
                    = $line == 0 ? $line + 1
                    : ( $offset == ( $lineoffsets->[$line] ) ? $line + 1
                    : $line );
            }
            if ( defined($rRoundedUp_line) ) {
                ${$rRoundedUp_line}
                    = $offset
                    == ( $line == 0 ? 0 : $lineoffsets->[ $line - 1 ] + 1 )
                    ? $line + 1
                    : $line + 2;
            }
            return $line + 1;
        }

        if ( $line > 0 && $lineoffsets->[ $line - 1 ] >= $offset ) {
            $r = $line;
            $line = int( ( $r + $l ) / 2 );
        }
        else {
            $l = $line;
            $line = int( ( $r + $l + 1 ) / 2 );
        }
    }
    return;
}

# line number is 1 based
sub offset2line {
    my ( $offset, $rRoundedUp_line, $rRoundedDown_line ) = @_;
    my $fileindex = offset2fileindex($offset);
    return offsetAndFileindex2line( $offset, $fileindex, $rRoundedUp_line,
        $rRoundedDown_line );
}

sub get_line_offsets_of_fileindex {
    my $fileindex = shift;
    return $file_lineoffsets[$fileindex];
}

sub get_concatenated_text {
    my ( $start, $length ) = @_;
    return substr( $codetotal, $start, $length );
}

sub enter_files {
    (my $rfiles) = @_;

    # reset all info
    @fileoffsets = @file_lineoffsets = ();
    $codetotal = '';

    # preprocess files content
    my $here = 0;
    for my $file (@{$rfiles}) {
        if (-z $file) {
            splice @{$rfiles}, $here, 1;
            next;    # skip empty files
	}

        my ( $code, @lineoffsets ) = __get_text($file);
        if ($code eq '') {
            splice @{$rfiles}, $here, 1;
            next;    # skip empty files
	}

        # we need the length of $code
        $codetotal .= $code;
        push @fileoffsets, ( length $codetotal ) - 1;

        # save line offsets per file
        push @file_lineoffsets, [@lineoffsets];
        ++$here;
    }
}

sub find_duplicates_in {
    ( my $minlength, my $ignoreContentFilter, @files ) = @_;
    enter_files(\@files);

    # enter codestring
    build_suffixarray_and_lcp($codetotal) == 0
        or die "Error building suffix array:$!\n";
    warn "analysing content of ", length $codetotal, " bytes out of ",
        scalar @files, " files...\n" if ($verbose);
    clip_lcp_to_fileboundaries( \@fileoffsets );
    reduce_lcp_to_nonoverlapping_lengths();
    set_lcp_to_zero_for_shadowed_substrings();

    my $n = get_size();

    my $cnt = 0;

    my @ranks;
    my $absminlength = abs($minlength);

    my $last_lcp = 0;
    @ranks = sort { get_len_at($b) <=> get_len_at($a) } grep {

# filter out when the lcp for this index is smaller than our requested minimal length
        my $lcp;    # length of match
        my $res = ( $lcp = get_len_at($_) )
            >= $absminlength;    # works for bytes and lines

        $res = $res && $lcp != $last_lcp;

        # ignore filter
        my $off;
        if ( $res && defined $ignoreContentFilter ) {
            $res = substr( $codetotal, $off = get_offset_at($_), $lcp )
                !~ m{$ignoreContentFilter}xms;
        }

        if ( $res && 0 <= $minlength )
        {                        # minimal length is specified in line units
            my $off = get_offset_at($_);

            # include complete lines
            my ( $upLine, $downLine );
            my $startLine = offset2line( $off, \$upLine );
            my $endLine = offset2line( $off + $lcp - 1, undef, \$downLine );
            my $includesCompleteLines = $downLine - $upLine + 1;

            # positive minlength is interpreted as lines
            $res = $includesCompleteLines >= $minlength;
        }

        if (1) {
            $last_lcp = $lcp;
        }

#print "index $_ with lcp ", get_len_at($_), " and offset ", get_offset_at($_), " is ", $res ? "accepted\n" : "filtered out\n";
#print "index $_ with lcp ", get_len_at($_), " and offset ", get_offset_at($_), " is accepted\n" if $res;
#print "index $_ with lcp ", get_len_at($_), " and offset ", get_offset_at($_), " is filtered out\n" if !$res;
        $res;
    } ( 1 .. $n - 1 );

    warn "ranking array created with ", scalar @ranks, " entries\n" if ($verbose);

    # now report the remaining duplicates
    for my $matchentry (@ranks) {

        # how many duplicates?
        my $count_dups = 2;
        my $lcp        = get_len_at($matchentry);    # length of match
        while ( $lcp == get_len_at( $matchentry + $count_dups - 1 ) ) {
            ++$count_dups;
        }

        report_dupes( $minlength, $count_dups, $lcp, $matchentry - 1 );
    }
}

use File::Find ();

sub scan_directories {
    my ( $minlength, $ignoreContentFilter, $regexAccept, $regexIgnore, @dirs )
        = @_;
    my @filepaths;

    if ( !defined $regexIgnore ) {
        $regexIgnore = qr{\.bak$|~$|\.swp$|\.bup$}xmsi;
    }
    if ( defined $regexAccept && ref $regexAccept ne 'Regexp' ) {
        $regexAccept = qr{$regexAccept}xms;
    }
    if ( defined $regexIgnore && ref $regexIgnore ne 'Regexp' ) {
        $regexIgnore = qr{$regexIgnore}xms;
    }
    if ( defined $ignoreContentFilter
        && ref $ignoreContentFilter ne 'Regexp' )
    {
        $ignoreContentFilter = qr{$ignoreContentFilter}xms;
    }
    if ( 1 == scalar @dirs && !-d $dirs[0] ) {

        # enable globs
        @dirs = <$dirs[0]>;
    }

    File::Find::find(
        sub {
            if ( -f $_ && -s $_
                && ( !defined($regexAccept) || $_ =~ m{$regexAccept}o ) )
            {
                if ( !defined($regexIgnore) || $_ !~ m{$regexIgnore}o ) {
                    push @filepaths, $File::Find::name;
                }
            }
        },
        @dirs
    );
    if ( 0 == scalar @filepaths ) {
        print "no files found for start dir(s) ", ( join ',', @dirs ),
            " with accept filter $regexAccept and ignore filter $regexIgnore!\n";
        return;
    }

    find_duplicates_in( $minlength, $ignoreContentFilter, @filepaths );
}

sub __get_text {
    my $file     = shift;
    my $contents = '';
    my @lineoffsets;
    open my $infile, '<', $file or die "cannot open file $file: $!\n";
    while (<$infile>) {
        $contents .= $_;
        push @lineoffsets, length($contents) - 1;
    }
    return ( $contents, @lineoffsets );
}

1;
__END__