The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
MATISSE / Perl-Metrics-Simple-0.18 / bin / countperl 
#!/usr/bin/env perl

use strict;
use warnings;
use English qw(-no_match_vars);
use Carp qw();
use Readonly;
use Pod::Usage qw(pod2usage);
use Perl::Metrics::Simple qw(0.13);

Readonly::Scalar my $MAX_PLAINTEXT_LABEL_LENGTH => 25;
Readonly::Scalar my $EMPTY_STRING               => q{};
Readonly::Scalar my $ONE_SPACE                  => q{ };

our $VERSION = '0.18';

my $COMPLEXITY_LEVEL_THRESHOLD = {
    BTW => 10,
    WTF => 20,
    OMG => 30,
};

my $THRESHOLD_TO_CSS_CLASS = {
    0                                  => 'fyi',
    $COMPLEXITY_LEVEL_THRESHOLD->{BTW} => 'btw',
    $COMPLEXITY_LEVEL_THRESHOLD->{WTF} => 'wtf',
    $COMPLEXITY_LEVEL_THRESHOLD->{OMG} => 'omg',
};

my $CSS = {
    body  => ['font-family:sans-serif;'],
    table => [
        'border-collapse:collapse;', 'border-spacing:0px;',
        'margin:10px 0px;'
    ],
    tr       => [ 'text-align:left;',          'vertical-align:top;' ],
    'td, th' => [ 'border:solid 1px #000000;', 'padding:2px;' ],
    th       => ['background-color:#cccccc;'],
    '.fyi'   => ['background-color:#99ff99;'],
    '.btw'   => ['background-color:#ffff99;'],
    '.wtf'   => ['background-color:#ffcc99;'],
    '.omg'   => ['background-color:#ff9999;'],
    '.w300'  => ['width:300px;'],
    '.w200'  => ['width:200px;'],
    '.w100'  => ['width:100px;'],
    '.right' => ['text-align:right;']
};

my $ANALYSIS;
my $HTML_OUTPUT = 0;
my @FILES       = ();

main();

exit;

sub main {
    parse_opts();

    set_analysis();

    if ($HTML_OUTPUT) {
        print make_html() || Carp::croak "Cannot print! $OS_ERROR";
    }
    else {
        print make_plain() || Carp::croak "Cannot print! $OS_ERROR";
    }
    return;
}

sub parse_opts {
    if ( !@ARGV ) {
        pod2usage(
            -msg     => "Missing required argument(s).\n",
            -exitval => 1,
            -verbose => 1,
        );    # exits program
    }

    foreach (@ARGV) {
        if ( $_ eq '--html' ) {
            $HTML_OUTPUT = 1;
            next;
        }

        if ( $_ eq '--help' ) {
            pod2usage( -verbose => 2, -exitval => 1 );  # exits program
        }

        if ( /--method-modifiers=(\S+)/ ) {
            push @Perl::Metrics::Simple::Analysis::File::METHOD_MODIFIERS,
                split /,/, $1;
            next;
        }

        push @FILES, $_;
    }

    return;
}

sub set_analysis {
    $ANALYSIS = Perl::Metrics::Simple->new()->analyze_files(@FILES);
    return $ANALYSIS;
}

sub _sort_by_complexity {
    return $b->{mccabe_complexity} <=> $a->{mccabe_complexity};
}

### PLAIN

sub make_plain {
    my $report = 'Perl files found: ' . $ANALYSIS->file_count() . "\n\n";
    $report .= make_counts_plain();
    $report .= make_subroutine_size_plain();
    $report .= make_code_complexity_plain();
    $report .= make_list_of_subs_plain();
    return $report;
}

sub make_counts_plain {
    my $counts_plain = make_headline_plain('Counts');
    $counts_plain .= make_line_plain( 'total code lines', $ANALYSIS->lines() );
    $counts_plain .= make_line_plain( 'lines of non-sub code',
        $ANALYSIS->main_stats()->{lines} );
    $counts_plain
        .= make_line_plain( 'packages found', $ANALYSIS->package_count() );
    $counts_plain .= make_line_plain( 'subs/methods', $ANALYSIS->sub_count() );
    $counts_plain .= "\n\n";
    return $counts_plain;
}

sub make_line_plain {
    my ( $key, $value ) = @_;
    my $line = $key . q{:};
    $line .= $ONE_SPACE x ( $MAX_PLAINTEXT_LABEL_LENGTH - length $key );
    $line .= $value . "\n";
    return $line;
}

sub make_headline_plain {
    my ($headline) = @_;
    my $formatted_headline = $headline . "\n";
    $formatted_headline .= q{-} x length $headline;
    $formatted_headline .= "\n";
    return $formatted_headline;
}

sub make_subroutine_size_plain {
    my $subroutine_size_plain = make_headline_plain('Subroutine/Method Size');
    $subroutine_size_plain .= make_line_plain( 'min',
        $ANALYSIS->summary_stats()->{sub_length}->{min} );
    $subroutine_size_plain .= make_line_plain( 'max',
        $ANALYSIS->summary_stats()->{sub_length}->{max} );
    $subroutine_size_plain .= make_line_plain( 'mean',
        $ANALYSIS->summary_stats()->{sub_length}->{mean} );
    $subroutine_size_plain .= make_line_plain( 'std. deviation',
        $ANALYSIS->summary_stats()->{sub_length}->{standard_deviation} );
    $subroutine_size_plain .= make_line_plain( 'median',
        $ANALYSIS->summary_stats()->{sub_length}->{median} );

    $subroutine_size_plain .= "\n\n";
    return $subroutine_size_plain;
}

sub make_code_complexity_plain {
    my $code_complexity_plain = make_headline_plain('McCabe Complexity');

    $code_complexity_plain
        .= make_complexity_section_plain( 'Code not in any subroutine',
        'main_complexity' );
    $code_complexity_plain .= "\n";
    $code_complexity_plain
        .= make_complexity_section_plain( 'Subroutines/Methods',
        'sub_complexity' );

    $code_complexity_plain .= "\n\n";
    return $code_complexity_plain;
}

sub make_complexity_section_plain {
    my ( $section, $key ) = @_;

    my $complexity_section_plain = $section . "\n";

    $complexity_section_plain
        .= make_line_plain( 'min', $ANALYSIS->summary_stats()->{$key}->{min} );
    $complexity_section_plain
        .= make_line_plain( 'max', $ANALYSIS->summary_stats()->{$key}->{max} );
    $complexity_section_plain .= make_line_plain( 'mean',
        $ANALYSIS->summary_stats()->{$key}->{mean} );
    $complexity_section_plain .= make_line_plain( 'std. deviation',
        $ANALYSIS->summary_stats()->{$key}->{standard_deviation} );
    $complexity_section_plain .= make_line_plain( 'median',
        $ANALYSIS->summary_stats()->{$key}->{median} );
    return $complexity_section_plain;
}

sub make_list_of_subs_plain {
    my @main_from_each_file
        = map { $_->{main_stats} } @{ $ANALYSIS->file_stats() };
    my @sorted_subs = sort _sort_by_complexity(),
        ( @{ $ANALYSIS->subs() }, @main_from_each_file );

    my $column_widths = get_column_widths(@main_from_each_file);

    my $list_of_subs_plain
        = make_headline_plain('List of subroutines, with most complex at top');

    $list_of_subs_plain
        .= make_column( 'complexity', $column_widths->{mccabe_complexity} );
    $list_of_subs_plain .= make_column( 'sub',  $column_widths->{name} );
    $list_of_subs_plain .= make_column( 'path', $column_widths->{path} );
    $list_of_subs_plain .= make_column( 'size', $column_widths->{lines} );
    $list_of_subs_plain .= "\n";

    foreach my $sub (@sorted_subs) {
        $list_of_subs_plain
            .= make_list_of_subs_line_plain( $sub, $column_widths );
    }

    $list_of_subs_plain .= "\n\n";
    return $list_of_subs_plain;
}

sub make_list_of_subs_line_plain {
    my ( $sub, $column_widths ) = @_;

    my $list_of_subs_line_plain;

    foreach my $col ( 'mccabe_complexity', 'name', 'path', 'lines' ) {
        $list_of_subs_line_plain
            .= make_column( $sub->{$col}, $column_widths->{$col} );
    }

    $list_of_subs_line_plain .= "\n";
    return $list_of_subs_line_plain;
}

sub make_column {
    my ( $value, $width ) = @_;

    my $column = $value;
    $column .= $ONE_SPACE x ( $width - length($value) + 2 );
    return $column;
}

sub get_column_widths {
    my @main_from_each_file = @_;

    my $column_widths = {
        mccabe_complexity => 10,
        name              => 3,
        path              => 4,
        lines             => 4,
    };

    foreach my $sub (@main_from_each_file) {
        foreach my $col ( 'mccabe_complexity', 'name', 'path', 'lines' ) {
            if ( length( $sub->{$col} ) > $column_widths->{$col} ) {
                $column_widths->{$col} = length( $sub->{$col} );
            }
        }
    }

    return $column_widths;
}

### /PLAIN
### HTML

sub make_html {
    my $html = '<!DOCTYPE html><html lang="en">';

    $html .= make_head();

    $html .= make_body();

    $html .= '</html>';
    return $html;
}

sub make_head {
    my $head = '<head><title>countperl</title><meta charset="utf-8">';

    $head .= make_css();

    $head .= '</head>';
    return $head;
}

sub make_css {
    my $css = '<style type="text/css">';

    foreach my $selector ( keys %{$CSS} ) {
        $css .= $selector . '{';

        foreach ( @{ $CSS->{$selector} } ) {
            $css .= $_;
        }

        $css .= '}';
    }

    $css .= '</style>';

    return $css;
}

sub make_body {
    my $body = '<body><h3>';
    $body .= 'Perl files found ' . $ANALYSIS->file_count();
    $body .= '</h3>';

    $body .= make_counts_html();
    $body .= make_subroutine_size_html();
    $body .= make_code_complexity_html();
    $body .= make_list_of_subs_html();
    $body .= make_complexity_levels();

    $body .= '</body>';
    return $body;
}

sub make_counts_html {
    my $counts_html = '<table><tr><th colspan="2">Counts</th></tr>';

    $counts_html .= make_tr( 'total code lines', $ANALYSIS->lines() );
    $counts_html
        .= make_tr( 'lines of non-sub code', $ANALYSIS->main_stats()->{lines} );
    $counts_html .= make_tr( 'packages found', $ANALYSIS->package_count() );
    $counts_html .= make_tr( 'subs/methods',   $ANALYSIS->sub_count() );

    $counts_html .= '</table>';
    return $counts_html;
}

sub make_tr {
    my ( $key, $value, $css ) = @_;
    $css = $css ? $ONE_SPACE . $css : $EMPTY_STRING;

    my $tr = '<tr><td class="w200">';
    $tr .= $key;
    $tr .= '</td><td class="w100 right' . $css . '">';
    $tr .= $value;
    $tr .= '</td></tr>';

    return $tr;
}

sub make_subroutine_size_html {
    my $subroutine_size_html
        = '<table><tr><th colspan="2">Subroutine/Method Size</th></tr>';

    my $min                = $ANALYSIS->summary_stats()->{sub_length}->{min}                || 0;
    my $max                = $ANALYSIS->summary_stats()->{sub_length}->{max}                || 0;
    my $mean               = $ANALYSIS->summary_stats()->{sub_length}->{mean}               || '0.00';
    my $standard_deviation = $ANALYSIS->summary_stats()->{sub_length}->{standard_deviation} || '0.00';
    my $median             = $ANALYSIS->summary_stats()->{sub_length}->{median}             || '0.00';

    $subroutine_size_html .= make_tr( 'min',            $min );
    $subroutine_size_html .= make_tr( 'max',            $max );
    $subroutine_size_html .= make_tr( 'mean',           $mean );
    $subroutine_size_html .= make_tr( 'std. deviation', $standard_deviation );
    $subroutine_size_html .= make_tr( 'median',         $median );

    $subroutine_size_html .= '</table>';

    return $subroutine_size_html;
}

sub make_code_complexity_html {
    my $code_complexity_html
        = '<table><tr><th colspan="3">McCabe Complexity</th></tr>';

    $code_complexity_html
        .= make_complexity_section_html( 'Code not in any subroutine',
        'main_complexity' );
    $code_complexity_html
        .= make_complexity_section_html( 'Subroutines/Methods',
        'sub_complexity' );

    $code_complexity_html .= '</table>';

    return $code_complexity_html;
}

sub make_complexity_section_html {
    my ( $section, $key ) = @_;

    my $complexity_section_html
        = '<tr><td rowspan="5" class="w200">' . $section . '</td>';

    my $min                = $ANALYSIS->summary_stats()->{$key}->{min}                || 0;
    my $max                = $ANALYSIS->summary_stats()->{$key}->{max}                || 0;
    my $mean               = $ANALYSIS->summary_stats()->{$key}->{mean}               || '0.00';
    my $standard_deviation = $ANALYSIS->summary_stats()->{$key}->{standard_deviation} || '0.00';
    my $median             = $ANALYSIS->summary_stats()->{$key}->{median}             || '0.00';

    $complexity_section_html .= '<td class="w200">min</td><td class="w100 right ' . get_class_by_count( $min ) . '">';
    $complexity_section_html .= $min;
    $complexity_section_html .= '</td></tr>';

    $complexity_section_html .= make_tr( 'max',            $max,                get_class_by_count( $max ) );
    $complexity_section_html .= make_tr( 'mean',           $mean,               get_class_by_count( $mean ) );
    $complexity_section_html .= make_tr( 'std. deviation', $standard_deviation, get_class_by_count( $standard_deviation ) );
    $complexity_section_html .= make_tr( 'median',         $median,             get_class_by_count( $median ) );

    return $complexity_section_html;
}

sub make_list_of_subs_tr {
    my ($sub) = @_;

    my $list_of_subs_tr
        = '<tr><td class="'
        . get_class_by_count( $sub->{mccabe_complexity} )
        . ' right">'
        . $sub->{mccabe_complexity}
        . '</td><td>'
        . $sub->{name}
        . '</td><td>'
        . $sub->{path}
        . '</td><td class="right">'
        . $sub->{lines}
        . '</td></tr>';

    return $list_of_subs_tr;
}

sub make_list_of_subs_html {
    my @main_from_each_file
        = map { $_->{main_stats} } @{ $ANALYSIS->file_stats() };
    my @sorted_subs = sort _sort_by_complexity(),
        ( @{ $ANALYSIS->subs() }, @main_from_each_file );

    my $list_of_subs_html
        = '<table><tr><th colspan="4">List of subroutines, with most complex at top</th></tr>'
        . '<tr><td class="w100">complexity</td><td>sub</td><td>path</td><td class="w100">size</td><tr>';

    foreach my $sub (@sorted_subs) {
        $list_of_subs_html .= make_list_of_subs_tr($sub);
    }

    $list_of_subs_html .= '</table>';

    return $list_of_subs_html;
}

sub make_complexity_levels {
    my $complexity_levels
        = '<table><tr><th colspan="2">Complexity Levels</th></tr>';

    foreach my $level ( sort keys %{$THRESHOLD_TO_CSS_CLASS} ) {
        $complexity_levels
            .= '<tr><td class="'
            . $THRESHOLD_TO_CSS_CLASS->{$level} . '">'
            . $THRESHOLD_TO_CSS_CLASS->{$level}
            . '</td><td class="'
            . $THRESHOLD_TO_CSS_CLASS->{$level} . '">'
            . '&gt;= '
            . $level
            . '</td></tr>';
    }

    $complexity_levels .= '</table>';

    return $complexity_levels;
}

sub get_class_by_count {
    my ($count) = @_;

    my @level = reverse sort keys %{$THRESHOLD_TO_CSS_CLASS};

    foreach (@level) {
        return $THRESHOLD_TO_CSS_CLASS->{$_} if ( $count >= $_ );
    }
    return;
}

### /HTML

__END__

=head1 NAME

countperl - count lines, packages, subs and complexity of Perl files.

=head1 USAGE

B<countperl> F<FILE_OR_DIRECTORY> [F<FILE_OR_DIRECTORY> ...] [--html] [--help] [--method-modifiers=a,b,c]

=head1 REQUIRED ARGUMENTS

At least one file or directory path must be supplied.

=head1 OPTIONS

=over 4

=item --help

Prints documentation to STDERR.

=item --html

Produces HTML output instead of the plain-text default.

=item --method-modifiers=a,b,c

A comma-separated list of method modifiers to be recognised, see
L<Moose::Manual::MethodModifiers> for details. If unspecified, the
default list is before,after,around.

=back

=head1 CONFIGURATION

N/A. Currently no support for any configuration files.

=head1 EXIT STATUS

Exits zero on success, non-zero on failure.

=head1 DESCRIPTION

F<countperl> uses B<Perl::Metrics::Simple> to examines the named files and
recursivesly searches named directories for Perl files.


Perl files are identified by B<Perl::Metrics::Simple-E<gt>is_perl_file>. Basically
if the file ends in C<.pl>, C<.pm>, or C<.t> or has what appears to be a perl
I<shebang> line.

F<countperl> produces a report on F<STDOUT> of counts of total lines,
packages, subroutines/methods,
the minimum, maximum, mean, standard deviation, and median size and
mccabe_complexity (cyclomatic complexity) of subroutines and
the 'main' portion of each file (everything not in a subroutine.)

=head2 Output Format

Line counts do not include comments nor pod.

The current output format is human-readable text:

    Perl files found:                3

    Counts
    ------
    total code lines:       856
    lines of non-sub code:  450
    packages found:           3
    subs/methods:            42

    Subroutine/Method Size
    ----------------------
    min:                  3 lines
    max:                  32 lines
    mean:                 9.67 lines
    std. deviation:       7.03
    median:               7.50

    McCabe Complexity
    -----------------
    Code not in any subroutine::
    min:                  1
    max                   1
    mean:                 1.00
    std. deviation:       0.00
    median:               1.00

    Subroutines/Methods:
    min:                  1
    max:                  5
    avg:                  1.00
    std. deviation:       1.36
    median:               1.00

    Tab-delimited list of subroutines, with most complex at top
    -----------------------------------------------------------
    complexity      sub     path    size
    5       is_perl_file    lib/Perl/Metrics/Simple.pm      11
    5       _has_perl_shebang       lib/Perl/Metrics/Simple.pm      13
    5       _init   lib/Perl/Metrics/Simple/Analysis/File.pm        30
    4       find_files      lib/Perl/Metrics/Simple.pm      11
    4       new     lib/Perl/Metrics/Simple/Analysis.pm     10
    4       is_ref  lib/Perl/Metrics/Simple/Analysis.pm     8

With --html switch output format is HTML.

=head1 VERSION

This is version 0.031 of F<countperl>.

=head1 DIAGNOSTICS

Prints usage message to STDERR if required arguments are not provided.

=head1 INCOMPATIBILITIES

None known.

=head1 BUGS AND LIMITATIONS

=head2 Bugs
No bugs reported yet :-)
See: http://rt.cpan.org/NoAuth/Bugs.html?Dist=Perl-Metrics-Simple

=head2 Limitations

=over 4

=item Does not accept input from STDIN.

=item No machine-readable report format available (e.g. XML, tab-delimited)

=back

=head1 SUPPORT

Via CPAN:

=head2 Disussion Forum

http://www.cpanforum.com/dist/Perl-Metrics-Simple

=head2 Bug Reports

http://rt.cpan.org/NoAuth/Bugs.html?Dist=Perl-Metrics-Simple

=head1 DEPENDENCIES

=over 4

=item L<Perl::Metrics::Simple|Perl::Metrics::Simple> 0.13 (which depends upon L<PPI|PPI>.)

=item L<Pod::Usage|Pod::Usage>

=back

=head1 SEE ALSO

=over 4

=item L<PPI|PPI>

=item L<Perl::Critic|Perl::Critic>

=item L<Perl::Metrics|Perl::Metrics>

=item http://en.wikipedia.org/wiki/Cyclomatic_complexity

=back

=head1 AUTHOR

    Matisse Enzer
    CPAN ID: MATISSE
    Eigenstate Consulting, LLC
    matisse@eigenstate.net
    http://www.eigenstate.net/

=head1 LICENSE AND COPYRIGHT

This program is free software; you can redistribute
it and/or modify it under the same terms as Perl itself.

The full text of the license can be found in the
LICENSE file included with this module.

=cut