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   # Returns a triplet, (5, major, minor) from the input, which can be in any
  24   # of several typical formats
  25
  26   my $ver = shift;
  27   $ver = "" unless defined $ver;
  28
  29   my($r,$v,$s);
  30
  31   if (   ($r, $v, $s) = $ver =~ /^(5)(\d{3})(\d{3})$/ # 5029010, from the file
  32                                                       # names in our
  33                                                       # parts/base/ and
  34                                                       # parts/todo directories
  35       or ($r, $v, $s) = $ver =~ /^(\d+)\.(\d+)\.(\d+)$/   # 5.25.7
  36       or ($r, $v, $s) = $ver =~ /^(\d+)\.(\d{3})(\d{3})$/ # 5.025008, from the
  37                                                           # output of $]
  38       or ($r, $v, $s) = $ver =~ /^(\d+)\.(\d{1,3})()$/    # 5.24, 5.004
  39       or ($r, $v, $s) = $ver =~ /^(\d+)\.(00[1-5])_?(\d{2})$/  # 5.003_07
  40   ) {
  41
  42     $s = 0 unless $s;
  43
  44     die "Only Perl 5 is supported '$ver'\n" if $r != 5;
  45     die "Invalid version number: $ver\n" if $v >= 1000 || $s >= 1000;
  46     return (5, 0 + $v, 0 + $s);
  47   }
  48
  49   my $mesg = "";
  50   $mesg = ".  (In 5.00x_yz, x must be 1-5.)" if $ver =~ /_/;
  51   die "Invalid version number format: '$ver'$mesg\n";
  52 }
  53
  54 sub int_parse_version
  55 {
  56     # Returns integer 7 digit human-readable version, suitable for use in file
  57     # names in parts/todo parts/base.
  58
  59     return 0 + join "", map { sprintf("%03d", $_) } parse_version(shift);
  60
  61 }
  62
  63 sub dictionary_order($$)    # Sort caselessly, ignoring punct
  64 {
  65     my ($lc_a, $lc_b);
  66     my ($squeezed_a, $squeezed_b);
  67     my ($valid_a, $valid_b);    # Meaning valid for all releases
  68
  69     # On early perls, the implicit pass by reference doesn't work, so we have
  70     # to use the globals to initialize.
  71     if ("$]" < "5.006" ) {
  72         $valid_a = $a; $valid_b = $b;
  73     }
  74     else {
  75         ($valid_a, $valid_b) = @_;
  76     }
  77
  78     $lc_a = lc $valid_a;
  79     $lc_b = lc $valid_b;
  80
  81     $squeezed_a = $lc_a;
  82     $squeezed_a =~ s/[\W_]//g;   # No punct, including no underscore
  83     $squeezed_b = $lc_b;
  84     $squeezed_b =~ s/[\W_]//g;
  85
  86     return( $squeezed_a cmp $squeezed_b
  87          or       $lc_a cmp $lc_b
  88          or    $valid_a cmp $valid_b);
  89 }
  90
  91 sub sort_api_lines  # Sort lines of the form flags|return|name|args...
  92                     # by 'name'
  93 {
  94     $a =~ / ^ [^|]* \| [^|]* \| (\w+) /x; # 3rd field '|' is sep
  95     my $a_name = $1;
  96     $b =~ / ^ [^|]* \| [^|]* \| (\w+) /x;
  97     my $b_name = $1;
  98     return dictionary_order($a_name, $b_name);
  99 }
 100
 101 1;