| 1 | #!/usr/bin/perl -w |
| 2 | # |
| 3 | # Regenerate (overwriting only if changed): |
| 4 | # |
| 5 | # embed.h |
| 6 | # embedvar.h |
| 7 | # proto.h |
| 8 | # |
| 9 | # from information stored in |
| 10 | # |
| 11 | # embed.fnc |
| 12 | # intrpvar.h |
| 13 | # perlvars.h |
| 14 | # regen/opcodes |
| 15 | # |
| 16 | # Accepts the standard regen_lib -q and -v args. |
| 17 | # |
| 18 | # This script is normally invoked from regen.pl. |
| 19 | |
| 20 | require 5.004; # keep this compatible, an old perl is all we may have before |
| 21 | # we build the new one |
| 22 | |
| 23 | use strict; |
| 24 | |
| 25 | BEGIN { |
| 26 | # Get function prototypes |
| 27 | require './regen/regen_lib.pl'; |
| 28 | require './regen/embed_lib.pl'; |
| 29 | } |
| 30 | |
| 31 | my $unflagged_pointers; |
| 32 | my @az = ('a'..'z'); |
| 33 | |
| 34 | # |
| 35 | # See database of global and static function prototypes in embed.fnc |
| 36 | # This is used to generate prototype headers under various configurations, |
| 37 | # export symbols lists for different platforms, and macros to provide an |
| 38 | # implicit interpreter context argument. |
| 39 | # |
| 40 | |
| 41 | my $error_count = 0; |
| 42 | sub die_at_end ($) { # Keeps going for now, but makes sure the regen doesn't |
| 43 | # succeed. |
| 44 | warn shift; |
| 45 | $error_count++; |
| 46 | } |
| 47 | |
| 48 | sub full_name ($$) { # Returns the function name with potentially the |
| 49 | # prefixes 'S_' or 'Perl_' |
| 50 | my ($func, $flags) = @_; |
| 51 | |
| 52 | return "Perl_$func" if $flags =~ /[ps]/; |
| 53 | return "S_$func" if $flags =~ /[SIi]/; |
| 54 | return $func; |
| 55 | } |
| 56 | |
| 57 | sub open_print_header { |
| 58 | my ($file, $quote) = @_; |
| 59 | |
| 60 | return open_new($file, '>', |
| 61 | { file => $file, style => '*', by => 'regen/embed.pl', |
| 62 | from => [ |
| 63 | 'embed.fnc', |
| 64 | 'intrpvar.h', |
| 65 | 'perlvars.h', |
| 66 | 'regen/opcodes', |
| 67 | 'regen/embed.pl', |
| 68 | 'regen/embed_lib.pl', |
| 69 | 'regen/HeaderParser.pm', |
| 70 | ], |
| 71 | final => "\nEdit those files and run 'make regen_headers' to effect changes.\n", |
| 72 | copyright => [1993 .. 2022], |
| 73 | quote => $quote }); |
| 74 | } |
| 75 | |
| 76 | |
| 77 | sub open_buf_out { |
| 78 | $_[0] //= ""; |
| 79 | open my $fh,">", \$_[0] |
| 80 | or die "Failed to open buffer: $!"; |
| 81 | return $fh; |
| 82 | } |
| 83 | |
| 84 | # generate proto.h |
| 85 | sub generate_proto_h { |
| 86 | my ($all)= @_; |
| 87 | my $pr = open_buf_out(my $proto_buffer); |
| 88 | my $ret; |
| 89 | |
| 90 | foreach (@$all) { |
| 91 | if ($_->{type} ne "content") { |
| 92 | print $pr "$_->{line}"; |
| 93 | next; |
| 94 | } |
| 95 | my $embed= $_->{embed} |
| 96 | or next; |
| 97 | |
| 98 | my $level= $_->{level}; |
| 99 | my $ind= $level ? " " : ""; |
| 100 | $ind .= " " x ($level-1) if $level>1; |
| 101 | my $inner_ind= $ind ? " " : " "; |
| 102 | |
| 103 | my ($flags,$retval,$plain_func,$args) = @{$embed}{qw(flags return_type name args)}; |
| 104 | if ($flags =~ / ( [^AabCDdEefFGhIiMmNnOoPpRrSsTUuWXx;] ) /x) { |
| 105 | die_at_end "flag $1 is not legal (for function $plain_func)"; |
| 106 | } |
| 107 | my @nonnull; |
| 108 | my $args_assert_line = ( $flags !~ /G/ ); |
| 109 | my $has_depth = ( $flags =~ /W/ ); |
| 110 | my $has_context = ( $flags !~ /T/ ); |
| 111 | my $never_returns = ( $flags =~ /r/ ); |
| 112 | my $binarycompat = ( $flags =~ /b/ ); |
| 113 | my $commented_out = ( $flags =~ /m/ ); |
| 114 | my $is_malloc = ( $flags =~ /a/ ); |
| 115 | my $can_ignore = ( $flags !~ /R/ ) && ( $flags !~ /P/ ) && !$is_malloc; |
| 116 | my @names_of_nn; |
| 117 | my $func; |
| 118 | |
| 119 | if (! $can_ignore && $retval eq 'void') { |
| 120 | warn "It is nonsensical to require the return value of a void function ($plain_func) to be checked"; |
| 121 | } |
| 122 | |
| 123 | die_at_end "$plain_func: S and p flags are mutually exclusive" |
| 124 | if $flags =~ /S/ && $flags =~ /p/; |
| 125 | die_at_end "$plain_func: m and $1 flags are mutually exclusive" |
| 126 | if $flags =~ /m/ && $flags =~ /([pS])/; |
| 127 | |
| 128 | die_at_end "$plain_func: u flag only usable with m" if $flags =~ /u/ |
| 129 | && $flags !~ /m/; |
| 130 | |
| 131 | my ($static_flag, @extra_static_flags)= do { |
| 132 | # the seen filter can be removed once flag dedupe |
| 133 | # is done in tidy_embed.pl |
| 134 | my %seen; |
| 135 | grep !$seen{$_}++, $flags =~/([SsIi])/g; |
| 136 | }; |
| 137 | |
| 138 | if (@extra_static_flags) { |
| 139 | my $flags_str = join ", ", $static_flag, @extra_static_flags; |
| 140 | $flags_str =~ s/, (\w)\z/ and $1/; |
| 141 | die_at_end "$plain_func: flags $flags_str are mutually exclusive\n"; |
| 142 | } |
| 143 | |
| 144 | my $static_inline = 0; |
| 145 | if ($static_flag) { |
| 146 | my $type; |
| 147 | if ($never_returns) { |
| 148 | $type = { |
| 149 | 'S' => 'PERL_STATIC_NO_RET', |
| 150 | 's' => 'PERL_STATIC_NO_RET', |
| 151 | 'i' => 'PERL_STATIC_INLINE_NO_RET', |
| 152 | 'I' => 'PERL_STATIC_FORCE_INLINE_NO_RET' |
| 153 | }->{$static_flag}; |
| 154 | } |
| 155 | else { |
| 156 | $type = { |
| 157 | 'S' => 'STATIC', |
| 158 | 's' => 'STATIC', |
| 159 | 'i' => 'PERL_STATIC_INLINE', |
| 160 | 'I' => 'PERL_STATIC_FORCE_INLINE' |
| 161 | }->{$static_flag}; |
| 162 | } |
| 163 | $retval = "$type $retval"; |
| 164 | die_at_end "Don't declare static function '$plain_func' pure" if $flags =~ /P/; |
| 165 | $static_inline = $type =~ /^PERL_STATIC(?:_FORCE)?_INLINE/; |
| 166 | } |
| 167 | else { |
| 168 | if ($never_returns) { |
| 169 | $retval = "PERL_CALLCONV_NO_RET $retval"; |
| 170 | } |
| 171 | else { |
| 172 | $retval = "PERL_CALLCONV $retval"; |
| 173 | } |
| 174 | } |
| 175 | |
| 176 | $func = full_name($plain_func, $flags); |
| 177 | |
| 178 | die_at_end "For '$plain_func', M flag requires p flag" |
| 179 | if $flags =~ /M/ && $flags !~ /p/; |
| 180 | my $C_required_flags = '[pIimbs]'; |
| 181 | die_at_end |
| 182 | "For '$plain_func', C flag requires one of $C_required_flags] flags" |
| 183 | if $flags =~ /C/ |
| 184 | && ($flags !~ /$C_required_flags/ |
| 185 | |
| 186 | # Notwithstanding the |
| 187 | # above, if the name won't |
| 188 | # clash with a user name, |
| 189 | # it's ok. |
| 190 | && $plain_func !~ /^[Pp]erl/); |
| 191 | |
| 192 | die_at_end "For '$plain_func', X flag requires one of [Iip] flags" |
| 193 | if $flags =~ /X/ && $flags !~ /[Iip]/; |
| 194 | die_at_end "For '$plain_func', X and m flags are mutually exclusive" |
| 195 | if $flags =~ /X/ && $flags =~ /m/; |
| 196 | die_at_end "For '$plain_func', [Ii] with [ACX] requires p flag" |
| 197 | if $flags =~ /[Ii]/ && $flags =~ /[ACX]/ && $flags !~ /p/; |
| 198 | die_at_end "For '$plain_func', b and m flags are mutually exclusive" |
| 199 | . " (try M flag)" if $flags =~ /b/ && $flags =~ /m/; |
| 200 | die_at_end "For '$plain_func', b flag without M flag requires D flag" |
| 201 | if $flags =~ /b/ && $flags !~ /M/ && $flags !~ /D/; |
| 202 | die_at_end "For '$plain_func', I and i flags are mutually exclusive" |
| 203 | if $flags =~ /I/ && $flags =~ /i/; |
| 204 | |
| 205 | $ret = ""; |
| 206 | $ret .= "$retval\n"; |
| 207 | $ret .= "$func("; |
| 208 | if ( $has_context ) { |
| 209 | $ret .= @$args ? "pTHX_ " : "pTHX"; |
| 210 | } |
| 211 | if (@$args) { |
| 212 | die_at_end "n flag is contradicted by having arguments" |
| 213 | if $flags =~ /n/; |
| 214 | my $n; |
| 215 | for my $arg ( @$args ) { |
| 216 | ++$n; |
| 217 | if ($arg =~ / ^ " (.+) " $ /x) { # Handle literal string |
| 218 | my $name = $1; |
| 219 | |
| 220 | # Make the string a legal C identifier; 'p' is arbitrary, |
| 221 | # and is because C reserves leading underscores |
| 222 | $name =~ s/^\W/p/a; |
| 223 | $name =~ s/\W/_/ag; |
| 224 | |
| 225 | $arg = "const char * const $name"; |
| 226 | die_at_end 'm flag required for "literal" argument' |
| 227 | unless $flags =~ /m/; |
| 228 | } |
| 229 | elsif ( $args_assert_line |
| 230 | && $arg =~ /\*/ |
| 231 | && $arg !~ /\b(NN|NULLOK)\b/ ) |
| 232 | { |
| 233 | warn "$func: $arg needs NN or NULLOK\n"; |
| 234 | ++$unflagged_pointers; |
| 235 | } |
| 236 | my $nn = ( $arg =~ s/\s*\bNN\b\s+// ); |
| 237 | push( @nonnull, $n ) if $nn; |
| 238 | my $nz = ( $arg =~ s/\s*\bNZ\b\s+// ); |
| 239 | |
| 240 | my $nullok = ( $arg =~ s/\s*\bNULLOK\b\s+// ); # strip NULLOK with no effect |
| 241 | |
| 242 | # Make sure each arg has at least a type and a var name. |
| 243 | # An arg of "int" is valid C, but want it to be "int foo". |
| 244 | my $temp_arg = $arg; |
| 245 | $temp_arg =~ s/\*//g; |
| 246 | $temp_arg =~ s/\s*\bstruct\b\s*/ /g; |
| 247 | if ( ($temp_arg ne "...") |
| 248 | && ($temp_arg !~ /\w+\s+(\w+)(?:\[\d+\])?\s*$/) ) { |
| 249 | die_at_end "$func: $arg ($n) doesn't have a name\n"; |
| 250 | } |
| 251 | if (defined $1 && ($nn||$nz) && !($commented_out && !$binarycompat)) { |
| 252 | push @names_of_nn, $1; |
| 253 | } |
| 254 | } |
| 255 | $ret .= join ", ", @$args; |
| 256 | } |
| 257 | else { |
| 258 | $ret .= "void" if !$has_context; |
| 259 | } |
| 260 | $ret .= " _pDEPTH" if $has_depth; |
| 261 | $ret .= ")"; |
| 262 | my @attrs; |
| 263 | if ( $flags =~ /r/ ) { |
| 264 | push @attrs, "__attribute__noreturn__"; |
| 265 | } |
| 266 | if ( $flags =~ /D/ ) { |
| 267 | push @attrs, "__attribute__deprecated__"; |
| 268 | } |
| 269 | if ( $is_malloc ) { |
| 270 | push @attrs, "__attribute__malloc__"; |
| 271 | } |
| 272 | if ( !$can_ignore ) { |
| 273 | push @attrs, "__attribute__warn_unused_result__"; |
| 274 | } |
| 275 | if ( $flags =~ /P/ ) { |
| 276 | push @attrs, "__attribute__pure__"; |
| 277 | } |
| 278 | if ( $flags =~ /I/ ) { |
| 279 | push @attrs, "__attribute__always_inline__"; |
| 280 | } |
| 281 | # roughly the inverse of the rules used in makedef.pl |
| 282 | if ( $flags !~ /[ACeIimSX]/ ) { |
| 283 | push @attrs, '__attribute__visibility__("hidden")' |
| 284 | } |
| 285 | if( $flags =~ /f/ ) { |
| 286 | my $prefix = $has_context ? 'pTHX_' : ''; |
| 287 | my ($argc, $pat); |
| 288 | if (!defined $args->[1]) { |
| 289 | use Data::Dumper; |
| 290 | die Dumper($_); |
| 291 | } |
| 292 | if ($args->[-1] eq '...') { |
| 293 | $argc = scalar @$args; |
| 294 | $pat = $argc - 1; |
| 295 | $argc = $prefix . $argc; |
| 296 | } |
| 297 | else { |
| 298 | # don't check args, and guess which arg is the pattern |
| 299 | # (one of 'fmt', 'pat', 'f'), |
| 300 | $argc = 0; |
| 301 | my @fmts = grep $args->[$_] =~ /\b(f|pat|fmt)$/, 0..$#$args; |
| 302 | if (@fmts != 1) { |
| 303 | die "embed.pl: '$plain_func': can't determine pattern arg\n"; |
| 304 | } |
| 305 | $pat = $fmts[0] + 1; |
| 306 | } |
| 307 | my $macro = grep($_ == $pat, @nonnull) |
| 308 | ? '__attribute__format__' |
| 309 | : '__attribute__format__null_ok__'; |
| 310 | if ($plain_func =~ /strftime/) { |
| 311 | push @attrs, sprintf "%s(__strftime__,%s1,0)", $macro, $prefix; |
| 312 | } |
| 313 | else { |
| 314 | push @attrs, sprintf "%s(__printf__,%s%d,%s)", $macro, |
| 315 | $prefix, $pat, $argc; |
| 316 | } |
| 317 | } |
| 318 | elsif ((grep { $_ eq '...' } @$args) && $flags !~ /F/) { |
| 319 | die_at_end "$plain_func: Function with '...' arguments must have" |
| 320 | . " f or F flag"; |
| 321 | } |
| 322 | if ( @attrs ) { |
| 323 | $ret .= "\n"; |
| 324 | $ret .= join( "\n", map { (" " x 8) . $_ } @attrs ); |
| 325 | } |
| 326 | $ret .= ";"; |
| 327 | $ret = "/* $ret */" if $commented_out; |
| 328 | |
| 329 | if ($args_assert_line || @names_of_nn) { |
| 330 | $ret .= "\n#${ind}define PERL_ARGS_ASSERT_\U$plain_func\E"; |
| 331 | if (@names_of_nn) { |
| 332 | $ret .= " \\\n"; |
| 333 | my $def = " " x 8; |
| 334 | foreach my $ix (0..$#names_of_nn) { |
| 335 | $def .= "assert($names_of_nn[$ix])"; |
| 336 | if ($ix == $#names_of_nn) { |
| 337 | $def .= "\n"; |
| 338 | } elsif (length $def > 70) { |
| 339 | $ret .= $def . "; \\\n"; |
| 340 | $def = " " x 8; |
| 341 | } else { |
| 342 | $def .= "; "; |
| 343 | } |
| 344 | } |
| 345 | $ret .= $def; |
| 346 | } |
| 347 | } |
| 348 | $ret .= "\n"; |
| 349 | |
| 350 | $ret = "#${ind}ifndef PERL_NO_INLINE_FUNCTIONS\n$ret\n#${ind}endif" |
| 351 | if $static_inline; |
| 352 | $ret = "#${ind}ifndef NO_MATHOMS\n$ret\n#${ind}endif" |
| 353 | if $binarycompat; |
| 354 | |
| 355 | $ret .= @attrs ? "\n\n" : "\n"; |
| 356 | |
| 357 | print $pr $ret; |
| 358 | } |
| 359 | |
| 360 | |
| 361 | close $pr; |
| 362 | |
| 363 | my $clean= normalize_group_content($proto_buffer); |
| 364 | |
| 365 | my $fh = open_print_header("proto.h"); |
| 366 | print $fh <<~"EOF"; |
| 367 | START_EXTERN_C |
| 368 | $clean |
| 369 | #ifdef PERL_CORE |
| 370 | # include "pp_proto.h" |
| 371 | #endif |
| 372 | END_EXTERN_C |
| 373 | EOF |
| 374 | |
| 375 | read_only_bottom_close_and_rename($fh) if ! $error_count; |
| 376 | } |
| 377 | |
| 378 | { |
| 379 | my $hp= HeaderParser->new(); |
| 380 | sub normalize_group_content { |
| 381 | open my $in, "<", \$_[0] |
| 382 | or die "Failed to open buffer: $!"; |
| 383 | $hp->parse_fh($in); |
| 384 | my $ppc= sub { |
| 385 | my ($self, $line_data)= @_; |
| 386 | # re-align defines so that the definitions line up at the 48th col |
| 387 | # as much as possible. |
| 388 | if ($line_data->{sub_type} eq "#define") { |
| 389 | $line_data->{line}=~s/^(\s*#\s*define\s+\S+?(?:\([^()]*\))?\s)(\s*)(\S+)/ |
| 390 | sprintf "%-48s%s", $1, $3/e; |
| 391 | } |
| 392 | }; |
| 393 | my $clean= $hp->lines_as_str($hp->group_content(),$ppc); |
| 394 | return $clean; |
| 395 | } |
| 396 | } |
| 397 | |
| 398 | sub normalize_and_print { |
| 399 | my ($file, $buffer)= @_; |
| 400 | my $fh = open_print_header($file); |
| 401 | print $fh normalize_group_content($buffer); |
| 402 | read_only_bottom_close_and_rename($fh); |
| 403 | } |
| 404 | |
| 405 | |
| 406 | sub readvars { |
| 407 | my ($file, $pre) = @_; |
| 408 | my $hp= HeaderParser->new()->read_file($file); |
| 409 | my %seen; |
| 410 | foreach my $line_data (@{$hp->lines}) { |
| 411 | #next unless $line_data->is_content; |
| 412 | my $line= $line_data->line; |
| 413 | if ($line=~m/^\s*PERLVARA?I?C?\(\s*$pre\s*,\s*(\w+)/){ |
| 414 | $seen{$1}++ |
| 415 | and |
| 416 | die_at_end "duplicate symbol $1 while processing $file line " |
| 417 | . ($line_data->start_line_num) . "\n" |
| 418 | } |
| 419 | } |
| 420 | my @keys= sort { lc($a) cmp lc($b) || |
| 421 | $a cmp $b } |
| 422 | keys %seen; |
| 423 | return @keys; |
| 424 | } |
| 425 | |
| 426 | sub add_indent { |
| 427 | #my ($ret, $add, $width)= @_; |
| 428 | my $width= $_[2] || 48; |
| 429 | $_[0] .= " " x ($width-length($_[0])) if length($_[0])<$width; |
| 430 | $_[0] .= " " unless $_[0]=~/\s\z/; |
| 431 | if (defined $_[1]) { |
| 432 | $_[0] .= $_[1]; |
| 433 | } |
| 434 | return $_[0]; |
| 435 | } |
| 436 | |
| 437 | sub indent_define { |
| 438 | my ($from, $to, $indent, $width) = @_; |
| 439 | $indent = '' unless defined $indent; |
| 440 | my $ret= "#${indent}define $from"; |
| 441 | add_indent($ret,"$to\n",$width); |
| 442 | } |
| 443 | |
| 444 | sub multon { |
| 445 | my ($sym,$pre,$ptr,$ind) = @_; |
| 446 | $ind//=""; |
| 447 | indent_define("PL_$sym", "($ptr$pre$sym)", $ind); |
| 448 | } |
| 449 | |
| 450 | sub embed_h { |
| 451 | my ($em, $guard, $funcs) = @_; |
| 452 | |
| 453 | my $lines; |
| 454 | foreach (@$funcs) { |
| 455 | if ($_->{type} ne "content") { |
| 456 | $lines .= $_->{line}; |
| 457 | next; |
| 458 | } |
| 459 | my $level= $_->{level}; |
| 460 | my $embed= $_->{embed} or next; |
| 461 | my ($flags,$retval,$func,$args) = @{$embed}{qw(flags return_type name args)}; |
| 462 | my $ret = ""; |
| 463 | my $ind= $level ? " " : ""; |
| 464 | $ind .= " " x ($level-1) if $level>1; |
| 465 | my $inner_ind= $ind ? " " : " "; |
| 466 | unless ($flags =~ /[omM]/) { |
| 467 | my $argc = scalar @$args; |
| 468 | if ($flags =~ /T/) { |
| 469 | my $full_name = full_name($func, $flags); |
| 470 | next if $full_name eq $func; # Don't output a no-op. |
| 471 | $ret = indent_define($func, $full_name, $ind); |
| 472 | } |
| 473 | else { |
| 474 | my $use_va_list = $argc && $args->[-1] =~ /\.\.\./; |
| 475 | |
| 476 | if($use_va_list) { |
| 477 | # CPP has trouble with empty __VA_ARGS__ and comma joining, |
| 478 | # so we'll have to eat an extra params here. |
| 479 | if($argc < 2) { |
| 480 | die "Cannot use ... as the only parameter to a macro ($func)\n"; |
| 481 | } |
| 482 | $argc -= 2; |
| 483 | } |
| 484 | |
| 485 | my $paramlist = join(",", @az[0..$argc-1], |
| 486 | $use_va_list ? ("...") : ()); |
| 487 | my $replacelist = join(",", @az[0..$argc-1], |
| 488 | $use_va_list ? ("__VA_ARGS__") : ()); |
| 489 | $ret = "#${ind}define $func($paramlist) "; |
| 490 | add_indent($ret,full_name($func, $flags) . "(aTHX"); |
| 491 | $ret .= "_ " if $replacelist; |
| 492 | $ret .= $replacelist; |
| 493 | if ($flags =~ /W/) { |
| 494 | if ($replacelist) { |
| 495 | $ret .= " _aDEPTH"; |
| 496 | } else { |
| 497 | die "Can't use W without other args (currently)"; |
| 498 | } |
| 499 | } |
| 500 | $ret .= ")\n"; |
| 501 | if($use_va_list) { |
| 502 | # Make them available to !MULTIPLICITY or PERL_CORE |
| 503 | $ret = "#${ind}if !defined(MULTIPLICITY) || defined(PERL_CORE)\n" . |
| 504 | $ret . |
| 505 | "#${ind}endif\n"; |
| 506 | } |
| 507 | } |
| 508 | $ret = "#${ind}ifndef NO_MATHOMS\n$ret#${ind}endif\n" if $flags =~ /b/; |
| 509 | } |
| 510 | $lines .= $ret; |
| 511 | } |
| 512 | # remove empty blocks |
| 513 | 1 while $lines =~ s/^#\s*if.*\n#\s*endif.*\n//mg |
| 514 | or $lines =~ s/^(#\s*if)\s+(.*)\n#else.*\n/$1 !($2)\n/mg; |
| 515 | if ($guard) { |
| 516 | print $em "$guard /* guard */\n"; |
| 517 | $lines=~s/^#(\s*)/"#".(length($1)?" ":" ").$1/mge; |
| 518 | } |
| 519 | print $em $lines; |
| 520 | print $em "#endif\n" if $guard; |
| 521 | } |
| 522 | |
| 523 | sub generate_embed_h { |
| 524 | my ($all, $api, $ext, $core)= @_; |
| 525 | |
| 526 | my $em= open_buf_out(my $embed_buffer); |
| 527 | |
| 528 | print $em <<~'END'; |
| 529 | /* (Doing namespace management portably in C is really gross.) */ |
| 530 | |
| 531 | /* By defining PERL_NO_SHORT_NAMES (not done by default) the short forms |
| 532 | * (like warn instead of Perl_warn) for the API are not defined. |
| 533 | * Not defining the short forms is a good thing for cleaner embedding. |
| 534 | * BEWARE that a bunch of macros don't have long names, so either must be |
| 535 | * added or don't use them if you define this symbol */ |
| 536 | |
| 537 | #ifndef PERL_NO_SHORT_NAMES |
| 538 | |
| 539 | /* Hide global symbols */ |
| 540 | |
| 541 | END |
| 542 | |
| 543 | embed_h($em, '', $api); |
| 544 | embed_h($em, '#if defined(PERL_CORE) || defined(PERL_EXT)', $ext); |
| 545 | embed_h($em, '#if defined(PERL_CORE)', $core); |
| 546 | |
| 547 | print $em <<~'END'; |
| 548 | |
| 549 | #endif /* #ifndef PERL_NO_SHORT_NAMES */ |
| 550 | |
| 551 | #if !defined(PERL_CORE) |
| 552 | /* Compatibility stubs. Compile extensions with -DPERL_NOCOMPAT to |
| 553 | * disable them. |
| 554 | */ |
| 555 | # define sv_setptrobj(rv,ptr,name) sv_setref_iv(rv,name,PTR2IV(ptr)) |
| 556 | # define sv_setptrref(rv,ptr) sv_setref_iv(rv,NULL,PTR2IV(ptr)) |
| 557 | #endif |
| 558 | |
| 559 | #if !defined(PERL_CORE) && !defined(PERL_NOCOMPAT) |
| 560 | |
| 561 | /* Compatibility for various misnamed functions. All functions |
| 562 | in the API that begin with "perl_" (not "Perl_") take an explicit |
| 563 | interpreter context pointer. |
| 564 | The following are not like that, but since they had a "perl_" |
| 565 | prefix in previous versions, we provide compatibility macros. |
| 566 | */ |
| 567 | # define perl_atexit(a,b) call_atexit(a,b) |
| 568 | END |
| 569 | |
| 570 | foreach (@$all) { |
| 571 | my $embed= $_->{embed} or next; |
| 572 | my ($flags, $retval, $func, $args) = @{$embed}{qw(flags return_type name args)}; |
| 573 | next unless $flags =~ /O/; |
| 574 | |
| 575 | my $alist = join ",", @az[0..$#$args]; |
| 576 | my $ret = "# define perl_$func($alist) "; |
| 577 | print $em add_indent($ret,"$func($alist)\n"); |
| 578 | } |
| 579 | |
| 580 | my @nocontext; |
| 581 | { |
| 582 | my (%has_va, %has_nocontext); |
| 583 | foreach (@$all) { |
| 584 | my $embed= $_->{embed} |
| 585 | or next; |
| 586 | ++$has_va{$embed->{name}} if @{$embed->{args}} and $embed->{args}[-1] =~ /\.\.\./; |
| 587 | ++$has_nocontext{$1} if $embed->{name} =~ /(.*)_nocontext/; |
| 588 | } |
| 589 | |
| 590 | @nocontext = sort grep { |
| 591 | $has_nocontext{$_} |
| 592 | && !/printf/ # Not clear to me why these are skipped but they are. |
| 593 | } keys %has_va; |
| 594 | } |
| 595 | |
| 596 | print $em <<~'END'; |
| 597 | |
| 598 | /* varargs functions can't be handled with CPP macros. :-( |
| 599 | This provides a set of compatibility functions that don't take |
| 600 | an extra argument but grab the context pointer using the macro |
| 601 | dTHX. |
| 602 | */ |
| 603 | #if defined(MULTIPLICITY) && !defined(PERL_NO_SHORT_NAMES) |
| 604 | END |
| 605 | |
| 606 | foreach (@nocontext) { |
| 607 | print $em indent_define($_, "Perl_${_}_nocontext", " "); |
| 608 | } |
| 609 | |
| 610 | print $em <<~'END'; |
| 611 | #endif |
| 612 | |
| 613 | #endif /* !defined(PERL_CORE) && !defined(PERL_NOCOMPAT) */ |
| 614 | |
| 615 | #if !defined(MULTIPLICITY) |
| 616 | /* undefined symbols, point them back at the usual ones */ |
| 617 | END |
| 618 | |
| 619 | foreach (@nocontext) { |
| 620 | print $em indent_define("Perl_${_}_nocontext", "Perl_$_", " "); |
| 621 | } |
| 622 | |
| 623 | print $em "#endif\n"; |
| 624 | close $em; |
| 625 | |
| 626 | normalize_and_print('embed.h',$embed_buffer) |
| 627 | unless $error_count; |
| 628 | } |
| 629 | |
| 630 | sub generate_embedvar_h { |
| 631 | my $em = open_buf_out(my $embedvar_buffer); |
| 632 | |
| 633 | print $em "#if defined(MULTIPLICITY)\n", |
| 634 | indent_define("vTHX","aTHX"," "); |
| 635 | |
| 636 | |
| 637 | my @intrp = readvars 'intrpvar.h','I'; |
| 638 | #my @globvar = readvars 'perlvars.h','G'; |
| 639 | |
| 640 | |
| 641 | for my $sym (@intrp) { |
| 642 | my $ind = " "; |
| 643 | if ($sym eq 'sawampersand') { |
| 644 | print $em "# if !defined(PL_sawampersand)\n"; |
| 645 | $ind = " "; |
| 646 | } |
| 647 | my $line = multon($sym, 'I', 'vTHX->', $ind); |
| 648 | print $em $line; |
| 649 | if ($sym eq 'sawampersand') { |
| 650 | print $em "# endif /* !defined(PL_sawampersand) */\n"; |
| 651 | } |
| 652 | } |
| 653 | |
| 654 | print $em "#endif /* MULTIPLICITY */\n"; |
| 655 | close $em; |
| 656 | |
| 657 | normalize_and_print('embedvar.h',$embedvar_buffer) |
| 658 | unless $error_count; |
| 659 | } |
| 660 | |
| 661 | sub update_headers { |
| 662 | my ($all, $api, $ext, $core) = setup_embed(); # see regen/embed_lib.pl |
| 663 | generate_proto_h($all); |
| 664 | die_at_end "$unflagged_pointers pointer arguments to clean up\n" if $unflagged_pointers; |
| 665 | generate_embed_h($all, $api, $ext, $core); |
| 666 | generate_embedvar_h(); |
| 667 | die "$error_count errors found" if $error_count; |
| 668 | } |
| 669 | |
| 670 | update_headers() unless caller; |
| 671 | |
| 672 | # ex: set ts=8 sts=4 sw=4 noet: |