191 lines
4.2 KiB
Perl
191 lines
4.2 KiB
Perl
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;
|
|
}
|
|
}
|