lib/version.pm

   1 #!perl -w
   2 package version;
   3
   4 use 5.005_04;
   5 use strict;
   6
   7 use vars qw(@ISA $VERSION $CLASS $STRICT $LAX *declare *qv);
   8
   9 $VERSION = 0.82;
  10
  11 $CLASS = 'version';
  12
  13 #--------------------------------------------------------------------------#
  14 # Version regexp components
  15 #--------------------------------------------------------------------------#
  16
  17 # Fraction part of a decimal version number.  This is a common part of
  18 # both strict and lax decimal versions
  19
  20 my $FRACTION_PART = qr/\.[0-9]+/;
  21
  22 # First part of either decimal or dotted-decimal strict version number.
  23 # Unsigned integer with no leading zeroes (except for zero itself) to
  24 # avoid confusion with octal.
  25
  26 my $STRICT_INTEGER_PART = qr/0|[1-9][0-9]*/;
  27
  28 # First part of either decimal or dotted-decimal lax version number.
  29 # Unsigned integer, but allowing leading zeros.  Always interpreted
  30 # as decimal.  However, some forms of the resulting syntax give odd
  31 # results if used as ordinary Perl expressions, due to how perl treats
  32 # octals.  E.g.
  33 #   version->new("010" ) == 10
  34 #   version->new( 010  ) == 8
  35 #   version->new( 010.2) == 82  # "8" . "2"
  36
  37 my $LAX_INTEGER_PART = qr/[0-9]+/;
  38
  39 # Second and subsequent part of a strict dotted-decimal version number.
  40 # Leading zeroes are permitted, and the number is always decimal.
  41 # Limited to three digits to avoid overflow when converting to decimal
  42 # form and also avoid problematic style with excessive leading zeroes.
  43
  44 my $STRICT_DOTTED_DECIMAL_PART = qr/\.[0-9]{1,3}/;
  45
  46 # Second and subsequent part of a lax dotted-decimal version number.
  47 # Leading zeroes are permitted, and the number is always decimal.  No
  48 # limit on the numerical value or number of digits, so there is the
  49 # possibility of overflow when converting to decimal form.
  50
  51 my $LAX_DOTTED_DECIMAL_PART = qr/\.[0-9]+/;
  52
  53 # Alpha suffix part of lax version number syntax.  Acts like a
  54 # dotted-decimal part.
  55
  56 my $LAX_ALPHA_PART = qr/_[0-9]+/;
  57
  58 #--------------------------------------------------------------------------#
  59 # Strict version regexp definitions
  60 #--------------------------------------------------------------------------#
  61
  62 # Strict decimal version number.
  63
  64 my $STRICT_DECIMAL_VERSION =
  65     qr/ $STRICT_INTEGER_PART $FRACTION_PART? /x;
  66
  67 # Strict dotted-decimal version number.  Must have both leading "v" and
  68 # at least three parts, to avoid confusion with decimal syntax.
  69
  70 my $STRICT_DOTTED_DECIMAL_VERSION =
  71     qr/ v $STRICT_INTEGER_PART $STRICT_DOTTED_DECIMAL_PART{2,} /x;
  72
  73 # Complete strict version number syntax -- should generally be used
  74 # anchored: qr/ \A $STRICT \z /x
  75
  76 $STRICT =
  77     qr/ $STRICT_DECIMAL_VERSION | $STRICT_DOTTED_DECIMAL_VERSION /x;
  78
  79 #--------------------------------------------------------------------------#
  80 # Lax version regexp definitions
  81 #--------------------------------------------------------------------------#
  82
  83 # Lax decimal version number.  Just like the strict one except for
  84 # allowing an alpha suffix or allowing a leading or trailing
  85 # decimal-point
  86
  87 my $LAX_DECIMAL_VERSION =
  88     qr/ $LAX_INTEGER_PART (?: \. | $FRACTION_PART $LAX_ALPHA_PART? )?
  89         |
  90         $FRACTION_PART $LAX_ALPHA_PART?
  91     /x;
  92
  93 # Lax dotted-decimal version number.  Distinguished by having either
  94 # leading "v" or at least three non-alpha parts.  Alpha part is only
  95 # permitted if there are at least two non-alpha parts. Strangely
  96 # enough, without the leading "v", Perl takes .1.2 to mean v0.1.2,
  97 # so when there is no "v", the leading part is optional
  98
  99 my $LAX_DOTTED_DECIMAL_VERSION =
 100     qr/
 101         v $LAX_INTEGER_PART (?: $LAX_DOTTED_DECIMAL_PART+ $LAX_ALPHA_PART? )?
 102         |
 103         $LAX_INTEGER_PART? $LAX_DOTTED_DECIMAL_PART{2,} $LAX_ALPHA_PART?
 104     /x;
 105
 106 # Complete lax version number syntax -- should generally be used
 107 # anchored: qr/ \A $LAX \z /x
 108 #
 109 # The string 'undef' is a special case to make for easier handling
 110 # of return values from ExtUtils::MM->parse_version
 111
 112 $LAX =
 113     qr/ undef | $LAX_DECIMAL_VERSION | $LAX_DOTTED_DECIMAL_VERSION /x;
 114
 115 #--------------------------------------------------------------------------#
 116
 117 # Preloaded methods go here.
 118 sub import {
 119     no strict 'refs';
 120     my ($class) = shift;
 121
 122     # Set up any derived class
 123     unless ($class eq 'version') {
 124         local $^W;
 125         *{$class.'::declare'} =  \&version::declare;
 126         *{$class.'::qv'} = \&version::qv;
 127     }
 128
 129     my %args;
 130     if (@_) { # any remaining terms are arguments
 131         map { $args{$_} = 1 } @_
 132     }
 133     else { # no parameters at all on use line
 134         %args =
 135         (
 136             qv => 1,
 137             'UNIVERSAL::VERSION' => 1,
 138         );
 139     }
 140
 141     my $callpkg = caller();
 142
 143     if (exists($args{declare})) {
 144         *{$callpkg.'::declare'} =
 145             sub {return $class->declare(shift) }
 146           unless defined(&{$callpkg.'::declare'});
 147     }
 148
 149     if (exists($args{qv})) {
 150         *{$callpkg.'::qv'} =
 151             sub {return $class->qv(shift) }
 152           unless defined(&{$callpkg.'::qv'});
 153     }
 154
 155     if (exists($args{'VERSION'})) {
 156         *{$callpkg.'::VERSION'} = \&version::_VERSION;
 157     }
 158
 159     if (exists($args{'is_strict'})) {
 160         *{$callpkg.'::is_strict'} =
 161             sub {return $class->is_strict(shift)}
 162           unless defined(&{$callpkg.'::is_strict'});
 163     }
 164
 165     if (exists($args{'is_lax'})) {
 166         *{$callpkg.'::is_lax'} =
 167             sub {return $class->is_lax(shift)}
 168           unless defined(&{$callpkg.'::is_lax'});
 169     }
 170 }
 171
 172 sub is_strict   { defined $_[0] && $_[0] =~ qr/ \A $STRICT \z /x }
 173 sub is_lax      { defined $_[0] && $_[0] =~ qr/ \A $LAX \z /x }
 174
 175 1;