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;