libv-perl 0.13-1 / usr / share / perl5 / V.pm

package V;
use strict;

# $Id: V.pm 1126 2007-11-07 00:10:02Z abeltje $

use vars qw( $VERSION $NO_EXIT );
$VERSION  = '0.13';

$NO_EXIT ||= 0; # prevent import() from exit()ing and fall of the edge

=head1 NAME

V - Print version of the specified module(s).

=head1 SYNOPSIS

    $ perl -MV=V

or if you want more than one

    $ perl -MV=CPAN,V

Can now also be used as a light-weight module for getting versions of
modules without loading them:

    BEGIN { $V::NO_EXIT = 1 }
    require V;

    printf "%s has version '%s'\n", "V", V::get_version( "V" );

=head1 DESCRIPTION

This module uses stolen code from L<Module::Info> to find the location 
and version of the specified module(s). It prints them and exit()s.

It defines C<import()> and is based on an idea from Michael Schwern
on the perl5-porters list. See the discussion:

  http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2002-01/msg00760.html

=head1 AUTHOR

Abe Timmerman C<< <abeltje@cpan.org> >>.

=head1 COPYRIGHT & LICENSE

Copyright 2002-2006 Abe Timmerman, All Rights Reserved.

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

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.

=cut

sub report_pkg($@) {
    my $pkg = shift;

    print "$pkg\n";
    @_ or print "\tNot found\n";
    for my $module ( @_ ) {
        printf "\t%s: %s\n", $module->file, $module->version || '?';
    }
}

sub import {
    shift;
    @_ or push @_, 'V';
 
   for my $pkg ( @_ ) {
        my @modules = V::Module::Info->all_installed( $pkg );
        report_pkg $pkg, @modules;
    }
    exit() unless $NO_EXIT;
}

sub get_version {
    my( $pkg ) = @_;
    my( $first ) = V::Module::Info->all_installed( $pkg );
    return $first ? $first->version : undef;
}

caller or V->import( @ARGV );

1;

# Okay I did the AUTOLOAD() bit, but this is a Copy 'n Paste job.
# Thank you Michael Schwern for Module::Info! This one is mostly that!

package V::Module::Info;

require File::Spec;

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} = '';

    return bless $self, $class;
}

sub all_installed {
    my($proto, $name, @inc) = @_;
    my($class) = ref $proto || $proto;

    @inc = @INC unless @inc;
    my $file = File::Spec->catfile(split m/::/, $name) . '.pm';
    
    my @modules = ();
    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;
        }
    }
              
    return @modules;
}

# Thieved from ExtUtils::MM_Unix 1.12603
sub version {
    my($self) = shift;

    my $parsefile = $self->file;

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

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

        chomp;
        next unless m/([\$*])(([\w\:\']*)\bVERSION)\b.*\=/;
        { local($1, $2); ($_ = $_) = m/(.*)/; } # untaint
        my $eval = qq{
            package V::Module::Info::_version;
            no strict;

            local $1$2;
            \$$2=undef; do {
                $_
            }; \$$2
        };
        local $^W = 0;
        $result = eval($eval);
        warn "Could not eval '$eval' in $parsefile: $@" if $@;
        $result = "undef" unless defined $result;
        last;
    }
    close MOD;
    return $result;
}

sub accessor {
    my $self = shift;
    my $field = shift;

    $self->{ $field } = $_[0] if @_;
    return $self->{ $field };
}

sub AUTOLOAD {
    my( $self ) = @_;

    use vars qw( $AUTOLOAD );
    my( $method ) = $AUTOLOAD =~ m|.+::(.+)$|;

    if ( exists $self->{ $method } ) {
        splice @_, 1, 0, $method;
        goto &accessor;
    }
}