1# These are tools that must be included in ppport.h.  It doesn't work if given
2# a .pl suffix.
3#
4# WARNING: Use only constructs that are legal as far back as D:P handles, as
5# this is run in the perl version being tested.
6
7# What revisions are legal, to be output as-is and converted into a pattern
8# that matches them precisely
9my $r_pat = "[57]";
10
11sub format_version
12{
13  # Given an input version that is acceptable to parse_version(), return a
14  # string of the standard representation of it.
15
16  my($r,$v,$s) = parse_version(shift);
17
18  if ($r < 5 || ($r == 5 && $v < 6)) {
19    my $ver = sprintf "%d.%03d", $r, $v;
20    $s > 0 and $ver .= sprintf "_%02d", $s;
21
22    return $ver;
23  }
24
25  return sprintf "%d.%d.%d", $r, $v, $s;
26}
27
28sub parse_version
29{
30  # Returns a triplet, (revision, major, minor) from the input, treated as a
31  # string, which can be in any of several typical formats.
32
33  my $ver = shift;
34  $ver = "" unless defined $ver;
35
36  my($r,$v,$s);
37
38  if (   ($r, $v, $s) = $ver =~ /^([0-9]+)([0-9]{3})([0-9]{3})$/ # 5029010, from the file
39                                                      # names in our
40                                                      # parts/base/ and
41                                                      # parts/todo directories
42      or ($r, $v, $s) = $ver =~ /^([0-9]+)\.([0-9]+)\.([0-9]+)$/  # 5.25.7
43      or ($r, $v, $s) = $ver =~ /^([0-9]+)\.([0-9]{3})([0-9]{3})$/ # 5.025008, from the
44                                                           # output of $]
45      or ($r, $v, $s) = $ver =~ /^([0-9]+)\.([0-9]{1,3})()$/    # 5.24, 5.004
46      or ($r, $v, $s) = $ver =~ /^([0-9]+)\.(00[1-5])_?([0-9]{2})$/ # 5.003_07
47  ) {
48
49    $s = 0 unless $s;
50
51    die "Only Perl $r_pat are supported '$ver'\n" unless $r =~ / ^ $r_pat $ /x;
52    die "Invalid version number: $ver\n" if $v >= 1000 || $s >= 1000;
53    return (0 +$r, 0 + $v, 0 + $s);
54  }
55
56  # For some safety, don't assume something is a version number if it has a
57  # literal dot as one of the three characters.  This will have to be fixed
58  # when we reach x.46 (since 46 is ord('.'))
59  if ($ver !~ /\./ && (($r, $v, $s) = $ver =~ /^(.)(.)(.)$/))  # vstring 5.25.7
60  {
61    $r = ord $r;
62    $v = ord $v;
63    $s = ord $s;
64
65    die "Only Perl $r_pat are supported '$ver'\n" unless $r =~ / ^ $r_pat $ /x;
66    return ($r, $v, $s);
67  }
68
69  my $mesg = "";
70  $mesg = ".  (In 5.00x_yz, x must be 1-5.)" if $ver =~ /_/;
71  die "Invalid version number format: '$ver'$mesg\n";
72}
73
74sub int_parse_version
75{
76    # Returns integer 7 digit human-readable version, suitable for use in file
77    # names in parts/todo parts/base.
78
79    return 0 + join "", map { sprintf("%03d", $_) } parse_version(shift);
80}
81
82sub ivers    # Shorter name for int_parse_version
83{
84    return int_parse_version(shift);
85}
86
87sub format_version_line
88{
89    # Returns a floating point representation of the input version
90
91    my $version = int_parse_version(shift);
92    $version =~ s/ ^  ( $r_pat ) \B /$1./x;
93    return $version;
94}
95
96BEGIN {
97  if ("$]" < "5.006" ) {
98    # On early perls, the implicit pass by reference doesn't work, so we have
99    # to use the globals to initialize.
100    eval q[sub dictionary_order($$) { _dictionary_order($a, $b) } ];
101  } elsif ("$]" < "5.022" ) {
102    eval q[sub dictionary_order($$) { _dictionary_order(@_) } ];
103  } else {
104    eval q[sub dictionary_order :prototype($$) { _dictionary_order(@_) } ];
105  }
106}
107
108sub _dictionary_order { # Sort caselessly, ignoring punct
109    my ($valid_a, $valid_b) = @_;
110
111    my ($lc_a, $lc_b);
112    my ($squeezed_a, $squeezed_b);
113
114    $valid_a = '' unless defined $valid_a;
115    $valid_b = '' unless defined $valid_b;
116
117    $lc_a = lc $valid_a;
118    $lc_b = lc $valid_b;
119
120    $squeezed_a = $lc_a;
121    $squeezed_a =~ s/^_+//g;    # No leading underscores
122    $squeezed_a =~ s/\B_+\B//g; # No connecting underscores
123    $squeezed_a =~ s/[\W]//g;   # No punct
124
125    $squeezed_b = $lc_b;
126    $squeezed_b =~ s/^_+//g;
127    $squeezed_b =~ s/\B_+\B//g;
128    $squeezed_b =~ s/[\W]//g;
129
130    return( $squeezed_a cmp $squeezed_b
131         or       $lc_a cmp $lc_b
132         or    $valid_a cmp $valid_b);
133}
134
135sub sort_api_lines  # Sort lines of the form flags|return|name|args...
136                    # by 'name'
137{
138    $a =~ / ^ [^|]* \| [^|]* \| ( [^|]* ) /x; # 3rd field '|' is sep
139    my $a_name = $1;
140    $b =~ / ^ [^|]* \| [^|]* \| ( [^|]* ) /x;
141    my $b_name = $1;
142    return dictionary_order($a_name, $b_name);
143}
144
1451;
146