Commit | Line | Data |
9acf5c35 |
1 | package Module::Build::Version; |
0ec9ad96 |
2 | use strict; |
3 | |
4 | eval "use version 0.661"; |
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 |
77e96e88 |
28 | eval $vpp; die $@ if $@; |
0ec9ad96 |
29 | $INC{'version/vpp.pm'} = 'inside Module::Build::Version'; |
77e96e88 |
30 | eval $version; die $@ if $@; |
0ec9ad96 |
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); |
9acf5c35 |
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; |
0ec9ad96 |
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 Scalar::Util; |
96 | use vars qw ($VERSION @ISA @REGEXS); |
77e96e88 |
97 | $VERSION = 0.67; |
0ec9ad96 |
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 | 'cmp' => \&vcmp, |
109 | '<=>' => \&vcmp, |
110 | ); |
111 | |
112 | sub new |
113 | { |
114 | my ($class, $value) = @_; |
115 | my $self = bless ({}, ref ($class) || $class); |
116 | |
117 | if ( not defined $value or $value =~ /^undef$/ ) { |
118 | # RT #19517 - special case for undef comparison |
119 | # or someone forgot to pass a value |
120 | push @{$self->{version}}, 0; |
121 | return ($self); |
122 | } |
123 | |
124 | if ( $#_ == 2 ) { # must be CVS-style |
125 | $value = 'v'.$_[2]; |
126 | } |
127 | |
128 | # may be a v-string |
129 | if ( $] >= 5.006_002 && length($value) >= 3 && $value !~ /[._]/ ) { |
130 | my $tvalue = sprintf("%vd",$value); |
131 | if ( $tvalue =~ /^\d+\.\d+\.\d+$/ ) { |
132 | # must be a v-string |
133 | $value = $tvalue; |
134 | } |
135 | } |
77e96e88 |
136 | |
137 | # exponential notation |
138 | if ( $value =~ /\d+e-?\d+/ ) { |
139 | $value = sprintf("%.9f",$value); |
140 | $value =~ s/(0+)$//; |
141 | } |
0ec9ad96 |
142 | |
143 | # This is not very efficient, but it is morally equivalent |
144 | # to the XS code (as that is the reference implementation). |
145 | # See vutil/vutil.c for details |
146 | my $qv = 0; |
147 | my $alpha = 0; |
148 | my $width = 3; |
149 | my $saw_period = 0; |
150 | my ($start, $last, $pos, $s); |
151 | $s = 0; |
152 | |
153 | while ( substr($value,$s,1) =~ /\s/ ) { # leading whitespace is OK |
154 | $s++; |
155 | } |
156 | |
157 | if (substr($value,$s,1) eq 'v') { |
158 | $s++; # get past 'v' |
159 | $qv = 1; # force quoted version processing |
160 | } |
161 | |
162 | $start = $last = $pos = $s; |
163 | |
164 | # pre-scan the input string to check for decimals/underbars |
165 | while ( substr($value,$pos,1) =~ /[._\d]/ ) { |
166 | if ( substr($value,$pos,1) eq '.' ) { |
167 | die "Invalid version format (underscores before decimal)" |
168 | if $alpha; |
169 | $saw_period++; |
170 | $last = $pos; |
171 | } |
172 | elsif ( substr($value,$pos,1) eq '_' ) { |
173 | die "Invalid version format (multiple underscores)" |
174 | if $alpha; |
175 | $alpha = 1; |
176 | $width = $pos - $last - 1; # natural width of sub-version |
177 | } |
178 | $pos++; |
179 | } |
180 | |
181 | if ( $alpha && !$saw_period ) { |
182 | die "Invalid version format (alpha without decimal)"; |
183 | } |
184 | |
185 | if ( $saw_period > 1 ) { |
186 | $qv = 1; # force quoted version processing |
187 | } |
188 | |
189 | $pos = $s; |
190 | |
191 | if ( $qv ) { |
192 | $self->{qv} = 1; |
193 | } |
194 | |
195 | if ( $alpha ) { |
196 | $self->{alpha} = 1; |
197 | } |
198 | |
199 | if ( !$qv && $width < 3 ) { |
200 | $self->{width} = $width; |
201 | } |
202 | |
203 | while ( substr($value,$pos,1) =~ /\d/ ) { |
204 | $pos++; |
205 | } |
206 | |
207 | if ( substr($value,$pos,1) !~ /[a-z]/ ) { ### FIX THIS ### |
208 | my $rev; |
209 | |
210 | while (1) { |
211 | $rev = 0; |
212 | { |
213 | |
214 | # this is atoi() that delimits on underscores |
215 | my $end = $pos; |
216 | my $mult = 1; |
217 | my $orev; |
218 | |
219 | # the following if() will only be true after the decimal |
220 | # point of a version originally created with a bare |
221 | # floating point number, i.e. not quoted in any way |
222 | if ( !$qv && $s > $start && $saw_period == 1 ) { |
223 | $mult *= 100; |
224 | while ( $s < $end ) { |
225 | $orev = $rev; |
226 | $rev += substr($value,$s,1) * $mult; |
227 | $mult /= 10; |
228 | if ( abs($orev) > abs($rev) ) { |
229 | die "Integer overflow in version"; |
230 | } |
231 | $s++; |
232 | if ( substr($value,$s,1) eq '_' ) { |
233 | $s++; |
234 | } |
235 | } |
236 | } |
237 | else { |
238 | while (--$end >= $s) { |
239 | $orev = $rev; |
240 | $rev += substr($value,$end,1) * $mult; |
241 | $mult *= 10; |
242 | if ( abs($orev) > abs($rev) ) { |
243 | die "Integer overflow in version"; |
244 | } |
245 | } |
246 | } |
247 | } |
248 | |
249 | # Append revision |
250 | push @{$self->{version}}, $rev; |
251 | if ( substr($value,$pos,1) eq '.' |
252 | && substr($value,$pos+1,1) =~ /\d/ ) { |
253 | $s = ++$pos; |
254 | } |
255 | elsif ( substr($value,$pos,1) eq '_' |
256 | && substr($value,$pos+1,1) =~ /\d/ ) { |
257 | $s = ++$pos; |
258 | } |
259 | elsif ( substr($value,$pos,1) =~ /\d/ ) { |
260 | $s = $pos; |
261 | } |
262 | else { |
263 | $s = $pos; |
264 | last; |
265 | } |
266 | if ( $qv ) { |
267 | while ( substr($value,$pos,1) =~ /\d/ ) { |
268 | $pos++; |
269 | } |
270 | } |
271 | else { |
272 | my $digits = 0; |
273 | while (substr($value,$pos,1) =~ /[\d_]/ && $digits < 3) { |
274 | if ( substr($value,$pos,1) ne '_' ) { |
275 | $digits++; |
276 | } |
277 | $pos++; |
278 | } |
279 | } |
280 | } |
281 | } |
282 | if ( $qv ) { # quoted versions always get at least three terms |
283 | my $len = scalar @{$self->{version}}; |
284 | $len = 3 - $len; |
285 | while ($len-- > 0) { |
286 | push @{$self->{version}}, 0; |
287 | } |
288 | } |
289 | |
290 | if ( substr($value,$pos) ) { # any remaining text |
291 | warn "Version string '$value' contains invalid data; ". |
292 | "ignoring: '".substr($value,$pos)."'"; |
293 | } |
294 | |
295 | return ($self); |
296 | } |
297 | |
298 | sub numify |
299 | { |
300 | my ($self) = @_; |
301 | unless (_verify($self)) { |
302 | die "Invalid version object"; |
303 | } |
304 | my $width = $self->{width} || 3; |
305 | my $alpha = $self->{alpha} || ""; |
306 | my $len = $#{$self->{version}}; |
307 | my $digit = $self->{version}[0]; |
308 | my $string = sprintf("%d.", $digit ); |
309 | |
310 | for ( my $i = 1 ; $i < $len ; $i++ ) { |
311 | $digit = $self->{version}[$i]; |
312 | if ( $width < 3 ) { |
313 | my $denom = 10**(3-$width); |
314 | my $quot = int($digit/$denom); |
315 | my $rem = $digit - ($quot * $denom); |
316 | $string .= sprintf("%0".$width."d_%d", $quot, $rem); |
317 | } |
318 | else { |
319 | $string .= sprintf("%03d", $digit); |
320 | } |
321 | } |
322 | |
323 | if ( $len > 0 ) { |
324 | $digit = $self->{version}[$len]; |
325 | if ( $alpha && $width == 3 ) { |
326 | $string .= "_"; |
327 | } |
328 | $string .= sprintf("%0".$width."d", $digit); |
329 | } |
330 | else # $len = 0 |
331 | { |
332 | $string .= sprintf("000"); |
333 | } |
334 | |
335 | return $string; |
336 | } |
337 | |
338 | sub normal |
339 | { |
340 | my ($self) = @_; |
341 | unless (_verify($self)) { |
342 | die "Invalid version object"; |
343 | } |
344 | my $alpha = $self->{alpha} || ""; |
345 | my $len = $#{$self->{version}}; |
346 | my $digit = $self->{version}[0]; |
347 | my $string = sprintf("v%d", $digit ); |
348 | |
349 | for ( my $i = 1 ; $i < $len ; $i++ ) { |
350 | $digit = $self->{version}[$i]; |
351 | $string .= sprintf(".%d", $digit); |
352 | } |
353 | |
354 | if ( $len > 0 ) { |
355 | $digit = $self->{version}[$len]; |
356 | if ( $alpha ) { |
357 | $string .= sprintf("_%0d", $digit); |
358 | } |
359 | else { |
360 | $string .= sprintf(".%0d", $digit); |
361 | } |
362 | } |
363 | |
364 | if ( $len <= 2 ) { |
365 | for ( $len = 2 - $len; $len != 0; $len-- ) { |
366 | $string .= sprintf(".%0d", 0); |
367 | } |
368 | } |
369 | |
370 | return $string; |
371 | } |
372 | |
373 | sub stringify |
374 | { |
375 | my ($self) = @_; |
376 | unless (_verify($self)) { |
377 | die "Invalid version object"; |
378 | } |
379 | if ( exists $self->{qv} ) { |
380 | return $self->normal; |
381 | } |
382 | else { |
383 | return $self->numify; |
384 | } |
385 | } |
386 | |
387 | sub vcmp |
388 | { |
389 | require UNIVERSAL; |
390 | my ($left,$right,$swap) = @_; |
391 | my $class = ref($left); |
392 | unless ( UNIVERSAL::isa($right, $class) ) { |
393 | $right = $class->new($right); |
394 | } |
395 | |
396 | if ( $swap ) { |
397 | ($left, $right) = ($right, $left); |
398 | } |
399 | unless (_verify($left)) { |
400 | die "Invalid version object"; |
401 | } |
402 | unless (_verify($right)) { |
403 | die "Invalid version object"; |
404 | } |
405 | my $l = $#{$left->{version}}; |
406 | my $r = $#{$right->{version}}; |
407 | my $m = $l < $r ? $l : $r; |
408 | my $lalpha = $left->is_alpha; |
409 | my $ralpha = $right->is_alpha; |
410 | my $retval = 0; |
411 | my $i = 0; |
412 | while ( $i <= $m && $retval == 0 ) { |
413 | $retval = $left->{version}[$i] <=> $right->{version}[$i]; |
414 | $i++; |
415 | } |
416 | |
417 | # tiebreaker for alpha with identical terms |
418 | if ( $retval == 0 |
419 | && $l == $r |
420 | && $left->{version}[$m] == $right->{version}[$m] |
421 | && ( $lalpha || $ralpha ) ) { |
422 | |
423 | if ( $lalpha && !$ralpha ) { |
424 | $retval = -1; |
425 | } |
426 | elsif ( $ralpha && !$lalpha) { |
427 | $retval = +1; |
428 | } |
429 | } |
430 | |
431 | # possible match except for trailing 0's |
432 | if ( $retval == 0 && $l != $r ) { |
433 | if ( $l < $r ) { |
434 | while ( $i <= $r && $retval == 0 ) { |
435 | if ( $right->{version}[$i] != 0 ) { |
436 | $retval = -1; # not a match after all |
437 | } |
438 | $i++; |
439 | } |
440 | } |
441 | else { |
442 | while ( $i <= $l && $retval == 0 ) { |
443 | if ( $left->{version}[$i] != 0 ) { |
444 | $retval = +1; # not a match after all |
445 | } |
446 | $i++; |
447 | } |
448 | } |
449 | } |
450 | |
451 | return $retval; |
452 | } |
453 | |
454 | sub is_alpha { |
455 | my ($self) = @_; |
456 | return (exists $self->{alpha}); |
457 | } |
458 | |
459 | sub qv { |
460 | my ($value) = @_; |
461 | |
0ec9ad96 |
462 | my $eval = eval 'Scalar::Util::isvstring($value)'; |
463 | if ( !$@ and $eval ) { |
464 | $value = sprintf("v%vd",$value); |
465 | } |
466 | else { |
467 | $value = 'v'.$value unless $value =~ /^v/; |
468 | } |
469 | return version->new($value); # always use base class |
470 | } |
471 | |
472 | sub _verify { |
473 | my ($self) = @_; |
474 | if ( Scalar::Util::reftype($self) eq 'HASH' |
475 | && exists $self->{version} |
476 | && ref($self->{version}) eq 'ARRAY' |
477 | ) { |
478 | return 1; |
479 | } |
480 | else { |
481 | return 0; |
482 | } |
483 | } |
484 | |
485 | # Thanks to Yitzchak Scott-Thoennes for this mode of operation |
486 | { |
487 | local $^W; |
488 | *UNIVERSAL::VERSION = sub { |
489 | my ($obj, $req) = @_; |
490 | my $class = ref($obj) || $obj; |
491 | |
492 | no strict 'refs'; |
493 | eval "require $class" unless %{"$class\::"}; # already existing |
494 | die "$class defines neither package nor VERSION--version check failed" |
495 | if $@ or not %{"$class\::"}; |
496 | |
497 | my $version = eval "\$$class\::VERSION"; |
498 | if ( defined $version ) { |
499 | $version = version::vpp->new($version); |
500 | } |
501 | |
502 | if ( defined $req ) { |
0ec9ad96 |
503 | unless ( defined $version ) { |
504 | my $msg = "$class does not define ". |
505 | "\$$class\::VERSION--version check failed"; |
506 | if ( $ENV{VERSION_DEBUG} ) { |
507 | require Carp; |
508 | Carp::confess($msg); |
509 | } |
510 | else { |
511 | die($msg); |
512 | } |
513 | } |
514 | |
515 | $req = version::vpp->new($req); |
516 | |
517 | if ( $req > $version ) { |
518 | die sprintf ("%s version %s (%s) required--". |
519 | "this is only version %s (%s)", $class, |
520 | $req->numify, $req->normal, |
521 | $version->numify, $version->normal); |
522 | } |
523 | } |
524 | |
525 | return defined $version ? $version->numify : undef; |
526 | }; |
527 | } |
528 | |
529 | 1; #this line is important and will help the module return a true value |