Initial Commit

database/perl/vendor/lib/V.pm

@@ -0,0 +1,190 @@
+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;
+    }
+}