2299946d39579d62ae8bb4039bbae1c514641174
[perl.git] / lib / Module / Build / Version.pm
1 package Module::Build::Version;
2 use strict;
3
4 eval "use version 0.70";
5 if ($@) { # can't locate version files, use our own
6
7     # Avoid redefined warnings if an old version.pm was available
8     delete $version::{$_} foreach keys %version::;
9
10     # first we get the stub version module
11     my $version;
12     while (<DATA>) {
13         s/(\$VERSION)\s=\s\d+/\$VERSION = 0/;
14         $version .= $_ if $_;
15         last if /^1;$/;
16     }
17
18     # and now get the current version::vpp code
19     my $vpp;
20     while (<DATA>) {
21         s/(\$VERSION)\s=\s\d+/\$VERSION = 0/;
22         $vpp .= $_ if $_;
23         last if /^1;$/;
24     }
25
26     # but we eval them in reverse order since version depends on
27     # version::vpp to already exist
28     eval $vpp; die $@ if $@;
29     $INC{'version/vpp.pm'} = 'inside Module::Build::Version';
30     eval $version; die $@ if $@;
31     $INC{'version.pm'} = 'inside Module::Build::Version';
32 }
33
34 # now we can safely subclass version, installed or not
35 use vars qw(@ISA);
36 @ISA = qw(version);
37
38 use overload (
39     '""' => \&stringify,
40 );
41
42 sub new {
43     my ($class, $value) = @_;
44     my $self = $class->SUPER::new($value);
45     $self->original($value);
46     return $self;
47 }
48
49 sub original {
50     my $self = shift;
51     $self->{original} = shift if @_;
52     return $self->{original};
53 }
54
55 sub stringify {
56     my $self = shift;
57     return $self->original;
58 }
59
60 1;
61 __DATA__
62 # stub version module to make everything else happy
63 package version;
64
65 use 5.005_04;
66 use strict;
67
68 use vars qw(@ISA $VERSION $CLASS *qv);
69
70 $VERSION = 0.000;
71
72 $CLASS = 'version';
73
74 push @ISA, "version::vpp";
75 *version::qv = \&version::vpp::qv;
76
77 # Preloaded methods go here.
78 sub import {
79     my ($class) = @_;
80     my $callpkg = caller();
81     no strict 'refs';
82     
83     *{$callpkg."::qv"} = 
84             sub {return bless version::qv(shift), $class }
85         unless defined(&{"$callpkg\::qv"});
86
87 }
88
89 1;
90 # replace everything from here to the end with the current version/vpp.pm
91
92 package version::vpp;
93 use strict;
94
95 use locale;
96 use vars qw ($VERSION @ISA @REGEXS);
97 $VERSION = 0.71;
98
99 push @REGEXS, qr/
100         ^v?     # optional leading 'v'
101         (\d*)   # major revision not required
102         \.      # requires at least one decimal
103         (?:(\d+)\.?){1,}
104         /x;
105
106 use overload (
107     '""'       => \&stringify,
108     '0+'       => \&numify,
109     'cmp'      => \&vcmp,
110     '<=>'      => \&vcmp,
111     'bool'     => \&vbool,
112     'nomethod' => \&vnoop,
113 );
114
115 sub new
116 {
117         my ($class, $value) = @_;
118         my $self = bless ({}, ref ($class) || $class);
119         require POSIX;
120         my $currlocale = POSIX::setlocale(&POSIX::LC_ALL);
121         my $radix_comma = ( POSIX::localeconv()->{decimal_point} eq ',' );
122
123         if ( not defined $value or $value =~ /^undef$/ ) {
124             # RT #19517 - special case for undef comparison
125             # or someone forgot to pass a value
126             push @{$self->{version}}, 0;
127             return ($self);
128         }
129
130         if ( $#_ == 2 ) { # must be CVS-style
131             $value = 'v'.$_[2];
132         }
133
134         $value = _un_vstring($value);
135
136         # exponential notation
137         if ( $value =~ /\d+.?\d*e-?\d+/ ) {
138             $value = sprintf("%.9f",$value);
139             $value =~ s/(0+)$//;
140         }
141         
142         # if the original locale used commas for decimal points, we
143         # just replace commas with decimal places, rather than changing
144         # locales
145         if ( $radix_comma ) {
146             $value =~ tr/,/./;
147         }
148
149         # This is not very efficient, but it is morally equivalent
150         # to the XS code (as that is the reference implementation).
151         # See vutil/vutil.c for details
152         my $qv = 0;
153         my $alpha = 0;
154         my $width = 3;
155         my $saw_period = 0;
156         my ($start, $last, $pos, $s);
157         $s = 0;
158
159         while ( substr($value,$s,1) =~ /\s/ ) { # leading whitespace is OK
160             $s++;
161         }
162
163         if (substr($value,$s,1) eq 'v') {
164             $s++;    # get past 'v'
165             $qv = 1; # force quoted version processing
166         }
167
168         $start = $last = $pos = $s;
169                 
170         # pre-scan the input string to check for decimals/underbars
171         while ( substr($value,$pos,1) =~ /[._\d]/ ) {
172             if ( substr($value,$pos,1) eq '.' ) {
173                 if ($alpha) {
174                     require Carp;
175                     Carp::croak("Invalid version format ".
176                         "(underscores before decimal)");
177                 }
178                 $saw_period++;
179                 $last = $pos;
180             }
181             elsif ( substr($value,$pos,1) eq '_' ) {
182                 if ($alpha) {
183                     require Carp;
184                     Carp::croak("Invalid version format ".
185                         "(multiple underscores)");
186                 }
187                 $alpha = 1;
188                 $width = $pos - $last - 1; # natural width of sub-version
189             }
190             $pos++;
191         }
192
193         if ( $alpha && !$saw_period ) {
194             require Carp;
195             Carp::croak("Invalid version format (alpha without decimal)");
196         }
197
198         if ( $alpha && $saw_period && $width == 0 ) {
199             require Carp;
200             Carp::croak("Invalid version format (misplaced _ in number)");
201         }
202
203         if ( $saw_period > 1 ) {
204             $qv = 1; # force quoted version processing
205         }
206
207         $pos = $s;
208
209         if ( $qv ) {
210             $self->{qv} = 1;
211         }
212
213         if ( $alpha ) {
214             $self->{alpha} = 1;
215         }
216
217         if ( !$qv && $width < 3 ) {
218             $self->{width} = $width;
219         }
220
221         while ( substr($value,$pos,1) =~ /\d/ ) {
222             $pos++;
223         }
224
225         if ( substr($value,$pos,1) !~ /[a-z]/ ) { ### FIX THIS ###
226             my $rev;
227
228             while (1) {
229                 $rev = 0;
230                 {
231
232                     # this is atoi() that delimits on underscores
233                     my $end = $pos;
234                     my $mult = 1;
235                     my $orev;
236
237                     # the following if() will only be true after the decimal
238                     # point of a version originally created with a bare
239                     # floating point number, i.e. not quoted in any way
240                     if ( !$qv && $s > $start && $saw_period == 1 ) {
241                         $mult *= 100;
242                         while ( $s < $end ) {
243                             $orev = $rev;
244                             $rev += substr($value,$s,1) * $mult;
245                             $mult /= 10;
246                             if ( abs($orev) > abs($rev) ) {
247                                 require Carp;
248                                 Carp::croak("Integer overflow in version");
249                             }
250                             $s++;
251                             if ( substr($value,$s,1) eq '_' ) {
252                                 $s++;
253                             }
254                         }
255                     }
256                     else {
257                         while (--$end >= $s) {
258                             $orev = $rev;
259                             $rev += substr($value,$end,1) * $mult;
260                             $mult *= 10;
261                             if ( abs($orev) > abs($rev) ) {
262                                 require Carp;
263                                 Carp::croak("Integer overflow in version");
264                             }
265                         }
266                     }
267                 }
268
269                 # Append revision
270                 push @{$self->{version}}, $rev;
271                 if ( substr($value,$pos,1) eq '.' 
272                     && substr($value,$pos+1,1) =~ /\d/ ) {
273                     $s = ++$pos;
274                 }
275                 elsif ( substr($value,$pos,1) eq '_' 
276                     && substr($value,$pos+1,1) =~ /\d/ ) {
277                     $s = ++$pos;
278                 }
279                 elsif ( substr($value,$pos,1) =~ /\d/ ) {
280                     $s = $pos;
281                 }
282                 else {
283                     $s = $pos;
284                     last;
285                 }
286                 if ( $qv ) {
287                     while ( substr($value,$pos,1) =~ /\d/ ) {
288                         $pos++;
289                     }
290                 }
291                 else {
292                     my $digits = 0;
293                     while (substr($value,$pos,1) =~ /[\d_]/ && $digits < 3) {
294                         if ( substr($value,$pos,1) ne '_' ) {
295                             $digits++;
296                         }
297                         $pos++;
298                     }
299                 }
300             }
301         }
302         if ( $qv ) { # quoted versions always get at least three terms
303             my $len = scalar @{$self->{version}};
304             $len = 3 - $len;
305             while ($len-- > 0) {
306                 push @{$self->{version}}, 0;
307             }
308         }
309
310         if ( substr($value,$pos) ) { # any remaining text
311             warn "Version string '$value' contains invalid data; ".
312                  "ignoring: '".substr($value,$pos)."'";
313         }
314
315         return ($self);
316 }
317
318 sub numify 
319 {
320     my ($self) = @_;
321     unless (_verify($self)) {
322         require Carp;
323         Carp::croak("Invalid version object");
324     }
325     my $width = $self->{width} || 3;
326     my $alpha = $self->{alpha} || "";
327     my $len = $#{$self->{version}};
328     my $digit = $self->{version}[0];
329     my $string = sprintf("%d.", $digit );
330
331     for ( my $i = 1 ; $i < $len ; $i++ ) {
332         $digit = $self->{version}[$i];
333         if ( $width < 3 ) {
334             my $denom = 10**(3-$width);
335             my $quot = int($digit/$denom);
336             my $rem = $digit - ($quot * $denom);
337             $string .= sprintf("%0".$width."d_%d", $quot, $rem);
338         }
339         else {
340             $string .= sprintf("%03d", $digit);
341         }
342     }
343
344     if ( $len > 0 ) {
345         $digit = $self->{version}[$len];
346         if ( $alpha && $width == 3 ) {
347             $string .= "_";
348         }
349         $string .= sprintf("%0".$width."d", $digit);
350     }
351     else # $len = 0
352     {
353         $string .= sprintf("000");
354     }
355
356     return $string;
357 }
358
359 sub normal 
360 {
361     my ($self) = @_;
362     unless (_verify($self)) {
363         require Carp;
364         Carp::croak("Invalid version object");
365     }
366     my $alpha = $self->{alpha} || "";
367     my $len = $#{$self->{version}};
368     my $digit = $self->{version}[0];
369     my $string = sprintf("v%d", $digit );
370
371     for ( my $i = 1 ; $i < $len ; $i++ ) {
372         $digit = $self->{version}[$i];
373         $string .= sprintf(".%d", $digit);
374     }
375
376     if ( $len > 0 ) {
377         $digit = $self->{version}[$len];
378         if ( $alpha ) {
379             $string .= sprintf("_%0d", $digit);
380         }
381         else {
382             $string .= sprintf(".%0d", $digit);
383         }
384     }
385
386     if ( $len <= 2 ) {
387         for ( $len = 2 - $len; $len != 0; $len-- ) {
388             $string .= sprintf(".%0d", 0);
389         }
390     }
391
392     return $string;
393 }
394
395 sub stringify
396 {
397     my ($self) = @_;
398     unless (_verify($self)) {
399         require Carp;
400         Carp::croak("Invalid version object");
401     }
402     if ( exists $self->{qv} ) {
403         return $self->normal;
404     }
405     else {
406         return $self->numify;
407     }
408 }
409
410 sub vcmp
411 {
412     require UNIVERSAL;
413     my ($left,$right,$swap) = @_;
414     my $class = ref($left);
415     unless ( UNIVERSAL::isa($right, $class) ) {
416         $right = $class->new($right);
417     }
418
419     if ( $swap ) {
420         ($left, $right) = ($right, $left);
421     }
422     unless (_verify($left)) {
423         require Carp;
424         Carp::croak("Invalid version object");
425     }
426     unless (_verify($right)) {
427         require Carp;
428         Carp::croak("Invalid version object");
429     }
430     my $l = $#{$left->{version}};
431     my $r = $#{$right->{version}};
432     my $m = $l < $r ? $l : $r;
433     my $lalpha = $left->is_alpha;
434     my $ralpha = $right->is_alpha;
435     my $retval = 0;
436     my $i = 0;
437     while ( $i <= $m && $retval == 0 ) {
438         $retval = $left->{version}[$i] <=> $right->{version}[$i];
439         $i++;
440     }
441
442     # tiebreaker for alpha with identical terms
443     if ( $retval == 0 
444         && $l == $r 
445         && $left->{version}[$m] == $right->{version}[$m]
446         && ( $lalpha || $ralpha ) ) {
447
448         if ( $lalpha && !$ralpha ) {
449             $retval = -1;
450         }
451         elsif ( $ralpha && !$lalpha) {
452             $retval = +1;
453         }
454     }
455
456     # possible match except for trailing 0's
457     if ( $retval == 0 && $l != $r ) {
458         if ( $l < $r ) {
459             while ( $i <= $r && $retval == 0 ) {
460                 if ( $right->{version}[$i] != 0 ) {
461                     $retval = -1; # not a match after all
462                 }
463                 $i++;
464             }
465         }
466         else {
467             while ( $i <= $l && $retval == 0 ) {
468                 if ( $left->{version}[$i] != 0 ) {
469                     $retval = +1; # not a match after all
470                 }
471                 $i++;
472             }
473         }
474     }
475
476     return $retval;  
477 }
478
479 sub vbool {
480     my ($self) = @_;
481     return vcmp($self,$self->new("0"),1);
482 }
483
484 sub vnoop { 
485     require Carp; 
486     Carp::croak("operation not supported with version object");
487 }
488
489 sub is_alpha {
490     my ($self) = @_;
491     return (exists $self->{alpha});
492 }
493
494 sub qv {
495     my ($value) = @_;
496
497     $value = _un_vstring($value);
498     $value = 'v'.$value unless $value =~ /^v/;
499     return version->new($value); # always use base class
500 }
501
502 sub is_qv {
503     my ($self) = @_;
504     return (exists $self->{qv});
505 }
506
507
508 sub _verify {
509     my ($self) = @_;
510     if ( ref($self)
511         && eval { exists $self->{version} }
512         && ref($self->{version}) eq 'ARRAY'
513         ) {
514         return 1;
515     }
516     else {
517         return 0;
518     }
519 }
520
521 sub _un_vstring {
522     my $value = shift;
523     # may be a v-string
524     if ( $] >= 5.006_000 && length($value) >= 3 && $value !~ /[._]/ ) {
525         my $tvalue = sprintf("%vd",$value);
526         if ( $tvalue =~ /^\d+\.\d+\.\d+$/ ) {
527             # must be a v-string
528             $value = $tvalue;
529         }
530     }
531     return $value;
532 }
533
534 # Thanks to Yitzchak Scott-Thoennes for this mode of operation
535 {
536     local $^W;
537     *UNIVERSAL::VERSION = sub {
538         my ($obj, $req) = @_;
539         my $class = ref($obj) || $obj;
540
541         no strict 'refs';
542         eval "require $class" unless %{"$class\::"}; # already existing
543         return undef if $@ =~ /Can't locate/ and not defined $req;
544         
545         if ( not %{"$class\::"} and $] >= 5.008) { # file but no package
546             require Carp;
547             Carp::croak( "$class defines neither package nor VERSION"
548                 ."--version check failed");
549         }
550         
551         my $version = eval "\$$class\::VERSION";
552         if ( defined $version ) {
553             local $^W if $] <= 5.008;
554             $version = version::vpp->new($version);
555         }
556
557         if ( defined $req ) {
558             unless ( defined $version ) {
559                 require Carp;
560                 my $msg =  $] < 5.006 
561                 ? "$class version $req required--this is only version "
562                 : "$class does not define \$$class\::VERSION"
563                   ."--version check failed";
564
565                 if ( $ENV{VERSION_DEBUG} ) {
566                     Carp::confess($msg);
567                 }
568                 else {
569                     Carp::croak($msg);
570                 }
571             }
572
573             $req = version::vpp->new($req);
574
575             if ( $req > $version ) {
576                 require Carp;
577                 if ( $req->is_qv ) {
578                     Carp::croak( 
579                         sprintf ("%s version %s required--".
580                             "this is only version %s", $class,
581                             $req->normal, $version->normal)
582                     );
583                 }
584                 else {
585                     Carp::croak( 
586                         sprintf ("%s version %s required--".
587                             "this is only version %s", $class,
588                             $req->numify, $version->numify)
589                     );
590                 }
591             }
592         }
593
594         return defined $version ? $version->numify : undef;
595     };
596 }
597
598 1; #this line is important and will help the module return a true value