Module::Info - Information about Perl modules

  use Module::Info;

  my $mod = Module::Info->new_from_file('Some/Module.pm');
  my $mod = Module::Info->new_from_module('Some::Module');
  my $mod = Module::Info->new_from_loaded('Some::Module');

  my @mods = Module::Info->all_installed('Some::Module');

  my $name    = $mod->name;
  my $version = $mod->version;
  my $dir     = $mod->inc_dir;
  my $file    = $mod->file;
  my $is_core = $mod->is_core;

  # Only available in perl 5.6.1 and up.
  # These do compile the module.
  my @packages = $mod->packages_inside;
  my @used     = $mod->modules_used;
  my @subs     = $mod->subroutines;
  my @isa      = $mod->superclasses;
  my @calls    = $mod->subroutines_called;

  # Check for constructs which make perl hard to predict.
  my @methods   = $mod->dynamic_method_calls;
  my @lines     = $mod->eval_string;    *UNIMPLEMENTED*
  my @lines     = $mod->gotos;          *UNIMPLEMENTED*
  my @controls  = $mod->exit_via_loop_control;      *UNIMPLEMENTED*
  my @unpredictables = $mod->has_unpredictables;    *UNIMPLEMENTED*

  # set/get Module::Info options
  $self->die_on_compilation_error(1);
  my $die_on_error = $mod->die_on_compilation_error;
  $self->safe(1);
  my $safe = $mod->safe;

package Module::Info;

use strict;
use Carp;
use File::Spec;
use Config;
require 5.004;

my $has_version_pm = eval 'use version; 1';

use vars qw($VERSION @ISA $AUTOLOAD);
# quotes 'version' for 5.004
$VERSION = eval 'use version; 1' ? 'version'->new('0.32') : '0.32';
$VERSION = eval $VERSION;

sub new_from_file {
    my($proto, $file) = @_;
    my($class) = ref $proto || $proto;

    return unless -r $file;

    my $self = {};
    $self->{file} = File::Spec->rel2abs($file);
    $self->{dir}  = '';
    $self->{name} = '';
    $self->{safe} = 0;
    $self->{use_version} = 0;

    return bless $self, $class;
}

sub new_from_module {
    my($class, $module, @inc) = @_;
    return ($class->_find_all_installed($module, 1, @inc))[0];
}

sub new_from_loaded {
    my($class, $name) = @_;

    my $mod_file = join('/', split('::', $name)) . '.pm';
    my $filepath = $INC{$mod_file} || '';

    my $module = Module::Info->new_from_file($filepath) or return;
    $module->{name} = $name;
    ($module->{dir} = $filepath) =~ s|/?\Q$mod_file\E$||;
    $module->{dir} = File::Spec->rel2abs($module->{dir});
    $module->{safe} = 0;
    $module->{use_version} = 0;

    return $module;
}

sub all_installed {
    my($class, $module, @inc) = @_;
    return $class->_find_all_installed($module, 0, @inc);
}

# Thieved from Module::InstalledVersion
sub _find_all_installed {
    my($proto, $name, $find_first_one, @inc) = @_;
    my($class) = ref $proto || $proto;

    @inc = @INC unless @inc;
    my $file = File::Spec->catfile(split /::/, $name) . '.pm';

    my @modules = ();
    DIR: foreach my $dir (@inc) {
        # Skip the new code ref in @INC feature.
        next if ref $dir;

        my $filename = File::Spec->catfile($dir, $file);
        if( -r $filename ) {
            my $module = $class->new_from_file($filename);
            $module->{dir} = File::Spec->rel2abs($dir);
            $module->{name} = $name;
            push @modules, $module;
            last DIR if $find_first_one;
        }
    }

    return @modules;
}

sub name {
    my($self) = shift;

    $self->{name} = shift if @_;
    return $self->{name};
}

# Thieved from ExtUtils::MM_Unix 1.12603
sub version {
    my($self) = shift;
    local($_, *MOD);

    my $parsefile = $self->file;
    my $safe = $self->safe;

    open(MOD, $parsefile) or die $!;

    my $inpod = 0;
    my $result;
    while (<MOD>) {
        $inpod = /^=(?!cut)/ ? 1 : /^=cut/ ? 0 : $inpod;
        next if $inpod || /^\s*#/;

        chomp;
        next unless /([\$*])(([\w\:\']*)\bVERSION)\b.*\=/;
        my $eval = sprintf qq{
                                            package Module::Info::_version;
                                            %s

                                            local $1$2;
                                            \$$2=undef; do {
                                                    %s
                                            }; \$$2
                }, ( $safe ? '' : 'no strict;' ), $_;
        local $^W = 0;
        $result = $self->_eval($eval);
        warn "Could not eval '$eval' in $parsefile: $@" if $@ && !$safe;
        $result = "undef" unless defined $result;
        last;
    }
    close MOD;
    $result = 'version'->new($result) # quotes for 5.004
      if    $self->use_version
         && (!ref($result) || !UNIVERSAL::isa($result, "version"));
    return $result;
}

sub inc_dir {
    my($self) = shift;

    return $self->{dir};
}

sub file {
    my($self) = shift;

    return $self->{file};
}

sub is_core {
    my($self) = shift;

    return scalar grep $self->{dir} eq File::Spec->canonpath($_), 
                           ($Config{installarchlib},
                            $Config{installprivlib},
                            $Config{archlib},
                            $Config{privlib});
}

sub packages_inside {
    my $self = shift;

    my %packs = map {$_, 1} $self->_call_B('packages');
    return keys %packs;
}

sub package_versions {
    my $self = shift;

    my @packs = $self->packages_inside;

    # To survive the print(), we translate undef into '~' and then back again.
    (my $quoted_file = $self->file) =~ s/(['\\])/\\$1/g;
    my $command = qq{-le "require '$quoted_file';};
    foreach (@packs) {
        $command .= " print defined $_->VERSION ? $_->VERSION : '~';"
    }
    $command .= qq{"};

    my ($status, @versions) = $self->_call_perl($command);
    chomp @versions;
    foreach (@versions) {
        $_ = undef if $_ eq '~';
    }

    my %map;
    @map{@packs} = @versions;

    return %map;
}

sub modules_used {
    my($self) = shift;
    my %used = $self->modules_required;

    return keys %used;
}

sub modules_required {
    my($self) = shift;

    my $mod_file = $self->file;
    my @mods = $self->_call_B('modules_used');

    my @used_mods = ();
    my %used_mods = ();
    for (grep /^use \D/ && /at "\Q$mod_file\E" /, @mods) {
        my($file, $version) = /^use (\S+) \(([^\)]*)\)/;
        $used_mods{_file2mod($file)} ||= [];
        next unless defined $version and length $version;

        push @{$used_mods{_file2mod($file)}}, $version;
    }

    push @used_mods, map { my($file) = /^require bare (\S+)/; _file2mod($file) }
                     grep /^require bare \D/ , @mods;

    push @used_mods, map { /^require not bare (\S+)/; $1 }
                     grep /^require not bare \D/, @mods;

    foreach ( @used_mods ) { $used_mods{$_} = [] };
    return %used_mods;
}

sub _file2mod {
    my($mod) = shift;
    $mod =~ s/\.pm//;
    $mod =~ s|/|::|g;
    return $mod;
}

sub subroutines {
    my($self) = shift;

    my $mod_file = $self->file;
    my @subs = $self->_call_B('subroutines');
    return  map { /^(\S+) at "[^"]+" from (\d+) to (\d+)/;
                  ($1 => { start => $2, end => $3 }) }
            grep /at "\Q$mod_file\E" /, @subs;
}

sub _get_extra_arguments { '' }

sub _call_B {
    my($self, $arg) = @_;

    my $mod_file = $self->file;
    my $extra_args = $self->_get_extra_arguments;
    my $command = qq{$extra_args "-MO=Module::Info,$arg" "$mod_file"};
    my($status, @out) = $self->_call_perl($command);

    if( $status ) {
        my $exit = $status >> 8;
        my $msg = join "\n",
                       "B::Module::Info,$arg use failed with $exit saying:",
                       @out;

        if( $self->{die_on_compilation_error} ) {
            die $msg;
        }
        else {
            warn $msg;
            return;
        }
    }

    @out = grep !/syntax OK$/, @out;
    chomp @out;
    return @out;
}

sub superclasses {
    my $self = shift;

    my $mod_file = $self->file;
    my $mod_name = $self->name;
    unless( $mod_name ) {
        carp 'isa() requires $module->name to be set';
        return;
    }

    my $extra_args = $self->_get_extra_arguments;
    my $command =
      qq{-e "require q{$mod_file}; print join qq{\\n}, \@$mod_name\::ISA"};
    my($status, @isa) = $self->_call_perl("$extra_args $command");
    chomp @isa;
    return @isa;
}

sub subroutines_called {
    my($self) = shift;

    my @subs = $self->_call_B('subs_called');
    my $mod_file = $self->file;

    @subs = grep /at "\Q$mod_file\E" line/, @subs;
    my @out = ();
    foreach (@subs) {
        my %info = ();
        ($info{type}) = /^(.+) call/;
        $info{type} = 'symbolic function' if /using symbolic ref/;
        ($info{'name'}) = /to (\S+)/;
        ($info{class})= /via (\S+)/;
        ($info{line}) = /line (\d+)/;
        push @out, \%info;
    }
    return @out;
}

sub dynamic_method_calls {
    my($self) = shift;
    return grep $_->{type} =~ /dynamic/, $self->subroutines_called;
}

sub die_on_compilation_error {
    my($self) = shift;

    $self->{die_on_compilation_error} = $_[0] ? 1 : 0 if @_;
    return $self->{die_on_compilation_error};
}

sub safe {
    my($self) = shift;

    if( @_ ) {
        $self->{safe} = $_[0] ? 1 : 0;
        require Safe if $self->{safe};
    }
    return $self->{safe};
}

sub AUTOLOAD {
    my($super) = $_[0]->safe ? 'Module::Info::Safe' : 'Module::Info::Unsafe';
    my($method) = $AUTOLOAD;
    $method =~ s/^.*::([^:]+)$/$1/;

    return if $method eq 'DESTROY';

    my($code) = $super->can($method);

    die "Can not find method '$method' in Module::Info" unless $code;

    goto &$code;
}

sub use_version {
    my($self) = shift;

    if( @_ ) {
        die "Can not use 'version.pm' as requested"
          if $_[0] && !$has_version_pm;

        $self->{use_version} = $_[0] ? 1 : 0;
    }

    return $self->{use_version};
}

package Module::Info::Safe;

my $root = 'Module::Info::Safe::_safe';

sub _create_compartment {
    my $safe = Safe->new( $root );

    $safe->permit_only( qw(:base_orig :base_core) );

    return $safe;
}

sub _eval {
    my($self, $code) = @_;
    $self->{compartment} ||= _create_compartment;

    return $self->{compartment}->reval( $code, 0 )
}

sub _call_perl {
    die "Module::Info attemped an unsafe operation while in 'safe' mode.";
}

package Module::Info::Unsafe;

sub _eval { eval($_[1]) }

sub _is_win95() {
    return $^O eq 'MSWin32' && (Win32::GetOSVersion())[4] == 1;
}

sub _is_macos_classic() {
    return $^O eq 'MacOS';
}

sub _call_perl {
    my($self, $args) = @_;

    my $perl = _is_macos_classic ? 'perl' : $^X;
    my $command = "$perl $args";
    my @out;

    if( _is_win95 ) {
        require IPC::Open3;
        local *OUTFH;
        my($line, $in);
        my $out = \*OUTFH;
        my $pid = IPC::Open3::open3($in, $out, $out, $command);
        close $in;
        while( defined($line = <OUTFH>) ) {
            $line =~ s/\r\n$/\n/; # strip CRs
            push @out, $line;
        }

        waitpid $pid, 0;
    }
    elsif( _is_macos_classic ) {
        @out = `$command \xb7 Dev:Stdout`;
    }
    else {
        @out = `$command 2>&1`;
    }

    @out = grep !/^Using.*blib$/, @out;
    return ($?, @out);
}

return 'Stepping on toes is what Schwerns do best!  *poing poing poing*';