File Coverage

blib/lib/Code/CutNPaste.pm

Criterion	Covered	Total	%
statement	233	264	88.2
branch	57	98	58.1
condition	7	18	38.8
subroutine	31	33	93.9
pod	0	3	0.0
total	328	416	78.8

package Code::CutNPaste;

use 5.006;

use autodie;
use Benchmark qw(timediff timestr);
use Try::Tiny;
use Capture::Tiny qw(capture);
use Carp;
use File::Find::Rule;
use File::HomeDir;
use File::Slurp;
use File::Spec::Functions qw(catfile catdir);
use Getopt::Long;
use Moo;
use Parallel::ForkManager;
use Term::ProgressBar;
use aliased 'Code::CutNPaste::Duplicate';
use aliased 'Code::CutNPaste::Duplicate::Item';

has 'renamed_vars'  => ( is => 'ro' );
has 'renamed_subs'  => ( is => 'ro' );
has 'verbose'       => ( is => 'ro' );
has 'window'        => ( is => 'rwp', default => sub {5} );
has 'jobs'          => ( is => 'ro', default => sub {1} );
has 'show_warnings' => ( is => 'ro' );
has 'noutf8'        => ( is => 'ro' );
has 'threshold' => (
    is      => 'rwp',
    default => sub {.75},
    isa     => sub {
        no warnings 'uninitialized';
        my $threshold = 0 + shift;
        if ( $threshold < 0 or $threshold > 1 ) {
            croak("threshold must be between 0 and 1, inclusive");
        }
    },
);
has 'dirs' => (
    is      => 'ro',
    default => sub {'lib'},
    coerce  => sub {
        my $dirs = shift;
        unless ( ref $dirs ) {
            $dirs = [$dirs];
        }
        return $dirs;
    },
    isa => sub {
        my $dirs = shift;
        for my $dir (@$dirs) {
            unless ( -d $dir ) {
                croak("Cannot find directory '$dir'");
            }
        }
    },
);

has 'files' => (
    is      => 'ro',
    default => sub { [] },
    isa     => sub {
        my $files = shift;
        unless ( 'ARRAY' eq ref $files ) {
            croak("Argument to files must be an array reference of files");
        }
        for my $file (@$files) {
            unless ( -f $file && -r _ ) {
                croak("File '$file' does not exist or cannot be read");
            }
        }
    },
);

has 'ignore' => (
    is     => 'ro',
    coerce => sub {
        my $ignore = shift;
        return unless defined $ignore;
        return $ignore if ref $ignore eq 'Regexp';
        if ( !ref $ignore ) {
            $ignore = qr/$ignore/;
        }
        if ( 'ARRAY' eq ref $ignore ) {
            return unless @$ignore;
            $ignore = join '|' => @$ignore;
            $ignore = qr/$ignore/;
        }
        return $ignore;
    },
    isa => sub {
        return unless defined $_[0];
        croak("ignore must be a qr/regex/!")
          unless 'Regexp' eq ref $_[0];
    },
);

has 'cache_dir' => (
    is      => 'ro',
    default => sub {
        my $homedir = File::HomeDir->my_home;
        return catdir( $homedir, '.cutnpaste' );
    },
);

has '_duplicates' => (
    is      => 'ro',
    default => sub { [] },
);
has '_find_dups_called' => ( is => 'rw' );

# XXX I don't expect this to be normal, but I have found this when I run this
# code against its own codebase due to "subroutine redefined" warnings
has '_could_not_deparse' => ( is => 'ro', default => sub { {} } );

=head1 NAME

Code::CutNPaste - Find Duplicate Perl Code

=head1 VERSION

Version 0.31

=cut

our $VERSION = '0.31';

=head1 SYNOPSIS

    use Code::CutNPaste;

    my $cutnpaste = Code::CutNPaste->new(
        dirs         => [ 'lib', 'path/to/other/lib' ],
        renamed_vars => 1,
        renamed_subs => 1,
    );
    my $duplicates = $cutnpaste->duplicates;

    foreach my $duplicate (@$duplicates) {
        my ( $left, $right ) = ( $duplicate->left, $duplicate->right );
        printf <<'END', $left->file, $left->line, $right->file, $right->line;

    Possible duplicate code found
    Left:  %s line %d
    Right: %s line %d

    END
        print $duplicate->report;
    }

=cut

sub BUILD {
    my $self = shift;

    unless ( $self->noutf8 ) {
        eval "use utf8::all";
        warn $@ if $@;
    }

    my $cache_dir = $self->cache_dir;
    $self->_set_window(5)      unless defined $self->window;
    $self->_set_threshold(.75) unless defined $self->threshold;

    if ( -d $cache_dir ) {
        my @cached = File::Find::Rule->file->in($cache_dir);
        unlink $_ for @cached;
    }
    else {
        mkdir $cache_dir;
    }
    for my $dir ( @{ $self->dirs } ) {
        my @files
          = grep { !/^\./ }
          File::Find::Rule->file->name( '*.pm', '*.t', '*.pl' )->in($dir);

        # XXX dups and subdirs?
        push @{ $self->files } => @files;
    }
}

sub find_dups {
    my $self = shift;

    printf "Started: %s\n", scalar localtime if $self->verbose;
    my $start = Benchmark->new;
    $self->_find_dups_called(1);
    my $jobs = $self->jobs;

    my $fork = Parallel::ForkManager->new( $jobs || 1 );
    $fork->run_on_finish(
        sub {
            my $duplicates = pop @_;
            push @{ $self->_duplicates } => @$duplicates;
        }
    );

    my @pairs = $self->_get_pairs_of_files;
    my $progress;
    $progress = Term::ProgressBar->new(
        {   count => scalar @pairs,
            ETA   => 'linear',
        }
    ) if $self->verbose;

    my $count = 1;
    foreach my $pair (@pairs) {
        $progress->update( $count++ ) if $self->verbose;
        my $pid = $fork->start and next;

        my $duplicates_found = $self->_search_for_dups(@$pair);

        $fork->finish( 0, $duplicates_found );
    }
    $fork->wait_all_children;
    if ( $self->verbose ) {
        printf "Ended:   %s\n", scalar localtime;
        my $time = timediff( Benchmark->new, $start );
        print STDERR "Time:   ", timestr($time), "\n";
    }
}

sub duplicates {
    my $self = shift;
    $self->find_dups unless $self->_find_dups_called;
    return $self->_duplicates;
}

sub _search_for_dups {
    my ( $self, $first, $second ) = @_;
    my $window = $self->window;

    my $code1 = $self->_get_text($first)  or return [];
    my $code2 = $self->_get_text($second) or return [];

    my %in_second = map { $_->{key} => 1 } @$code2;

    my $matches_found = 0;
    my $last_found    = 0;
    foreach my $i ( 0 .. $#$code1 ) {
        if ( $in_second{ $code1->[$i]{key} } ) {
            if ( $i == $last_found + 1 ) {
                $matches_found++;
            }
            $last_found = $i;
        }
    }
    if ( $matches_found < $window ) {
        return [];
    }

    # brute force is bad!

    my @duplicates_found;
    LINE: foreach ( my $i = 0; $i < @$code1 - $window; $i++ ) {
        next LINE unless $in_second{ $code1->[$i]{key} };

        my @code1 = @{$code1}[ $i .. $#$code1 ];
        foreach my $j ( 0 .. $#$code2 - $window ) {
            my @code2   = @{$code2}[ $j .. $#$code2 ];
            my $matches = 0;
            my $longest = 0;
            WINDOW: foreach my $k ( 0 .. $#code1 ) {
                if ( $code1[$k]{key} eq $code2[$k]{key} ) {
                    $matches++;
                    my $length1 = length( $code1[$k]{code} );
                    if ( $length1 > $longest ) {
                        $longest = $length1;
                    }
                    my $length2 = length( $code2[$k]{code} );
                    if ( $length2 > $longest ) {
                        $longest = $length2;
                    }
                }
                else {
                    last WINDOW;
                }
            }

            # if too many lines don't meet our threshold level, don't report
            # this block of code
            if ( $matches >= $window ) {
                $matches = 0
                  if $self->_match_below_threshold( $matches, \@code1 );
            }
            if ( $matches >= $window ) {
                my $line1 = $code1[0]{line};
                my $line2 = $code2[0]{line};

                my ( $left, $right, $report ) = ( '', '', '' );
                for ( 0 .. $matches - 1 ) {
                    $left  .= $code1[$_]{code} . "\n";
                    $right .= $code2[$_]{code} . "\n";
                    my ( $line1, $line2 )
                      = map { chomp; $_ }
                      ( $code1[$_]{code}, $code2[$_]{code} );
                    $report
                      .= $line1 . ( ' ' x ( $longest - length($line1) ) );
                    $report .= " | $line2\n";
                }

                # Next duplicate report should start after this chunk of code
                $i += $matches;

                my $ignore = $self->ignore;
                if ( $ignore and $report =~ /$ignore/ ) {
                    next LINE;
                }
                push @duplicates_found => Duplicate->new(
                    left => Item->new(
                        file => $first,
                        line => $line1,
                        code => $left,
                    ),
                    right => Item->new(
                        file => $second,
                        line => $line2,
                        code => $right,
                    ),
                    report => $report,
                );
            }
        }
    }
    return \@duplicates_found;
}

sub _match_below_threshold {
    my ( $self, $matches, $code ) = @_;

    return unless $self->threshold;

    my $total = 0;
    for ( 0 .. $matches - 1 ) {
        $total++ if $code->[$_]{code} =~ /\w/;
    }
    return $self->threshold > $total / $matches;
}

sub _get_text {
    my ( $self, $file ) = @_;

    my $filename = $file;
    $filename =~ s/\W/_/g;
    $filename = catfile( $self->cache_dir, $filename );

    my $filename_munged = $filename . ".munged";
    my ( @contents, @munged );
    if ( -f $filename ) {
        @contents = split /(\n)/ => read_file($filename);

        # sometimes another fork has already written the $filename, but not
        # yet written the $filename_munged, so we will wait up to three
        # seconds for it before trying to read it.
        # A better ordering of the @pairs might help?
        my $retry = 1;
        while ( !-f $filename_munged ) {
            sleep 1;
            last if $retry++ > 3;
        }
        @munged = split /(\n)/ => read_file($filename_munged);
    }
    else {
        my $stderr;
        try {
            ( undef, $stderr, @contents )
              = capture {qx($^X -Ilib -MO=CutNPaste $file)};
        } catch {
            warn "Problem when capturing $^X -Ilib -MO=CutNPaste $file: $_";
        };
        return undef if !@contents; #properly return, so we can avoid undef value as an array ref error
        undef $stderr if $stderr =~ /syntax OK/;
        if ( $stderr and !$self->_could_not_deparse->{$file} ) {
            warn "Problem when parsing $file: $stderr"
              if $self->show_warnings;
        }
        undef $stderr;
        write_file( $filename, @contents );

        local $ENV{RENAME_VARS} = $self->renamed_vars || 0;
        local $ENV{RENAME_SUBS} = $self->renamed_subs || 0;
        try {
            ( undef, $stderr, @munged )
              = capture {qx($^X -Ilib -MO=CutNPaste $file)};
        } catch {
            warn "Problem when capturing $^X -Ilib -MO=CutNPaste $file: $_";
        };
        return undef if !@munged;
        undef $stderr if $stderr =~ /syntax OK/;
        if ( $stderr and !$self->_could_not_deparse->{$file} ) {
            warn "\nProblem when parsing $file: $stderr"
              if $self->show_warnings;
        }
        write_file( $filename_munged, @munged );
    }
    return $self->_add_line_numbers( $file, \@contents, \@munged );
}

sub _add_line_numbers {
    my $self = shift;
    my $file = shift;
    return if $self->_could_not_deparse->{$file};
    my $contents = $self->_prefilter(shift);
    my $munged   = $self->_prefilter(shift);

    if ( @$contents != @$munged ) {
        warn <<"END";

There was a problem parsing $file. It will be skipped.
Try rerunning with show_warnings => 1.

END
        $self->_could_not_deparse->{$file} = 1;
        return;
    }
    my @contents;

    my $line_num = 1;
    foreach my $i ( 0 .. $#$contents ) {
        my ( $line, $munged_line ) = ( $contents->[$i], $munged->[$i] );
        chomp $line;
        chomp $munged_line;

        if ( $line =~ /^#line\s+([0-9]+)/ ) {
            $line_num = $1;
            next;
        }
        push @contents => {
            line => $line_num,
            key  => $self->_make_key($munged_line),
            code => $line,
        };
        $line_num++;
    }
    return $self->_postfilter( \@contents );
}

sub _prefilter {
    my ( $self, $contents ) = @_;
    my @contents;
    my %skip = (
        sub_begin => 0,
    );
    my $skip = 0;

    LINE: for ( my $i = 0; $i < @$contents; $i++ ) {
        local $_ = $contents->[$i];
        next if /^\s*(?:use|require)\b/;    # use/require
        next if /^\s*$/;                    # blank lines
        next if /^#(?!line\s+[0-9]+)/; # comments which aren't line directives

        # Modules which import things create code like this:
        #
        #     sub BEGIN {
        #         require strict;
        #         do {
        #             'strict'->import('refs')
        #         };
        #     }
        #
        # $skip{sub_begin} filters this out

        if (/^sub BEGIN \{/) {
            $skip{sub_begin} = 1;
            $skip++;
        }
        elsif ( $skip{sub_begin} and /^}/ ) {
            $skip{sub_begin} = 0;
            $skip--;
            next;
        }

        push @contents => $_ unless $skip;
    }
    return \@contents;
}

sub _postfilter {
    my ( $self, $contents ) = @_;

    my @contents;
    INDEX: for ( my $i = 0; $i < @$contents; $i++ ) {
        if ( $contents->[$i]{code} =~ /^(\s*)BEGIN\s*\{/ ) {    #    BmEGIN {
            my $padding = $1;
            if ( $contents->[ $i + 1 ]{code} =~ /^$padding}/ ) {
                $i++;
                next INDEX;
            }
        }
        push @contents => $contents->[$i];
    }
    return \@contents;
}

sub _make_key {
    my $self = shift;
    local $_ = shift;
    chomp;
    s/\s//g;
    return $_;
}

sub _get_pairs_of_files {
    my $self      = shift;
    my $files     = $self->files;
    my $num_files = @$files;
    my $jobs      = $self->jobs;

    my @pairs;
    for my $i ( 0 .. $#$files - 1 ) {
        my $next = $i + 1;
        for my $j ( $next .. $#$files ) {
            push @pairs => [ @{$files}[ $i, $j ] ];
        }
    }

    my @left_right;
    if ( $jobs > 1 ) {
        my $files_per_job = int( $num_files / $jobs );
        for ( 1 .. $jobs ) {
            if ( $_ < $jobs ) {
                push @left_right => splice @pairs, 0, $files_per_job;
            }
            else {
                push @left_right => @pairs;
            }
        }
    }
    else {
        @left_right = @pairs;
    }
    return @left_right;
}

1;
__END__