view release on metacpan or  search on metacpan

bin/used  view on Meta::CPAN

    }

    # do stuff here
    if (!@dirs) {
        push @dirs, '.';
    }

    my %used;
    my %versions;
    while ( my $file = shift @dirs ) {
        next if $file =~ m{ (?: README(?: [.]pod | [.]md)? $ | MANIFEST(?:[.]SKIP)?$ | Changes$ | [._]build | blib | [.](?: git | svn | bzr | cpanm) | CVS | RCS | debian ) }xms;
        next if skip($file);

        if ( -f $file ) {
            next if $file !~ /[.](?:pm|pod|pl|cgi|t)$/ && path($file)->basename =~ /[.]/;
            next if $option{exclude} && $file =~ m{/ $option{exclude} /}xms;

            if ( path($file)->basename !~ /[.]/xms ) {
                next if path($file)->slurp !~ /\A.*perl/;
            }

            process_file($file, \%used, \%versions);
        }
        else {
            eval {
                push @dirs, grep {!/^[.][^.]+/} path($file)->children;
                warn "$file\n" if $option{verbose} > 5;
            };
        }
    }

    # remove modules that available from the maximum of the minimum versions of Perl required for these files
    my $max_ver = max map { version->parse($_) } keys %versions;
    warn "Files with the hightest Perl version:\n\t", join "\n\t", @{ $versions{$max_ver} }, "\n" if $option{perl_version};
    for my $module (keys %used) {
        my $rel_ver = Module::CoreList->first_release($module);
        if ( $rel_ver && $rel_ver <= $max_ver ) {
            my $value = delete $used{$module};
            if ( $option{verbose} > 1 ) {
                $used{$module} = { count => $value, colour => 'blue' };
            }
        }
    }

    # remove any modules defined in the local lib directory
    for my $lib ( @{ $option{lib} } ) {
        next if !-d $lib;
        $lib =~ s{/$}{};
        my @files = eval { grep {!/^[.][^.]+/} path($lib)->children };
        while (my $file = shift @files) {
            if ( -d $file ) {
                push @files, grep {!/^[.][^.]+/} $file->children;
            }
            elsif ( $file =~ /[.]pm$/ ) {
                my $mod = "$file";
                $mod =~ s{^$lib/}{}xms;
                $mod =~ s{/}{::}gxms;
                $mod =~ s{[.]pm$}{}xms;
                my $value = delete $used{$mod};
                if ( $option{verbose} > 1 ) {
                    $used{$mod} = { count => $value, colour => 'bold' };
                }
            }
        }
    }

    for my $module (keys %used) {
        $used{$module} = { count => $used{$module}, colour => '' } if !ref $used{$module};
    }

    # Check what modules have been already required
    my %specified = pre_specified();

    show_results( $max_ver, \%used, \%specified );
    return;
}

sub show_results {
    my ( $max_ver, $used, $specified ) = @_;

    if ( $option{update} ) {
        my $max = 0;
        my %map
            = map {
                $max = length $_ if length $_ > $max;
                $_ => get_version($_)->{num}
            }
            grep {
                $_ ne 'v5'
            }
            keys %{$used};

        $max += 2;
        print ' ' x 8,
            join ' ' x 8,
            ( sprintf "%-${max}s => %s,\n", "'perl'", "'$max_ver'" ),
            map {
                sprintf "%-${max}s => %s,\n", "'$_'", $map{$_} eq 0 ? $map{$_} : "'$map{$_}'"
            }
            sort keys %map;
        return;
    }

    my %notes;
    $max_ver ||= 0;

    # start the out put
    my $star = ' ';
    if ( $specified->{perl} && $max_ver > $specified->{perl}{version} ) {
        $star = '⁑';
        $notes{$star} = "The specified minimum perl version ($specified->{perl}{version}) is less than some used features require";
    }
    print "Perl$star $max_ver\n" unless $option{quiet};
    delete $specified->{perl};

    if ( $option{verbose} ) {
        for my $defined ( keys %$specified ) {
            $used->{$defined} = { count => 0, build_only => $specified->{$defined}{build_only}, recommended => $specified->{$defined}{recommended} }
                if defined $specified->{$defined} && !exists $used->{$defined};
            warn $defined if defined $specified->{$defined} && !exists $used->{$defined};
        }
    }

    my $max = max map { length $_ } keys %$used;

    my @keys
        = $option{uses} ? sort { $used->{$a}{count} <=> $used->{$b}{count} || uc $a cmp uc $b } keys %$used
        :                 sort { uc $a cmp uc $b } keys %$used;

    if ( $option{decending} ) {
        @keys = reverse @keys;
    }

    for my $module (@keys) {
        my $version = '';
        my $star    = '';

        if ( $option{verbose} ) {
            my $ver = get_version($module);
            my $num = $ver->{num};
            $version = $ver->{version};

            my $spec = defined $specified->{$module} ? " ($specified->{$module}{version})" : '';
            $version .= ' ' x (8 - length $version) . $spec;
            $version = ' ' x ($max + 1 - length $module) . $version;

            $star =
                  ! exists $specified->{$module}                                    ? '†'
                : ! defined $specified->{$module}                                   ? ' '
                : version->new($num) < version->new($specified->{$module}{version}) ? '‡'
                : $used->{$module}{build_only}                                      ? '⁎'
                : $used->{$module}{recommended}                                     ? '⁂'
                :                                                                     ' ';
        }
        else {
            $star = exists $specified->{$module} ? ' ' : '†';
        }
        if ( $star ne ' ' && !exists $notes{$star} ) {
            $notes{$star} =
                $star eq '‡' ? 'The version specified in Build.PL greater that the currently installed version'
                : $star eq '⁎' ? 'The module is specified in Build.PL but doesn\'t appear to be used'
                : $star eq '⁂' ? 'The module is recommended in Build.PL but doesn\'t appear to be used'
                :                'This module is not specified in Build.PL';
        }

        $used->{$module}{count}  ||= 0;
        $used->{$module}{colour} ||= '';

        printf "%4d %s$star$version\n", $used->{$module}{count}, $used->{$module}{colour} ? colored($module, $used->{$module}{colour} ) : $module
            unless $option{quiet};
        if ( $used->{$module}{colour} && $used->{$module}{colour} ne '' && !$notes{ colored( $used->{$module}{colour}, $used->{$module}{colour} ) } ) {
            $notes{ colored( $used->{$module}{colour}, $used->{$module}{colour} ) }
                = $used->{$module}{colour} eq 'blue' ? "Core module"
                : $used->{$module}{colour} eq 'bold' ? 'Local module'
                :                                      'Update the code for this colour';
        }
    }

    print "\n" unless $option{quiet};
    $max = 1;
    for my $key ( keys %notes ) {
        $max = 4 if length $key > 4;
    }
    for my $note (sort keys %notes) {
        print $note . ( ' ' x ( $max + 1 - ( length $note > 4 ? 4 : 1 ) ) ) . "$notes{$note}\n";
    }

    # return an error if some notes found
    exit scalar keys %notes if keys %notes;

    return;
}

{
    my %cache;
    sub get_version {
        my ($module) = @_;
        return $cache{$module} if $cache{$module};

        my $file = "$module.pm";
        $file =~ s{::}{/}gxms;

        eval { require $file };

        {
            no strict qw/refs/;   ## no critic
            $cache{$module}{version} =
                 $EVAL_ERROR                       ? '0?0'
                : defined ${$module . '::VERSION'} ? ${$module . '::VERSION'}
                :                                    'undef';
            $cache{$module}{num} =
                 $EVAL_ERROR                       ? 0
                : defined ${$module . '::VERSION'} ? ${$module . '::VERSION'}
                :                                    0;
        }

        return $cache{$module};
    }
}

sub process_file {
    my ($file, $used, $versions) = @_;

    my $contents = path($file)->slurp;

    # remove any data or end sections
    $contents =~ s{^__(?:DATA|END)__\n.*\Z}{}xms;

    # remove any POD
    $contents =~ s/^=.*?^=cut$//gxms;

    # TODO need to make the extends logic work for multiple extended modules
    my @modules = grep { $_ ne 'ok' } $contents =~ m{^ \s* (?: use | require ) \s+ ( [\w:]+ ) }gxms;
    push @modules, $contents =~ m{^ \s* (?: (?: use | require ) \s+ ok | extends ) \s+ ['"]( [\w:]+ )['"] }gxms;