#!/usr/bin/perl -w
#
# Regenerate (overwriting only if changed):
#
# overload.h
# overload.c
# lib/overload/numbers.pm
#
# from information stored in the DATA section of this file.
#
# This allows the order of overloading constants to be changed.
#
# Accepts the standard regen_lib -q and -v args.
#
# This script is normally invoked from regen.pl.
BEGIN {
# Get function prototypes
require 'regen_lib.pl';
}
use strict;
use File::Spec::Functions qw(catdir catfile);;
my (@enums, @names);
while (<DATA>) {
next if /^#/;
next if /^$/;
my ($enum, $name) = /^(\S+)\s+(\S+)/ or die "Can't parse $_";
push @enums, $enum;
push @names, $name;
}
safer_unlink (catfile(qw(lib overload numbers.pm)));
my $c = safer_open("overload.c-new");
my $h = safer_open("overload.h-new");
mkdir("lib/overload") unless -d catdir(qw(lib overload));
my $p = safer_open(catfile(qw(lib overload numbers.pm)));
select $p;
{
local $" = "\n ";
print <<"EOF";
# -*- buffer-read-only: t -*-
#
# lib/overload/numbers.pm
#
# Copyright (C) 2008 by Larry Wall and others
#
# You may distribute under the terms of either the GNU General Public
# License or the Artistic License, as specified in the README file.
#
# !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
# This file is built by overload.pl
#
package overload::numbers;
our \@names = qw#
@names
#;
our \@enums = qw#
@enums
#;
{ my \$i = 0; our %names = map { \$_ => \$i++ } \@names }
{ my \$i = 0; our %enums = map { \$_ => \$i++ } \@enums }
EOF
}
sub print_header {
my $file = shift;
print <<"EOF";
/* -*- buffer-read-only: t -*-
*
* $file
*
* Copyright (C) 1997, 1998, 2000, 2001, 2005, 2006, 2007 by Larry Wall
* and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
*
* !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
* This file is built by overload.pl
*/
EOF
}
select $c;
print_header('overload.c');
select $h;
print_header('overload.h');
print <<'EOF';
enum {
EOF
print " ${_}_amg,\n", foreach @enums;
print <<'EOF';
max_amg_code
/* Do not leave a trailing comma here. C9X allows it, C89 doesn't. */
};
#define NofAMmeth max_amg_code
EOF
print $c <<'EOF';
#define AMG_id2name(id) (PL_AMG_names[id]+1)
#define AMG_id2namelen(id) (PL_AMG_namelens[id]-1)
static const U8 PL_AMG_namelens[NofAMmeth] = {
EOF
my $last = pop @names;
print $c " $_,\n" foreach map { length $_ } @names;
my $lastlen = length $last;
print $c <<"EOT";
$lastlen
};
static const char * const PL_AMG_names[NofAMmeth] = {
/* Names kept in the symbol table. fallback => "()", the rest has
"(" prepended. The only other place in perl which knows about
this convention is AMG_id2name (used for debugging output and
'nomethod' only), the only other place which has it hardwired is
overload.pm. */
EOT
print $c " \"$_\",\n" foreach map { s/(["\\"])/\\$1/g; $_ } @names;
print $c <<"EOT";
"$last"
};
EOT
safer_close($h);
safer_close($c);
safer_close($p);
rename_if_different("overload.c-new", "overload.c");
rename_if_different("overload.h-new","overload.h");
__DATA__
# Fallback should be the first
fallback ()
# These 5 are the most common in the fallback switch statement in amagic_call
to_sv (${}
to_av (@{}
to_hv (%{}
to_gv (*{}
to_cv (&{}
# These have non-default cases in that switch statement
inc (++
dec (--
bool_ (bool
numer (0+
string (""
not (!
copy (=
abs (abs
neg (neg
iter (<>
int (int
# These 12 feature in the next switch statement
lt (<
le (<=
gt (>
ge (>=
eq (==
ne (!=
slt (lt
sle (le
sgt (gt
sge (ge
seq (eq
sne (ne
nomethod (nomethod
add (+
add_ass (+=
subtr (-
subtr_ass (-=
mult (*
mult_ass (*=
div (/
div_ass (/=
modulo (%
modulo_ass (%=
pow (**
pow_ass (**=
lshift (<<
lshift_ass (<<=
rshift (>>
rshift_ass (>>=
band (&
band_ass (&=
bor (|
bor_ass (|=
bxor (^
bxor_ass (^=
ncmp (<=>
scmp (cmp
compl (~
atan2 (atan2
cos (cos
sin (sin
exp (exp
log (log
sqrt (sqrt
repeat (x
repeat_ass (x=
concat (.
concat_ass (.=
smart (~~
ftest (-X
regexp (qr
# Note: Perl_Gv_AMupdate() assumes that DESTROY is the last entry
DESTROY DESTROY