diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/version')
| -rw-r--r-- | Master/tlpkg/tlperl/lib/version/Internals.pod | 699 | ||||
| -rw-r--r-- | Master/tlpkg/tlperl/lib/version/regex.pm | 117 | ||||
| -rw-r--r-- | Master/tlpkg/tlperl/lib/version/vpp.pm | 1023 |
3 files changed, 1839 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/version/Internals.pod b/Master/tlpkg/tlperl/lib/version/Internals.pod new file mode 100644 index 00000000000..95be8448811 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/version/Internals.pod @@ -0,0 +1,699 @@ +=head1 NAME + +version::Internals - Perl extension for Version Objects + +=head1 DESCRIPTION + +Overloaded version objects for all modern versions of Perl. This documents +the internal data representation and underlying code for version.pm. See +F<version.pod> for daily usage. This document is only useful for users +interested in the gory details. + +=head1 WHAT IS A VERSION? + +For the purposes of this module, a version "number" is a sequence of +positive integer values separated by one or more decimal points and +optionally a single underscore. This corresponds to what Perl itself +uses for a version, as well as extending the "version as number" that +is discussed in the various editions of the Camel book. + +There are actually two distinct kinds of version objects: + +=over 4 + +=item Decimal Versions + +Any version which "looks like a number", see L<Decimal Versions>. This +also includes versions with a single decimal point and a single embedded +underscore, see L<Alpha Versions>, even though these must be quoted +to preserve the underscore formatting. + +=item Dotted-Decimal Versions + +Also referred to as "Dotted-Integer", these contains more than one decimal +point and may have an optional embedded underscore, see L<Dotted-Decimal +Versions>. This is what is commonly used in most open source software as +the "external" version (the one used as part of the tag or tarfile name). +A leading 'v' character is now required and will warn if it missing. + +=back + +Both of these methods will produce similar version objects, in that +the default stringification will yield the version L<Normal Form> only +if required: + + $v = version->new(1.002); # 1.002, but compares like 1.2.0 + $v = version->new(1.002003); # 1.002003 + $v2 = version->new("v1.2.3"); # v1.2.3 + +In specific, version numbers initialized as L<Decimal Versions> will +stringify as they were originally created (i.e. the same string that was +passed to C<new()>. Version numbers initialized as L<Dotted-Decimal Versions> +will be stringified as L<Normal Form>. + +=head2 Decimal Versions + +These correspond to historical versions of Perl itself prior to 5.6.0, +as well as all other modules which follow the Camel rules for the +$VERSION scalar. A Decimal version is initialized with what looks like +a floating point number. Leading zeros B<are> significant and trailing +zeros are implied so that a minimum of three places is maintained +between subversions. What this means is that any subversion (digits +to the right of the decimal place) that contains less than three digits +will have trailing zeros added to make up the difference, but only for +purposes of comparison with other version objects. For example: + + # Prints Equivalent to + $v = version->new( 1.2); # 1.2 v1.200.0 + $v = version->new( 1.02); # 1.02 v1.20.0 + $v = version->new( 1.002); # 1.002 v1.2.0 + $v = version->new( 1.0023); # 1.0023 v1.2.300 + $v = version->new( 1.00203); # 1.00203 v1.2.30 + $v = version->new( 1.002003); # 1.002003 v1.2.3 + +All of the preceding examples are true whether or not the input value is +quoted. The important feature is that the input value contains only a +single decimal. See also L<Alpha Versions>. + +IMPORTANT NOTE: As shown above, if your Decimal version contains more +than 3 significant digits after the decimal place, it will be split on +each multiple of 3, so 1.0003 is equivalent to v1.0.300, due to the need +to remain compatible with Perl's own 5.005_03 == 5.5.30 interpretation. +Any trailing zeros are ignored for mathematical comparison purposes. + +=head2 Dotted-Decimal Versions + +These are the newest form of versions, and correspond to Perl's own +version style beginning with 5.6.0. Starting with Perl 5.10.0, +and most likely Perl 6, this is likely to be the preferred form. This +method normally requires that the input parameter be quoted, although +Perl's after 5.8.1 can use v-strings as a special form of quoting, but +this is highly discouraged. + +Unlike L<Decimal Versions>, Dotted-Decimal Versions have more than +a single decimal point, e.g.: + + # Prints + $v = version->new( "v1.200"); # v1.200.0 + $v = version->new("v1.20.0"); # v1.20.0 + $v = qv("v1.2.3"); # v1.2.3 + $v = qv("1.2.3"); # v1.2.3 + $v = qv("1.20"); # v1.20.0 + +In general, Dotted-Decimal Versions permit the greatest amount of freedom +to specify a version, whereas Decimal Versions enforce a certain +uniformity. + +Just like L</Decimal Versions>, Dotted-Decimal Versions can be used as +L</Alpha Versions>. + +=head2 Alpha Versions + +For module authors using CPAN, the convention has been to note unstable +releases with an underscore in the version string. (See L<CPAN>.) version.pm +follows this convention and alpha releases will test as being newer than the +more recent stable release, and less than the next stable release. Only the +last element may be separated by an underscore: + + # Declaring + use version 0.77; our $VERSION = version->declare("v1.2_3"); + + # Parsing + $v1 = version->parse("v1.2_3"); + $v1 = version->parse("1.002_003"); + +Note that you B<must> quote the version when writing an alpha Decimal version. +The stringified form of Decimal versions will always be the same string that +was used to initialize the version object. + +=head2 Regular Expressions for Version Parsing + +A formalized definition of the legal forms for version strings is +included in the C<version::regex> class. Primitives are included for +common elements, although they are scoped to the file so they are useful +for reference purposes only. There are two publicly accessible scalars +that can be used in other code (not exported): + +=over 4 + +=item C<$version::LAX> + +This regexp covers all of the legal forms allowed under the current +version string parser. This is not to say that all of these forms +are recommended, and some of them can only be used when quoted. + +For dotted decimals: + + v1.2 + 1.2345.6 + v1.23_4 + +The leading 'v' is optional if two or more decimals appear. If only +a single decimal is included, then the leading 'v' is required to +trigger the dotted-decimal parsing. A leading zero is permitted, +though not recommended except when quoted, because of the risk that +Perl will treat the number as octal. A trailing underscore plus one +or more digits denotes an alpha or development release (and must be +quoted to be parsed properly). + +For decimal versions: + + 1 + 1.2345 + 1.2345_01 + +an integer portion, an optional decimal point, and optionally one or +more digits to the right of the decimal are all required. A trailing +underscore is permitted and a leading zero is permitted. Just like +the lax dotted-decimal version, quoting the values is required for +alpha/development forms to be parsed correctly. + +=item C<$version::STRICT> + +This regexp covers a much more limited set of formats and constitutes +the best practices for initializing version objects. Whether you choose +to employ decimal or dotted-decimal for is a personal preference however. + +=over 4 + +=item v1.234.5 + +For dotted-decimal versions, a leading 'v' is required, with three or +more sub-versions of no more than three digits. A leading 0 (zero) +before the first sub-version (in the above example, '1') is also +prohibited. + +=item 2.3456 + +For decimal versions, an integer portion (no leading 0), a decimal point, +and one or more digits to the right of the decimal are all required. + +=back + +=back + +Both of the provided scalars are already compiled as regular expressions +and do not contain either anchors or implicit groupings, so they can be +included in your own regular expressions freely. For example, consider +the following code: + + ($pkg, $ver) =~ / + ^[ \t]* + use [ \t]+($PKGNAME) + (?:[ \t]+($version::STRICT))? + [ \t]*; + /x; + +This would match a line of the form: + + use Foo::Bar::Baz v1.2.3; # legal only in Perl 5.8.1+ + +where C<$PKGNAME> is another regular expression that defines the legal +forms for package names. + +=head1 IMPLEMENTATION DETAILS + +=head2 Equivalence between Decimal and Dotted-Decimal Versions + +When Perl 5.6.0 was released, the decision was made to provide a +transformation between the old-style decimal versions and new-style +dotted-decimal versions: + + 5.6.0 == 5.006000 + 5.005_04 == 5.5.40 + +The floating point number is taken and split first on the single decimal +place, then each group of three digits to the right of the decimal makes up +the next digit, and so on until the number of significant digits is exhausted, +B<plus> enough trailing zeros to reach the next multiple of three. + +This was the method that version.pm adopted as well. Some examples may be +helpful: + + equivalent + decimal zero-padded dotted-decimal + ------- ----------- -------------- + 1.2 1.200 v1.200.0 + 1.02 1.020 v1.20.0 + 1.002 1.002 v1.2.0 + 1.0023 1.002300 v1.2.300 + 1.00203 1.002030 v1.2.30 + 1.002003 1.002003 v1.2.3 + +=head2 Quoting Rules + +Because of the nature of the Perl parsing and tokenizing routines, +certain initialization values B<must> be quoted in order to correctly +parse as the intended version, especially when using the C<declare> or +L</qv()> methods. While you do not have to quote decimal numbers when +creating version objects, it is always safe to quote B<all> initial values +when using version.pm methods, as this will ensure that what you type is +what is used. + +Additionally, if you quote your initializer, then the quoted value that goes +B<in> will be exactly what comes B<out> when your $VERSION is printed +(stringified). If you do not quote your value, Perl's normal numeric handling +comes into play and you may not get back what you were expecting. + +If you use a mathematic formula that resolves to a floating point number, +you are dependent on Perl's conversion routines to yield the version you +expect. You are pretty safe by dividing by a power of 10, for example, +but other operations are not likely to be what you intend. For example: + + $VERSION = version->new((qw$Revision: 1.4)[1]/10); + print $VERSION; # yields 0.14 + $V2 = version->new(100/9); # Integer overflow in decimal number + print $V2; # yields something like 11.111.111.100 + +Perl 5.8.1 and beyond are able to automatically quote v-strings but +that is not possible in earlier versions of Perl. In other words: + + $version = version->new("v2.5.4"); # legal in all versions of Perl + $newvers = version->new(v2.5.4); # legal only in Perl >= 5.8.1 + +=head2 What about v-strings? + +There are two ways to enter v-strings: a bare number with two or more +decimal points, or a bare number with one or more decimal points and a +leading 'v' character (also bare). For example: + + $vs1 = 1.2.3; # encoded as \1\2\3 + $vs2 = v1.2; # encoded as \1\2 + +However, the use of bare v-strings to initialize version objects is +B<strongly> discouraged in all circumstances. Also, bare +v-strings are not completely supported in any version of Perl prior to +5.8.1. + +If you insist on using bare v-strings with Perl > 5.6.0, be aware of the +following limitations: + +1) For Perl releases 5.6.0 through 5.8.0, the v-string code merely guesses, +based on some characteristics of v-strings. You B<must> use a three part +version, e.g. 1.2.3 or v1.2.3 in order for this heuristic to be successful. + +2) For Perl releases 5.8.1 and later, v-strings have changed in the Perl +core to be magical, which means that the version.pm code can automatically +determine whether the v-string encoding was used. + +3) In all cases, a version created using v-strings will have a stringified +form that has a leading 'v' character, for the simple reason that sometimes +it is impossible to tell whether one was present initially. + +=head2 Version Object Internals + +version.pm provides an overloaded version object that is designed to both +encapsulate the author's intended $VERSION assignment as well as make it +completely natural to use those objects as if they were numbers (e.g. for +comparisons). To do this, a version object contains both the original +representation as typed by the author, as well as a parsed representation +to ease comparisons. Version objects employ L<overload> methods to +simplify code that needs to compare, print, etc the objects. + +The internal structure of version objects is a blessed hash with several +components: + + bless( { + 'original' => 'v1.2.3_4', + 'alpha' => 1, + 'qv' => 1, + 'version' => [ + 1, + 2, + 3, + 4 + ] + }, 'version' ); + +=over 4 + +=item original + +A faithful representation of the value used to initialize this version +object. The only time this will not be precisely the same characters +that exist in the source file is if a short dotted-decimal version like +v1.2 was used (in which case it will contain 'v1.2'). This form is +B<STRONGLY> discouraged, in that it will confuse you and your users. + +=item qv + +A boolean that denotes whether this is a decimal or dotted-decimal version. +See L<version/is_qv()>. + +=item alpha + +A boolean that denotes whether this is an alpha version. NOTE: that the +underscore can only appear in the last position. See L<version/is_alpha()>. + +=item version + +An array of non-negative integers that is used for comparison purposes with +other version objects. + +=back + +=head2 Replacement UNIVERSAL::VERSION + +In addition to the version objects, this modules also replaces the core +UNIVERSAL::VERSION function with one that uses version objects for its +comparisons. The return from this operator is always the stringified form +as a simple scalar (i.e. not an object), but the warning message generated +includes either the stringified form or the normal form, depending on how +it was called. + +For example: + + package Foo; + $VERSION = 1.2; + + package Bar; + $VERSION = "v1.3.5"; # works with all Perl's (since it is quoted) + + package main; + use version; + + print $Foo::VERSION; # prints 1.2 + + print $Bar::VERSION; # prints 1.003005 + + eval "use foo 10"; + print $@; # prints "foo version 10 required..." + eval "use foo 1.3.5; # work in Perl 5.6.1 or better + print $@; # prints "foo version 1.3.5 required..." + + eval "use bar 1.3.6"; + print $@; # prints "bar version 1.3.6 required..." + eval "use bar 1.004"; # note Decimal version + print $@; # prints "bar version 1.004 required..." + + +IMPORTANT NOTE: This may mean that code which searches for a specific +string (to determine whether a given module is available) may need to be +changed. It is always better to use the built-in comparison implicit in +C<use> or C<require>, rather than manually poking at C<< class->VERSION >> +and then doing a comparison yourself. + +The replacement UNIVERSAL::VERSION, when used as a function, like this: + + print $module->VERSION; + +will also exclusively return the stringified form. See L</Stringification> +for more details. + +=head1 USAGE DETAILS + +=head2 Using modules that use version.pm + +As much as possible, the version.pm module remains compatible with all +current code. However, if your module is using a module that has defined +C<$VERSION> using the version class, there are a couple of things to be +aware of. For purposes of discussion, we will assume that we have the +following module installed: + + package Example; + use version; $VERSION = qv('1.2.2'); + ...module code here... + 1; + +=over 4 + +=item Decimal versions always work + +Code of the form: + + use Example 1.002003; + +will always work correctly. The C<use> will perform an automatic +C<$VERSION> comparison using the floating point number given as the first +term after the module name (e.g. above 1.002.003). In this case, the +installed module is too old for the requested line, so you would see an +error like: + + Example version 1.002003 (v1.2.3) required--this is only version 1.002002 (v1.2.2)... + +=item Dotted-Decimal version work sometimes + +With Perl >= 5.6.2, you can also use a line like this: + + use Example 1.2.3; + +and it will again work (i.e. give the error message as above), even with +releases of Perl which do not normally support v-strings (see L<What about v-strings?> above). This has to do with that fact that C<use> only checks +to see if the second term I<looks like a number> and passes that to the +replacement L<UNIVERSAL::VERSION|UNIVERSAL/VERSION>. This is not true in Perl 5.005_04, +however, so you are B<strongly encouraged> to always use a Decimal version +in your code, even for those versions of Perl which support the Dotted-Decimal +version. + +=back + +=head2 Object Methods + +=over 4 + +=item new() + +Like many OO interfaces, the new() method is used to initialize version +objects. If two arguments are passed to C<new()>, the B<second> one will be +used as if it were prefixed with "v". This is to support historical use of the +C<qw> operator with the CVS variable $Revision, which is automatically +incremented by CVS every time the file is committed to the repository. + +In order to facilitate this feature, the following +code can be employed: + + $VERSION = version->new(qw$Revision: 2.7 $); + +and the version object will be created as if the following code +were used: + + $VERSION = version->new("v2.7"); + +In other words, the version will be automatically parsed out of the +string, and it will be quoted to preserve the meaning CVS normally +carries for versions. The CVS $Revision$ increments differently from +Decimal versions (i.e. 1.10 follows 1.9), so it must be handled as if +it were a Dotted-Decimal Version. + +A new version object can be created as a copy of an existing version +object, either as a class method: + + $v1 = version->new(12.3); + $v2 = version->new($v1); + +or as an object method: + + $v1 = version->new(12.3); + $v2 = $v1->new(12.3); + +and in each case, $v1 and $v2 will be identical. NOTE: if you create +a new object using an existing object like this: + + $v2 = $v1->new(); + +the new object B<will not> be a clone of the existing object. In the +example case, $v2 will be an empty object of the same type as $v1. + +=back + +=over 4 + +=item qv() + +An alternate way to create a new version object is through the exported +qv() sub. This is not strictly like other q? operators (like qq, qw), +in that the only delimiters supported are parentheses (or spaces). It is +the best way to initialize a short version without triggering the floating +point interpretation. For example: + + $v1 = qv(1.2); # v1.2.0 + $v2 = qv("1.2"); # also v1.2.0 + +As you can see, either a bare number or a quoted string can usually +be used interchangeably, except in the case of a trailing zero, which +must be quoted to be converted properly. For this reason, it is strongly +recommended that all initializers to qv() be quoted strings instead of +bare numbers. + +To prevent the C<qv()> function from being exported to the caller's namespace, +either use version with a null parameter: + + use version (); + +or just require version, like this: + + require version; + +Both methods will prevent the import() method from firing and exporting the +C<qv()> sub. + +=back + +For the subsequent examples, the following three objects will be used: + + $ver = version->new("1.2.3.4"); # see "Quoting Rules" + $alpha = version->new("1.2.3_4"); # see "Alpha Versions" + $nver = version->new(1.002); # see "Decimal Versions" + +=over 4 + +=item Normal Form + +For any version object which is initialized with multiple decimal +places (either quoted or if possible v-string), or initialized using +the L<qv()|version/qv()> operator, the stringified representation is returned in +a normalized or reduced form (no extraneous zeros), and with a leading 'v': + + print $ver->normal; # prints as v1.2.3.4 + print $ver->stringify; # ditto + print $ver; # ditto + print $nver->normal; # prints as v1.2.0 + print $nver->stringify; # prints as 1.002, + # see "Stringification" + +In order to preserve the meaning of the processed version, the +normalized representation will always contain at least three sub terms. +In other words, the following is guaranteed to always be true: + + my $newver = version->new($ver->stringify); + if ($newver eq $ver ) # always true + {...} + +=back + +=over 4 + +=item Numification + +Although all mathematical operations on version objects are forbidden +by default, it is possible to retrieve a number which corresponds +to the version object through the use of the $obj->numify +method. For formatting purposes, when displaying a number which +corresponds a version object, all sub versions are assumed to have +three decimal places. So for example: + + print $ver->numify; # prints 1.002003004 + print $nver->numify; # prints 1.002 + +Unlike the stringification operator, there is never any need to append +trailing zeros to preserve the correct version value. + +=back + +=over 4 + +=item Stringification + +The default stringification for version objects returns exactly the same +string as was used to create it, whether you used C<new()> or C<qv()>, +with one exception. The sole exception is if the object was created using +C<qv()> and the initializer did not have two decimal places or a leading +'v' (both optional), then the stringified form will have a leading 'v' +prepended, in order to support round-trip processing. + +For example: + + Initialized as Stringifies to + ============== ============== + version->new("1.2") 1.2 + version->new("v1.2") v1.2 + qv("1.2.3") 1.2.3 + qv("v1.3.5") v1.3.5 + qv("1.2") v1.2 ### exceptional case + +See also L<UNIVERSAL::VERSION|UNIVERSAL/VERSION>, as this also returns the stringified form +when used as a class method. + +IMPORTANT NOTE: There is one exceptional cases shown in the above table +where the "initializer" is not stringwise equivalent to the stringified +representation. If you use the C<qv>() operator on a version without a +leading 'v' B<and> with only a single decimal place, the stringified output +will have a leading 'v', to preserve the sense. See the L</qv()> operator +for more details. + +IMPORTANT NOTE 2: Attempting to bypass the normal stringification rules by +manually applying L<numify()|version/numify()> and L<normal()|version/normal()> will sometimes yield +surprising results: + + print version->new(version->new("v1.0")->numify)->normal; # v1.0.0 + +The reason for this is that the L<numify()|version/numify()> operator will turn "v1.0" +into the equivalent string "1.000000". Forcing the outer version object +to L<normal()|version/normal()> form will display the mathematically equivalent "v1.0.0". + +As the example in L</new()> shows, you can always create a copy of an +existing version object with the same value by the very compact: + + $v2 = $v1->new($v1); + +and be assured that both C<$v1> and C<$v2> will be completely equivalent, +down to the same internal representation as well as stringification. + +=back + +=over 4 + +=item Comparison operators + +Both C<cmp> and C<E<lt>=E<gt>> operators perform the same comparison between +terms (upgrading to a version object automatically). Perl automatically +generates all of the other comparison operators based on those two. +In addition to the obvious equalities listed below, appending a single +trailing 0 term does not change the value of a version for comparison +purposes. In other words "v1.2" and "1.2.0" will compare as identical. + +For example, the following relations hold: + + As Number As String Truth Value + ------------- ---------------- ----------- + $ver > 1.0 $ver gt "1.0" true + $ver < 2.5 $ver lt true + $ver != 1.3 $ver ne "1.3" true + $ver == 1.2 $ver eq "1.2" false + $ver == 1.2.3.4 $ver eq "1.2.3.4" see discussion below + +It is probably best to chose either the Decimal notation or the string +notation and stick with it, to reduce confusion. Perl6 version objects +B<may> only support Decimal comparisons. See also L<Quoting Rules>. + +WARNING: Comparing version with unequal numbers of decimal points (whether +explicitly or implicitly initialized), may yield unexpected results at +first glance. For example, the following inequalities hold: + + version->new(0.96) > version->new(0.95); # 0.960.0 > 0.950.0 + version->new("0.96.1") < version->new(0.95); # 0.096.1 < 0.950.0 + +For this reason, it is best to use either exclusively L<Decimal Versions> or +L<Dotted-Decimal Versions> with multiple decimal points. + +=back + +=over 4 + +=item Logical Operators + +If you need to test whether a version object +has been initialized, you can simply test it directly: + + $vobj = version->new($something); + if ( $vobj ) # true only if $something was non-blank + +You can also test whether a version object is an alpha version, for +example to prevent the use of some feature not present in the main +release: + + $vobj = version->new("1.2_3"); # MUST QUOTE + ...later... + if ( $vobj->is_alpha ) # True + +=back + +=head1 AUTHOR + +John Peacock E<lt>jpeacock@cpan.orgE<gt> + +=head1 SEE ALSO + +L<perl>. + +=cut diff --git a/Master/tlpkg/tlperl/lib/version/regex.pm b/Master/tlpkg/tlperl/lib/version/regex.pm new file mode 100644 index 00000000000..f73296383a5 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/version/regex.pm @@ -0,0 +1,117 @@ +package version::regex; + +use strict; + +use vars qw($VERSION $CLASS $STRICT $LAX); + +$VERSION = 0.9909; + +#--------------------------------------------------------------------------# +# 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; + +#--------------------------------------------------------------------------# + +# Preloaded methods go here. +sub is_strict { defined $_[0] && $_[0] =~ qr/ \A $STRICT \z /x } +sub is_lax { defined $_[0] && $_[0] =~ qr/ \A $LAX \z /x } + +1; diff --git a/Master/tlpkg/tlperl/lib/version/vpp.pm b/Master/tlpkg/tlperl/lib/version/vpp.pm new file mode 100644 index 00000000000..b821f92497a --- /dev/null +++ b/Master/tlpkg/tlperl/lib/version/vpp.pm @@ -0,0 +1,1023 @@ +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 5.006002; +use strict; + +use Config; +use vars qw($VERSION $CLASS @ISA $LAX $STRICT); +$VERSION = 0.9909; +$CLASS = 'version::vpp'; + +require version::regex; +*version::vpp::is_strict = \&version::regex::is_strict; +*version::vpp::is_lax = \&version::regex::is_lax; +*LAX = \$version::regex::LAX; +*STRICT = \$version::regex::STRICT; + +use overload ( + '""' => \&stringify, + '0+' => \&numify, + 'cmp' => \&vcmp, + '<=>' => \&vcmp, + 'bool' => \&vbool, + '+' => \&vnoop, + '-' => \&vnoop, + '*' => \&vnoop, + '/' => \&vnoop, + '+=' => \&vnoop, + '-=' => \&vnoop, + '*=' => \&vnoop, + '/=' => \&vnoop, + 'abs' => \&vnoop, +); + +eval "use warnings"; +if ($@) { + eval ' + package + warnings; + sub enabled {return $^W;} + 1; + '; +} + +sub import { + no strict 'refs'; + my ($class) = shift; + + # Set up any derived class + unless ($class eq $CLASS) { + local $^W; + *{$class.'::declare'} = \&{$CLASS.'::declare'}; + *{$class.'::qv'} = \&{$CLASS.'::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 + = \&{$CLASS.'::_VERSION'}; + } + + if (exists($args{'VERSION'})) { + *{$callpkg.'::VERSION'} = \&{$CLASS.'::_VERSION'}; + } + + if (exists($args{'is_strict'})) { + *{$callpkg.'::is_strict'} = \&{$CLASS.'::is_strict'} + unless defined(&{$callpkg.'::is_strict'}); + } + + if (exists($args{'is_lax'})) { + *{$callpkg.'::is_lax'} = \&{$CLASS.'::is_lax'} + unless defined(&{$callpkg.'::is_lax'}); + } +} + +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 + my $j = 0; + # 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)"); + } + } + + # and we never support negative version numbers + if ($d eq '-') { + return BADVERSION($s,$errstr,"Invalid version format (negative version number)"); + } + + # 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++; $j++; + 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)"); + } + $width = $j; + $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') { + require 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 = shift; + unless (defined $class or $#_ > 1) { + require Carp; + Carp::croak('Usage: version::new(class, version)'); + } + + my $self = bless ({}, ref ($class) || $class); + my $qv = FALSE; + + if ( $#_ == 1 ) { # must be CVS-style + $qv = TRUE; + } + my $value = pop; # always going to be the last element + + 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; + } + + 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 (ref($value) =~ m/ARRAY|HASH/) { + require Carp; + Carp::croak("Invalid version format (non-numeric data)"); + } + + $value = _un_vstring($value); + + if ($Config{d_setlocale}) { + use POSIX qw/locale_h/; + use if $Config{d_setlocale}, 'locale'; + 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/,/./; + } + } + + # 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 { + 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 format"); + } + 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 = $CLASS; + if (@_) { + $class = ref($value) || $value; + $value = shift; + } + + $value = _un_vstring($value); + $value = 'v'.$value unless $value =~ /(^v|\d+\.\d+\.\d)/; + my $obj = $CLASS->new($value); + return bless $obj, $class; +} + +*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 |