File Coverage

blib/lib/Devel/ModuleDumper.pm

Criterion	Covered	Total	%
statement	54	57	94.7
branch	15	20	75.0
condition	26	36	72.2
subroutine	11	12	91.6
pod	1	2	50.0
total	107	127	84.2

package Devel::ModuleDumper;
use strict;
use warnings;

our %seen;
BEGIN {
    %seen = %INC;
}

our $VERSION = '0.03';

our %pragmas;
for my $pragma (qw/
    charnames  constant
    diagnostics
    encoding
    feature  fields  filetest
    if  integer
    less  lib  locale
    mro
    open  ops  overload  overloading
    parent
    re
    sigtrap  sort  strict  subs
    threads  threads::shared
    utf8
    vars  vmsish
    warnings  warnings::register
/) {
    $pragmas{$pragma} = 1;
}

our %skips;
for my $class (qw/
    AutoLoader
    Benchmark
    base
    bytes
    Config
    DynaLoader
    XSLoader
/) {
    $skips{$class} = 1;
}

my $ALL = $ENV{MODULEDUMPER_SHOW_ALL};

our $SHOWN = 0;

my $CONF;
sub import {
    my ($class) = shift;

    for my $opt (@_) {
        next unless $opt;
        if ($opt =~ m!^(show(?:all|seen|pragma|pragmas|skip|skips|pl))$!) {
            $CONF->{$1} = 1;
            next;
        }
        if ($opt eq '-stderr') {
            $CONF->{'-stderr'} = 1;
        }
    }
}

sub show {
    my $self = shift;

    my $result = '';

    return $result if $SHOWN;

    my $modules = _get_module_information();

    $result .= "Perl\t$]\n";

    for my $module (sort { uc($a) cmp uc($b) } keys %{$modules}) {
        $result .= sprintf "%s\t%s\n", $module, $modules->{$module}->{version};
    }

    $SHOWN = 1;

    return $result;
}

sub _get_module_information {
    my %modules;
    for my $module_path (keys %INC) {
        my $class = _path2class($module_path);
        if (!$ALL && !$CONF->{showall}) {
            next if _skip_to_show($module_path, $class);
        }
        $modules{$class} = {
            version => _get_version($class),
        };
    }
    return \%modules;
}

sub _skip_to_show {
    my ($module_path, $class) = @_;

    return 1 if (!$CONF->{showseen} && $seen{$module_path})
                || (!$CONF->{showpl} && $module_path !~ m!\.pm$!)
                || ((!$CONF->{showpragma} && !$CONF->{showpragmas}) && $pragmas{$class})
                || ((!$CONF->{skip} && !$CONF->{skips}) && $skips{$class})
                || $class eq __PACKAGE__;
}

sub _path2class {
    my $path = shift;

    my $class = $path;
    $class =~ s!/!::!g;
    $class =~ s!\.pm$!!;

    return $class;
}

sub _get_version {
    my $module = shift;

    my $version = eval {
        my $v = $module->VERSION;
        unless (defined $v) {
            $v = ${"${module}::VERSION"};
        }
        $v;
    };
    if ($@ || !defined $version) {
        $version = 'none';
    }

    return $version;
}

END {
    my $info = __PACKAGE__->show;
    my $out = $CONF->{'-stderr'} ? *STDERR : *STDOUT;
    print $out "$info";
}

package # hide the package from the PAUSE indexer
    DB;
no warnings 'redefine'; ## no critic
sub DB {}

1;

__END__