summaryrefslogtreecommitdiff
path: root/inc
diff options
context:
space:
mode:
Diffstat (limited to 'inc')
-rw-r--r--inc/MBVersion.pm1187
-rw-r--r--inc/Module/Metadata.pm759
-rw-r--r--inc/Perl/OSType.pm174
-rw-r--r--inc/bootstrap.pl47
4 files changed, 2167 insertions, 0 deletions
diff --git a/inc/MBVersion.pm b/inc/MBVersion.pm
new file mode 100644
index 0000000..558a9ff
--- /dev/null
+++ b/inc/MBVersion.pm
@@ -0,0 +1,1187 @@
+# Bootstrap pure-perl version
+package MB::Version;
+use strict;
+
+use vars qw($VERSION);
+$VERSION = 0.86;
+
+eval "use version $VERSION";
+if ($@) { # can't locate new enough version files, use our own
+ # We might be here because version.pm was present but there was
+ # an error, so make we want to be sure users see what's happening
+ # We also need to clear %INC entries, as the "undef" for a broken
+ # version.pm can't be directly overwritten later.
+ if ( exists $INC{'version.pm'} && ! defined $INC{'version.pm'} ) {
+ warn "Error loading version.pm: $@\n";
+ warn "Using Module::Build::Version bundled version code instead.\n";
+ delete $INC{'version.pm'};
+ delete $INC{'version/vpp.pm'};
+ }
+
+ # Avoid redefined warnings if an old version.pm was available
+ delete $version::{$_} foreach keys %version::;
+
+ # first we get the stub version module
+ my $version;
+ while (<DATA>) {
+ s/(\$VERSION)\s=\s\d+/\$VERSION = 0/;
+ $version .= $_ if $_;
+ last if /^1;$/;
+ }
+
+ # and now get the current version::vpp code
+ my $vpp;
+ while (<DATA>) {
+ s/(\$VERSION)\s=\s\d+/\$VERSION = 0/;
+ $vpp .= $_ if $_;
+ last if /^1;$/;
+ }
+
+ # but we eval them in reverse order since version depends on
+ # version::vpp to already exist
+ eval $vpp; die $@ if $@;
+ $INC{'version/vpp.pm'} = 'inside Module::Build::Version';
+ eval $version; die $@ if $@;
+ $INC{'version.pm'} = 'inside Module::Build::Version';
+}
+
+1;
+__DATA__
+# XXX replace everything from here to the next XXX with the
+# contents of version.pm from CPAN and then edit to ensure
+# the XS clause is not invoked and comment out the line about
+# C<< eval "use version::vpp $VERSION"; >> since we provide
+# our own copy
+
+package version;
+
+use 5.005_04;
+use strict;
+
+use vars qw(@ISA $VERSION $CLASS $STRICT $LAX *declare *qv);
+
+$VERSION = 0.87;
+
+$CLASS = 'version';
+
+#--------------------------------------------------------------------------#
+# Version regexp components
+#--------------------------------------------------------------------------#
+
+# Fraction part of a decimal version number. This is a common part of
+# both strict and lax decimal versions
+
+my $FRACTION_PART = qr/\.[0-9]+/;
+
+# First part of either decimal or dotted-decimal strict version number.
+# Unsigned integer with no leading zeroes (except for zero itself) to
+# avoid confusion with octal.
+
+my $STRICT_INTEGER_PART = qr/0|[1-9][0-9]*/;
+
+# First part of either decimal or dotted-decimal lax version number.
+# Unsigned integer, but allowing leading zeros. Always interpreted
+# as decimal. However, some forms of the resulting syntax give odd
+# results if used as ordinary Perl expressions, due to how perl treats
+# octals. E.g.
+# version->new("010" ) == 10
+# version->new( 010 ) == 8
+# version->new( 010.2) == 82 # "8" . "2"
+
+my $LAX_INTEGER_PART = qr/[0-9]+/;
+
+# Second and subsequent part of a strict dotted-decimal version number.
+# Leading zeroes are permitted, and the number is always decimal.
+# Limited to three digits to avoid overflow when converting to decimal
+# form and also avoid problematic style with excessive leading zeroes.
+
+my $STRICT_DOTTED_DECIMAL_PART = qr/\.[0-9]{1,3}/;
+
+# Second and subsequent part of a lax dotted-decimal version number.
+# Leading zeroes are permitted, and the number is always decimal. No
+# limit on the numerical value or number of digits, so there is the
+# possibility of overflow when converting to decimal form.
+
+my $LAX_DOTTED_DECIMAL_PART = qr/\.[0-9]+/;
+
+# Alpha suffix part of lax version number syntax. Acts like a
+# dotted-decimal part.
+
+my $LAX_ALPHA_PART = qr/_[0-9]+/;
+
+#--------------------------------------------------------------------------#
+# Strict version regexp definitions
+#--------------------------------------------------------------------------#
+
+# Strict decimal version number.
+
+my $STRICT_DECIMAL_VERSION =
+ qr/ $STRICT_INTEGER_PART $FRACTION_PART? /x;
+
+# Strict dotted-decimal version number. Must have both leading "v" and
+# at least three parts, to avoid confusion with decimal syntax.
+
+my $STRICT_DOTTED_DECIMAL_VERSION =
+ qr/ v $STRICT_INTEGER_PART $STRICT_DOTTED_DECIMAL_PART{2,} /x;
+
+# Complete strict version number syntax -- should generally be used
+# anchored: qr/ \A $STRICT \z /x
+
+$STRICT =
+ qr/ $STRICT_DECIMAL_VERSION | $STRICT_DOTTED_DECIMAL_VERSION /x;
+
+#--------------------------------------------------------------------------#
+# Lax version regexp definitions
+#--------------------------------------------------------------------------#
+
+# Lax decimal version number. Just like the strict one except for
+# allowing an alpha suffix or allowing a leading or trailing
+# decimal-point
+
+my $LAX_DECIMAL_VERSION =
+ qr/ $LAX_INTEGER_PART (?: \. | $FRACTION_PART $LAX_ALPHA_PART? )?
+ |
+ $FRACTION_PART $LAX_ALPHA_PART?
+ /x;
+
+# Lax dotted-decimal version number. Distinguished by having either
+# leading "v" or at least three non-alpha parts. Alpha part is only
+# permitted if there are at least two non-alpha parts. Strangely
+# enough, without the leading "v", Perl takes .1.2 to mean v0.1.2,
+# so when there is no "v", the leading part is optional
+
+my $LAX_DOTTED_DECIMAL_VERSION =
+ qr/
+ v $LAX_INTEGER_PART (?: $LAX_DOTTED_DECIMAL_PART+ $LAX_ALPHA_PART? )?
+ |
+ $LAX_INTEGER_PART? $LAX_DOTTED_DECIMAL_PART{2,} $LAX_ALPHA_PART?
+ /x;
+
+# Complete lax version number syntax -- should generally be used
+# anchored: qr/ \A $LAX \z /x
+#
+# The string 'undef' is a special case to make for easier handling
+# of return values from ExtUtils::MM->parse_version
+
+$LAX =
+ qr/ undef | $LAX_DECIMAL_VERSION | $LAX_DOTTED_DECIMAL_VERSION /x;
+
+#--------------------------------------------------------------------------#
+
+#eval "use version::vxs $VERSION"; XXX DONT TRY XS
+if ( 1 ) { # XXX FORCE PURE PERL
+# eval "use version::vpp $VERSION"; # don't tempt fate
+# die "$@" if ( $@ );
+ push @ISA, "version::vpp";
+ local $^W;
+ *version::qv = \&version::vpp::qv;
+ *version::declare = \&version::vpp::declare;
+ *version::_VERSION = \&version::vpp::_VERSION;
+ if ($] >= 5.009000 && $] < 5.011004) {
+ no strict 'refs';
+ *version::stringify = \&version::vpp::stringify;
+ *{'version::(""'} = \&version::vpp::stringify;
+ *version::new = \&version::vpp::new;
+ *version::parse = \&version::vpp::parse;
+ }
+}
+else { # use XS module
+# XXX NO XS FOR US -- WE DELETED IT
+}
+
+# Preloaded methods go here.
+sub import {
+ no strict 'refs';
+ my ($class) = shift;
+
+ # Set up any derived class
+ unless ($class eq 'version') {
+ local $^W;
+ *{$class.'::declare'} = \&version::declare;
+ *{$class.'::qv'} = \&version::qv;
+ }
+
+ my %args;
+ if (@_) { # any remaining terms are arguments
+ map { $args{$_} = 1 } @_
+ }
+ else { # no parameters at all on use line
+ %args =
+ (
+ qv => 1,
+ 'UNIVERSAL::VERSION' => 1,
+ );
+ }
+
+ my $callpkg = caller();
+
+ if (exists($args{declare})) {
+ *{$callpkg.'::declare'} =
+ sub {return $class->declare(shift) }
+ unless defined(&{$callpkg.'::declare'});
+ }
+
+ if (exists($args{qv})) {
+ *{$callpkg.'::qv'} =
+ sub {return $class->qv(shift) }
+ unless defined(&{$callpkg.'::qv'});
+ }
+
+ if (exists($args{'UNIVERSAL::VERSION'})) {
+ local $^W;
+ *UNIVERSAL::VERSION
+ = \&version::_VERSION;
+ }
+
+ if (exists($args{'VERSION'})) {
+ *{$callpkg.'::VERSION'} = \&version::_VERSION;
+ }
+
+ if (exists($args{'is_strict'})) {
+ *{$callpkg.'::is_strict'} = \&version::is_strict
+ unless defined(&{$callpkg.'::is_strict'});
+ }
+
+ if (exists($args{'is_lax'})) {
+ *{$callpkg.'::is_lax'} = \&version::is_lax
+ unless defined(&{$callpkg.'::is_lax'});
+ }
+}
+
+sub is_strict { defined $_[0] && $_[0] =~ qr/ \A $STRICT \z /x }
+sub is_lax { defined $_[0] && $_[0] =~ qr/ \A $LAX \z /x }
+
+1;
+
+# XXX replace everything from here to the end with the current version/vpp.pm
+
+package charstar;
+# a little helper class to emulate C char* semantics in Perl
+# so that prescan_version can use the same code as in C
+
+use overload (
+ '""' => \&thischar,
+ '0+' => \&thischar,
+ '++' => \&increment,
+ '--' => \&decrement,
+ '+' => \&plus,
+ '-' => \&minus,
+ '*' => \&multiply,
+ 'cmp' => \&cmp,
+ '<=>' => \&spaceship,
+ 'bool' => \&thischar,
+ '=' => \&clone,
+);
+
+sub new {
+ my ($self, $string) = @_;
+ my $class = ref($self) || $self;
+
+ my $obj = {
+ string => [split(//,$string)],
+ current => 0,
+ };
+ return bless $obj, $class;
+}
+
+sub thischar {
+ my ($self) = @_;
+ my $last = $#{$self->{string}};
+ my $curr = $self->{current};
+ if ($curr >= 0 && $curr <= $last) {
+ return $self->{string}->[$curr];
+ }
+ else {
+ return '';
+ }
+}
+
+sub increment {
+ my ($self) = @_;
+ $self->{current}++;
+}
+
+sub decrement {
+ my ($self) = @_;
+ $self->{current}--;
+}
+
+sub plus {
+ my ($self, $offset) = @_;
+ my $rself = $self->clone;
+ $rself->{current} += $offset;
+ return $rself;
+}
+
+sub minus {
+ my ($self, $offset) = @_;
+ my $rself = $self->clone;
+ $rself->{current} -= $offset;
+ return $rself;
+}
+
+sub multiply {
+ my ($left, $right, $swapped) = @_;
+ my $char = $left->thischar();
+ return $char * $right;
+}
+
+sub spaceship {
+ my ($left, $right, $swapped) = @_;
+ unless (ref($right)) { # not an object already
+ $right = $left->new($right);
+ }
+ return $left->{current} <=> $right->{current};
+}
+
+sub cmp {
+ my ($left, $right, $swapped) = @_;
+ unless (ref($right)) { # not an object already
+ if (length($right) == 1) { # comparing single character only
+ return $left->thischar cmp $right;
+ }
+ $right = $left->new($right);
+ }
+ return $left->currstr cmp $right->currstr;
+}
+
+sub bool {
+ my ($self) = @_;
+ my $char = $self->thischar;
+ return ($char ne '');
+}
+
+sub clone {
+ my ($left, $right, $swapped) = @_;
+ $right = {
+ string => [@{$left->{string}}],
+ current => $left->{current},
+ };
+ return bless $right, ref($left);
+}
+
+sub currstr {
+ my ($self, $s) = @_;
+ my $curr = $self->{current};
+ my $last = $#{$self->{string}};
+ if (defined($s) && $s->{current} < $last) {
+ $last = $s->{current};
+ }
+
+ my $string = join('', @{$self->{string}}[$curr..$last]);
+ return $string;
+}
+
+package version::vpp;
+use strict;
+
+use POSIX qw/locale_h/;
+use locale;
+use vars qw ($VERSION @ISA @REGEXS);
+$VERSION = 0.87;
+
+use overload (
+ '""' => \&stringify,
+ '0+' => \&numify,
+ 'cmp' => \&vcmp,
+ '<=>' => \&vcmp,
+ 'bool' => \&vbool,
+ 'nomethod' => \&vnoop,
+);
+
+eval "use warnings";
+if ($@) {
+ eval '
+ package warnings;
+ sub enabled {return $^W;}
+ 1;
+ ';
+}
+
+my $VERSION_MAX = 0x7FFFFFFF;
+
+# implement prescan_version as closely to the C version as possible
+use constant TRUE => 1;
+use constant FALSE => 0;
+
+sub isDIGIT {
+ my ($char) = shift->thischar();
+ return ($char =~ /\d/);
+}
+
+sub isALPHA {
+ my ($char) = shift->thischar();
+ return ($char =~ /[a-zA-Z]/);
+}
+
+sub isSPACE {
+ my ($char) = shift->thischar();
+ return ($char =~ /\s/);
+}
+
+sub BADVERSION {
+ my ($s, $errstr, $error) = @_;
+ if ($errstr) {
+ $$errstr = $error;
+ }
+ return $s;
+}
+
+sub prescan_version {
+ my ($s, $strict, $errstr, $sqv, $ssaw_decimal, $swidth, $salpha) = @_;
+ my $qv = defined $sqv ? $$sqv : FALSE;
+ my $saw_decimal = defined $ssaw_decimal ? $$ssaw_decimal : 0;
+ my $width = defined $swidth ? $$swidth : 3;
+ my $alpha = defined $salpha ? $$salpha : FALSE;
+
+ my $d = $s;
+
+ if ($qv && isDIGIT($d)) {
+ goto dotted_decimal_version;
+ }
+
+ if ($d eq 'v') { # explicit v-string
+ $d++;
+ if (isDIGIT($d)) {
+ $qv = TRUE;
+ }
+ else { # degenerate v-string
+ # requires v1.2.3
+ return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
+ }
+
+dotted_decimal_version:
+ if ($strict && $d eq '0' && isDIGIT($d+1)) {
+ # no leading zeros allowed
+ return BADVERSION($s,$errstr,"Invalid version format (no leading zeros)");
+ }
+
+ while (isDIGIT($d)) { # integer part
+ $d++;
+ }
+
+ if ($d eq '.')
+ {
+ $saw_decimal++;
+ $d++; # decimal point
+ }
+ else
+ {
+ if ($strict) {
+ # require v1.2.3
+ return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
+ }
+ else {
+ goto version_prescan_finish;
+ }
+ }
+
+ {
+ my $i = 0;
+ my $j = 0;
+ while (isDIGIT($d)) { # just keep reading
+ $i++;
+ while (isDIGIT($d)) {
+ $d++; $j++;
+ # maximum 3 digits between decimal
+ if ($strict && $j > 3) {
+ return BADVERSION($s,$errstr,"Invalid version format (maximum 3 digits between decimals)");
+ }
+ }
+ if ($d eq '_') {
+ if ($strict) {
+ return BADVERSION($s,$errstr,"Invalid version format (no underscores)");
+ }
+ if ( $alpha ) {
+ return BADVERSION($s,$errstr,"Invalid version format (multiple underscores)");
+ }
+ $d++;
+ $alpha = TRUE;
+ }
+ elsif ($d eq '.') {
+ if ($alpha) {
+ return BADVERSION($s,$errstr,"Invalid version format (underscores before decimal)");
+ }
+ $saw_decimal++;
+ $d++;
+ }
+ elsif (!isDIGIT($d)) {
+ last;
+ }
+ $j = 0;
+ }
+
+ if ($strict && $i < 2) {
+ # requires v1.2.3
+ return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
+ }
+ }
+ } # end if dotted-decimal
+ else
+ { # decimal versions
+ # special $strict case for leading '.' or '0'
+ if ($strict) {
+ if ($d eq '.') {
+ return BADVERSION($s,$errstr,"Invalid version format (0 before decimal required)");
+ }
+ if ($d eq '0' && isDIGIT($d+1)) {
+ return BADVERSION($s,$errstr,"Invalid version format (no leading zeros)");
+ }
+ }
+
+ # consume all of the integer part
+ while (isDIGIT($d)) {
+ $d++;
+ }
+
+ # look for a fractional part
+ if ($d eq '.') {
+ # we found it, so consume it
+ $saw_decimal++;
+ $d++;
+ }
+ elsif (!$d || $d eq ';' || isSPACE($d) || $d eq '}') {
+ if ( $d == $s ) {
+ # found nothing
+ return BADVERSION($s,$errstr,"Invalid version format (version required)");
+ }
+ # found just an integer
+ goto version_prescan_finish;
+ }
+ elsif ( $d == $s ) {
+ # didn't find either integer or period
+ return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)");
+ }
+ elsif ($d eq '_') {
+ # underscore can't come after integer part
+ if ($strict) {
+ return BADVERSION($s,$errstr,"Invalid version format (no underscores)");
+ }
+ elsif (isDIGIT($d+1)) {
+ return BADVERSION($s,$errstr,"Invalid version format (alpha without decimal)");
+ }
+ else {
+ return BADVERSION($s,$errstr,"Invalid version format (misplaced underscore)");
+ }
+ }
+ elsif ($d) {
+ # anything else after integer part is just invalid data
+ return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)");
+ }
+
+ # scan the fractional part after the decimal point
+ if ($d && !isDIGIT($d) && ($strict || ! ($d eq ';' || isSPACE($d) || $d eq '}') )) {
+ # $strict or lax-but-not-the-end
+ return BADVERSION($s,$errstr,"Invalid version format (fractional part required)");
+ }
+
+ while (isDIGIT($d)) {
+ $d++;
+ if ($d eq '.' && isDIGIT($d-1)) {
+ if ($alpha) {
+ return BADVERSION($s,$errstr,"Invalid version format (underscores before decimal)");
+ }
+ if ($strict) {
+ return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions must begin with 'v')");
+ }
+ $d = $s; # start all over again
+ $qv = TRUE;
+ goto dotted_decimal_version;
+ }
+ if ($d eq '_') {
+ if ($strict) {
+ return BADVERSION($s,$errstr,"Invalid version format (no underscores)");
+ }
+ if ( $alpha ) {
+ return BADVERSION($s,$errstr,"Invalid version format (multiple underscores)");
+ }
+ if ( ! isDIGIT($d+1) ) {
+ return BADVERSION($s,$errstr,"Invalid version format (misplaced underscore)");
+ }
+ $d++;
+ $alpha = TRUE;
+ }
+ }
+ }
+
+version_prescan_finish:
+ while (isSPACE($d)) {
+ $d++;
+ }
+
+ if ($d && !isDIGIT($d) && (! ($d eq ';' || $d eq '}') )) {
+ # trailing non-numeric data
+ return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)");
+ }
+
+ if (defined $sqv) {
+ $$sqv = $qv;
+ }
+ if (defined $swidth) {
+ $$swidth = $width;
+ }
+ if (defined $ssaw_decimal) {
+ $$ssaw_decimal = $saw_decimal;
+ }
+ if (defined $salpha) {
+ $$salpha = $alpha;
+ }
+ return $d;
+}
+
+sub scan_version {
+ my ($s, $rv, $qv) = @_;
+ my $start;
+ my $pos;
+ my $last;
+ my $errstr;
+ my $saw_decimal = 0;
+ my $width = 3;
+ my $alpha = FALSE;
+ my $vinf = FALSE;
+ my @av;
+
+ $s = new charstar $s;
+
+ while (isSPACE($s)) { # leading whitespace is OK
+ $s++;
+ }
+
+ $last = prescan_version($s, FALSE, \$errstr, \$qv, \$saw_decimal,
+ \$width, \$alpha);
+
+ if ($errstr) {
+ # 'undef' is a special case and not an error
+ if ( $s ne 'undef') {
+ use Carp;
+ Carp::croak($errstr);
+ }
+ }
+
+ $start = $s;
+ if ($s eq 'v') {
+ $s++;
+ }
+ $pos = $s;
+
+ if ( $qv ) {
+ $$rv->{qv} = $qv;
+ }
+ if ( $alpha ) {
+ $$rv->{alpha} = $alpha;
+ }
+ if ( !$qv && $width < 3 ) {
+ $$rv->{width} = $width;
+ }
+
+ while (isDIGIT($pos)) {
+ $pos++;
+ }
+ if (!isALPHA($pos)) {
+ my $rev;
+
+ for (;;) {
+ $rev = 0;
+ {
+ # this is atoi() that delimits on underscores
+ my $end = $pos;
+ my $mult = 1;
+ my $orev;
+
+ # the following if() will only be true after the decimal
+ # point of a version originally created with a bare
+ # floating point number, i.e. not quoted in any way
+ #
+ if ( !$qv && $s > $start && $saw_decimal == 1 ) {
+ $mult *= 100;
+ while ( $s < $end ) {
+ $orev = $rev;
+ $rev += $s * $mult;
+ $mult /= 10;
+ if ( (abs($orev) > abs($rev))
+ || (abs($rev) > $VERSION_MAX )) {
+ warn("Integer overflow in version %d",
+ $VERSION_MAX);
+ $s = $end - 1;
+ $rev = $VERSION_MAX;
+ $vinf = 1;
+ }
+ $s++;
+ if ( $s eq '_' ) {
+ $s++;
+ }
+ }
+ }
+ else {
+ while (--$end >= $s) {
+ $orev = $rev;
+ $rev += $end * $mult;
+ $mult *= 10;
+ if ( (abs($orev) > abs($rev))
+ || (abs($rev) > $VERSION_MAX )) {
+ warn("Integer overflow in version");
+ $end = $s - 1;
+ $rev = $VERSION_MAX;
+ $vinf = 1;
+ }
+ }
+ }
+ }
+
+ # Append revision
+ push @av, $rev;
+ if ( $vinf ) {
+ $s = $last;
+ last;
+ }
+ elsif ( $pos eq '.' ) {
+ $s = ++$pos;
+ }
+ elsif ( $pos eq '_' && isDIGIT($pos+1) ) {
+ $s = ++$pos;
+ }
+ elsif ( $pos eq ',' && isDIGIT($pos+1) ) {
+ $s = ++$pos;
+ }
+ elsif ( isDIGIT($pos) ) {
+ $s = $pos;
+ }
+ else {
+ $s = $pos;
+ last;
+ }
+ if ( $qv ) {
+ while ( isDIGIT($pos) ) {
+ $pos++;
+ }
+ }
+ else {
+ my $digits = 0;
+ while ( ( isDIGIT($pos) || $pos eq '_' ) && $digits < 3 ) {
+ if ( $pos ne '_' ) {
+ $digits++;
+ }
+ $pos++;
+ }
+ }
+ }
+ }
+ if ( $qv ) { # quoted versions always get at least three terms
+ my $len = $#av;
+ # This for loop appears to trigger a compiler bug on OS X, as it
+ # loops infinitely. Yes, len is negative. No, it makes no sense.
+ # Compiler in question is:
+ # gcc version 3.3 20030304 (Apple Computer, Inc. build 1640)
+ # for ( len = 2 - len; len > 0; len-- )
+ # av_push(MUTABLE_AV(sv), newSViv(0));
+ #
+ $len = 2 - $len;
+ while ($len-- > 0) {
+ push @av, 0;
+ }
+ }
+
+ # need to save off the current version string for later
+ if ( $vinf ) {
+ $$rv->{original} = "v.Inf";
+ $$rv->{vinf} = 1;
+ }
+ elsif ( $s > $start ) {
+ $$rv->{original} = $start->currstr($s);
+ if ( $qv && $saw_decimal == 1 && $start ne 'v' ) {
+ # need to insert a v to be consistent
+ $$rv->{original} = 'v' . $$rv->{original};
+ }
+ }
+ else {
+ $$rv->{original} = '0';
+ push(@av, 0);
+ }
+
+ # And finally, store the AV in the hash
+ $$rv->{version} = \@av;
+
+ # fix RT#19517 - special case 'undef' as string
+ if ($s eq 'undef') {
+ $s += 5;
+ }
+
+ return $s;
+}
+
+sub new
+{
+ my ($class, $value) = @_;
+ my $self = bless ({}, ref ($class) || $class);
+ my $qv = FALSE;
+
+ if ( ref($value) && eval('$value->isa("version")') ) {
+ # Can copy the elements directly
+ $self->{version} = [ @{$value->{version} } ];
+ $self->{qv} = 1 if $value->{qv};
+ $self->{alpha} = 1 if $value->{alpha};
+ $self->{original} = ''.$value->{original};
+ return $self;
+ }
+
+ my $currlocale = setlocale(LC_ALL);
+
+ # if the current locale uses commas for decimal points, we
+ # just replace commas with decimal places, rather than changing
+ # locales
+ if ( localeconv()->{decimal_point} eq ',' ) {
+ $value =~ tr/,/./;
+ }
+
+ if ( not defined $value or $value =~ /^undef$/ ) {
+ # RT #19517 - special case for undef comparison
+ # or someone forgot to pass a value
+ push @{$self->{version}}, 0;
+ $self->{original} = "0";
+ return ($self);
+ }
+
+ if ( $#_ == 2 ) { # must be CVS-style
+ $value = $_[2];
+ $qv = TRUE;
+ }
+
+ $value = _un_vstring($value);
+
+ # exponential notation
+ if ( $value =~ /\d+.?\d*e[-+]?\d+/ ) {
+ $value = sprintf("%.9f",$value);
+ $value =~ s/(0+)$//; # trim trailing zeros
+ }
+
+ my $s = scan_version($value, \$self, $qv);
+
+ if ($s) { # must be something left over
+ warn("Version string '%s' contains invalid data; "
+ ."ignoring: '%s'", $value, $s);
+ }
+
+ return ($self);
+}
+
+*parse = \&new;
+
+sub numify
+{
+ my ($self) = @_;
+ unless (_verify($self)) {
+ require Carp;
+ Carp::croak("Invalid version object");
+ }
+ my $width = $self->{width} || 3;
+ my $alpha = $self->{alpha} || "";
+ my $len = $#{$self->{version}};
+ my $digit = $self->{version}[0];
+ my $string = sprintf("%d.", $digit );
+
+ for ( my $i = 1 ; $i < $len ; $i++ ) {
+ $digit = $self->{version}[$i];
+ if ( $width < 3 ) {
+ my $denom = 10**(3-$width);
+ my $quot = int($digit/$denom);
+ my $rem = $digit - ($quot * $denom);
+ $string .= sprintf("%0".$width."d_%d", $quot, $rem);
+ }
+ else {
+ $string .= sprintf("%03d", $digit);
+ }
+ }
+
+ if ( $len > 0 ) {
+ $digit = $self->{version}[$len];
+ if ( $alpha && $width == 3 ) {
+ $string .= "_";
+ }
+ $string .= sprintf("%0".$width."d", $digit);
+ }
+ else # $len = 0
+ {
+ $string .= sprintf("000");
+ }
+
+ return $string;
+}
+
+sub normal
+{
+ my ($self) = @_;
+ unless (_verify($self)) {
+ require Carp;
+ Carp::croak("Invalid version object");
+ }
+ my $alpha = $self->{alpha} || "";
+ my $len = $#{$self->{version}};
+ my $digit = $self->{version}[0];
+ my $string = sprintf("v%d", $digit );
+
+ for ( my $i = 1 ; $i < $len ; $i++ ) {
+ $digit = $self->{version}[$i];
+ $string .= sprintf(".%d", $digit);
+ }
+
+ if ( $len > 0 ) {
+ $digit = $self->{version}[$len];
+ if ( $alpha ) {
+ $string .= sprintf("_%0d", $digit);
+ }
+ else {
+ $string .= sprintf(".%0d", $digit);
+ }
+ }
+
+ if ( $len <= 2 ) {
+ for ( $len = 2 - $len; $len != 0; $len-- ) {
+ $string .= sprintf(".%0d", 0);
+ }
+ }
+
+ return $string;
+}
+
+sub stringify
+{
+ my ($self) = @_;
+ unless (_verify($self)) {
+ require Carp;
+ Carp::croak("Invalid version object");
+ }
+ return exists $self->{original}
+ ? $self->{original}
+ : exists $self->{qv}
+ ? $self->normal
+ : $self->numify;
+}
+
+sub vcmp
+{
+ my ($left,$right,$swap) = @_;
+ my $class = ref($left);
+ unless ( eval { $right->isa($class) } ) {
+ $right = $class->new($right);
+ }
+
+ if ( $swap ) {
+ ($left, $right) = ($right, $left);
+ }
+ unless (_verify($left)) {
+ require Carp;
+ Carp::croak("Invalid version object");
+ }
+ unless (_verify($right)) {
+ require Carp;
+ Carp::croak("Invalid version object");
+ }
+ my $l = $#{$left->{version}};
+ my $r = $#{$right->{version}};
+ my $m = $l < $r ? $l : $r;
+ my $lalpha = $left->is_alpha;
+ my $ralpha = $right->is_alpha;
+ my $retval = 0;
+ my $i = 0;
+ while ( $i <= $m && $retval == 0 ) {
+ $retval = $left->{version}[$i] <=> $right->{version}[$i];
+ $i++;
+ }
+
+ # tiebreaker for alpha with identical terms
+ if ( $retval == 0
+ && $l == $r
+ && $left->{version}[$m] == $right->{version}[$m]
+ && ( $lalpha || $ralpha ) ) {
+
+ if ( $lalpha && !$ralpha ) {
+ $retval = -1;
+ }
+ elsif ( $ralpha && !$lalpha) {
+ $retval = +1;
+ }
+ }
+
+ # possible match except for trailing 0's
+ if ( $retval == 0 && $l != $r ) {
+ if ( $l < $r ) {
+ while ( $i <= $r && $retval == 0 ) {
+ if ( $right->{version}[$i] != 0 ) {
+ $retval = -1; # not a match after all
+ }
+ $i++;
+ }
+ }
+ else {
+ while ( $i <= $l && $retval == 0 ) {
+ if ( $left->{version}[$i] != 0 ) {
+ $retval = +1; # not a match after all
+ }
+ $i++;
+ }
+ }
+ }
+
+ return $retval;
+}
+
+sub vbool {
+ my ($self) = @_;
+ return vcmp($self,$self->new("0"),1);
+}
+
+sub vnoop {
+ require Carp;
+ Carp::croak("operation not supported with version object");
+}
+
+sub is_alpha {
+ my ($self) = @_;
+ return (exists $self->{alpha});
+}
+
+sub qv {
+ my $value = shift;
+ my $class = 'version';
+ if (@_) {
+ $class = ref($value) || $value;
+ $value = shift;
+ }
+
+ $value = _un_vstring($value);
+ $value = 'v'.$value unless $value =~ /(^v|\d+\.\d+\.\d)/;
+ my $version = $class->new($value);
+ return $version;
+}
+
+*declare = \&qv;
+
+sub is_qv {
+ my ($self) = @_;
+ return (exists $self->{qv});
+}
+
+
+sub _verify {
+ my ($self) = @_;
+ if ( ref($self)
+ && eval { exists $self->{version} }
+ && ref($self->{version}) eq 'ARRAY'
+ ) {
+ return 1;
+ }
+ else {
+ return 0;
+ }
+}
+
+sub _is_non_alphanumeric {
+ my $s = shift;
+ $s = new charstar $s;
+ while ($s) {
+ return 0 if isSPACE($s); # early out
+ return 1 unless (isALPHA($s) || isDIGIT($s) || $s =~ /[.-]/);
+ $s++;
+ }
+ return 0;
+}
+
+sub _un_vstring {
+ my $value = shift;
+ # may be a v-string
+ if ( length($value) >= 3 && $value !~ /[._]/
+ && _is_non_alphanumeric($value)) {
+ my $tvalue;
+ if ( $] ge 5.008_001 ) {
+ $tvalue = _find_magic_vstring($value);
+ $value = $tvalue if length $tvalue;
+ }
+ elsif ( $] ge 5.006_000 ) {
+ $tvalue = sprintf("v%vd",$value);
+ if ( $tvalue =~ /^v\d+(\.\d+){2,}$/ ) {
+ # must be a v-string
+ $value = $tvalue;
+ }
+ }
+ }
+ return $value;
+}
+
+sub _find_magic_vstring {
+ my $value = shift;
+ my $tvalue = '';
+ require B;
+ my $sv = B::svref_2object(\$value);
+ my $magic = ref($sv) eq 'B::PVMG' ? $sv->MAGIC : undef;
+ while ( $magic ) {
+ if ( $magic->TYPE eq 'V' ) {
+ $tvalue = $magic->PTR;
+ $tvalue =~ s/^v?(.+)$/v$1/;
+ last;
+ }
+ else {
+ $magic = $magic->MOREMAGIC;
+ }
+ }
+ return $tvalue;
+}
+
+sub _VERSION {
+ my ($obj, $req) = @_;
+ my $class = ref($obj) || $obj;
+
+ no strict 'refs';
+ if ( exists $INC{"$class.pm"} and not %{"$class\::"} and $] >= 5.008) {
+ # file but no package
+ require Carp;
+ Carp::croak( "$class defines neither package nor VERSION"
+ ."--version check failed");
+ }
+
+ my $version = eval "\$$class\::VERSION";
+ if ( defined $version ) {
+ local $^W if $] <= 5.008;
+ $version = version::vpp->new($version);
+ }
+
+ if ( defined $req ) {
+ unless ( defined $version ) {
+ require Carp;
+ my $msg = $] < 5.006
+ ? "$class version $req required--this is only version "
+ : "$class does not define \$$class\::VERSION"
+ ."--version check failed";
+
+ if ( $ENV{VERSION_DEBUG} ) {
+ Carp::confess($msg);
+ }
+ else {
+ Carp::croak($msg);
+ }
+ }
+
+ $req = version::vpp->new($req);
+
+ if ( $req > $version ) {
+ require Carp;
+ if ( $req->is_qv ) {
+ Carp::croak(
+ sprintf ("%s version %s required--".
+ "this is only version %s", $class,
+ $req->normal, $version->normal)
+ );
+ }
+ else {
+ Carp::croak(
+ sprintf ("%s version %s required--".
+ "this is only version %s", $class,
+ $req->stringify, $version->stringify)
+ );
+ }
+ }
+ }
+
+ return defined $version ? $version->stringify : undef;
+}
+
+1; #this line is important and will help the module return a true value
diff --git a/inc/Module/Metadata.pm b/inc/Module/Metadata.pm
new file mode 100644
index 0000000..5d8b5c0
--- /dev/null
+++ b/inc/Module/Metadata.pm
@@ -0,0 +1,759 @@
+# -*- mode: cperl; tab-width: 8; indent-tabs-mode: nil; basic-offset: 2 -*-
+# vim:ts=8:sw=2:et:sta:sts=2
+package Module::Metadata;
+
+# stolen from Module::Build::Version and ::Base - this is perl licensed code,
+# copyright them.
+
+# This module provides routines to gather information about
+# perl modules (assuming this may be expanded in the distant
+# parrot future to look at other types of modules).
+
+use strict;
+use vars qw($VERSION);
+$VERSION = '1.000002';
+$VERSION = eval $VERSION;
+
+use File::Spec;
+use version 0.87;
+BEGIN {
+ if ($INC{'Log/Contextual.pm'}) {
+ Log::Contextual->import('log_info');
+ } else {
+ *log_info = sub (&) { warn $_[0]->() };
+ }
+}
+use File::Find qw(find);
+
+my $V_NUM_REGEXP = qr{v?[0-9._]+}; # crudely, a v-string or decimal
+
+my $PKG_REGEXP = qr{ # match a package declaration
+ ^[\s\{;]* # intro chars on a line
+ package # the word 'package'
+ \s+ # whitespace
+ ([\w:]+) # a package name
+ \s* # optional whitespace
+ ($V_NUM_REGEXP)? # optional version number
+ \s* # optional whitesapce
+ ; # semicolon line terminator
+}x;
+
+my $VARNAME_REGEXP = qr{ # match fully-qualified VERSION name
+ ([\$*]) # sigil - $ or *
+ (
+ ( # optional leading package name
+ (?:::|\')? # possibly starting like just :: (Ì la $::VERSION)
+ (?:\w+(?:::|\'))* # Foo::Bar:: ...
+ )?
+ VERSION
+ )\b
+}x;
+
+my $VERS_REGEXP = qr{ # match a VERSION definition
+ (?:
+ \(\s*$VARNAME_REGEXP\s*\) # with parens
+ |
+ $VARNAME_REGEXP # without parens
+ )
+ \s*
+ =[^=~] # = but not ==, nor =~
+}x;
+
+
+sub new_from_file {
+ my $class = shift;
+ my $filename = File::Spec->rel2abs( shift );
+
+ return undef unless defined( $filename ) && -f $filename;
+ return $class->_init(undef, $filename, @_);
+}
+
+sub new_from_module {
+ my $class = shift;
+ my $module = shift;
+ my %props = @_;
+
+ $props{inc} ||= \@INC;
+ my $filename = $class->find_module_by_name( $module, $props{inc} );
+ return undef unless defined( $filename ) && -f $filename;
+ return $class->_init($module, $filename, %props);
+}
+
+{
+
+ my $compare_versions = sub {
+ my ($v1, $op, $v2) = @_;
+ $v1 = version->new($v1)
+ unless eval { $v1->isa('version') };
+
+ my $eval_str = "\$v1 $op \$v2";
+ my $result = eval $eval_str;
+ log_info { "error comparing versions: '$eval_str' $@" } if $@;
+
+ return $result;
+ };
+
+ my $normalize_version = sub {
+ my ($version) = @_;
+ if ( $version =~ /[=<>!,]/ ) { # logic, not just version
+ # take as is without modification
+ }
+ elsif ( ref $version eq 'version' ) { # version objects
+ $version = $version->is_qv ? $version->normal : $version->stringify;
+ }
+ elsif ( $version =~ /^[^v][^.]*\.[^.]+\./ ) { # no leading v, multiple dots
+ # normalize string tuples without "v": "1.2.3" -> "v1.2.3"
+ $version = "v$version";
+ }
+ else {
+ # leave alone
+ }
+ return $version;
+ };
+
+ # separate out some of the conflict resolution logic
+
+ my $resolve_module_versions = sub {
+ my $packages = shift;
+
+ my( $file, $version );
+ my $err = '';
+ foreach my $p ( @$packages ) {
+ if ( defined( $p->{version} ) ) {
+ if ( defined( $version ) ) {
+ if ( $compare_versions->( $version, '!=', $p->{version} ) ) {
+ $err .= " $p->{file} ($p->{version})\n";
+ } else {
+ # same version declared multiple times, ignore
+ }
+ } else {
+ $file = $p->{file};
+ $version = $p->{version};
+ }
+ }
+ $file ||= $p->{file} if defined( $p->{file} );
+ }
+
+ if ( $err ) {
+ $err = " $file ($version)\n" . $err;
+ }
+
+ my %result = (
+ file => $file,
+ version => $version,
+ err => $err
+ );
+
+ return \%result;
+ };
+
+ sub package_versions_from_directory {
+ my ( $class, $dir, $files ) = @_;
+
+ my @files;
+
+ if ( $files ) {
+ @files = @$files;
+ } else {
+ find( {
+ wanted => sub {
+ push @files, $_ if -f $_ && /\.pm$/;
+ },
+ no_chdir => 1,
+ }, $dir );
+ }
+
+ # First, we enumerate all packages & versions,
+ # separating into primary & alternative candidates
+ my( %prime, %alt );
+ foreach my $file (@files) {
+ my $mapped_filename = File::Spec->abs2rel( $file, $dir );
+ my @path = split( /\//, $mapped_filename );
+ (my $prime_package = join( '::', @path )) =~ s/\.pm$//;
+
+ my $pm_info = $class->new_from_file( $file );
+
+ foreach my $package ( $pm_info->packages_inside ) {
+ next if $package eq 'main'; # main can appear numerous times, ignore
+ next if $package eq 'DB'; # special debugging package, ignore
+ next if grep /^_/, split( /::/, $package ); # private package, ignore
+
+ my $version = $pm_info->version( $package );
+
+ if ( $package eq $prime_package ) {
+ if ( exists( $prime{$package} ) ) {
+ # M::B::ModuleInfo will handle this conflict
+ die "Unexpected conflict in '$package'; multiple versions found.\n";
+ } else {
+ $prime{$package}{file} = $mapped_filename;
+ $prime{$package}{version} = $version if defined( $version );
+ }
+ } else {
+ push( @{$alt{$package}}, {
+ file => $mapped_filename,
+ version => $version,
+ } );
+ }
+ }
+ }
+
+ # Then we iterate over all the packages found above, identifying conflicts
+ # and selecting the "best" candidate for recording the file & version
+ # for each package.
+ foreach my $package ( keys( %alt ) ) {
+ my $result = $resolve_module_versions->( $alt{$package} );
+
+ if ( exists( $prime{$package} ) ) { # primary package selected
+
+ if ( $result->{err} ) {
+ # Use the selected primary package, but there are conflicting
+ # errors among multiple alternative packages that need to be
+ # reported
+ log_info {
+ "Found conflicting versions for package '$package'\n" .
+ " $prime{$package}{file} ($prime{$package}{version})\n" .
+ $result->{err}
+ };
+
+ } elsif ( defined( $result->{version} ) ) {
+ # There is a primary package selected, and exactly one
+ # alternative package
+
+ if ( exists( $prime{$package}{version} ) &&
+ defined( $prime{$package}{version} ) ) {
+ # Unless the version of the primary package agrees with the
+ # version of the alternative package, report a conflict
+ if ( $compare_versions->(
+ $prime{$package}{version}, '!=', $result->{version}
+ )
+ ) {
+
+ log_info {
+ "Found conflicting versions for package '$package'\n" .
+ " $prime{$package}{file} ($prime{$package}{version})\n" .
+ " $result->{file} ($result->{version})\n"
+ };
+ }
+
+ } else {
+ # The prime package selected has no version so, we choose to
+ # use any alternative package that does have a version
+ $prime{$package}{file} = $result->{file};
+ $prime{$package}{version} = $result->{version};
+ }
+
+ } else {
+ # no alt package found with a version, but we have a prime
+ # package so we use it whether it has a version or not
+ }
+
+ } else { # No primary package was selected, use the best alternative
+
+ if ( $result->{err} ) {
+ log_info {
+ "Found conflicting versions for package '$package'\n" .
+ $result->{err}
+ };
+ }
+
+ # Despite possible conflicting versions, we choose to record
+ # something rather than nothing
+ $prime{$package}{file} = $result->{file};
+ $prime{$package}{version} = $result->{version}
+ if defined( $result->{version} );
+ }
+ }
+
+ # Normalize versions. Can't use exists() here because of bug in YAML::Node.
+ # XXX "bug in YAML::Node" comment seems irrelvant -- dagolden, 2009-05-18
+ for (grep defined $_->{version}, values %prime) {
+ $_->{version} = $normalize_version->( $_->{version} );
+ }
+
+ return \%prime;
+ }
+}
+
+
+sub _init {
+ my $class = shift;
+ my $module = shift;
+ my $filename = shift;
+ my %props = @_;
+
+ my( %valid_props, @valid_props );
+ @valid_props = qw( collect_pod inc );
+ @valid_props{@valid_props} = delete( @props{@valid_props} );
+ warn "Unknown properties: @{[keys %props]}\n" if scalar( %props );
+
+ my %data = (
+ module => $module,
+ filename => $filename,
+ version => undef,
+ packages => [],
+ versions => {},
+ pod => {},
+ pod_headings => [],
+ collect_pod => 0,
+
+ %valid_props,
+ );
+
+ my $self = bless(\%data, $class);
+
+ $self->_parse_file();
+
+ unless($self->{module} and length($self->{module})) {
+ my ($v, $d, $f) = File::Spec->splitpath($self->{filename});
+ if($f =~ /\.pm$/) {
+ $f =~ s/\..+$//;
+ my @candidates = grep /$f$/, @{$self->{packages}};
+ $self->{module} = shift(@candidates); # punt
+ }
+ else {
+ if(grep /main/, @{$self->{packages}}) {
+ $self->{module} = 'main';
+ }
+ else {
+ $self->{module} = $self->{packages}[0] || '';
+ }
+ }
+ }
+
+ $self->{version} = $self->{versions}{$self->{module}}
+ if defined( $self->{module} );
+
+ return $self;
+}
+
+# class method
+sub _do_find_module {
+ my $class = shift;
+ my $module = shift || die 'find_module_by_name() requires a package name';
+ my $dirs = shift || \@INC;
+
+ my $file = File::Spec->catfile(split( /::/, $module));
+ foreach my $dir ( @$dirs ) {
+ my $testfile = File::Spec->catfile($dir, $file);
+ return [ File::Spec->rel2abs( $testfile ), $dir ]
+ if -e $testfile and !-d _; # For stuff like ExtUtils::xsubpp
+ return [ File::Spec->rel2abs( "$testfile.pm" ), $dir ]
+ if -e "$testfile.pm";
+ }
+ return;
+}
+
+# class method
+sub find_module_by_name {
+ my $found = shift()->_do_find_module(@_) or return;
+ return $found->[0];
+}
+
+# class method
+sub find_module_dir_by_name {
+ my $found = shift()->_do_find_module(@_) or return;
+ return $found->[1];
+}
+
+
+# given a line of perl code, attempt to parse it if it looks like a
+# $VERSION assignment, returning sigil, full name, & package name
+sub _parse_version_expression {
+ my $self = shift;
+ my $line = shift;
+
+ my( $sig, $var, $pkg );
+ if ( $line =~ $VERS_REGEXP ) {
+ ( $sig, $var, $pkg ) = $2 ? ( $1, $2, $3 ) : ( $4, $5, $6 );
+ if ( $pkg ) {
+ $pkg = ($pkg eq '::') ? 'main' : $pkg;
+ $pkg =~ s/::$//;
+ }
+ }
+
+ return ( $sig, $var, $pkg );
+}
+
+sub _parse_file {
+ my $self = shift;
+
+ my $filename = $self->{filename};
+ open( my $fh, '<', $filename )
+ or die( "Can't open '$filename': $!" );
+
+ $self->_parse_fh($fh);
+}
+
+sub _parse_fh {
+ my ($self, $fh) = @_;
+
+ my( $in_pod, $seen_end, $need_vers ) = ( 0, 0, 0 );
+ my( @pkgs, %vers, %pod, @pod );
+ my $pkg = 'main';
+ my $pod_sect = '';
+ my $pod_data = '';
+
+ while (defined( my $line = <$fh> )) {
+ my $line_num = $.;
+
+ chomp( $line );
+ next if $line =~ /^\s*#/;
+
+ $in_pod = ($line =~ /^=(?!cut)/) ? 1 : ($line =~ /^=cut/) ? 0 : $in_pod;
+
+ # Would be nice if we could also check $in_string or something too
+ last if !$in_pod && $line =~ /^__(?:DATA|END)__$/;
+
+ if ( $in_pod || $line =~ /^=cut/ ) {
+
+ if ( $line =~ /^=head\d\s+(.+)\s*$/ ) {
+ push( @pod, $1 );
+ if ( $self->{collect_pod} && length( $pod_data ) ) {
+ $pod{$pod_sect} = $pod_data;
+ $pod_data = '';
+ }
+ $pod_sect = $1;
+
+
+ } elsif ( $self->{collect_pod} ) {
+ $pod_data .= "$line\n";
+
+ }
+
+ } else {
+
+ $pod_sect = '';
+ $pod_data = '';
+
+ # parse $line to see if it's a $VERSION declaration
+ my( $vers_sig, $vers_fullname, $vers_pkg ) =
+ $self->_parse_version_expression( $line );
+
+ if ( $line =~ $PKG_REGEXP ) {
+ $pkg = $1;
+ push( @pkgs, $pkg ) unless grep( $pkg eq $_, @pkgs );
+ $vers{$pkg} = (defined $2 ? $2 : undef) unless exists( $vers{$pkg} );
+ $need_vers = defined $2 ? 0 : 1;
+
+ # VERSION defined with full package spec, i.e. $Module::VERSION
+ } elsif ( $vers_fullname && $vers_pkg ) {
+ push( @pkgs, $vers_pkg ) unless grep( $vers_pkg eq $_, @pkgs );
+ $need_vers = 0 if $vers_pkg eq $pkg;
+
+ unless ( defined $vers{$vers_pkg} && length $vers{$vers_pkg} ) {
+ $vers{$vers_pkg} =
+ $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line );
+ } else {
+ # Warn unless the user is using the "$VERSION = eval
+ # $VERSION" idiom (though there are probably other idioms
+ # that we should watch out for...)
+ warn <<"EOM" unless $line =~ /=\s*eval/;
+Package '$vers_pkg' already declared with version '$vers{$vers_pkg}',
+ignoring subsequent declaration on line $line_num.
+EOM
+ }
+
+ # first non-comment line in undeclared package main is VERSION
+ } elsif ( !exists($vers{main}) && $pkg eq 'main' && $vers_fullname ) {
+ $need_vers = 0;
+ my $v =
+ $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line );
+ $vers{$pkg} = $v;
+ push( @pkgs, 'main' );
+
+ # first non-comment line in undeclared package defines package main
+ } elsif ( !exists($vers{main}) && $pkg eq 'main' && $line =~ /\w+/ ) {
+ $need_vers = 1;
+ $vers{main} = '';
+ push( @pkgs, 'main' );
+
+ # only keep if this is the first $VERSION seen
+ } elsif ( $vers_fullname && $need_vers ) {
+ $need_vers = 0;
+ my $v =
+ $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line );
+
+
+ unless ( defined $vers{$pkg} && length $vers{$pkg} ) {
+ $vers{$pkg} = $v;
+ } else {
+ warn <<"EOM";
+Package '$pkg' already declared with version '$vers{$pkg}'
+ignoring new version '$v' on line $line_num.
+EOM
+ }
+
+ }
+
+ }
+
+ }
+
+ if ( $self->{collect_pod} && length($pod_data) ) {
+ $pod{$pod_sect} = $pod_data;
+ }
+
+ $self->{versions} = \%vers;
+ $self->{packages} = \@pkgs;
+ $self->{pod} = \%pod;
+ $self->{pod_headings} = \@pod;
+}
+
+{
+my $pn = 0;
+sub _evaluate_version_line {
+ my $self = shift;
+ my( $sigil, $var, $line ) = @_;
+
+ # Some of this code came from the ExtUtils:: hierarchy.
+
+ # We compile into $vsub because 'use version' would cause
+ # compiletime/runtime issues with local()
+ my $vsub;
+ $pn++; # everybody gets their own package
+ my $eval = qq{BEGIN { q# Hide from _packages_inside()
+ #; package Module::Metadata::_version::p$pn;
+ use version;
+ no strict;
+
+ local $sigil$var;
+ \$$var=undef;
+ \$vsub = sub {
+ $line;
+ \$$var
+ };
+ }};
+
+ local $^W;
+ # Try to get the $VERSION
+ eval $eval;
+ # some modules say $VERSION = $Foo::Bar::VERSION, but Foo::Bar isn't
+ # installed, so we need to hunt in ./lib for it
+ if ( $@ =~ /Can't locate/ && -d 'lib' ) {
+ local @INC = ('lib',@INC);
+ eval $eval;
+ }
+ warn "Error evaling version line '$eval' in $self->{filename}: $@\n"
+ if $@;
+ (ref($vsub) eq 'CODE') or
+ die "failed to build version sub for $self->{filename}";
+ my $result = eval { $vsub->() };
+ die "Could not get version from $self->{filename} by executing:\n$eval\n\nThe fatal error was: $@\n"
+ if $@;
+
+ # Upgrade it into a version object
+ my $version = eval { _dwim_version($result) };
+
+ die "Version '$result' from $self->{filename} does not appear to be valid:\n$eval\n\nThe fatal error was: $@\n"
+ unless defined $version; # "0" is OK!
+
+ return $version;
+}
+}
+
+# Try to DWIM when things fail the lax version test in obvious ways
+{
+ my @version_prep = (
+ # Best case, it just works
+ sub { return shift },
+
+ # If we still don't have a version, try stripping any
+ # trailing junk that is prohibited by lax rules
+ sub {
+ my $v = shift;
+ $v =~ s{([0-9])[a-z-].*$}{$1}i; # 1.23-alpha or 1.23b
+ return $v;
+ },
+
+ # Activestate apparently creates custom versions like '1.23_45_01', which
+ # cause version.pm to think it's an invalid alpha. So check for that
+ # and strip them
+ sub {
+ my $v = shift;
+ my $num_dots = () = $v =~ m{(\.)}g;
+ my $num_unders = () = $v =~ m{(_)}g;
+ my $leading_v = substr($v,0,1) eq 'v';
+ if ( ! $leading_v && $num_dots < 2 && $num_unders > 1 ) {
+ $v =~ s{_}{}g;
+ $num_unders = () = $v =~ m{(_)}g;
+ }
+ return $v;
+ },
+
+ # Worst case, try numifying it like we would have before version objects
+ sub {
+ my $v = shift;
+ no warnings 'numeric';
+ return 0 + $v;
+ },
+
+ );
+
+ sub _dwim_version {
+ my ($result) = shift;
+
+ return $result if ref($result) eq 'version';
+
+ my ($version, $error);
+ for my $f (@version_prep) {
+ $result = $f->($result);
+ $version = eval { version->new($result) };
+ $error ||= $@ if $@; # capture first failure
+ last if defined $version;
+ }
+
+ die $error unless defined $version;
+
+ return $version;
+ }
+}
+
+############################################################
+
+# accessors
+sub name { $_[0]->{module} }
+
+sub filename { $_[0]->{filename} }
+sub packages_inside { @{$_[0]->{packages}} }
+sub pod_inside { @{$_[0]->{pod_headings}} }
+sub contains_pod { $#{$_[0]->{pod_headings}} }
+
+sub version {
+ my $self = shift;
+ my $mod = shift || $self->{module};
+ my $vers;
+ if ( defined( $mod ) && length( $mod ) &&
+ exists( $self->{versions}{$mod} ) ) {
+ return $self->{versions}{$mod};
+ } else {
+ return undef;
+ }
+}
+
+sub pod {
+ my $self = shift;
+ my $sect = shift;
+ if ( defined( $sect ) && length( $sect ) &&
+ exists( $self->{pod}{$sect} ) ) {
+ return $self->{pod}{$sect};
+ } else {
+ return undef;
+ }
+}
+
+1;
+
+=head1 NAME
+
+Module::Metadata - Gather package and POD information from perl module files
+
+=head1 DESCRIPTION
+
+=over 4
+
+=item new_from_file($filename, collect_pod => 1)
+
+Construct a C<ModuleInfo> object given the path to a file. Takes an optional
+argument C<collect_pod> which is a boolean that determines whether
+POD data is collected and stored for reference. POD data is not
+collected by default. POD headings are always collected.
+
+=item new_from_module($module, collect_pod => 1, inc => \@dirs)
+
+Construct a C<ModuleInfo> object given a module or package name. In addition
+to accepting the C<collect_pod> argument as described above, this
+method accepts a C<inc> argument which is a reference to an array of
+of directories to search for the module. If none are given, the
+default is @INC.
+
+=item name()
+
+Returns the name of the package represented by this module. If there
+are more than one packages, it makes a best guess based on the
+filename. If it's a script (i.e. not a *.pm) the package name is
+'main'.
+
+=item version($package)
+
+Returns the version as defined by the $VERSION variable for the
+package as returned by the C<name> method if no arguments are
+given. If given the name of a package it will attempt to return the
+version of that package if it is specified in the file.
+
+=item filename()
+
+Returns the absolute path to the file.
+
+=item packages_inside()
+
+Returns a list of packages.
+
+=item pod_inside()
+
+Returns a list of POD sections.
+
+=item contains_pod()
+
+Returns true if there is any POD in the file.
+
+=item pod($section)
+
+Returns the POD data in the given section.
+
+=item find_module_by_name($module, \@dirs)
+
+Returns the path to a module given the module or package name. A list
+of directories can be passed in as an optional parameter, otherwise
+@INC is searched.
+
+Can be called as either an object or a class method.
+
+=item find_module_dir_by_name($module, \@dirs)
+
+Returns the entry in C<@dirs> (or C<@INC> by default) that contains
+the module C<$module>. A list of directories can be passed in as an
+optional parameter, otherwise @INC is searched.
+
+Can be called as either an object or a class method.
+
+=item package_versions_from_directory($dir, \@files?)
+
+Scans C<$dir> for .pm files (unless C<@files> is given, in which case looks
+for those files in C<$dir> - and reads each file for packages and versions,
+returning a hashref of the form:
+
+ {
+ 'Package::Name' => {
+ version => '0.123',
+ file => 'Package/Name.pm'
+ },
+ 'OtherPackage::Name' => ...
+ }
+
+=item log_info (internal)
+
+Used internally to perform logging; imported from Log::Contextual if
+Log::Contextual has already been loaded, otherwise simply calls warn.
+
+=back
+
+=head1 AUTHOR
+
+Ken Williams <kwilliams@cpan.org>, Randy W. Sims <RandyS@ThePierianSpring.org>
+
+Released as Module::Metadata by Matt S Trout (mst) <mst@shadowcat.co.uk> with
+assistance from David Golden (xdg) <dagolden@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2001-2006 Ken Williams. All rights reserved.
+
+This library is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=head1 SEE ALSO
+
+perl(1), L<Module::Build::ModuleInfo>(3)
+
+=cut
+
diff --git a/inc/Perl/OSType.pm b/inc/Perl/OSType.pm
new file mode 100644
index 0000000..6c2cf12
--- /dev/null
+++ b/inc/Perl/OSType.pm
@@ -0,0 +1,174 @@
+#
+# This file is part of Perl-OSType
+#
+# This software is copyright (c) 2010 by David Golden.
+#
+# This is free software; you can redistribute it and/or modify it under
+# the same terms as the Perl 5 programming language system itself.
+#
+use strict;
+use warnings;
+package Perl::OSType;
+BEGIN {
+ $Perl::OSType::VERSION = '1.002';
+}
+# ABSTRACT: Map Perl operating system names to generic types
+
+require Exporter;
+our @ISA = qw(Exporter);
+
+our %EXPORT_TAGS = (
+ all => [ qw( os_type is_os_type ) ]
+);
+
+our @EXPORT_OK = @{ $EXPORT_TAGS{all} };
+
+# originally taken from Module::Build by Ken Williams et al.
+my %OSTYPES = qw(
+ aix Unix
+ bsdos Unix
+ beos Unix
+ dgux Unix
+ dragonfly Unix
+ dynixptx Unix
+ freebsd Unix
+ linux Unix
+ haiku Unix
+ hpux Unix
+ iphoneos Unix
+ irix Unix
+ darwin Unix
+ machten Unix
+ midnightbsd Unix
+ mirbsd Unix
+ next Unix
+ openbsd Unix
+ netbsd Unix
+ dec_osf Unix
+ nto Unix
+ svr4 Unix
+ svr5 Unix
+ sco_sv Unix
+ unicos Unix
+ unicosmk Unix
+ solaris Unix
+ sunos Unix
+ cygwin Unix
+ os2 Unix
+ interix Unix
+ gnu Unix
+ gnukfreebsd Unix
+ nto Unix
+ qnx Unix
+
+ dos Windows
+ MSWin32 Windows
+
+ os390 EBCDIC
+ os400 EBCDIC
+ posix-bc EBCDIC
+ vmesa EBCDIC
+
+ MacOS MacOS
+ VMS VMS
+ VOS VOS
+ riscos RiscOS
+ amigaos Amiga
+ mpeix MPEiX
+);
+
+sub os_type {
+ my ($os) = @_;
+ $os = $^O unless defined $os;
+ return $OSTYPES{ $os } || q{};
+}
+
+sub is_os_type {
+ my ($type, $os) = @_;
+ return unless $type;
+ $os = $^O unless defined $os;
+ return os_type($os) eq $type;
+}
+
+1;
+
+
+=pod
+
+=head1 NAME
+
+Perl::OSType - Map Perl operating system names to generic types
+
+=head1 VERSION
+
+version 1.002
+
+=head1 SYNOPSIS
+
+ use Perl::OSType ':all';
+
+ $current_type = os_type();
+ $other_type = os_type('dragonfly'); # gives 'Unix'
+
+=head1 DESCRIPTION
+
+Modules that provide OS-specific behaviors often need to know if
+the current operating system matches a more generic type of
+operating systems. For example, 'linux' is a type of 'Unix' operating system
+and so is 'freebsd'.
+
+This module provides a mapping between an operating system name as given by
+C<$^O> and a more generic type. The initial version is based on the OS type
+mappings provided in L<Module::Build> and L<ExtUtils::CBuilder>. (Thus,
+Microsoft operating systems are given the type 'Windows' rather than 'Win32'.)
+
+=head1 USAGE
+
+No functions are exported by default. The export tag ":all" will export
+all functions listed below.
+
+=head2 os_type()
+
+ $os_type = os_type();
+ $os_type = os_type('MSWin32');
+
+Returns a single, generic OS type for a given operating system name. With no
+arguments, returns the OS type for the current value of C<$^O>. If the
+operating system is not recognized, the function will return the empty string.
+
+=head2 is_os_type()
+
+ $is_windows = is_os_type('Windows');
+ $is_unix = is_os_type('Unix', 'dragonfly');
+
+Given an OS type and OS name, returns true or false if the OS name is of the
+given type. As with C<os_type>, it will use the current operating system as a
+default if no OS name is provided.
+
+=head1 SEE ALSO
+
+=over 4
+
+=item *
+
+L<Devel::CheckOS>
+
+=back
+
+=head1 AUTHOR
+
+David Golden <dagolden@cpan.org>
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is copyright (c) 2010 by David Golden.
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+=cut
+
+
+__END__
+
+
diff --git a/inc/bootstrap.pl b/inc/bootstrap.pl
new file mode 100644
index 0000000..2011fc7
--- /dev/null
+++ b/inc/bootstrap.pl
@@ -0,0 +1,47 @@
+# bootstrap.pl
+# bootstrap modules in inc/ for use during configuration with
+# either Build.PL or Makefile.PL
+
+my @exit_warn;
+
+END {
+ warn "\nThese additional prerequisites must be installed:\n requires:\n"
+ if @exit_warn;
+ while( my $h = shift @exit_warn ) {
+ my ($mod, $min) = @$h;
+ warn " ! $mod (we need version $min)\n";
+ }
+}
+
+BEGIN {
+ if ( ! eval "use Perl::OSType 1 (); 1" ) {
+ print "*** BOOTSTRAPPING Perl::OSType ***\n";
+ push @exit_warn, [ 'Perl::OSType', '1.00' ];
+ delete $INC{'Perl/OSType.pm'};
+ local @INC = @INC;
+ push @INC, 'inc';
+ eval "require Perl::OSType; 1"
+ or die "BOOSTRAP FAIL: $@";
+ }
+ if ( ! eval "use version 0.87 (); 1" ) {
+ print "*** BOOTSTRAPPING version ***\n";
+ push @exit_warn, [ 'version', '0.87' ];
+ delete $INC{'version.pm'};
+ local @INC = @INC;
+ push @INC, 'inc';
+ eval "require MBVersion; 1"
+ or die "BOOSTRAP FAIL: $@";
+ }
+ if ( ! eval "use Module::Metadata 1.000002 (); 1" ) {
+ print "*** BOOTSTRAPPING Module::Metadata ***\n";
+ push @exit_warn, [ 'Module::Metadata', '1.000002' ];
+ delete $INC{'Module/Metadata.pm'};
+ local @INC = @INC;
+ push @INC, 'inc';
+ eval "require Module::Metadata; 1"
+ or die "BOOSTRAP FAIL: $@";
+ }
+}
+
+1;
+
View Lorry Controller Status