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     reghop
 364     reghopmaybe
 365     dump
 366     do_aspawn
 367     debprof
 368     bset_obj_store
 369     new_logop
 370     do_trans_CC_simple
 371     do_trans_CC_count
 372     do_trans_CC_complex
 373     do_trans_UU_simple
 374     do_trans_UU_count
 375     do_trans_UU_complex
 376     do_trans_UC_simple
 377     do_trans_CU_simple
 378     do_trans_UC_trivial
 379     do_trans_CU_trivial
 380     unwind_handler_stack
 381     restore_magic
 382     restore_rsfp
 383     restore_expect
 384     restore_lex_expect
 385     yydestruct
 386     del_sv
 387     fprintf
 388 );
 389
 390 for $sym (sort(keys(%global),@staticfuncs)) {
 391     print EM embedobj($sym);
 392 }
 393
 394 print EM <<'END';
 395
 396 #endif  /* PERL_OBJECT */
 397
 398 END
 399
 400 close(EM);
 401
 402 unlink 'embedvar.h';
 403 open(EM, '> embedvar.h')
 404     or die "Can't create embedvar.h: $!\n";
 405
 406 print EM <<'END';
 407 /* !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
 408    This file is built by embed.pl from global.sym, pp.sym, intrpvar.h,
 409    perlvars.h and thrdvar.h.  Any changes made here will be lost!
 410 */
 411
 412 /* (Doing namespace management portably in C is really gross.) */
 413
 414 /* Put interpreter-specific symbols into a struct? */
 415
 416 #ifdef MULTIPLICITY
 417
 418 #ifndef USE_THREADS
 419 /* If we do not have threads then per-thread vars are per-interpreter */
 420
 421 END
 422
 423 for $sym (sort keys %thread) {
 424     print EM multon($sym,'T','PL_curinterp->');
 425 }
 426
 427 print EM <<'END';
 428
 429 #endif /* !USE_THREADS */
 430
 431 /* These are always per-interpreter if there is more than one */
 432
 433 END
 434
 435 for $sym (sort keys %intrp) {
 436     print EM multon($sym,'I','PL_curinterp->');
 437 }
 438
 439 print EM <<'END';
 440
 441 #else   /* !MULTIPLICITY */
 442
 443 END
 444
 445 for $sym (sort keys %intrp) {
 446     print EM multoff($sym,'I');
 447 }
 448
 449 print EM <<'END';
 450
 451 #ifndef USE_THREADS
 452
 453 END
 454
 455 for $sym (sort keys %thread) {
 456     print EM multoff($sym,'T');
 457 }
 458
 459 print EM <<'END';
 460
 461 #endif /* USE_THREADS */
 462
 463 /* Hide what would have been interpreter-specific symbols? */
 464
 465 END
 466
 467 for $sym (sort keys %intrp) {
 468     print EM embedvar($sym);
 469 }
 470
 471 print EM <<'END';
 472
 473 #ifndef USE_THREADS
 474
 475 END
 476
 477 for $sym (sort keys %thread) {
 478     print EM embedvar($sym);
 479 }
 480
 481 print EM <<'END';
 482
 483 #endif /* USE_THREADS */
 484 #endif /* MULTIPLICITY */
 485
 486 /* Now same trickey for per-thread variables */
 487
 488 #ifdef USE_THREADS
 489
 490 END
 491
 492 for $sym (sort keys %thread) {
 493     print EM multon($sym,'T','thr->');
 494 }
 495
 496 print EM <<'END';
 497
 498 #endif /* USE_THREADS */
 499
 500 #ifdef PERL_GLOBAL_STRUCT
 501
 502 END
 503
 504 for $sym (sort keys %globvar) {
 505     print EM multon($sym,'G','PL_Vars.');
 506 }
 507
 508 print EM <<'END';
 509
 510 #else /* !PERL_GLOBAL_STRUCT */
 511
 512 END
 513
 514 for $sym (sort keys %globvar) {
 515     print EM multoff($sym,'G');
 516 }
 517
 518 print EM <<'END';
 519
 520 END
 521
 522 for $sym (sort keys %globvar) {
 523     print EM embedvar($sym);
 524 }
 525
 526 print EM <<'END';
 527
 528 #endif /* PERL_GLOBAL_STRUCT */
 529
 530 END
 531
 532 print EM <<'END';
 533
 534 #ifdef PERL_POLLUTE             /* unsupported in 5.006 */
 535
 536 END
 537
 538 for $sym (sort @extvars) {
 539     print EM hide($sym,"PL_$sym");
 540 }
 541
 542 print EM <<'END';
 543
 544 #endif /* MIN_PERL_DEFINE */
 545 END
 546
 547
 548 close(EM);
 549
 550 unlink 'objXSUB.h';
 551 open(OBX, '> objXSUB.h')
 552     or die "Can't create objXSUB.h: $!\n";
 553
 554 print OBX <<'EOT';
 555 /* !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
 556    This file is built by embed.pl from global.sym, pp.sym, intrpvar.h,
 557    perlvars.h and thrdvar.h.  Any changes made here will be lost!
 558 */
 559
 560 #ifndef __objXSUB_h__
 561 #define __objXSUB_h__
 562
 563 /* Variables */
 564
 565 EOT
 566
 567 foreach my $sym (sort(keys(%intrp),
 568                       keys(%thread),
 569                       keys(%globvar),
 570                       keys(%objvar)))
 571 {
 572     print OBX objxsub_var($sym);
 573 }
 574
 575 print OBX <<'EOT';
 576
 577 /* Functions */
 578
 579 EOT
 580
 581
 582 for $sym (sort(keys(%global),@staticfuncs)) {
 583     print OBX objxsub_func($sym);
 584 }
 585
 586
 587 print OBX <<'EOT';
 588
 589 #endif  /* __objXSUB_h__ */
 590 EOT
 591
 592 close(OBX);