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