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