This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
phase 2 of PERL_OBJECT cleanup; objXSUB.h autogeneration
[perl5.git] / 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);