[perl5.git] / regen / mg_vtable.pl

#!/usr/bin/perl -w
#
# Regenerate (overwriting only if changed):
#
#    mg_names.inc
#    mg_raw.h
#    mg_vtable.h
#    pod/perlguts.pod
#
# from information stored in this file.  pod/perlguts.pod is not completely
# regenerated.  Only the magic table is replaced; the other parts remain
# untouched.
#
# Accepts the standard regen_lib -q and -v args.
#
# This script is normally invoked from regen.pl.
#
# Its output files contain:
#
# mg_names.inc
#    included by dump.c - the textual representation for each magic type.
#    Contains a list of
#
#         { PERL_MAGIC_foo, "foo(f)" }
#
#    pairs.
#
#
# mg_raw.h
#    processed by generate_uudmap.c into mg_data.h which eventually
#    populates PL_magic_vtables[].
#
#    Contains a list of:
#
#         { 'f', "want_vtbl_foo | FLAGS", "description for comments" }
#
#    triplets. FLAGS can be:
#         PERL_MAGIC_READONLY_ACCEPTABLE
#               ok set this type of magic on an SvREADONLY() SV
#         PERL_MAGIC_VALUE_MAGIC
#               this is value magic (pos, taint etc)
#               rather than container magic (%ENV, $1 etc)
#
#
# mg_vtable.h
#     This contains five kinds of entries:
#
#     #define PERL_MAGIC_arylen         '#'
#     ....
#
#     enum { /* pass one of these to get_vtbl */
#          want_vtbl_arylen,
#          ...
#     }
#
#     PL_magic_vtable_names[] = {
#         "arylen",
#         ...
#     }
#
#     PL_magic_vtables[] = {
#         /* per-magic sets of vtable function pointers */
#         { get, set, len, clear, free, copy, dup, local },
#     }
#
#     define PL_vtbl_arylen PL_magic_vtables[want_vtbl_arylen]
#     ....
#
#
#
# pod/perlguts.pod
#     updates the list of magic types between
#     =for mg_vtable.pl begin
#     ...
#     =for mg_vtable.pl end


use strict;
require 5.004;

BEGIN {
    # Get function prototypes
    require './regen/regen_lib.pl';
}

# =====================================================================
#
# START OF CONFIGURATION DATA


# %mg
#
# This hash is mainly concerned with populating all the other stuff
# ancillary to the vtable.
#
# The key is the name, e.g. 'regdata' for PERL_MAGIC_regdata
#
# The keys of the value hash are:
#    char
#       the magic's char identifier
#
#    desc
#       a description which appears in code comments in generated files
#
#    readonly_acceptable
#       If true, set PERL_MAGIC_READONLY_ACCEPTABLE flag;
#       SvREADONLY() svs are allowed to have this magic added to them
#
#    unknown_to_sv_magic
#       if true, this isn't one of the standard magic types which
#       Perl_sv_magic() knows how to deal with
#
#    value_magic
#       If true, set PERL_MAGIC_VALUE_MAGIC flag;
#       this kind of magic is value (pos, taint etc) rather than
#       container magic (%ENV, $1 etc)
#
#    vtable
#        name of the vtable lookup enum, e.g. 'foo' creates want_vtbl_foo

my %mg =
    (
     sv => { char => "\0", vtable => 'sv', readonly_acceptable => 1,
	     desc => 'Special scalar variable' },
     # overload, or type "A" magic, used to be here.  Hence overloaded is
     # often called AMAGIC internally, even though it does not use "A"
     # magic any more.
     overload_table => { char => 'c', vtable => 'ovrld',
			 desc => 'Holds overload table (AMT) on stash' },
     bm => { char => 'B', vtable => 'regexp', value_magic => 1,
	     readonly_acceptable => 1,
	     desc => 'Boyer-Moore (fast string search)' },
     regdata => { char => 'D', vtable => 'regdata',
		  desc => "Regex match position data\n(\@+ and \@- vars)" },
     regdatum => { char => 'd', vtable => 'regdatum',
		   desc => 'Regex match position data element' },
     env => { char => 'E', vtable => 'env', desc => '%ENV hash' },
     envelem => { char => 'e', vtable => 'envelem',
		  desc => '%ENV hash element' },
     fm => { char => 'f', vtable => 'regexp', value_magic => 1,
	     readonly_acceptable => 1, desc => "Formline ('compiled' format)" },
     regex_global => { char => 'g', vtable => 'mglob', value_magic => 1,
		       readonly_acceptable => 1, desc => 'm//g target' },
     hints => { char => 'H', vtable => 'hints', desc => '%^H hash' },
     hintselem => { char => 'h', vtable => 'hintselem',
		    desc => '%^H hash element' },
     isa => { char => 'I', vtable => 'isa', desc => '@ISA array' },
     isaelem => { char => 'i', vtable => 'isaelem',
		  desc => '@ISA array element' },
     nkeys => { char => 'k', vtable => 'nkeys', value_magic => 1,
		desc => 'scalar(keys()) lvalue' },
     dbfile => { char => 'L',
		 desc => 'Debugger %_<filename' },
     dbline => { char => 'l', vtable => 'dbline',
		 desc => 'Debugger %_<filename element' },
     shared => { char => 'N', desc => 'Shared between threads',
		 unknown_to_sv_magic => 1 },
     shared_scalar => { char => 'n', desc => 'Shared between threads',
			unknown_to_sv_magic => 1 },
     collxfrm => { char => 'o', vtable => 'collxfrm', value_magic => 1,
		   desc => 'Locale transformation' },
     tied => { char => 'P', vtable => 'pack',
	       value_magic => 1, # treat as value, so 'local @tied' isn't tied
	       desc => 'Tied array or hash' },
     tiedelem => { char => 'p', vtable => 'packelem',
		   desc => 'Tied array or hash element' },
     tiedscalar => { char => 'q', vtable => 'packelem',
		     desc => 'Tied scalar or handle' },
     qr => { char => 'r', vtable => 'regexp', value_magic => 1, 
	     readonly_acceptable => 1, desc => 'Precompiled qr// regex' },
     sig => { char => 'S', desc => '%SIG hash' },
     sigelem => { char => 's', vtable => 'sigelem',
		  desc => '%SIG hash element' },
     taint => { char => 't', vtable => 'taint', value_magic => 1,
		desc => 'Taintedness' },
     uvar => { char => 'U', vtable => 'uvar',
	       desc => 'Available for use by extensions' },
     uvar_elem => { char => 'u', desc => 'Reserved for use by extensions',
		    unknown_to_sv_magic => 1 },
     vec => { char => 'v', vtable => 'vec', value_magic => 1,
	      desc => 'vec() lvalue' },
     vstring => { char => 'V', value_magic => 1,
		  desc => 'SV was vstring literal' },
     utf8 => { char => 'w', vtable => 'utf8', value_magic => 1,
	       desc => 'Cached UTF-8 information' },
     substr => { char => 'x', vtable => 'substr',  value_magic => 1,
		 desc => 'substr() lvalue' },
     defelem => { char => 'y', vtable => 'defelem', value_magic => 1,
		  desc => "Shadow \"foreach\" iterator variable /\nsmart parameter vivification" },
     nonelem => { char => 'Y', vtable => 'nonelem', value_magic => 1,
		  desc => "Array element that does not exist" },
     arylen => { char => '#', vtable => 'arylen', value_magic => 1,
		 desc => 'Array length ($#ary)' },
     pos => { char => '.', vtable => 'pos', value_magic => 1,
	      desc => 'pos() lvalue' },
     backref => { char => '<', vtable => 'backref', value_magic => 1,
		  readonly_acceptable => 1, desc => 'For weak ref data' },
     symtab => { char => ':', value_magic => 1,
		 desc => 'Extra data for symbol tables' },
     rhash => { char => '%', value_magic => 1,
		desc => 'Extra data for restricted hashes' },
     arylen_p => { char => '@', value_magic => 1,
		   desc => 'To move arylen out of XPVAV' },
     ext => { char => '~', desc => 'Available for use by extensions',
	      readonly_acceptable => 1 },
     checkcall => { char => ']', value_magic => 1, vtable => 'checkcall',
		    desc => 'Inlining/mutation of call to this CV'},
     debugvar => { char => '*', desc => '$DB::single, signal, trace vars',
		   vtable => 'debugvar' },
     lvref => { char => '\\', vtable => 'lvref',
		  desc => "Lvalue reference constructor" },
);


# %sig
#
# This hash is mainly concerned with populating the vtable.
# (despite the name it has nothing to do with signals!)
#
# These have a subtly different "namespace" from the magic types.
#
# The key is the name, e.g. 'regdata' for PERL_MAGIC_regdata
# The keys of the value hash are:
#
#    alias
#       for each entry in the anon array, add
#       add "#define want_vtbl_$_ want_vtbl_$name"
#
#    cond
#       prefix the vtable with the specified entry (e.g. '#ifdef FOO')
#       and suffix it with '#else { 0, 0, 0, 0, 0, 0, 0, 0 } #endif'
#
#    const
#       special-case cast a 'get' function whose signature expects
#       a pointer to constant magic, so that it can be added to a vtable
#       which expects pointers to functions without the 'const'.
#
#    get
#    set
#    len
#    clear
#    free
#    copy
#    dup
#    local
#       For each specified method, add a vtable function pointer
#       of the form "Perl_magic_$sig{foo}{get}" etc

my %sig =
    (
     'sv' => {get => 'get', set => 'set'},
     'env' => {set => 'set_all_env', clear => 'clear_all_env'},
     'envelem' => {set => 'setenv', clear => 'clearenv'},
     'sigelem' => {get => 'getsig', set => 'setsig', clear => 'clearsig',
		   cond => '#ifndef PERL_MICRO'},
     'pack' => {len => 'sizepack', clear => 'wipepack'},
     'packelem' => {get => 'getpack', set => 'setpack', clear => 'clearpack'},
     'dbline' => {set => 'setdbline'},
     'isa' => {set => 'setisa', clear => 'clearisa'},
     'isaelem' => {set => 'setisa'},
     'arylen' => {get => 'getarylen', set => 'setarylen', const => 1},
     'arylen_p' => {clear => 'cleararylen_p', free => 'freearylen_p'},
     'mglob' => {set => 'setmglob'},
     'nkeys' => {get => 'getnkeys', set => 'setnkeys'},
     'taint' => {get => 'gettaint', set => 'settaint'},
     'substr' => {get => 'getsubstr', set => 'setsubstr'},
     'vec' => {get => 'getvec', set => 'setvec'},
     'pos' => {get => 'getpos', set => 'setpos'},
     'uvar' => {get => 'getuvar', set => 'setuvar'},
     'defelem' => {get => 'getdefelem', set => 'setdefelem'},
     'nonelem' => {set => 'setnonelem'},
     'regexp' => {set => 'setregexp', alias => [qw(bm fm)]},
     'regdata' => {len => 'regdata_cnt'},
     'regdatum' => {get => 'regdatum_get', set => 'regdatum_set'},
     'backref' => {free => 'killbackrefs'},
     'ovrld' => {free => 'freeovrld'},
     'utf8' => {set => 'setutf8'},
     'collxfrm' => {set => 'setcollxfrm',
		    cond => '#ifdef USE_LOCALE_COLLATE'},
     'hintselem' => {set => 'sethint', clear => 'clearhint'},
     'hints' => {clear => 'clearhints'},
     'checkcall' => {copy => 'copycallchecker'},
     'debugvar' => { set => 'setdebugvar', get => 'getdebugvar' },
     'lvref' => {set => 'setlvref'},
);


# END OF CONFIGURATION DATA
#
# =====================================================================


my ($vt, $raw, $names) = map {
    open_new($_, '>',
	     { by => 'regen/mg_vtable.pl', file => $_, style => '*' });
} 'mg_vtable.h', 'mg_raw.h', 'mg_names.inc';
my $guts = open_new("pod/perlguts.pod", ">");

print $vt <<'EOH';
/* These constants should be used in preference to raw characters
 * when using magic. Note that some perl guts still assume
 * certain character properties of these constants, namely that
 * isUPPER() and toLOWER() may do useful mappings.
 */

EOH

# Of course, it would be *much* easier if we could output this table directly
# here and now. However, for our sins, we try to support EBCDIC, which wouldn't
# be *so* bad, except that there are (at least) 3 EBCDIC charset variants, and
# they don't agree on the code point for '~'. Which we use. Great.
# So we have to get the local build runtime to sort our table in character order
# (And of course, just to be helpful, in POSIX BC '~' is \xFF, so we can't even
# simplify the C code by assuming that the last element of the array is
# predictable)

# Process %mg

{
    my $longest = 0;
    foreach (keys %mg) {
	$longest = length $_ if length $_ > $longest;
    }

    my $longest_p1 = $longest + 1;

    my %mg_order;
    while (my ($name, $data) = each %mg) {
	my $byte = $data->{char};
	if ($byte =~ /[[:print:]]/) {
	    $data->{r_char} = $byte; # readable char
	    ($data->{c_char} = $byte) =~ s/([\\"])/\\$1/g; # for C strings
	}
	else {
	    $data->{c_char} = $data->{r_char} = '\\'.ord $byte;
	}
	$mg_order{(uc $byte) . $byte} = $name;
    }

    my @rows;
    my @names;
    foreach (sort keys %mg_order) {
	my $name = $mg_order{$_};
        push @names, $name;
	my $data = $mg{$name};
	my $i = ord $data->{char};

        # add entry to mg_raw.h

	unless ($data->{unknown_to_sv_magic}) {
	    my $value = $data->{vtable}
		? "want_vtbl_$data->{vtable}" : 'magic_vtable_max';
	    $value .= ' | PERL_MAGIC_READONLY_ACCEPTABLE'
		if $data->{readonly_acceptable};
	    $value .= ' | PERL_MAGIC_VALUE_MAGIC' if $data->{value_magic};
	    my $comment = "/* $name '$data->{r_char}' $data->{desc} */";
	    $comment =~ s/([\\"])/\\$1/g;
	    $comment =~ tr/\n/ /;
	    print $raw qq{    { '$data->{c_char}', "$value",\n      "$comment" },\n};
	}

        # add #define PERL_MAGIC_foo entry to vt_table.h

	my $comment = $data->{desc};
	my $leader = ' ' x ($longest + 27);
	$comment =~ s/\n/\n$leader/s;
	printf $vt "#define PERL_MAGIC_%-${longest}s '%s' /* %s */\n",
	    $name, $data->{c_char}, $comment;

        # add entry to mg_names.inc

	my $char = $data->{r_char};
	$char =~ s/([\\"])/\\$1/g;
	printf $names qq[\t{ PERL_MAGIC_%-${longest_p1}s "%s(%s)" },\n],
	    "$name,", $name, $char;

        # construct perlguts.pod entry

	push @rows, [(sprintf "%-2s PERL_MAGIC_%s", $data->{r_char},$name),
		     $data->{vtable} ? "vtbl_$data->{vtable}" : '(none)',
		     $data->{desc}];
    }

    # output @rows to perlguts.pod

    select +(select($guts), do {
	my @header = ('(old-style char and macro)', 'MGVTBL', 'Type of magic');
	my @widths = (0, 0);
	foreach my $row (@rows) {
	    for (0, 1) {
		$widths[$_] = length $row->[$_]
		    if length $row->[$_] > $widths[$_];
	    }
	}
	my $indent = ' ';
	my $format
	    = sprintf "$indent%%-%ds%%-%ds%%s\n", $widths[0] + 1, $widths[1] + 1;
	my $desc_wrap =
	    79 - 7 - (length $indent) - $widths[0] - $widths[1] - 2;

	open my $oldguts, "<", "pod/perlguts.pod"
	   or die "$0 cannot open pod/perlguts.pod for reading: $!";
	while (<$oldguts>) {
	    print;
	    last if /^=for mg_vtable.pl begin/
	}

	print "\n", $indent . "mg_type\n";
	printf $format, @header;
	printf $format, map {'-' x length $_} @header;
	foreach (@rows) {
	    my ($type, $vtbl, $desc) = @$_;
	    $desc =~ tr/\n/ /;
	    my @cont;
	    if (length $desc > $desc_wrap) {
		# If it's too long, first split on '(', if there.
		# [Which, if there, is always short enough, currently.
		# Make this more robust if that changes]
		($desc, @cont) = split /(?=\()/, $desc;
		if (!@cont) {
		    ($desc, @cont) = $desc =~ /(.{1,$desc_wrap})(?: |\z)/g
		}
	    }
	    printf $format, $type, $vtbl, $desc;
	    printf $format, '', '', $_ foreach @cont;
	}
	print "\n\n";

        print "=for apidoc Amnh||PERL_MAGIC_$names[0]\n";
        for (my $i = 1; $i < @names; $i++) {
            print "=for apidoc_item ||PERL_MAGIC_$_\n";
        }
        print "\n";

	while (<$oldguts>) {
	    last if /^=for mg_vtable.pl end/;
	}
	do { print } while <$oldguts>;
    })[0];
}


# Process %sig - everything goes to mg_vtable.h

my @names = sort keys %sig;
{
    my $want = join ",\n    ", (map {"want_vtbl_$_"} @names), 'magic_vtable_max';
    my $names = join qq{",\n    "}, @names;

    print $vt <<"EOH";

enum {		/* pass one of these to get_vtbl */
    $want
};

#ifdef DOINIT
EXTCONST char * const PL_magic_vtable_names[magic_vtable_max] = {
    "$names"
};
#else
EXTCONST char * const PL_magic_vtable_names[magic_vtable_max];
#endif

EOH
}

print $vt <<'EOH';
/* These all need to be 0, not NULL, as NULL can be (void*)0, which is a
 * pointer to data, whereas we're assigning pointers to functions, which are
 * not the same beast. ANSI doesn't allow the assignment from one to the other.
 * (although most, but not all, compilers are prepared to do it)
 */

/* order is:
    get
    set
    len
    clear
    free
    copy
    dup
    local
*/

#ifdef DOINIT
EXT_MGVTBL PL_magic_vtables[magic_vtable_max] = {
EOH

my @vtable_names;
my @aliases;

while (my $name = shift @names) {
    my $data = $sig{$name};
    push @vtable_names, $name;
    my @funcs = map {
	$data->{$_} ? "Perl_magic_$data->{$_}" : 0;
    } qw(get set len clear free copy dup local);

    $funcs[0] = "(int (*)(pTHX_ SV *, MAGIC *))" . $funcs[0] if $data->{const};
    my $funcs = join ", ", @funcs;

    # Because we can't have a , after the last {...}
    my $comma = @names ? ',' : '';

    print $vt "$data->{cond}\n" if $data->{cond};
    print $vt "  { $funcs }$comma\n";
    print $vt <<"EOH" if $data->{cond};
#else
  { 0, 0, 0, 0, 0, 0, 0, 0 }$comma
#endif
EOH
    foreach(@{$data->{alias}}) {
	push @aliases, "#define want_vtbl_$_ want_vtbl_$name\n";
	push @vtable_names, $_;
    }
}

print $vt <<'EOH';
};
#else
EXT_MGVTBL PL_magic_vtables[magic_vtable_max];
#endif

EOH

print $vt (sort @aliases), "\n";

print $vt "#define PL_vtbl_$_ PL_magic_vtables[want_vtbl_$_]\n"
    foreach sort @vtable_names;

# 63, not 64, As we rely on the last possible value to mean "NULL vtable"
die "Too many vtable names" if @vtable_names > 63;

read_only_bottom_close_and_rename($_) foreach $vt, $raw, $names;
		 close_and_rename($guts);
Commit	Line	Data
8b09643d NC	1	#!/usr/bin/perl -w
	2	#
	3	# Regenerate (overwriting only if changed):
	4	#
16bc0f48	5	# mg_names.inc
130e6ef5	6	# mg_raw.h
8b09643d	7	# mg_vtable.h
1083e5c1	8	# pod/perlguts.pod
8b09643d	9	#
1083e5c1 FC	10	# from information stored in this file. pod/perlguts.pod is not completely
	11	# regenerated. Only the magic table is replaced; the other parts remain
	12	# untouched.
8b09643d NC	13	#
	14	# Accepts the standard regen_lib -q and -v args.
	15	#
	16	# This script is normally invoked from regen.pl.
e558f276 DM	17	#
	18	# Its output files contain:
	19	#
	20	# mg_names.inc
	21	# included by dump.c - the textual representation for each magic type.
	22	# Contains a list of
	23	#
	24	# { PERL_MAGIC_foo, "foo(f)" }
	25	#
	26	# pairs.
	27	#
	28	#
	29	# mg_raw.h
	30	# processed by generate_uudmap.c into mg_data.h which eventually
	31	# populates PL_magic_vtables[].
	32	#
	33	# Contains a list of:
	34	#
	35	# { 'f', "want_vtbl_foo \| FLAGS", "description for comments" }
	36	#
	37	# triplets. FLAGS can be:
	38	# PERL_MAGIC_READONLY_ACCEPTABLE
	39	# ok set this type of magic on an SvREADONLY() SV
	40	# PERL_MAGIC_VALUE_MAGIC
	41	# this is value magic (pos, taint etc)
	42	# rather than container magic (%ENV, $1 etc)
	43	#
	44	#
	45	# mg_vtable.h
	46	# This contains five kinds of entries:
	47	#
	48	# #define PERL_MAGIC_arylen '#'
	49	# ....
	50	#
	51	# enum { /* pass one of these to get_vtbl */
	52	# want_vtbl_arylen,
	53	# ...
	54	# }
	55	#
	56	# PL_magic_vtable_names[] = {
	57	# "arylen",
	58	# ...
	59	# }
	60	#
	61	# PL_magic_vtables[] = {
	62	# /* per-magic sets of vtable function pointers */
	63	# { get, set, len, clear, free, copy, dup, local },
	64	# }
	65	#
	66	# define PL_vtbl_arylen PL_magic_vtables[want_vtbl_arylen]
	67	# ....
	68	#
	69	#
	70	#
	71	# pod/perlguts.pod
	72	# updates the list of magic types between
	73	# =for mg_vtable.pl begin
	74	# ...
	75	# =for mg_vtable.pl end
	76
8b09643d NC	77
	78	use strict;
	79	require 5.004;
	80
	81	BEGIN {
	82	# Get function prototypes
3d7c117d	83	require './regen/regen_lib.pl';
8b09643d NC	84	}
8b09643d NC	85
e558f276 DM	86	# =====================================================================
	87	#
	88	# START OF CONFIGURATION DATA
	89
	90
	91	# %mg
	92	#
	93	# This hash is mainly concerned with populating all the other stuff
	94	# ancillary to the vtable.
	95	#
	96	# The key is the name, e.g. 'regdata' for PERL_MAGIC_regdata
	97	#
	98	# The keys of the value hash are:
	99	# char
	100	# the magic's char identifier
	101	#
	102	# desc
	103	# a description which appears in code comments in generated files
	104	#
	105	# readonly_acceptable
	106	# If true, set PERL_MAGIC_READONLY_ACCEPTABLE flag;
	107	# SvREADONLY() svs are allowed to have this magic added to them
	108	#
	109	# unknown_to_sv_magic
	110	# if true, this isn't one of the standard magic types which
	111	# Perl_sv_magic() knows how to deal with
	112	#
	113	# value_magic
	114	# If true, set PERL_MAGIC_VALUE_MAGIC flag;
	115	# this kind of magic is value (pos, taint etc) rather than
	116	# container magic (%ENV, $1 etc)
	117	#
	118	# vtable
	119	# name of the vtable lookup enum, e.g. 'foo' creates want_vtbl_foo
	120
23cfd2fc	121	my %mg =
6f83ef0e	122	(
9cce4f9a	123	sv => { char => "\0", vtable => 'sv', readonly_acceptable => 1,
82ff486e	124	desc => 'Special scalar variable' },
bd6e6c12 FC	125	# overload, or type "A" magic, used to be here. Hence overloaded is
	126	# often called AMAGIC internally, even though it does not use "A"
	127	# magic any more.
6f83ef0e NC	128	overload_table => { char => 'c', vtable => 'ovrld',
6f83ef0e NC	129	desc => 'Holds overload table (AMT) on stash' },
e0a73de4	130	bm => { char => 'B', vtable => 'regexp', value_magic => 1,
82ff486e	131	readonly_acceptable => 1,
6f83ef0e NC	132	desc => 'Boyer-Moore (fast string search)' },
6f83ef0e NC	133	regdata => { char => 'D', vtable => 'regdata',
abf9aa7a	134	desc => "Regex match position data\n(\@+ and \@- vars)" },
6f83ef0e NC	135	regdatum => { char => 'd', vtable => 'regdatum',
	136	desc => 'Regex match position data element' },
	137	env => { char => 'E', vtable => 'env', desc => '%ENV hash' },
	138	envelem => { char => 'e', vtable => 'envelem',
	139	desc => '%ENV hash element' },
eccba044	140	fm => { char => 'f', vtable => 'regexp', value_magic => 1,
82ff486e	141	readonly_acceptable => 1, desc => "Formline ('compiled' format)" },
e0a73de4	142	regex_global => { char => 'g', vtable => 'mglob', value_magic => 1,
0177730e	143	readonly_acceptable => 1, desc => 'm//g target' },
6f83ef0e NC	144	hints => { char => 'H', vtable => 'hints', desc => '%^H hash' },
	145	hintselem => { char => 'h', vtable => 'hintselem',
	146	desc => '%^H hash element' },
	147	isa => { char => 'I', vtable => 'isa', desc => '@ISA array' },
	148	isaelem => { char => 'i', vtable => 'isaelem',
	149	desc => '@ISA array element' },
e0a73de4	150	nkeys => { char => 'k', vtable => 'nkeys', value_magic => 1,
6f83ef0e	151	desc => 'scalar(keys()) lvalue' },
f34d1562	152	dbfile => { char => 'L',
6f83ef0e	153	desc => 'Debugger %_<filename' },
f34d1562 FC	154	dbline => { char => 'l', vtable => 'dbline',
f34d1562 FC	155	desc => 'Debugger %_<filename element' },
6f83ef0e NC	156	shared => { char => 'N', desc => 'Shared between threads',
	157	unknown_to_sv_magic => 1 },
	158	shared_scalar => { char => 'n', desc => 'Shared between threads',
	159	unknown_to_sv_magic => 1 },
e0a73de4	160	collxfrm => { char => 'o', vtable => 'collxfrm', value_magic => 1,
6f83ef0e	161	desc => 'Locale transformation' },
e0a73de4 NC	162	tied => { char => 'P', vtable => 'pack',
	163	value_magic => 1, # treat as value, so 'local @tied' isn't tied
	164	desc => 'Tied array or hash' },
6f83ef0e NC	165	tiedelem => { char => 'p', vtable => 'packelem',
	166	desc => 'Tied array or hash element' },
	167	tiedscalar => { char => 'q', vtable => 'packelem',
	168	desc => 'Tied scalar or handle' },
e0a73de4	169	qr => { char => 'r', vtable => 'regexp', value_magic => 1,
e5e1ee61	170	readonly_acceptable => 1, desc => 'Precompiled qr// regex' },
6f83ef0e NC	171	sig => { char => 'S', desc => '%SIG hash' },
	172	sigelem => { char => 's', vtable => 'sigelem',
	173	desc => '%SIG hash element' },
e0a73de4 NC	174	taint => { char => 't', vtable => 'taint', value_magic => 1,
e0a73de4 NC	175	desc => 'Taintedness' },
6f83ef0e NC	176	uvar => { char => 'U', vtable => 'uvar',
	177	desc => 'Available for use by extensions' },
	178	uvar_elem => { char => 'u', desc => 'Reserved for use by extensions',
	179	unknown_to_sv_magic => 1 },
e0a73de4 NC	180	vec => { char => 'v', vtable => 'vec', value_magic => 1,
e0a73de4 NC	181	desc => 'vec() lvalue' },
4499db73	182	vstring => { char => 'V', value_magic => 1,
e0a73de4 NC	183	desc => 'SV was vstring literal' },
e0a73de4 NC	184	utf8 => { char => 'w', vtable => 'utf8', value_magic => 1,
6f83ef0e	185	desc => 'Cached UTF-8 information' },
e0a73de4 NC	186	substr => { char => 'x', vtable => 'substr', value_magic => 1,
	187	desc => 'substr() lvalue' },
	188	defelem => { char => 'y', vtable => 'defelem', value_magic => 1,
abf9aa7a	189	desc => "Shadow \"foreach\" iterator variable /\nsmart parameter vivification" },
1f1dcfb5 FC	190	nonelem => { char => 'Y', vtable => 'nonelem', value_magic => 1,
1f1dcfb5 FC	191	desc => "Array element that does not exist" },
e0a73de4	192	arylen => { char => '#', vtable => 'arylen', value_magic => 1,
6f83ef0e	193	desc => 'Array length ($#ary)' },
e0a73de4 NC	194	pos => { char => '.', vtable => 'pos', value_magic => 1,
	195	desc => 'pos() lvalue' },
	196	backref => { char => '<', vtable => 'backref', value_magic => 1,
e5e1ee61	197	readonly_acceptable => 1, desc => 'For weak ref data' },
e0a73de4	198	symtab => { char => ':', value_magic => 1,
e5e1ee61	199	desc => 'Extra data for symbol tables' },
e0a73de4	200	rhash => { char => '%', value_magic => 1,
e5e1ee61	201	desc => 'Extra data for restricted hashes' },
e0a73de4	202	arylen_p => { char => '@', value_magic => 1,
e5e1ee61	203	desc => 'To move arylen out of XPVAV' },
1d5686ec FC	204	ext => { char => '~', desc => 'Available for use by extensions',
1d5686ec FC	205	readonly_acceptable => 1 },
09fb282d	206	checkcall => { char => ']', value_magic => 1, vtable => 'checkcall',
e5e1ee61	207	desc => 'Inlining/mutation of call to this CV'},
a6d69523 TC	208	debugvar => { char => '*', desc => '$DB::single, signal, trace vars',
a6d69523 TC	209	vtable => 'debugvar' },
9cce4f9a	210	lvref => { char => '\\', vtable => 'lvref',
baabe3fb	211	desc => "Lvalue reference constructor" },
6f83ef0e NC	212	);
6f83ef0e NC	213
e558f276 DM	214
	215	# %sig
	216	#
	217	# This hash is mainly concerned with populating the vtable.
	218	# (despite the name it has nothing to do with signals!)
	219	#
0a1f728a	220	# These have a subtly different "namespace" from the magic types.
e558f276 DM	221	#
	222	# The key is the name, e.g. 'regdata' for PERL_MAGIC_regdata
	223	# The keys of the value hash are:
	224	#
	225	# alias
	226	# for each entry in the anon array, add
	227	# add "#define want_vtbl_$_ want_vtbl_$name"
	228	#
	229	# cond
	230	# prefix the vtable with the specified entry (e.g. '#ifdef FOO')
	231	# and suffix it with '#else { 0, 0, 0, 0, 0, 0, 0, 0 } #endif'
	232	#
	233	# const
	234	# special-case cast a 'get' function whose signature expects
	235	# a pointer to constant magic, so that it can be added to a vtable
	236	# which expects pointers to functions without the 'const'.
	237	#
	238	# get
	239	# set
	240	# len
	241	# clear
	242	# free
	243	# copy
	244	# dup
	245	# local
	246	# For each specified method, add a vtable function pointer
	247	# of the form "Perl_magic_$sig{foo}{get}" etc
	248
23cfd2fc	249	my %sig =
8b09643d	250	(
9bb29b68	251	'sv' => {get => 'get', set => 'set'},
8b09643d NC	252	'env' => {set => 'set_all_env', clear => 'clear_all_env'},
	253	'envelem' => {set => 'setenv', clear => 'clearenv'},
	254	'sigelem' => {get => 'getsig', set => 'setsig', clear => 'clearsig',
	255	cond => '#ifndef PERL_MICRO'},
	256	'pack' => {len => 'sizepack', clear => 'wipepack'},
	257	'packelem' => {get => 'getpack', set => 'setpack', clear => 'clearpack'},
	258	'dbline' => {set => 'setdbline'},
	259	'isa' => {set => 'setisa', clear => 'clearisa'},
	260	'isaelem' => {set => 'setisa'},
	261	'arylen' => {get => 'getarylen', set => 'setarylen', const => 1},
83f29afa	262	'arylen_p' => {clear => 'cleararylen_p', free => 'freearylen_p'},
8b09643d NC	263	'mglob' => {set => 'setmglob'},
	264	'nkeys' => {get => 'getnkeys', set => 'setnkeys'},
	265	'taint' => {get => 'gettaint', set => 'settaint'},
	266	'substr' => {get => 'getsubstr', set => 'setsubstr'},
	267	'vec' => {get => 'getvec', set => 'setvec'},
	268	'pos' => {get => 'getpos', set => 'setpos'},
8b09643d NC	269	'uvar' => {get => 'getuvar', set => 'setuvar'},
8b09643d NC	270	'defelem' => {get => 'getdefelem', set => 'setdefelem'},
1f1dcfb5	271	'nonelem' => {set => 'setnonelem'},
b2e9fc6f	272	'regexp' => {set => 'setregexp', alias => [qw(bm fm)]},
8b09643d NC	273	'regdata' => {len => 'regdata_cnt'},
8b09643d NC	274	'regdatum' => {get => 'regdatum_get', set => 'regdatum_set'},
8b09643d NC	275	'backref' => {free => 'killbackrefs'},
	276	'ovrld' => {free => 'freeovrld'},
	277	'utf8' => {set => 'setutf8'},
	278	'collxfrm' => {set => 'setcollxfrm',
	279	cond => '#ifdef USE_LOCALE_COLLATE'},
	280	'hintselem' => {set => 'sethint', clear => 'clearhint'},
	281	'hints' => {clear => 'clearhints'},
09fb282d	282	'checkcall' => {copy => 'copycallchecker'},
a6d69523	283	'debugvar' => { set => 'setdebugvar', get => 'getdebugvar' },
9cce4f9a	284	'lvref' => {set => 'setlvref'},
8b09643d NC	285	);
8b09643d NC	286
e558f276 DM	287
	288	# END OF CONFIGURATION DATA
	289	#
	290	# =====================================================================
	291
	292
	293
52f49505	294	my ($vt, $raw, $names) = map {
6f83ef0e NC	295	open_new($_, '>',
6f83ef0e NC	296	{ by => 'regen/mg_vtable.pl', file => $_, style => '*' });
16bc0f48	297	} 'mg_vtable.h', 'mg_raw.h', 'mg_names.inc';
f1f5ddd7	298	my $guts = open_new("pod/perlguts.pod", ">");
6f83ef0e	299
abf9aa7a NC	300	print $vt <<'EOH';
	301	/* These constants should be used in preference to raw characters
	302	* when using magic. Note that some perl guts still assume
	303	* certain character properties of these constants, namely that
	304	* isUPPER() and toLOWER() may do useful mappings.
	305	*/
	306
	307	EOH
	308
6f83ef0e NC	309	# Of course, it would be much easier if we could output this table directly
	310	# here and now. However, for our sins, we try to support EBCDIC, which wouldn't
	311	# be so bad, except that there are (at least) 3 EBCDIC charset variants, and
	312	# they don't agree on the code point for '~'. Which we use. Great.
	313	# So we have to get the local build runtime to sort our table in character order
	314	# (And of course, just to be helpful, in POSIX BC '~' is \xFF, so we can't even
	315	# simplify the C code by assuming that the last element of the array is
	316	# predictable)
	317
e558f276 DM	318	# Process %mg
e558f276 DM	319
6f83ef0e	320	{
e972d315 NC	321	my $longest = 0;
	322	foreach (keys %mg) {
	323	$longest = length $_ if length $_ > $longest;
	324	}
	325
52f49505 NC	326	my $longest_p1 = $longest + 1;
52f49505 NC	327
23cfd2fc NC	328	my %mg_order;
23cfd2fc NC	329	while (my ($name, $data) = each %mg) {
9cce4f9a FC	330	my $byte = $data->{char};
	331	if ($byte =~ /[[:print:]]/) {
	332	$data->{r_char} = $byte; # readable char
	333	($data->{c_char} = $byte) =~ s/([\\"])/\\$1/g; # for C strings
	334	}
	335	else {
	336	$data->{c_char} = $data->{r_char} = '\\'.ord $byte;
	337	}
23cfd2fc NC	338	$mg_order{(uc $byte) . $byte} = $name;
23cfd2fc NC	339	}
e558f276	340
63e77aaf	341	my @rows;
f2f5335a	342	my @names;
23cfd2fc NC	343	foreach (sort keys %mg_order) {
23cfd2fc NC	344	my $name = $mg_order{$_};
f2f5335a	345	push @names, $name;
23cfd2fc	346	my $data = $mg{$name};
9cce4f9a	347	my $i = ord $data->{char};
e558f276 DM	348
	349	# add entry to mg_raw.h
	350
6f83ef0e	351	unless ($data->{unknown_to_sv_magic}) {
e0a73de4	352	my $value = $data->{vtable}
6f83ef0e	353	? "want_vtbl_$data->{vtable}" : 'magic_vtable_max';
82ff486e NC	354	$value .= ' \| PERL_MAGIC_READONLY_ACCEPTABLE'
82ff486e NC	355	if $data->{readonly_acceptable};
e0a73de4	356	$value .= ' \| PERL_MAGIC_VALUE_MAGIC' if $data->{value_magic};
9cce4f9a	357	my $comment = "/* $name '$data->{r_char}' $data->{desc} */";
6f83ef0e	358	$comment =~ s/([\\"])/\\$1/g;
abf9aa7a	359	$comment =~ tr/\n/ /;
9cce4f9a	360	print $raw qq{ { '$data->{c_char}', "$value",\n "$comment" },\n};
6f83ef0e	361	}
abf9aa7a	362
e558f276 DM	363	# add #define PERL_MAGIC_foo entry to vt_table.h
e558f276 DM	364
abf9aa7a NC	365	my $comment = $data->{desc};
	366	my $leader = ' ' x ($longest + 27);
	367	$comment =~ s/\n/\n$leader/s;
	368	printf $vt "#define PERL_MAGIC_%-${longest}s '%s' /* %s */\n",
9cce4f9a	369	$name, $data->{c_char}, $comment;
52f49505	370
e558f276 DM	371	# add entry to mg_names.inc
e558f276 DM	372
9cce4f9a	373	my $char = $data->{r_char};
52f49505 NC	374	$char =~ s/([\\"])/\\$1/g;
	375	printf $names qq[\t{ PERL_MAGIC_%-${longest_p1}s "%s(%s)" },\n],
	376	"$name,", $name, $char;
63e77aaf	377
e558f276 DM	378	# construct perlguts.pod entry
e558f276 DM	379
9cce4f9a	380	push @rows, [(sprintf "%-2s PERL_MAGIC_%s", $data->{r_char},$name),
63e77aaf NC	381	$data->{vtable} ? "vtbl_$data->{vtable}" : '(none)',
	382	$data->{desc}];
	383	}
e558f276 DM	384
	385	# output @rows to perlguts.pod
	386
f1f5ddd7	387	select +(select($guts), do {
63e77aaf NC	388	my @header = ('(old-style char and macro)', 'MGVTBL', 'Type of magic');
	389	my @widths = (0, 0);
	390	foreach my $row (@rows) {
	391	for (0, 1) {
	392	$widths[$_] = length $row->[$_]
	393	if length $row->[$_] > $widths[$_];
	394	}
	395	}
f1f5ddd7	396	my $indent = ' ';
63e77aaf NC	397	my $format
63e77aaf NC	398	= sprintf "$indent%%-%ds%%-%ds%%s\n", $widths[0] + 1, $widths[1] + 1;
f1f5ddd7 FC	399	my $desc_wrap =
	400	79 - 7 - (length $indent) - $widths[0] - $widths[1] - 2;
	401
	402	open my $oldguts, "<", "pod/perlguts.pod"
	403	or die "$0 cannot open pod/perlguts.pod for reading: $!";
	404	while (<$oldguts>) {
	405	print;
	406	last if /^=for mg_vtable.pl begin/
	407	}
63e77aaf	408
f1f5ddd7	409	print "\n", $indent . "mg_type\n";
63e77aaf NC	410	printf $format, @header;
	411	printf $format, map {'-' x length $_} @header;
	412	foreach (@rows) {
	413	my ($type, $vtbl, $desc) = @$_;
	414	$desc =~ tr/\n/ /;
	415	my @cont;
	416	if (length $desc > $desc_wrap) {
	417	# If it's too long, first split on '(', if there.
	418	# [Which, if there, is always short enough, currently.
	419	# Make this more robust if that changes]
	420	($desc, @cont) = split /(?=\()/, $desc;
	421	if (!@cont) {
	422	($desc, @cont) = $desc =~ /(.{1,$desc_wrap})(?: \|\z)/g
	423	}
	424	}
	425	printf $format, $type, $vtbl, $desc;
	426	printf $format, '', '', $_ foreach @cont;
	427	}
f2f5335a KW	428	print "\n\n";
f2f5335a KW	429
ed48408e KW	430	print "=for apidoc Amnh\|\|PERL_MAGIC_$names[0]\n";
	431	for (my $i = 1; $i < @names; $i++) {
	432	print "=for apidoc_item \|\|PERL_MAGIC_$_\n";
	433	}
f2f5335a	434	print "\n";
f1f5ddd7 FC	435
	436	while (<$oldguts>) {
	437	last if /^=for mg_vtable.pl end/;
	438	}
	439	do { print } while <$oldguts>;
	440	})[0];
6f83ef0e	441	}
8b09643d	442
e558f276 DM	443
	444	# Process %sig - everything goes to mg_vtable.h
	445
23cfd2fc	446	my @names = sort keys %sig;
ca298f7d	447	{
2d1f1fe5 NC	448	my $want = join ",\n ", (map {"want_vtbl_$_"} @names), 'magic_vtable_max';
	449	my $names = join qq{",\n "}, @names;
	450
6f83ef0e	451	print $vt <<"EOH";
abf9aa7a	452
ca298f7d	453	enum { /* pass one of these to get_vtbl */
2d1f1fe5 NC	454	$want
	455	};
	456
	457	#ifdef DOINIT
bfd14e52	458	EXTCONST char * const PL_magic_vtable_names[magic_vtable_max] = {
2d1f1fe5	459	"$names"
ca298f7d	460	};
2d1f1fe5	461	#else
bfd14e52	462	EXTCONST char * const PL_magic_vtable_names[magic_vtable_max];
2d1f1fe5	463	#endif
ca298f7d NC	464
	465	EOH
	466	}
	467
6f83ef0e	468	print $vt <<'EOH';
8b09643d NC	469	/* These all need to be 0, not NULL, as NULL can be (void*)0, which is a
	470	* pointer to data, whereas we're assigning pointers to functions, which are
	471	* not the same beast. ANSI doesn't allow the assignment from one to the other.
	472	* (although most, but not all, compilers are prepared to do it)
	473	*/
	474
0ffb5b03	475	/* order is:
8b09643d NC	476	get
	477	set
	478	len
	479	clear
	480	free
	481	copy
	482	dup
	483	local
	484	*/
	485
b7b5e578	486	#ifdef DOINIT
c7fdacb9	487	EXT_MGVTBL PL_magic_vtables[magic_vtable_max] = {
8b09643d NC	488	EOH
8b09643d NC	489
b7b5e578	490	my @vtable_names;
b2e9fc6f	491	my @aliases;
b7b5e578	492
23cfd2fc NC	493	while (my $name = shift @names) {
23cfd2fc NC	494	my $data = $sig{$name};
b7b5e578	495	push @vtable_names, $name;
0a1f728a	496	my @funcs = map {
8b09643d NC	497	$data->{$_} ? "Perl_magic_$data->{$_}" : 0;
	498	} qw(get set len clear free copy dup local);
	499
0a1f728a	500	$funcs[0] = "(int ()(pTHX_ SV , MAGIC *))" . $funcs[0] if $data->{const};
0ffb5b03	501	my $funcs = join ", ", @funcs;
8b09643d	502
b7b5e578	503	# Because we can't have a , after the last {...}
23cfd2fc	504	my $comma = @names ? ',' : '';
b7b5e578	505
6f83ef0e NC	506	print $vt "$data->{cond}\n" if $data->{cond};
	507	print $vt " { $funcs }$comma\n";
	508	print $vt <<"EOH" if $data->{cond};
0ffb5b03	509	#else
b7b5e578	510	{ 0, 0, 0, 0, 0, 0, 0, 0 }$comma
0ffb5b03	511	#endif
b7b5e578	512	EOH
b2e9fc6f NC	513	foreach(@{$data->{alias}}) {
	514	push @aliases, "#define want_vtbl_$_ want_vtbl_$name\n";
	515	push @vtable_names, $_;
	516	}
8b09643d NC	517	}
8b09643d NC	518
6f83ef0e	519	print $vt <<'EOH';
b7b5e578 NC	520	};
b7b5e578 NC	521	#else
c7fdacb9	522	EXT_MGVTBL PL_magic_vtables[magic_vtable_max];
b7b5e578 NC	523	#endif
	524
	525	EOH
	526
6f83ef0e	527	print $vt (sort @aliases), "\n";
b7b5e578	528
6f83ef0e	529	print $vt "#define PL_vtbl_$_ PL_magic_vtables[want_vtbl_$_]\n"
b7b5e578 NC	530	foreach sort @vtable_names;
b7b5e578 NC	531
e0a73de4 NC	532	# 63, not 64, As we rely on the last possible value to mean "NULL vtable"
	533	die "Too many vtable names" if @vtable_names > 63;
	534
52f49505	535	read_only_bottom_close_and_rename($_) foreach $vt, $raw, $names;
f1f5ddd7	536	close_and_rename($guts);