From: Matt S Trout Date: Wed, 3 Mar 2010 01:01:44 +0000 (+0000) Subject: import Module::Metadata X-Git-Tag: release_1.0.0~8 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=p5sagit%2FModule-Metadata.git;a=commitdiff_plain;h=5ac756c6fca58d5071a88e893267ea2fb752d987 import Module::Metadata --- 5ac756c6fca58d5071a88e893267ea2fb752d987 diff --git a/lib/Module/Metadata.pm b/lib/Module/Metadata.pm new file mode 100644 index 0000000..330a687 --- /dev/null +++ b/lib/Module/Metadata.pm @@ -0,0 +1,693 @@ +# -*- 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 = '0.36_04'; +$VERSION = eval $VERSION; + +use File::Spec; +use IO::File; +use Module::Metadata::Version; +use Log::Contextual qw(:log :dlog); +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 = Module::Metadata::Version->new($v1) + unless UNIVERSAL::isa($v1,'Module::Metadata::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' || + ref $version eq 'Module::Metadata::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}; + my $fh = IO::File->new( $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 Module::Metadata::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 $@; + + # Activestate apparently creates custom versions like '1.23_45_01', which + # cause M::B::Version to think it's an invalid alpha. So check for that + # and strip them + my $num_dots = () = $result =~ m{\.}g; + my $num_unders = () = $result =~ m{_}g; + if ( substr($result,0,1) ne 'v' && $num_dots < 2 && $num_unders > 1 ) { + $result =~ s{_}{}g; + } + + # Bless it into our own version class + eval { $result = Module::Metadata::Version->new($result) }; + die "Version '$result' from $self->{filename} does not appear to be valid:\n$eval\n\nThe fatal error was: $@\n" + if $@; + + return $result; +} +} + + +############################################################ + +# 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; + +__END__ + +=for :stopwords ModuleInfo + +=head1 NAME + +ModuleInfo - Gather package and POD information from a perl module file + + +=head1 DESCRIPTION + +=over 4 + +=item new_from_file($filename, collect_pod => 1) + +Construct a C object given the path to a file. Takes an optional +argument C 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 object given a module or package name. In addition +to accepting the C argument as described above, this +method accepts a C 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 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. + +=back + + +=head1 AUTHOR + +Ken Williams , Randy W. Sims + + +=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(3) + +=cut + diff --git a/lib/Module/Metadata/Version.pm b/lib/Module/Metadata/Version.pm new file mode 100644 index 0000000..fd0a976 --- /dev/null +++ b/lib/Module/Metadata/Version.pm @@ -0,0 +1,687 @@ +package Module::Metadata::Version; +use strict; + +# stolen from Module::Build::Version - this is perl licensed code, +# copyright them. + +use vars qw($VERSION); +$VERSION = 0.77; + +eval "use version $VERSION"; +if ($@) { # can't locate version files, use our own + + # 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 () { + s/(\$VERSION)\s=\s\d+/\$VERSION = 0/; + $version .= $_ if $_; + last if /^1;$/; + } + + # and now get the current version::vpp code + my $vpp; + while () { + 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::Metadata::Version'; + eval $version; die $@ if $@; + $INC{'version.pm'} = 'inside Module::Metadata::Version'; +} + +# now we can safely subclass version, installed or not +use vars qw(@ISA); +@ISA = qw(version); + +1; +__DATA__ +# stub version module to make everything else happy +package version; + +use 5.005_04; +use strict; + +use vars qw(@ISA $VERSION $CLASS *declare *qv); + +$VERSION = 0.77; + +$CLASS = 'version'; + +push @ISA, "version::vpp"; +local $^W; +*version::qv = \&version::vpp::qv; +*version::declare = \&version::vpp::declare; +*version::_VERSION = \&version::vpp::_VERSION; +if ($] > 5.009001 && $] <= 5.010000) { + no strict 'refs'; + *{'version::stringify'} = \*version::vpp::stringify; + *{'version::(""'} = \*version::vpp::stringify; + *{'version::new'} = \*version::vpp::new; +} + +# 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; + } +} + +1; + +# replace everything from here to the end with the current version/vpp.pm +package version::vpp; +use strict; + +use POSIX qw/locale_h/; +use locale; +use vars qw ($VERSION @ISA @REGEXS); +$VERSION = '0.77'; +$VERSION = eval $VERSION; + +push @REGEXS, qr/ + ^v? # optional leading 'v' + (\d*) # major revision not required + \. # requires at least one decimal + (?:(\d+)\.?){1,} + /x; + +use overload ( + '""' => \&stringify, + '0+' => \&numify, + 'cmp' => \&vcmp, + '<=>' => \&vcmp, + 'bool' => \&vbool, + 'nomethod' => \&vnoop, +); + +my $VERSION_MAX = 0x7FFFFFFF; + +eval "use warnings"; +if ($@) { + eval ' + package warnings; + sub enabled {return $^W;} + 1; + '; +} + +sub new +{ + my ($class, $value) = @_; + my $self = bless ({}, ref ($class) || $class); + + 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 = 'v'.$_[2]; + } + + $value = _un_vstring($value); + + # exponential notation + if ( $value =~ /\d+.?\d*e[-+]?\d+/ ) { + $value = sprintf("%.9f",$value); + $value =~ s/(0+)$//; # trim trailing zeros + } + + # This is not very efficient, but it is morally equivalent + # to the XS code (as that is the reference implementation). + # See vutil/vutil.c for details + my $qv = 0; + my $alpha = 0; + my $width = 3; + my $saw_period = 0; + my $vinf = 0; + my ($start, $last, $pos, $s); + $s = 0; + + while ( substr($value,$s,1) =~ /\s/ ) { # leading whitespace is OK + $s++; + } + + if (substr($value,$s,1) eq 'v') { + $s++; # get past 'v' + $qv = 1; # force quoted version processing + } + + $start = $last = $pos = $s; + + # pre-scan the input string to check for decimals/underbars + while ( substr($value,$pos,1) =~ /[._\d,]/ ) { + if ( substr($value,$pos,1) eq '.' ) { + if ($alpha) { + Carp::croak("Invalid version format ". + "(underscores before decimal)"); + } + $saw_period++; + $last = $pos; + } + elsif ( substr($value,$pos,1) eq '_' ) { + if ($alpha) { + require Carp; + Carp::croak("Invalid version format ". + "(multiple underscores)"); + } + $alpha = 1; + $width = $pos - $last - 1; # natural width of sub-version + } + elsif ( substr($value,$pos,1) eq ',' + and substr($value,$pos+1,1) =~ /[0-9]/ ) { + # looks like an unhandled locale + $saw_period++; + $last = $pos; + } + $pos++; + } + + if ( $alpha && !$saw_period ) { + require Carp; + Carp::croak("Invalid version format ". + "(alpha without decimal)"); + } + + if ( $alpha && $saw_period && $width == 0 ) { + require Carp; + Carp::croak("Invalid version format ". + "(misplaced _ in number)"); + } + + if ( $saw_period > 1 ) { + $qv = 1; # force quoted version processing + } + + $last = $pos; + $pos = $s; + + if ( $qv ) { + $self->{qv} = 1; + } + + if ( $alpha ) { + $self->{alpha} = 1; + } + + if ( !$qv && $width < 3 ) { + $self->{width} = $width; + } + + while ( substr($value,$pos,1) =~ /\d/ ) { + $pos++; + } + + if ( substr($value,$pos,1) !~ /[a-z]/ ) { ### FIX THIS ### + my $rev; + + while (1) { + $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_period == 1 ) { + $mult *= 100; + while ( $s < $end ) { + $orev = $rev; + $rev += substr($value,$s,1) * $mult; + $mult /= 10; + if ( abs($orev) > abs($rev) + || abs($rev) > abs($VERSION_MAX) ) { + if ( warnings::enabled("overflow") ) { + require Carp; + Carp::carp("Integer overflow in version"); + } + $s = $end - 1; + $rev = $VERSION_MAX; + } + $s++; + if ( substr($value,$s,1) eq '_' ) { + $s++; + } + } + } + else { + while (--$end >= $s) { + $orev = $rev; + $rev += substr($value,$end,1) * $mult; + $mult *= 10; + if ( abs($orev) > abs($rev) + || abs($rev) > abs($VERSION_MAX) ) { + if ( warnings::enabled("overflow") ) { + require Carp; + Carp::carp("Integer overflow in version"); + } + $end = $s - 1; + $rev = $VERSION_MAX; + } + } + } + } + + # Append revision + push @{$self->{version}}, $rev; + if ( substr($value,$pos,1) eq '.' + && substr($value,$pos+1,1) =~ /\d/ ) { + $s = ++$pos; + } + elsif ( substr($value,$pos,1) eq '_' + && substr($value,$pos+1,1) =~ /\d/ ) { + $s = ++$pos; + } + elsif ( substr($value,$pos,1) eq ',' + && substr($value,$pos+1,1) =~ /\d/ ) { + $s = ++$pos; + } + elsif ( substr($value,$pos,1) =~ /\d/ ) { + $s = $pos; + } + else { + $s = $pos; + last; + } + if ( $qv ) { + while ( substr($value,$pos,1) =~ /\d/ ) { + $pos++; + } + } + else { + my $digits = 0; + while (substr($value,$pos,1) =~ /[\d_]/ && $digits < 3) { + if ( substr($value,$pos,1) ne '_' ) { + $digits++; + } + $pos++; + } + } + } + } + if ( $qv ) { # quoted versions always get at least three terms + my $len = scalar @{$self->{version}}; + $len = 3 - $len; + while ($len-- > 0) { + push @{$self->{version}}, 0; + } + } + + if ( substr($value,$pos) ) { # any remaining text + if ( warnings::enabled("misc") ) { + require Carp; + Carp::carp("Version string '$value' contains invalid data; ". + "ignoring: '".substr($value,$pos)."'"); + } + } + + # cache the original value for use when stringification + if ( $vinf ) { + $self->{vinf} = 1; + $self->{original} = 'v.Inf'; + } + else { + $self->{original} = substr($value,0,$pos); + } + + 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 +{ + require UNIVERSAL; + my ($left,$right,$swap) = @_; + my $class = ref($left); + unless ( UNIVERSAL::isa($right, $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 _un_vstring { + my $value = shift; + # may be a v-string + if ( $] >= 5.006_000 && length($value) >= 3 && $value !~ /[._]/ ) { + my $tvalue = sprintf("v%vd",$value); + if ( $tvalue =~ /^v\d+\.\d+\.\d+$/ ) { + # must be a v-string + $value = $tvalue; + } + } + return $value; +} + +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