Update Devel-PPPort to match 3.67

[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.
#
# WARNING: Use only constructs that are legal as far back as D:P handles, as
# this is run in the perl version being tested.

# What revisions are legal, to be output as-is and converted into a pattern
# that matches them precisely
my $r_pat = "[57]";

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, (revision, major, minor) from the input, treated as a
  # string, 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 =~ /^([0-9]+)([0-9]{3})([0-9]{3})$/ # 5029010, from the file
                                                      # names in our
                                                      # parts/base/ and
                                                      # parts/todo directories
      or ($r, $v, $s) = $ver =~ /^([0-9]+)\.([0-9]+)\.([0-9]+)$/  # 5.25.7
      or ($r, $v, $s) = $ver =~ /^([0-9]+)\.([0-9]{3})([0-9]{3})$/ # 5.025008, from the
                                                           # output of $]
      or ($r, $v, $s) = $ver =~ /^([0-9]+)\.([0-9]{1,3})()$/    # 5.24, 5.004
      or ($r, $v, $s) = $ver =~ /^([0-9]+)\.(00[1-5])_?([0-9]{2})$/ # 5.003_07
  ) {

    $s = 0 unless $s;

    die "Only Perl $r_pat are supported '$ver'\n" unless $r =~ / ^ $r_pat $ /x;
    die "Invalid version number: $ver\n" if $v >= 1000 || $s >= 1000;
    return (0 +$r, 0 + $v, 0 + $s);
  }

  # For some safety, don't assume something is a version number if it has a
  # literal dot as one of the three characters.  This will have to be fixed
  # when we reach x.46 (since 46 is ord('.'))
  if ($ver !~ /\./ && (($r, $v, $s) = $ver =~ /^(.)(.)(.)$/))  # vstring 5.25.7
  {
    $r = ord $r;
    $v = ord $v;
    $s = ord $s;

    die "Only Perl $r_pat are supported '$ver'\n" unless $r =~ / ^ $r_pat $ /x;
    return ($r, $v, $s);
  }

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

sub int_parse_version
{
    # Returns integer 7 digit human-readable version, suitable for use in file
    # names in parts/todo parts/base.

    return 0 + join "", map { sprintf("%03d", $_) } parse_version(shift);
}

sub ivers    # Shorter name for int_parse_version
{
    return int_parse_version(shift);
}

sub format_version_line
{
    # Returns a floating point representation of the input version

    my $version = int_parse_version(shift);
    $version =~ s/ ^  ( $r_pat ) \B /$1./x;
    return $version;
}

BEGIN {
  if ("$]" < "5.006" ) {
    # On early perls, the implicit pass by reference doesn't work, so we have
    # to use the globals to initialize.
    eval q[sub dictionary_order($$) { _dictionary_order($a, $b) } ];
  } elsif ("$]" < "5.022" ) {
    eval q[sub dictionary_order($$) { _dictionary_order(@_) } ];
  } else {
    eval q[sub dictionary_order :prototype($$) { _dictionary_order(@_) } ];
  }
}

sub _dictionary_order { # Sort caselessly, ignoring punct
    my ($valid_a, $valid_b) = @_;

    my ($lc_a, $lc_b);
    my ($squeezed_a, $squeezed_b);

    $valid_a = '' unless defined $valid_a;
    $valid_b = '' unless defined $valid_b;

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

    $squeezed_a = $lc_a;
    $squeezed_a =~ s/^_+//g;    # No leading underscores
    $squeezed_a =~ s/\B_+\B//g; # No connecting underscores
    $squeezed_a =~ s/[\W]//g;   # No punct

    $squeezed_b = $lc_b;
    $squeezed_b =~ s/^_+//g;
    $squeezed_b =~ s/\B_+\B//g;
    $squeezed_b =~ s/[\W]//g;

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

sub sort_api_lines  # Sort lines of the form flags|return|name|args...
                    # by 'name'
{
    $a =~ / ^ [^|]* \| [^|]* \| ( [^|]* ) /x; # 3rd field '|' is sep
    my $a_name = $1;
    $b =~ / ^ [^|]* \| [^|]* \| ( [^|]* ) /x;
    my $b_name = $1;
    return dictionary_order($a_name, $b_name);
}

1;