embed.pl

   1 #!/usr/bin/perl -w
   2
   3 require 5.003;
   4
   5 # XXX others that may need adding
   6 #       warnhook
   7 #       hints
   8 #       copline
   9 my @extvars = qw(sv_undef sv_yes sv_no na dowarn
  10                  curcop compiling
  11                  tainting tainted stack_base stack_sp sv_arenaroot
  12                  curstash DBsub DBsingle debstash
  13                  rsfp
  14                  stdingv
  15                  defgv
  16                  errgv
  17                  rsfp_filters
  18                  perldb
  19                  diehook
  20                  dirty
  21                  perl_destruct_level
  22                 );
  23
  24 sub readsyms (\%$) {
  25     my ($syms, $file) = @_;
  26     local (*FILE, $_);
  27     open(FILE, "< $file")
  28         or die "embed.pl: Can't open $file: $!\n";
  29     while (<FILE>) {
  30         s/[ \t]*#.*//;          # Delete comments.
  31         if (/^\s*(\S+)\s*$/) {
  32             my $sym = $1;
  33             warn "duplicate symbol $sym while processing $file\n"
  34                 if exists $$syms{$sym};
  35             $$syms{$sym} = 1;
  36         }
  37     }
  38     close(FILE);
  39 }
  40
  41 readsyms %global, 'global.sym';
  42 readsyms %global, 'pp.sym';
  43
  44 sub readvars(\%$$) {
  45     my ($syms, $file,$pre) = @_;
  46     local (*FILE, $_);
  47     open(FILE, "< $file")
  48         or die "embed.pl: Can't open $file: $!\n";
  49     while (<FILE>) {
  50         s/[ \t]*#.*//;          # Delete comments.
  51         if (/PERLVARI?C?\($pre(\w+)/) {
  52             my $sym = $1;
  53             warn "duplicate symbol $sym while processing $file\n"
  54                 if exists $$syms{$sym};
  55             $$syms{$sym} = 1;
  56         }
  57     }
  58     close(FILE);
  59 }
  60
  61 my %intrp;
  62 my %thread;
  63
  64 readvars %intrp,  'intrpvar.h','I';
  65 readvars %thread, 'thrdvar.h','T';
  66 readvars %globvar, 'perlvars.h','G';
  67
  68 foreach my $sym (sort keys %intrp)
  69  {
  70   if (exists $global{$sym})
  71    {
  72     delete $global{$sym};
  73     warn "$sym in {global,pp}.sym as well as intrpvar.h\n";
  74    }
  75  }
  76
  77 foreach my $sym (sort keys %globvar)
  78  {
  79   if (exists $global{$sym})
  80    {
  81     delete $global{$sym};
  82     warn "$sym in {global,pp}.sym as well as perlvars.h\n";
  83    }
  84  }
  85
  86 foreach my $sym (sort keys %thread)
  87  {
  88   warn "$sym in intrpvar.h as well as thrdvar.h\n" if exists $intrp{$sym};
  89   if (exists $global{$sym})
  90    {
  91     delete $global{$sym};
  92     warn "$sym in {global,pp}.sym as well as thrdvar.h\n";
  93    }
  94  }
  95
  96 sub hide ($$) {
  97     my ($from, $to) = @_;
  98     my $t = int(length($from) / 8);
  99     "#define $from" . "\t" x ($t < 3 ? 3 - $t : 1) . "$to\n";
 100 }
 101 sub embed ($) {
 102     my ($sym) = @_;
 103     hide($sym, "Perl_$sym");
 104 }
 105 sub embedobj ($) {
 106     my ($sym) = @_;
 107     hide($sym, $sym =~ /^perl_/i ? "CPerlObj::$sym" : "CPerlObj::Perl_$sym");
 108 }
 109 sub embedvar ($) {
 110     my ($sym) = @_;
 111 #   hide($sym, "Perl_$sym");
 112     return '';
 113 }
 114
 115 sub multon ($$$) {
 116     my ($sym,$pre,$ptr) = @_;
 117     hide("PL_$sym", "($ptr$pre$sym)");
 118 }
 119 sub multoff ($$) {
 120     my ($sym,$pre) = @_;
 121     return hide("PL_$pre$sym", "PL_$sym");
 122 }
 123
 124 unlink 'embed.h';
 125 open(EM, '> embed.h')
 126     or die "Can't create embed.h: $!\n";
 127
 128 print EM <<'END';
 129 /* !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
 130    This file is built by embed.pl from global.sym, pp.sym, intrpvar.h,
 131    and thrdvar.h.  Any changes made here will be lost!
 132 */
 133
 134 /* (Doing namespace management portably in C is really gross.) */
 135
 136 /* NO_EMBED is no longer supported. i.e. EMBED is always active. */
 137
 138 /* Hide global symbols */
 139
 140 #if !defined(PERL_OBJECT)
 141
 142 END
 143
 144 for $sym (sort keys %global) {
 145     print EM embed($sym);
 146 }
 147
 148 print EM <<'END';
 149
 150 #else   /* PERL_OBJECT */
 151
 152 END
 153
 154 # XXX these should be in a *.sym file
 155 my @extras = qw(
 156     perl_init_i18nl10n
 157     perl_init_i18nl14n
 158     perl_new_collate
 159     perl_new_ctype
 160     perl_new_numeric
 161     perl_set_numeric_local
 162     perl_set_numeric_standard
 163     perl_construct
 164     perl_destruct
 165     perl_atexit
 166     perl_free
 167     perl_parse
 168     perl_run
 169     perl_get_sv
 170     perl_get_av
 171     perl_get_hv
 172     perl_get_cv
 173     perl_call_argv
 174     perl_call_pv
 175     perl_call_method
 176     perl_call_sv
 177     perl_eval_pv
 178     perl_eval_sv
 179     perl_require_pv
 180
 181     hsplit
 182     hfreeentries
 183     more_he
 184     new_he
 185     del_he
 186     save_hek
 187     mess_alloc
 188     gv_init_sv
 189     save_scalar_at
 190     asIV
 191     asUV
 192     more_sv
 193     more_xiv
 194     more_xnv
 195     more_xpv
 196     more_xrv
 197     new_xiv
 198     new_xnv
 199     new_xpv
 200     new_xrv
 201     del_xiv
 202     del_xnv
 203     del_xpv
 204     del_xrv
 205     sv_mortalgrow
 206     sv_unglob
 207     sv_check_thinkfirst
 208     avhv_index_sv
 209     do_report_used
 210     do_clean_objs
 211     do_clean_named_objs
 212     do_clean_all
 213     not_a_number
 214     my_safemalloc
 215     visit
 216     qsortsv
 217     sortcv
 218     save_magic
 219     magic_methpack
 220     magic_methcall
 221     magic_methcall
 222     doform
 223     doencodes
 224     refto
 225     seed
 226     docatch
 227     dofindlabel
 228     doparseform
 229     dopoptoeval
 230     dopoptolabel
 231     dopoptoloop
 232     dopoptosub
 233     dopoptosub_at
 234     save_lines
 235     doeval
 236     amagic_cmp
 237     amagic_cmp_locale
 238     mul128
 239     is_an_int
 240     div128
 241     runops_standard
 242     runops_debug
 243     check_uni
 244     force_next
 245     force_version
 246     force_word
 247     tokeq
 248     scan_const
 249     scan_formline
 250     scan_heredoc
 251     scan_ident
 252     scan_inputsymbol
 253     scan_pat
 254     scan_str
 255     scan_subst
 256     scan_trans
 257     scan_word
 258     skipspace
 259     checkcomma
 260     force_ident
 261     incline
 262     intuit_method
 263     intuit_more
 264     lop
 265     missingterm
 266     no_op
 267     set_csh
 268     sublex_done
 269     sublex_push
 270     sublex_start
 271     uni
 272     filter_gets
 273     new_constant
 274     ao
 275     depcom
 276     win32_textfilter
 277     incl_perldb
 278     isa_lookup
 279     get_db_sub
 280     list_assignment
 281     bad_type
 282     modkids
 283     no_fh_allowed
 284     scalarboolean
 285     too_few_arguments
 286     too_many_arguments
 287     null
 288     pad_findlex
 289     newDEFSVOP
 290     gv_ename
 291     cv_clone2
 292     find_beginning
 293     forbid_setid
 294     incpush
 295     init_interp
 296     init_ids
 297     init_debugger
 298     init_lexer
 299     init_main_stash
 300     init_perllib
 301     init_postdump_symbols
 302     init_predump_symbols
 303     my_exit_jump
 304     nuke_stacks
 305     open_script
 306     usage
 307     validate_suid
 308     emulate_eaccess
 309     reg
 310     reganode
 311     regatom
 312     regbranch
 313     regc
 314     reguni
 315     regclass
 316     regclassutf8
 317     regcurly
 318     reg_node
 319     regpiece
 320     reginsert
 321     regoptail
 322     regset
 323     regtail
 324     regwhite
 325     nextchar
 326     dumpuntil
 327     scan_commit
 328     study_chunk
 329     add_data
 330     re_croak2
 331     regmatch
 332     regrepeat
 333     regrepeat_hard
 334     regtry
 335     reginclass
 336     reginclassutf8
 337     regcppush
 338     regcppop
 339     regcp_set_to
 340     cache_re
 341     reghop
 342     reghopmaybe
 343     dump
 344     do_aspawn
 345     debprof
 346     bset_obj_store
 347     new_logop
 348     do_trans_CC_simple
 349     do_trans_CC_count
 350     do_trans_CC_complex
 351     do_trans_UU_simple
 352     do_trans_UU_count
 353     do_trans_UU_complex
 354     do_trans_UC_simple
 355     do_trans_CU_simple
 356     do_trans_UC_trivial
 357     do_trans_CU_trivial
 358     unwind_handler_stack
 359     restore_magic
 360     restore_rsfp
 361     restore_expect
 362     restore_lex_expect
 363     yydestruct
 364     del_sv
 365     fprintf
 366 );
 367
 368 my %skip;
 369
 370 for $sym (qw[
 371     utf8skip
 372           ])
 373 {
 374     $skip{$sym}++;
 375 }
 376
 377 for $sym (sort(keys(%global),@extras)) {
 378     next if exists $skip{$sym};
 379     print EM embedobj($sym);
 380 }
 381
 382 print EM <<'END';
 383
 384 #endif  /* PERL_OBJECT */
 385
 386 END
 387
 388 close(EM);
 389
 390 unlink 'embedvar.h';
 391 open(EM, '> embedvar.h')
 392     or die "Can't create embedvar.h: $!\n";
 393
 394 print EM <<'END';
 395 /* !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
 396    This file is built by embed.pl from global.sym, pp.sym, intrpvar.h,
 397    and thrdvar.h.  Any changes made here will be lost!
 398 */
 399
 400 /* (Doing namespace management portably in C is really gross.) */
 401
 402 /* Put interpreter-specific symbols into a struct? */
 403
 404 #ifdef MULTIPLICITY
 405
 406 #ifndef USE_THREADS
 407 /* If we do not have threads then per-thread vars are per-interpreter */
 408
 409 END
 410
 411 for $sym (sort keys %thread) {
 412     print EM multon($sym,'T','PL_curinterp->');
 413 }
 414
 415 print EM <<'END';
 416
 417 #endif /* !USE_THREADS */
 418
 419 /* These are always per-interpreter if there is more than one */
 420
 421 END
 422
 423 for $sym (sort keys %intrp) {
 424     print EM multon($sym,'I','PL_curinterp->');
 425 }
 426
 427 print EM <<'END';
 428
 429 #else   /* !MULTIPLICITY */
 430
 431 END
 432
 433 for $sym (sort keys %intrp) {
 434     print EM multoff($sym,'I');
 435 }
 436
 437 print EM <<'END';
 438
 439 #ifndef USE_THREADS
 440
 441 END
 442
 443 for $sym (sort keys %thread) {
 444     print EM multoff($sym,'T');
 445 }
 446
 447 print EM <<'END';
 448
 449 #endif /* USE_THREADS */
 450
 451 /* Hide what would have been interpreter-specific symbols? */
 452
 453 END
 454
 455 for $sym (sort keys %intrp) {
 456     print EM embedvar($sym);
 457 }
 458
 459 print EM <<'END';
 460
 461 #ifndef USE_THREADS
 462
 463 END
 464
 465 for $sym (sort keys %thread) {
 466     print EM embedvar($sym);
 467 }
 468
 469 print EM <<'END';
 470
 471 #endif /* USE_THREADS */
 472 #endif /* MULTIPLICITY */
 473
 474 /* Now same trickey for per-thread variables */
 475
 476 #ifdef USE_THREADS
 477
 478 END
 479
 480 for $sym (sort keys %thread) {
 481     print EM multon($sym,'T','thr->');
 482 }
 483
 484 print EM <<'END';
 485
 486 #endif /* USE_THREADS */
 487
 488 #ifdef PERL_GLOBAL_STRUCT
 489
 490 END
 491
 492 for $sym (sort keys %globvar) {
 493     print EM multon($sym,'G','PL_Vars.');
 494 }
 495
 496 print EM <<'END';
 497
 498 #else /* !PERL_GLOBAL_STRUCT */
 499
 500 END
 501
 502 for $sym (sort keys %globvar) {
 503     print EM multoff($sym,'G');
 504 }
 505
 506 print EM <<'END';
 507
 508 END
 509
 510 for $sym (sort keys %globvar) {
 511     print EM embedvar($sym);
 512 }
 513
 514 print EM <<'END';
 515
 516 #endif /* PERL_GLOBAL_STRUCT */
 517
 518 END
 519
 520 print EM <<'END';
 521
 522 #if 0 /* ndef MIN_PERL_DEFINE */        /* unsupported in 5.006 */
 523
 524 END
 525
 526 for $sym (sort @extvars) {
 527     print EM hide($sym,"PL_$sym");
 528 }
 529
 530 print EM <<'END';
 531
 532 #endif /* MIN_PERL_DEFINE */
 533 END
 534
 535
 536 close(EM);