This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
parts/inc/parse_version: Call fcn to not duplicate logic
[perl5.git] / dist / Devel-PPPort / parts / inc / inctools
1 # These are tools that must be included in ppport.h.  It doesn't work if given
2 # a .pl suffix
3
4 sub format_version
5 {
6   # Given an input version that is acceptable to parse_version(), return a
7   # string of the standard representation of it.
8
9   my($r,$v,$s) = parse_version(shift);
10
11   if ($r < 5 || ($r == 5 && $v < 6)) {
12     my $ver = sprintf "%d.%03d", $r, $v;
13     $s > 0 and $ver .= sprintf "_%02d", $s;
14
15     return $ver;
16   }
17
18   return sprintf "%d.%d.%d", $r, $v, $s;
19 }
20
21 sub parse_version
22 {
23   my $ver = shift;
24
25   if ($ver =~ /^(\d+)\.(\d+)\.(\d+)$/) {
26     return ($1, $2, $3);
27   }
28   elsif ($ver !~ /^\d+\.\d{3}(?:_\d{2})?$/) {
29     die "cannot parse version '$ver'\n";
30   }
31
32   $ver =~ s/_//g;
33   $ver =~ s/$/000000/;
34
35   my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/;
36
37   $v = int $v;
38   $s = int $s;
39
40   if ($r < 5 || ($r == 5 && $v < 6)) {
41     if ($s % 10) {
42       die "cannot parse version '$ver'\n";
43     }
44     $s /= 10;
45   }
46
47   return ($r, $v, $s);
48 }
49
50 sub dictionary_order($$)    # Sort caselessly, ignoring punct
51 {
52     my ($lc_a, $lc_b);
53     my ($squeezed_a, $squeezed_b);
54     my ($valid_a, $valid_b);    # Meaning valid for all releases
55
56     # On early perls, the implicit pass by reference doesn't work, so we have
57     # to use the globals to initialize.
58     if ("$]" < "5.006" ) {
59         $valid_a = $a; $valid_b = $b;
60     }
61     else {
62         ($valid_a, $valid_b) = @_;
63     }
64
65     $lc_a = lc $valid_a;
66     $lc_b = lc $valid_b;
67
68     $squeezed_a = $lc_a;
69     $squeezed_a =~ s/[\W_]//g;   # No punct, including no underscore
70     $squeezed_b = $lc_b;
71     $squeezed_b =~ s/[\W_]//g;
72
73     return( $squeezed_a cmp $squeezed_b
74          or       $lc_a cmp $lc_b
75          or    $valid_a cmp $valid_b);
76 }
77
78 1;