← Back to branch summary

~ubuntu-branches/ubuntu/maverick/libversion-perl/maverick

« back to all changes in this revision

Viewing changes to vperl/vpp.pm

  • Committer: Bazaar Package Importer
  • Author(s): Fabrice Coutadeur
  • Date: 2010-08-21 07:23:08 UTC
  • mfrom: (7.1.1 sid)
  • Revision ID: james.westby@ubuntu.com-20100821072308-af0a3cipsnohw3k2
Tags: 1:0.8200-1ubuntu1
https://launchpad.net/bugs/621576
* Merge from Debian unstable (LP: #621576). Remaining changes:
  - debian/control: Fixed dependency locales-all -> locales

Show diffs side-by-side

added added

removed removed

Lines of Context:
vperl/vpp.pm
 
1
package charstar;
 
2
# a little helper class to emulate C char* semantics in Perl
 
3
# so that prescan_version can use the same code as in C
 
4
 
 
5
use overload (
 
6
    '""'        => \&thischar,
 
7
    '0+'        => \&thischar,
 
8
    '++'        => \&increment,
 
9
    '--'        => \&decrement,
 
10
    '+'         => \&plus,
 
11
    '-'         => \&minus,
 
12
    '*'         => \&multiply,
 
13
    'cmp'       => \&cmp,
 
14
    '<=>'       => \&spaceship,
 
15
    'bool'      => \&thischar,
 
16
    '='         => \&clone,
 
17
);
 
18
 
 
19
sub new {
 
20
    my ($self, $string) = @_;
 
21
    my $class = ref($self) || $self;
 
22
 
 
23
    my $obj = {
 
24
        string  => [split(//,$string)],
 
25
        current => 0,
 
26
    };
 
27
    return bless $obj, $class;
 
28
}
 
29
 
 
30
sub thischar {
 
31
    my ($self) = @_;
 
32
    my $last = $#{$self->{string}};
 
33
    my $curr = $self->{current};
 
34
    if ($curr >= 0 && $curr <= $last) {
 
35
        return $self->{string}->[$curr];
 
36
    }
 
37
    else {
 
38
        return '';
 
39
    }
 
40
}
 
41
 
 
42
sub increment {
 
43
    my ($self) = @_;
 
44
    $self->{current}++;
 
45
}
 
46
 
 
47
sub decrement {
 
48
    my ($self) = @_;
 
49
    $self->{current}--;
 
50
}
 
51
 
 
52
sub plus {
 
53
    my ($self, $offset) = @_;
 
54
    my $rself = $self->clone;
 
55
    $rself->{current} += $offset;
 
56
    return $rself;
 
57
}
 
58
 
 
59
sub minus {
 
60
    my ($self, $offset) = @_;
 
61
    my $rself = $self->clone;
 
62
    $rself->{current} -= $offset;
 
63
    return $rself;
 
64
}
 
65
 
 
66
sub multiply {
 
67
    my ($left, $right, $swapped) = @_;
 
68
    my $char = $left->thischar();
 
69
    return $char * $right;
 
70
}
 
71
 
 
72
sub spaceship {
 
73
    my ($left, $right, $swapped) = @_;
 
74
    unless (ref($right)) { # not an object already
 
75
        $right = $left->new($right);
 
76
    }
 
77
    return $left->{current} <=> $right->{current};
 
78
}
 
79
 
 
80
sub cmp {
 
81
    my ($left, $right, $swapped) = @_;
 
82
    unless (ref($right)) { # not an object already
 
83
        if (length($right) == 1) { # comparing single character only
 
84
            return $left->thischar cmp $right;
 
85
        }
 
86
        $right = $left->new($right);
 
87
    }
 
88
    return $left->currstr cmp $right->currstr;
 
89
}
 
90
 
 
91
sub bool {
 
92
    my ($self) = @_;
 
93
    my $char = $self->thischar;
 
94
    return ($char ne '');
 
95
}
 
96
 
 
97
sub clone {
 
98
    my ($left, $right, $swapped) = @_;
 
99
    $right = {
 
100
        string  => [@{$left->{string}}],
 
101
        current => $left->{current},
 
102
    };
 
103
    return bless $right, ref($left);
 
104
}
 
105
 
 
106
sub currstr {
 
107
    my ($self, $s) = @_;
 
108
    my $curr = $self->{current};
 
109
    my $last = $#{$self->{string}};
 
110
    if (defined($s) && $s->{current} < $last) {
 
111
        $last = $s->{current};
 
112
    }
 
113
 
 
114
    my $string = join('', @{$self->{string}}[$curr..$last]);
 
115
    return $string;
 
116
}
 
117
 
1
118
package version::vpp;
2
119
use strict;
3
120
 
 
121
use POSIX qw/locale_h/;
4
122
use locale;
5
123
use vars qw ($VERSION @ISA @REGEXS);
6
 
$VERSION = 0.74;
7
 
 
8
 
push @REGEXS, qr/
9
 
        ^v?     # optional leading 'v'
10
 
        (\d*)   # major revision not required
11
 
        \.      # requires at least one decimal
12
 
        (?:(\d+)\.?){1,}
13
 
        /x;
 
124
$VERSION = 0.82;
14
125
 
15
126
use overload (
16
127
    '""'       => \&stringify,
21
132
    'nomethod' => \&vnoop,
22
133
);
23
134
 
24
 
my $VERSION_MAX = 0x7FFFFFFF;
25
 
 
26
135
eval "use warnings";
27
136
if ($@) {
28
137
    eval '
32
141
    ';
33
142
}
34
143
 
 
144
my $VERSION_MAX = 0x7FFFFFFF;
 
145
 
 
146
# implement prescan_version as closely to the C version as possible
 
147
use constant TRUE  => 1;
 
148
use constant FALSE => 0;
 
149
 
 
150
sub isDIGIT {
 
151
    my ($char) = shift->thischar();
 
152
    return ($char =~ /\d/);
 
153
}
 
154
 
 
155
sub isALPHA {
 
156
    my ($char) = shift->thischar();
 
157
    return ($char =~ /[a-zA-Z]/);
 
158
}
 
159
 
 
160
sub isSPACE {
 
161
    my ($char) = shift->thischar();
 
162
    return ($char =~ /\s/);
 
163
}
 
164
 
 
165
sub BADVERSION {
 
166
    my ($s, $errstr, $error) = @_;
 
167
    if ($errstr) {
 
168
        $$errstr = $error;
 
169
    }
 
170
    return $s;
 
171
}
 
172
 
 
173
sub prescan_version {
 
174
    my ($s, $strict, $errstr, $sqv, $ssaw_decimal, $swidth, $salpha) = @_;
 
175
    my $qv          = defined $sqv          ? $$sqv          : FALSE;
 
176
    my $saw_decimal = defined $ssaw_decimal ? $$ssaw_decimal : 0;
 
177
    my $width       = defined $swidth       ? $$swidth       : 3;
 
178
    my $alpha       = defined $salpha       ? $$salpha       : FALSE;
 
179
 
 
180
    my $d = $s;
 
181
 
 
182
    if ($qv && isDIGIT($d)) {
 
183
        goto dotted_decimal_version;
 
184
    }
 
185
 
 
186
    if ($d eq 'v') { # explicit v-string
 
187
        $d++;
 
188
        if (isDIGIT($d)) {
 
189
            $qv = TRUE;
 
190
        }
 
191
        else { # degenerate v-string
 
192
            # requires v1.2.3
 
193
            return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
 
194
        }
 
195
 
 
196
dotted_decimal_version:
 
197
        if ($strict && $d eq '0' && isDIGIT($d+1)) {
 
198
            # no leading zeros allowed
 
199
            return BADVERSION($s,$errstr,"Invalid version format (no leading zeros)");
 
200
        }
 
201
 
 
202
        while (isDIGIT($d)) {   # integer part
 
203
            $d++;
 
204
        }
 
205
 
 
206
        if ($d eq '.')
 
207
        {
 
208
            $saw_decimal++;
 
209
            $d++;               # decimal point
 
210
        }
 
211
        else
 
212
        {
 
213
            if ($strict) {
 
214
                # require v1.2.3
 
215
                return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
 
216
            }
 
217
            else {
 
218
                goto version_prescan_finish;
 
219
            }
 
220
        }
 
221
 
 
222
        {
 
223
            my $i = 0;
 
224
            my $j = 0;
 
225
            while (isDIGIT($d)) {       # just keep reading
 
226
                $i++;
 
227
                while (isDIGIT($d)) {
 
228
                    $d++; $j++;
 
229
                    # maximum 3 digits between decimal
 
230
                    if ($strict && $j > 3) {
 
231
                        return BADVERSION($s,$errstr,"Invalid version format (maximum 3 digits between decimals)");
 
232
                    }
 
233
                }
 
234
                if ($d eq '_') {
 
235
                    if ($strict) {
 
236
                        return BADVERSION($s,$errstr,"Invalid version format (no underscores)");
 
237
                    }
 
238
                    if ( $alpha ) {
 
239
                        return BADVERSION($s,$errstr,"Invalid version format (multiple underscores)");
 
240
                    }
 
241
                    $d++;
 
242
                    $alpha = TRUE;
 
243
                }
 
244
                elsif ($d eq '.') {
 
245
                    if ($alpha) {
 
246
                        return BADVERSION($s,$errstr,"Invalid version format (underscores before decimal)");
 
247
                    }
 
248
                    $saw_decimal++;
 
249
                    $d++;
 
250
                }
 
251
                elsif (!isDIGIT($d)) {
 
252
                    last;
 
253
                }
 
254
                $j = 0;
 
255
            }
 
256
        
 
257
            if ($strict && $i < 2) {
 
258
                # requires v1.2.3
 
259
                return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
 
260
            }
 
261
        }
 
262
    }                                   # end if dotted-decimal
 
263
    else
 
264
    {                                   # decimal versions
 
265
        # special $strict case for leading '.' or '0'
 
266
        if ($strict) {
 
267
            if ($d eq '.') {
 
268
                return BADVERSION($s,$errstr,"Invalid version format (0 before decimal required)");
 
269
            }
 
270
            if ($d eq '0' && isDIGIT($d+1)) {
 
271
                return BADVERSION($s,$errstr,"Invalid version format (no leading zeros)");
 
272
            }
 
273
        }
 
274
 
 
275
        # consume all of the integer part
 
276
        while (isDIGIT($d)) {
 
277
            $d++;
 
278
        }
 
279
 
 
280
        # look for a fractional part
 
281
        if ($d eq '.') {
 
282
            # we found it, so consume it
 
283
            $saw_decimal++;
 
284
            $d++;
 
285
        }
 
286
        elsif (!$d || $d eq ';' || isSPACE($d) || $d eq '}') {
 
287
            if ( $d == $s ) {
 
288
                # found nothing
 
289
                return BADVERSION($s,$errstr,"Invalid version format (version required)");
 
290
            }
 
291
            # found just an integer
 
292
            goto version_prescan_finish;
 
293
        }
 
294
        elsif ( $d == $s ) {
 
295
            # didn't find either integer or period
 
296
            return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)");
 
297
        }
 
298
        elsif ($d eq '_') {
 
299
            # underscore can't come after integer part
 
300
            if ($strict) {
 
301
                return BADVERSION($s,$errstr,"Invalid version format (no underscores)");
 
302
            }
 
303
            elsif (isDIGIT($d+1)) {
 
304
                return BADVERSION($s,$errstr,"Invalid version format (alpha without decimal)");
 
305
            }
 
306
            else {
 
307
                return BADVERSION($s,$errstr,"Invalid version format (misplaced underscore)");
 
308
            }
 
309
        }
 
310
        elsif ($d) {
 
311
            # anything else after integer part is just invalid data
 
312
            return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)");
 
313
        }
 
314
 
 
315
        # scan the fractional part after the decimal point
 
316
        if ($d && !isDIGIT($d) && ($strict || ! ($d eq ';' || isSPACE($d) || $d eq '}') )) {
 
317
                # $strict or lax-but-not-the-end
 
318
                return BADVERSION($s,$errstr,"Invalid version format (fractional part required)");
 
319
        }
 
320
 
 
321
        while (isDIGIT($d)) {
 
322
            $d++;
 
323
            if ($d eq '.' && isDIGIT($d-1)) {
 
324
                if ($alpha) {
 
325
                    return BADVERSION($s,$errstr,"Invalid version format (underscores before decimal)");
 
326
                }
 
327
                if ($strict) {
 
328
                    return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions must begin with 'v')");
 
329
                }
 
330
                $d = $s; # start all over again
 
331
                $qv = TRUE;
 
332
                goto dotted_decimal_version;
 
333
            }
 
334
            if ($d eq '_') {
 
335
                if ($strict) {
 
336
                    return BADVERSION($s,$errstr,"Invalid version format (no underscores)");
 
337
                }
 
338
                if ( $alpha ) {
 
339
                    return BADVERSION($s,$errstr,"Invalid version format (multiple underscores)");
 
340
                }
 
341
                if ( ! isDIGIT($d+1) ) {
 
342
                    return BADVERSION($s,$errstr,"Invalid version format (misplaced underscore)");
 
343
                }
 
344
                $d++;
 
345
                $alpha = TRUE;
 
346
            }
 
347
        }
 
348
    }
 
349
 
 
350
version_prescan_finish:
 
351
    while (isSPACE($d)) {
 
352
        $d++;
 
353
    }
 
354
 
 
355
    if ($d && !isDIGIT($d) && (! ($d eq ';' || $d eq '}') )) {
 
356
        # trailing non-numeric data
 
357
        return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)");
 
358
    }
 
359
 
 
360
    if (defined $sqv) {
 
361
        $$sqv = $qv;
 
362
    }
 
363
    if (defined $swidth) {
 
364
        $$swidth = $width;
 
365
    }
 
366
    if (defined $ssaw_decimal) {
 
367
        $$ssaw_decimal = $saw_decimal;
 
368
    }
 
369
    if (defined $salpha) {
 
370
        $$salpha = $alpha;
 
371
    }
 
372
    return $d;
 
373
}
 
374
 
 
375
sub scan_version {
 
376
    my ($s, $rv, $qv) = @_;
 
377
    my $start;
 
378
    my $pos;
 
379
    my $last;
 
380
    my $errstr;
 
381
    my $saw_decimal = 0;
 
382
    my $width = 3;
 
383
    my $alpha = FALSE;
 
384
    my $vinf = FALSE;
 
385
    my @av;
 
386
 
 
387
    $s = new charstar $s;
 
388
 
 
389
    while (isSPACE($s)) { # leading whitespace is OK
 
390
        $s++;
 
391
    }
 
392
 
 
393
    $last = prescan_version($s, FALSE, \$errstr, \$qv, \$saw_decimal,
 
394
        \$width, \$alpha);
 
395
 
 
396
    if ($errstr) {
 
397
        # 'undef' is a special case and not an error
 
398
        if ( $s ne 'undef') {
 
399
            use Carp;
 
400
            Carp::croak($errstr);
 
401
        }
 
402
    }
 
403
 
 
404
    $start = $s;
 
405
    if ($s eq 'v') {
 
406
        $s++;
 
407
    }
 
408
    $pos = $s;
 
409
 
 
410
    if ( $qv ) {
 
411
        $$rv->{qv} = $qv;
 
412
    }
 
413
    if ( $alpha ) {
 
414
        $$rv->{alpha} = $alpha;
 
415
    }
 
416
    if ( !$qv && $width < 3 ) {
 
417
        $$rv->{width} = $width;
 
418
    }
 
419
    
 
420
    while (isDIGIT($pos)) {
 
421
        $pos++;
 
422
    }
 
423
    if (!isALPHA($pos)) {
 
424
        my $rev;
 
425
 
 
426
        for (;;) {
 
427
            $rev = 0;
 
428
            {
 
429
                # this is atoi() that delimits on underscores
 
430
                my $end = $pos;
 
431
                my $mult = 1;
 
432
                my $orev;
 
433
 
 
434
                #  the following if() will only be true after the decimal
 
435
                #  point of a version originally created with a bare
 
436
                #  floating point number, i.e. not quoted in any way
 
437
                #
 
438
                if ( !$qv && $s > $start && $saw_decimal == 1 ) {
 
439
                    $mult *= 100;
 
440
                    while ( $s < $end ) {
 
441
                        $orev = $rev;
 
442
                        $rev += $s * $mult;
 
443
                        $mult /= 10;
 
444
                        if (   (abs($orev) > abs($rev)) 
 
445
                            || (abs($rev) > $VERSION_MAX )) {
 
446
                            warn("Integer overflow in version %d",
 
447
                                           $VERSION_MAX);
 
448
                            $s = $end - 1;
 
449
                            $rev = $VERSION_MAX;
 
450
                            $vinf = 1;
 
451
                        }
 
452
                        $s++;
 
453
                        if ( $s eq '_' ) {
 
454
                            $s++;
 
455
                        }
 
456
                    }
 
457
                }
 
458
                else {
 
459
                    while (--$end >= $s) {
 
460
                        $orev = $rev;
 
461
                        $rev += $end * $mult;
 
462
                        $mult *= 10;
 
463
                        if (   (abs($orev) > abs($rev)) 
 
464
                            || (abs($rev) > $VERSION_MAX )) {
 
465
                            warn("Integer overflow in version");
 
466
                            $end = $s - 1;
 
467
                            $rev = $VERSION_MAX;
 
468
                            $vinf = 1;
 
469
                        }
 
470
                    }
 
471
                } 
 
472
            }
 
473
 
 
474
            # Append revision
 
475
            push @av, $rev;
 
476
            if ( $vinf ) {
 
477
                $s = $last;
 
478
                last;
 
479
            }
 
480
            elsif ( $pos eq '.' ) {
 
481
                $s = ++$pos;
 
482
            }
 
483
            elsif ( $pos eq '_' && isDIGIT($pos+1) ) {
 
484
                $s = ++$pos;
 
485
            }
 
486
            elsif ( $pos eq ',' && isDIGIT($pos+1) ) {
 
487
                $s = ++$pos;
 
488
            }
 
489
            elsif ( isDIGIT($pos) ) {
 
490
                $s = $pos;
 
491
            }
 
492
            else {
 
493
                $s = $pos;
 
494
                last;
 
495
            }
 
496
            if ( $qv ) {
 
497
                while ( isDIGIT($pos) ) {
 
498
                    $pos++;
 
499
                }
 
500
            }
 
501
            else {
 
502
                my $digits = 0;
 
503
                while ( ( isDIGIT($pos) || $pos eq '_' ) && $digits < 3 ) {
 
504
                    if ( $pos ne '_' ) {
 
505
                        $digits++;
 
506
                    }
 
507
                    $pos++;
 
508
                }
 
509
            }
 
510
        }
 
511
    }
 
512
    if ( $qv ) { # quoted versions always get at least three terms
 
513
        my $len = $#av;
 
514
        #  This for loop appears to trigger a compiler bug on OS X, as it
 
515
        #  loops infinitely. Yes, len is negative. No, it makes no sense.
 
516
        #  Compiler in question is:
 
517
        #  gcc version 3.3 20030304 (Apple Computer, Inc. build 1640)
 
518
        #  for ( len = 2 - len; len > 0; len-- )
 
519
        #  av_push(MUTABLE_AV(sv), newSViv(0));
 
520
        # 
 
521
        $len = 2 - $len;
 
522
        while ($len-- > 0) {
 
523
            push @av, 0;
 
524
        }
 
525
    }
 
526
 
 
527
    # need to save off the current version string for later
 
528
    if ( $vinf ) {
 
529
        $$rv->{original} = "v.Inf";
 
530
        $$rv->{vinf} = 1;
 
531
    }
 
532
    elsif ( $s > $start ) {
 
533
        $$rv->{original} = $start->currstr($s);
 
534
        if ( $qv && $saw_decimal == 1 && $start ne 'v' ) {
 
535
            # need to insert a v to be consistent
 
536
            $$rv->{original} = 'v' . $$rv->{original};
 
537
        }
 
538
    }
 
539
    else {
 
540
        $$rv->{original} = '0';
 
541
        push(@av, 0);
 
542
    }
 
543
 
 
544
    # And finally, store the AV in the hash
 
545
    $$rv->{version} = \@av;
 
546
 
 
547
    # fix RT#19517 - special case 'undef' as string
 
548
    if ($s eq 'undef') {
 
549
        $s += 5;
 
550
    }
 
551
 
 
552
    return $s;
 
553
}
 
554
 
35
555
sub new
36
556
{
37
557
        my ($class, $value) = @_;
38
558
        my $self = bless ({}, ref ($class) || $class);
 
559
        my $qv = FALSE;
39
560
        
40
 
        if ( ref($value) && eval("$value->isa('version')") ) {
 
561
        if ( ref($value) && eval('$value->isa("version")') ) {
41
562
            # Can copy the elements directly
42
563
            $self->{version} = [ @{$value->{version} } ];
43
564
            $self->{qv} = 1 if $value->{qv};
46
567
            return $self;
47
568
        }
48
569
 
49
 
        require POSIX;
50
 
        my $currlocale = POSIX::setlocale(&POSIX::LC_ALL);
51
 
        my $radix_comma = ( POSIX::localeconv()->{decimal_point} eq ',' );
 
570
        my $currlocale = setlocale(LC_ALL);
 
571
 
 
572
        # if the current locale uses commas for decimal points, we
 
573
        # just replace commas with decimal places, rather than changing
 
574
        # locales
 
575
        if ( localeconv()->{decimal_point} eq ',' ) {
 
576
            $value =~ tr/,/./;
 
577
        }
52
578
 
53
579
        if ( not defined $value or $value =~ /^undef$/ ) {
54
580
            # RT #19517 - special case for undef comparison
59
585
        }
60
586
 
61
587
        if ( $#_ == 2 ) { # must be CVS-style
62
 
            $value = 'v'.$_[2];
 
588
            $value = $_[2];
 
589
            $qv = TRUE;
63
590
        }
64
591
 
65
592
        $value = _un_vstring($value);
66
593
 
67
594
        # exponential notation
68
 
        if ( $value =~ /\d+.?\d*e-?\d+/ ) {
 
595
        if ( $value =~ /\d+.?\d*e[-+]?\d+/ ) {
69
596
            $value = sprintf("%.9f",$value);
70
 
            $value =~ s/(0+)$//;
 
597
            $value =~ s/(0+)$//; # trim trailing zeros
71
598
        }
72
599
        
73
 
        # if the original locale used commas for decimal points, we
74
 
        # just replace commas with decimal places, rather than changing
75
 
        # locales
76
 
        if ( $radix_comma ) {
77
 
            $value =~ tr/,/./;
78
 
        }
79
 
 
80
 
        # This is not very efficient, but it is morally equivalent
81
 
        # to the XS code (as that is the reference implementation).
82
 
        # See vutil/vutil.c for details
83
 
        my $qv = 0;
84
 
        my $alpha = 0;
85
 
        my $width = 3;
86
 
        my $saw_period = 0;
87
 
        my $vinf = 0;
88
 
        my ($start, $last, $pos, $s);
89
 
        $s = 0;
90
 
 
91
 
        while ( substr($value,$s,1) =~ /\s/ ) { # leading whitespace is OK
92
 
            $s++;
93
 
        }
94
 
 
95
 
        if (substr($value,$s,1) eq 'v') {
96
 
            $s++;    # get past 'v'
97
 
            $qv = 1; # force quoted version processing
98
 
        }
99
 
 
100
 
        $start = $last = $pos = $s;
101
 
                
102
 
        # pre-scan the input string to check for decimals/underbars
103
 
        while ( substr($value,$pos,1) =~ /[._\d]/ ) {
104
 
            if ( substr($value,$pos,1) eq '.' ) {
105
 
                if ($alpha) {
106
 
                    Carp::croak("Invalid version format ".
107
 
                      "(underscores before decimal)");
108
 
                }
109
 
                $saw_period++;
110
 
                $last = $pos;
111
 
            }
112
 
            elsif ( substr($value,$pos,1) eq '_' ) {
113
 
                if ($alpha) {
114
 
                    require Carp;
115
 
                    Carp::croak("Invalid version format ".
116
 
                        "(multiple underscores)");
117
 
                }
118
 
                $alpha = 1;
119
 
                $width = $pos - $last - 1; # natural width of sub-version
120
 
            }
121
 
            $pos++;
122
 
        }
123
 
 
124
 
        if ( $alpha && !$saw_period ) {
125
 
            require Carp;
126
 
            Carp::croak("Invalid version format ".
127
 
                "(alpha without decimal)");
128
 
        }
129
 
 
130
 
        if ( $alpha && $saw_period && $width == 0 ) {
131
 
            require Carp;
132
 
            Carp::croak("Invalid version format ".
133
 
                "(misplaced _ in number)");
134
 
        }
135
 
 
136
 
        if ( $saw_period > 1 ) {
137
 
            $qv = 1; # force quoted version processing
138
 
        }
139
 
 
140
 
        $last = $pos;
141
 
        $pos = $s;
142
 
 
143
 
        if ( $qv ) {
144
 
            $self->{qv} = 1;
145
 
        }
146
 
 
147
 
        if ( $alpha ) {
148
 
            $self->{alpha} = 1;
149
 
        }
150
 
 
151
 
        if ( !$qv && $width < 3 ) {
152
 
            $self->{width} = $width;
153
 
        }
154
 
 
155
 
        while ( substr($value,$pos,1) =~ /\d/ ) {
156
 
            $pos++;
157
 
        }
158
 
 
159
 
        if ( substr($value,$pos,1) !~ /[a-z]/ ) { ### FIX THIS ###
160
 
            my $rev;
161
 
 
162
 
            while (1) {
163
 
                $rev = 0;
164
 
                {
165
 
 
166
 
                    # this is atoi() that delimits on underscores
167
 
                    my $end = $pos;
168
 
                    my $mult = 1;
169
 
                    my $orev;
170
 
 
171
 
                    # the following if() will only be true after the decimal
172
 
                    # point of a version originally created with a bare
173
 
                    # floating point number, i.e. not quoted in any way
174
 
                    if ( !$qv && $s > $start && $saw_period == 1 ) {
175
 
                        $mult *= 100;
176
 
                        while ( $s < $end ) {
177
 
                            $orev = $rev;
178
 
                            $rev += substr($value,$s,1) * $mult;
179
 
                            $mult /= 10;
180
 
                            if (   abs($orev) > abs($rev) 
181
 
                                || abs($rev) > abs($VERSION_MAX) ) {
182
 
                                if ( warnings::enabled("overflow") ) {
183
 
                                    require Carp;
184
 
                                    Carp::carp("Integer overflow in version");
185
 
                                }
186
 
                                $s = $end - 1;
187
 
                                $rev = $VERSION_MAX;
188
 
                            }
189
 
                            $s++;
190
 
                            if ( substr($value,$s,1) eq '_' ) {
191
 
                                $s++;
192
 
                            }
193
 
                        }
194
 
                    }
195
 
                    else {
196
 
                        while (--$end >= $s) {
197
 
                            $orev = $rev;
198
 
                            $rev += substr($value,$end,1) * $mult;
199
 
                            $mult *= 10;
200
 
                            if (   abs($orev) > abs($rev) 
201
 
                                || abs($rev) > abs($VERSION_MAX) ) {
202
 
                                if ( warnings::enabled("overflow") ) {
203
 
                                    require Carp;
204
 
                                    Carp::carp("Integer overflow in version");
205
 
                                }
206
 
                                $end = $s - 1;
207
 
                                $rev = $VERSION_MAX;
208
 
                            }
209
 
                        }
210
 
                    }
211
 
                }
212
 
 
213
 
                # Append revision
214
 
                push @{$self->{version}}, $rev;
215
 
                if ( substr($value,$pos,1) eq '.' 
216
 
                    && substr($value,$pos+1,1) =~ /\d/ ) {
217
 
                    $s = ++$pos;
218
 
                }
219
 
                elsif ( substr($value,$pos,1) eq '_' 
220
 
                    && substr($value,$pos+1,1) =~ /\d/ ) {
221
 
                    $s = ++$pos;
222
 
                }
223
 
                elsif ( substr($value,$pos,1) =~ /\d/ ) {
224
 
                    $s = $pos;
225
 
                }
226
 
                else {
227
 
                    $s = $pos;
228
 
                    last;
229
 
                }
230
 
                if ( $qv ) {
231
 
                    while ( substr($value,$pos,1) =~ /\d/ ) {
232
 
                        $pos++;
233
 
                    }
234
 
                }
235
 
                else {
236
 
                    my $digits = 0;
237
 
                    while (substr($value,$pos,1) =~ /[\d_]/ && $digits < 3) {
238
 
                        if ( substr($value,$pos,1) ne '_' ) {
239
 
                            $digits++;
240
 
                        }
241
 
                        $pos++;
242
 
                    }
243
 
                }
244
 
            }
245
 
        }
246
 
        if ( $qv ) { # quoted versions always get at least three terms
247
 
            my $len = scalar @{$self->{version}};
248
 
            $len = 3 - $len;
249
 
            while ($len-- > 0) {
250
 
                push @{$self->{version}}, 0;
251
 
            }
252
 
        }
253
 
 
254
 
        if ( substr($value,$pos) ) { # any remaining text
255
 
            if ( warnings::enabled("misc") ) {
256
 
                require Carp;
257
 
                Carp::carp("Version string '$value' contains invalid data; ".
258
 
                     "ignoring: '".substr($value,$pos)."'");
259
 
            }
260
 
        }
261
 
 
262
 
        # cache the original value for use when stringification
263
 
        if ( $vinf ) {
264
 
            $self->{vinf} = 1;
265
 
            $self->{original} = 'v.Inf';
266
 
        }
267
 
        else {
268
 
            $self->{original} = substr($value,0,$pos);
 
600
        my $s = scan_version($value, \$self, $qv);
 
601
 
 
602
        if ($s) { # must be something left over
 
603
            warn("Version string '%s' contains invalid data; "
 
604
                       ."ignoring: '%s'", $value, $s);
269
605
        }
270
606
 
271
607
        return ($self);
272
608
}
273
609
 
 
610
*parse = \&new;
 
611
 
274
612
sub numify 
275
613
{
276
614
    my ($self) = @_;
355
693
        require Carp;
356
694
        Carp::croak("Invalid version object");
357
695
    }
358
 
    return $self->{original};
 
696
    return exists $self->{original} 
 
697
        ? $self->{original} 
 
698
        : exists $self->{qv} 
 
699
            ? $self->normal
 
700
            : $self->numify;
359
701
}
360
702
 
361
703
sub vcmp
443
785
}
444
786
 
445
787
sub qv {
446
 
    my ($value) = @_;
 
788
    my $value = shift;
 
789
    my $class = 'version';
 
790
    if (@_) {
 
791
        $class = ref($value) || $value;
 
792
        $value = shift;
 
793
    }
447
794
 
448
795
    $value = _un_vstring($value);
449
796
    $value = 'v'.$value unless $value =~ /(^v|\d+\.\d+\.\d)/;
450
 
    my $version = version->new($value); # always use base class
 
797
    my $version = $class->new($value);
451
798
    return $version;
452
799
}
453
800
 
 
801
*declare = \&qv;
 
802
 
454
803
sub is_qv {
455
804
    my ($self) = @_;
456
805
    return (exists $self->{qv});
473
822
sub _un_vstring {
474
823
    my $value = shift;
475
824
    # may be a v-string
476
 
    if ( $] >= 5.006_000 && length($value) >= 3 && $value !~ /[._]/ ) {
477
 
        my $tvalue = sprintf("v%vd",$value);
478
 
        if ( $tvalue =~ /^v\d+\.\d+\.\d+$/ ) {
479
 
            # must be a v-string
480
 
            $value = $tvalue;
 
825
    if ( $] >= 5.006_000 && length($value) >= 3 && $value !~ /[._]/) {
 
826
        foreach my $char (split(//,$value)) {
 
827
            # if one of the characters is non-text assume v-string
 
828
            if (ord($char) < ord(" ")) {
 
829
                my $tvalue = sprintf("v%vd",$value);
 
830
                if ( $tvalue =~ /^v\d+(\.\d+){2,}$/ ) {
 
831
                    # must be a v-string
 
832
                    $value = $tvalue;
 
833
                }
 
834
                last;
 
835
            }
481
836
        }
482
837
    }
483
838
    return $value;
484
839
}
485
840
 
486
 
# Thanks to Yitzchak Scott-Thoennes for this mode of operation
487
 
{
488
 
    local $^W;
489
 
    *UNIVERSAL::VERSION = sub {
490
 
        my ($obj, $req) = @_;
491
 
        my $class = ref($obj) || $obj;
492
 
 
493
 
        no strict 'refs';
494
 
        eval "require $class" unless %{"$class\::"}; # already existing
495
 
        return undef if $@ =~ /Can't locate/ and not defined $req;
496
 
        
497
 
        if ( not %{"$class\::"} and $] >= 5.008) { # file but no package
498
 
            require Carp;
499
 
            Carp::croak( "$class defines neither package nor VERSION"
500
 
                ."--version check failed");
501
 
        }
502
 
        
503
 
        my $version = eval "\$$class\::VERSION";
504
 
        if ( defined $version ) {
505
 
            local $^W if $] <= 5.008;
506
 
            $version = version::vpp->new($version);
507
 
        }
508
 
 
509
 
        if ( defined $req ) {
510
 
            unless ( defined $version ) {
511
 
                require Carp;
512
 
                my $msg =  $] < 5.006 
513
 
                ? "$class version $req required--this is only version "
514
 
                : "$class does not define \$$class\::VERSION"
515
 
                  ."--version check failed";
516
 
 
517
 
                if ( $ENV{VERSION_DEBUG} ) {
518
 
                    Carp::confess($msg);
519
 
                }
520
 
                else {
521
 
                    Carp::croak($msg);
522
 
                }
523
 
            }
524
 
 
525
 
            $req = version::vpp->new($req);
526
 
 
527
 
            if ( $req > $version ) {
528
 
                require Carp;
529
 
                if ( $req->is_qv ) {
530
 
                    Carp::croak( 
531
 
                        sprintf ("%s version %s required--".
532
 
                            "this is only version %s", $class,
533
 
                            $req->normal, $version->normal)
534
 
                    );
535
 
                }
536
 
                else {
537
 
                    Carp::croak( 
538
 
                        sprintf ("%s version %s required--".
539
 
                            "this is only version %s", $class,
540
 
                            $req->stringify, $version->stringify)
541
 
                    );
542
 
                }
543
 
            }
544
 
        }
545
 
 
546
 
        return defined $version ? $version->stringify : undef;
547
 
    };
 
841
sub _VERSION {
 
842
    my ($obj, $req) = @_;
 
843
    my $class = ref($obj) || $obj;
 
844
 
 
845
    no strict 'refs';
 
846
    if ( exists $INC{"$class.pm"} and not %{"$class\::"} and $] >= 5.008) {
 
847
         # file but no package
 
848
        require Carp;
 
849
        Carp::croak( "$class defines neither package nor VERSION"
 
850
            ."--version check failed");
 
851
    }
 
852
 
 
853
    my $version = eval "\$$class\::VERSION";
 
854
    if ( defined $version ) {
 
855
        local $^W if $] <= 5.008;
 
856
        $version = version::vpp->new($version);
 
857
    }
 
858
 
 
859
    if ( defined $req ) {
 
860
        unless ( defined $version ) {
 
861
            require Carp;
 
862
            my $msg =  $] < 5.006 
 
863
            ? "$class version $req required--this is only version "
 
864
            : "$class does not define \$$class\::VERSION"
 
865
              ."--version check failed";
 
866
 
 
867
            if ( $ENV{VERSION_DEBUG} ) {
 
868
                Carp::confess($msg);
 
869
            }
 
870
            else {
 
871
                Carp::croak($msg);
 
872
            }
 
873
        }
 
874
 
 
875
        $req = version::vpp->new($req);
 
876
 
 
877
        if ( $req > $version ) {
 
878
            require Carp;
 
879
            if ( $req->is_qv ) {
 
880
                Carp::croak( 
 
881
                    sprintf ("%s version %s required--".
 
882
                        "this is only version %s", $class,
 
883
                        $req->normal, $version->normal)
 
884
                );
 
885
            }
 
886
            else {
 
887
                Carp::croak( 
 
888
                    sprintf ("%s version %s required--".
 
889
                        "this is only version %s", $class,
 
890
                        $req->stringify, $version->stringify)
 
891
                );
 
892
            }
 
893
        }
 
894
    }
 
895
 
 
896
    return defined $version ? $version->stringify : undef;
548
897
}
549
898
 
550
899
1; #this line is important and will help the module return a true value