This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
remove duplicate code and an extra branch in sv_setsv() and
[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                  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_mortalgrow
229     sv_unglob
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     sv_ncmp
259     sv_i_ncmp
260     amagic_ncmp
261     amagic_i_ncmp
262     amagic_cmp
263     amagic_cmp_locale
264     mul128
265     is_an_int
266     div128
267     runops_standard
268     runops_debug
269     check_uni
270     force_next
271     force_version
272     force_word
273     tokeq
274     scan_const
275     scan_formline
276     scan_heredoc
277     scan_ident
278     scan_inputsymbol
279     scan_pat
280     scan_str
281     scan_subst
282     scan_trans
283     scan_word
284     skipspace
285     checkcomma
286     force_ident
287     incline
288     intuit_method
289     intuit_more
290     lop
291     missingterm
292     no_op
293     set_csh
294     sublex_done
295     sublex_push
296     sublex_start
297     uni
298     filter_gets
299     new_constant
300     ao
301     depcom
302     win32_textfilter
303     incl_perldb
304     isa_lookup
305     get_db_sub
306     list_assignment
307     bad_type
308     modkids
309     no_fh_allowed
310     scalarboolean
311     too_few_arguments
312     too_many_arguments
313     null
314     pad_findlex
315     newDEFSVOP
316     gv_ename
317     cv_clone2
318     find_beginning
319     forbid_setid
320     incpush
321     init_interp
322     init_ids
323     init_debugger
324     init_lexer
325     init_main_stash
326     init_perllib
327     init_postdump_symbols
328     init_predump_symbols
329     my_exit_jump
330     nuke_stacks
331     open_script
332     usage
333     validate_suid
334     emulate_eaccess
335     reg
336     reganode
337     regatom
338     regbranch
339     regc
340     reguni
341     regclass
342     regclassutf8
343     regcurly
344     reg_node
345     regpiece
346     reginsert
347     regoptail
348     regset
349     regtail
350     regwhite
351     nextchar
352     dumpuntil
353     scan_commit
354     study_chunk
355     add_data
356     re_croak2
357     regpposixcc
358     clear_re
359     regmatch
360     regrepeat
361     regrepeat_hard
362     regtry
363     reginclass
364     reginclassutf8
365     regcppush
366     regcppop
367     regcp_set_to
368     cache_re
369     restore_pos
370     reghop
371     reghopmaybe
372     dump
373     do_aspawn
374     debprof
375     bset_obj_store
376     new_logop
377     simplify_sort
378     is_handle_constructor
379     do_trans_CC_simple
380     do_trans_CC_count
381     do_trans_CC_complex
382     do_trans_UU_simple
383     do_trans_UU_count
384     do_trans_UU_complex
385     do_trans_UC_simple
386     do_trans_CU_simple
387     do_trans_UC_trivial
388     do_trans_CU_trivial
389     unwind_handler_stack
390     restore_magic
391     restore_rsfp
392     restore_expect
393     restore_lex_expect
394     yydestruct
395     del_sv
396     fprintf
397 );
398
399 for $sym (sort(keys(%global),@staticfuncs)) {
400     print EM embedobj($sym);
401 }
402
403 print EM <<'END';
404
405 #endif  /* PERL_OBJECT */
406
407 /* compatibility stubs */
408
409 #define sv_setptrobj(rv,ptr,name)       sv_setref_iv(rv,name,(IV)ptr)
410 #define sv_setptrref(rv,ptr)            sv_setref_iv(rv,Nullch,(IV)ptr)
411
412 END
413
414 close(EM);
415
416 unlink 'embedvar.h';
417 open(EM, '> embedvar.h')
418     or die "Can't create embedvar.h: $!\n";
419
420 print EM <<'END';
421 /* !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!! 
422    This file is built by embed.pl from global.sym, pp.sym, intrpvar.h,
423    perlvars.h and thrdvar.h.  Any changes made here will be lost!
424 */
425
426 /* (Doing namespace management portably in C is really gross.) */
427
428 /* Put interpreter-specific symbols into a struct? */
429
430 #ifdef MULTIPLICITY
431
432 #ifndef USE_THREADS
433 /* If we do not have threads then per-thread vars are per-interpreter */
434
435 END
436
437 for $sym (sort keys %thread) {
438     print EM multon($sym,'T','PL_curinterp->');
439 }
440
441 print EM <<'END';
442
443 #endif /* !USE_THREADS */
444
445 /* These are always per-interpreter if there is more than one */
446
447 END
448
449 for $sym (sort keys %intrp) {
450     print EM multon($sym,'I','PL_curinterp->');
451 }
452
453 print EM <<'END';
454
455 #else   /* !MULTIPLICITY */
456
457 END
458
459 for $sym (sort keys %intrp) {
460     print EM multoff($sym,'I');
461 }
462
463 print EM <<'END';
464
465 #ifndef USE_THREADS
466
467 END
468
469 for $sym (sort keys %thread) {
470     print EM multoff($sym,'T');
471 }
472
473 print EM <<'END';
474
475 #endif /* USE_THREADS */
476
477 /* Hide what would have been interpreter-specific symbols? */
478
479 END
480
481 for $sym (sort keys %intrp) {
482     print EM embedvar($sym);
483 }
484
485 print EM <<'END';
486
487 #ifndef USE_THREADS
488
489 END
490
491 for $sym (sort keys %thread) {
492     print EM embedvar($sym);
493 }
494
495 print EM <<'END';
496
497 #endif /* USE_THREADS */
498 #endif /* MULTIPLICITY */
499
500 /* Now same trickey for per-thread variables */
501
502 #ifdef USE_THREADS
503
504 END
505
506 for $sym (sort keys %thread) {
507     print EM multon($sym,'T','thr->');
508 }
509
510 print EM <<'END';
511
512 #endif /* USE_THREADS */
513
514 #ifdef PERL_GLOBAL_STRUCT
515
516 END
517
518 for $sym (sort keys %globvar) {
519     print EM multon($sym,'G','PL_Vars.');
520 }
521
522 print EM <<'END';
523
524 #else /* !PERL_GLOBAL_STRUCT */
525
526 END
527
528 for $sym (sort keys %globvar) {
529     print EM multoff($sym,'G');
530 }
531
532 print EM <<'END';
533
534 END
535
536 for $sym (sort keys %globvar) {
537     print EM embedvar($sym);
538 }
539
540 print EM <<'END';
541
542 #endif /* PERL_GLOBAL_STRUCT */
543
544 END
545
546 print EM <<'END';
547
548 #ifdef PERL_POLLUTE             /* disabled by default in 5.006 */
549
550 END
551
552 for $sym (sort @extvars) {
553     print EM hide($sym,"PL_$sym");
554 }
555
556 print EM <<'END';
557
558 #endif /* PERL_POLLUTE */
559 END
560
561
562 close(EM);
563
564 unlink 'objXSUB.h';
565 open(OBX, '> objXSUB.h')
566     or die "Can't create objXSUB.h: $!\n";
567
568 print OBX <<'EOT';
569 /* !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!! 
570    This file is built by embed.pl from global.sym, pp.sym, intrpvar.h,
571    perlvars.h and thrdvar.h.  Any changes made here will be lost!
572 */
573
574 #ifndef __objXSUB_h__
575 #define __objXSUB_h__
576
577 /* Variables */
578
579 EOT
580
581 foreach my $sym (sort(keys(%intrp),
582                       keys(%thread),
583                       keys(%globvar),
584                       keys(%objvar)))
585 {
586     print OBX objxsub_var($sym);
587 }
588
589 print OBX <<'EOT';
590
591 /* Functions */
592
593 EOT
594
595
596 for $sym (sort(keys(%global),@staticfuncs)) {
597     print OBX objxsub_func($sym);
598 }
599
600
601 print OBX <<'EOT';
602
603 #endif  /* __objXSUB_h__ */
604 EOT
605
606 close(OBX);