parts/inc/inctools: Rewrite parse_version

[perl5.git] / dist / Devel-PPPort / parts / inc / inctools

# These are tools that must be included in ppport.h.  It doesn't work if given
# a .pl suffix

sub format_version
{
  # Given an input version that is acceptable to parse_version(), return a
  # string of the standard representation of it.

  my($r,$v,$s) = parse_version(shift);

  if ($r < 5 || ($r == 5 && $v < 6)) {
    my $ver = sprintf "%d.%03d", $r, $v;
    $s > 0 and $ver .= sprintf "_%02d", $s;

    return $ver;
  }

  return sprintf "%d.%d.%d", $r, $v, $s;
}

sub parse_version
{
  # Returns a triplet, (5, major, minor) from the input, which can be in any
  # of several typical formats

  my $ver = shift;
  $ver = "" unless defined $ver;

  my($r,$v,$s);

  if (   ($r, $v, $s) = $ver =~ /^(5)(\d{3})(\d{3})$/ # 5029010, from the file
                                                      # names in our
                                                      # parts/base/ and
                                                      # parts/todo directories
      or ($r, $v, $s) = $ver =~ /^(\d+)\.(\d+)\.(\d+)$/   # 5.25.7
      or ($r, $v, $s) = $ver =~ /^(\d+)\.(\d{3})(\d{3})$/ # 5.025008, from the
                                                          # output of $]
      or ($r, $v, $s) = $ver =~ /^(\d+)\.(\d{1,3})()$/    # 5.24, 5.004
      or ($r, $v, $s) = $ver =~ /^(\d+)\.(00[1-5])_?(\d{2})$/  # 5.003_07
  ) {

    $s = 0 unless $s;

    die "Only Perl 5 is supported '$ver'\n" if $r != 5;
    die "Invalid version number: $ver\n" if $v >= 1000 || $s >= 1000;
    return (5, 0 + $v, 0 + $s);
  }

  my $mesg = "";
  $mesg = ".  (In 5.00x_yz, x must be 1-5.)" if $ver =~ /_/;
  die "Invalid version number format: '$ver'$mesg\n";
}



}

sub dictionary_order($$)    # Sort caselessly, ignoring punct
{
    my ($lc_a, $lc_b);
    my ($squeezed_a, $squeezed_b);
    my ($valid_a, $valid_b);    # Meaning valid for all releases

    # On early perls, the implicit pass by reference doesn't work, so we have
    # to use the globals to initialize.
    if ("$]" < "5.006" ) {
        $valid_a = $a; $valid_b = $b;
    }
    else {
        ($valid_a, $valid_b) = @_;
    }

    $lc_a = lc $valid_a;
    $lc_b = lc $valid_b;

    $squeezed_a = $lc_a;
    $squeezed_a =~ s/[\W_]//g;   # No punct, including no underscore
    $squeezed_b = $lc_b;
    $squeezed_b =~ s/[\W_]//g;

    return( $squeezed_a cmp $squeezed_b
         or       $lc_a cmp $lc_b
         or    $valid_a cmp $valid_b);
}

1;