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