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