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