summaryrefslogtreecommitdiff
path: root/embed.pl
diff options
context:
space:
mode:
Diffstat (limited to 'embed.pl')
-rwxr-xr-xembed.pl216
1 files changed, 171 insertions, 45 deletions
diff --git a/embed.pl b/embed.pl
index 25ff092996..bdca208dd8 100755
--- a/embed.pl
+++ b/embed.pl
@@ -218,12 +218,12 @@ sub readvars(\%$$@) {
or die "embed.pl: Can't open $file: $!\n";
while (<FILE>) {
s/[ \t]*#.*//; # Delete comments.
- if (/PERLVARI?C?\($pre(\w+)/) {
+ if (/PERLVARA?I?C?\($pre(\w+)/) {
my $sym = $1;
$sym = $pre . $sym if $keep_pre;
warn "duplicate symbol $sym while processing $file\n"
if exists $$syms{$sym};
- $$syms{$sym} = 1;
+ $$syms{$sym} = $pre || 1;
}
}
close(FILE);
@@ -235,12 +235,10 @@ my %thread;
readvars %intrp, 'intrpvar.h','I';
readvars %thread, 'thrdvar.h','T';
readvars %globvar, 'perlvars.h','G';
-readvars %objvar, 'intrpvar.h','pi', 1;
-foreach my $sym (sort keys %thread)
- {
+foreach my $sym (sort keys %thread) {
warn "$sym in intrpvar.h as well as thrdvar.h\n" if exists $intrp{$sym};
- }
+}
sub undefine ($) {
my ($sym) = @_;
@@ -253,9 +251,9 @@ sub hide ($$) {
"#define $from" . "\t" x ($t < 3 ? 3 - $t : 1) . "$to\n";
}
-sub objxsub_var ($) {
- my ($sym) = @_;
- undefine("PL_$sym") . hide("PL_$sym", "pPerl->PL_$sym");
+sub objxsub_var ($$) {
+ my ($pfx, $sym) = @_;
+ undefine("PL_$sym") . hide("PL_$sym", "(*Perl_${pfx}${sym}_ptr(pPerl))");
}
sub embedvar ($) {
@@ -672,12 +670,16 @@ print OBX <<'EOT';
EOT
-foreach my $sym (sort(keys(%intrp),
- keys(%thread),
- keys(%globvar),
- keys(%objvar)))
-{
- print OBX objxsub_var($sym);
+foreach my $sym (sort keys %intrp) {
+ print OBX objxsub_var('I',$sym);
+}
+
+foreach my $sym (sort keys %thread) {
+ print OBX objxsub_var('T',$sym);
+}
+
+foreach my $sym (sort keys %globvar) {
+ print OBX objxsub_var('G',$sym);
}
print OBX <<'EOT';
@@ -720,6 +722,160 @@ EOT
close(OBX);
+unlink 'perlapi.h';
+unlink 'perlapi.c';
+open(CAPI, '> perlapi.c') or die "Can't create perlapi.c: $!\n";
+open(CAPIH, '> perlapi.h') or die "Can't create perlapi.h: $!\n";
+
+print CAPIH <<'EOT';
+/* !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ This file is built by embed.pl from data in embed.pl, pp.sym, intrpvar.h,
+ perlvars.h and thrdvar.h. Any changes made here will be lost!
+*/
+
+#if defined(PERL_OBJECT)
+
+/* declare accessor functions for Perl variables */
+
+START_EXTERN_C
+
+#undef PERLVAR
+#undef PERLVARA
+#undef PERLVARI
+#undef PERLVARIC
+#define PERLVAR(v,t) EXTERN_C t* Perl_##v##_ptr(void *p);
+#define PERLVARA(v,n,t) typedef t PL_##v##_t[n]; \
+ EXTERN_C PL_##v##_t* Perl_##v##_ptr(void *p);
+#define PERLVARI(v,t,i) PERLVAR(v,t)
+#define PERLVARIC(v,t,i) PERLVAR(v,t)
+
+#include "thrdvar.h"
+#include "intrpvar.h"
+#include "perlvars.h"
+
+#undef PERLVAR
+#undef PERLVARA
+#undef PERLVARI
+#undef PERLVARIC
+
+END_EXTERN_C
+
+#endif /* PERL_OBJECT */
+
+EOT
+
+
+print CAPI <<'EOT';
+/* !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ This file is built by embed.pl from data in embed.pl, pp.sym, intrpvar.h,
+ perlvars.h and thrdvar.h. Any changes made here will be lost!
+*/
+
+#include "EXTERN.h"
+#include "perl.h"
+#include "perlapi.h"
+
+#if defined(PERL_OBJECT)
+
+/* accessor functions for Perl variables (provides binary compatibility) */
+START_EXTERN_C
+
+#undef PERLVAR
+#undef PERLVARA
+#undef PERLVARI
+#undef PERLVARIC
+#define PERLVAR(v,t) t* Perl_##v##_ptr(void *p) \
+ { return &(((CPerlObj*)p)->PL_##v); }
+#define PERLVARA(v,n,t) PL_##v##_t* Perl_##v##_ptr(void *p) \
+ { return &(((CPerlObj*)p)->PL_##v); }
+#define PERLVARI(v,t,i) PERLVAR(v,t)
+#define PERLVARIC(v,t,i) PERLVAR(v,t)
+
+#include "thrdvar.h"
+#include "intrpvar.h"
+#include "perlvars.h"
+
+#undef PERLVAR
+#undef PERLVARA
+#undef PERLVARI
+#undef PERLVARIC
+
+EOT
+
+sub emit_func {
+ my ($retval,$func,@args) = @_;
+ my @aargs = @args;
+ for my $a (@aargs) { $a =~ s/^.*\b(\w+)$/$1/ }
+ unshift @args, 'void *pPerl';
+ local $" = ', ';
+ my $return = ($retval =~ /^\s*(void|Free_t|Signal_t)\s*$/ ? '' : 'return ');
+ return <<EOT
+$retval
+$func(@args)
+{
+ $return((CPerlObj*)pPerl)->$func(@aargs);
+}
+EOT
+
+}
+
+# XXXX temporary hack
+for my $sym (qw(
+ perl_construct
+ perl_destruct
+ perl_free
+ perl_run
+ perl_parse
+ ))
+{
+ $skipapi_funcs{$sym}++;
+}
+
+walk_table {
+ my $ret = "";
+ if (@_ == 1) {
+ my $arg = shift;
+ $ret .= "$arg\n" if $arg =~ /^#\s*(if|ifdef|else|endif)\b/;
+ }
+ else {
+ my ($flags,$retval,$func,@args) = @_;
+ return $ret if exists $skipapi_funcs{$func};
+ unless (@args and $args[$#args] =~ /\.\.\./) {
+ unless ($flags =~ /s/) {
+ $ret .= "\n";
+ if ($flags =~ /p/) {
+ $ret .= undefine("Perl_$func");
+ $ret .= emit_func($retval,"Perl_$func",@args);
+ }
+ else {
+ $ret .= undefine($func);
+ $ret .= emit_func($retval,$func,@args);
+ }
+ }
+ }
+ }
+ $ret;
+} \*CAPI;
+
+for $sym (sort keys %ppsym) {
+ $sym =~ s/^Perl_//;
+ print CAPI "\n";
+ print CAPI undefine("Perl_$sym");
+ if ($sym =~ /^ck_/) {
+ print CAPI emit_func('OP *',"Perl_$sym",'OP *o');
+ }
+ else { # pp_foo
+ print CAPI emit_func('OP *',"Perl_$sym");
+ }
+}
+
+print CAPI <<'EOT';
+
+END_EXTERN_C
+
+#endif /* PERL_OBJECT */
+EOT
+
__END__
# Lines are of the form:
@@ -1448,17 +1604,8 @@ pn |void |safexfree |Malloc_t where
#if defined(PERL_GLOBAL_STRUCT)
p |struct perl_vars *|GetVars
#endif
-p |void |yydestruct |void *ptr
p |int |runops_standard
p |int |runops_debug
-
-#if defined(WIN32)
-#if defined(PERL_OBJECT)
-p |int& |ErrorNo
-#else
-p |int* |ErrorNo
-#endif
-#endif
p |void |sv_catpvf_mg |SV *sv|const char* pat|...
p |void |sv_catpv_mg |SV *sv|const char *ptr
p |void |sv_catpvn_mg |SV *sv|const char *ptr|STRLEN len
@@ -1534,8 +1681,6 @@ s |void |save_magic |I32 mgs_ix|SV *sv
s |int |magic_methpack |SV *sv|MAGIC *mg|char *meth
s |int |magic_methcall |SV *sv|MAGIC *mg|char *meth|I32 f \
|int n|SV *val
-s |void |unwind_handler_stack |void *p
-s |void |restore_magic |void *p
#endif
#if defined(PERL_IN_OP_C) || defined(PERL_DECL_PROT)
@@ -1617,20 +1762,10 @@ s |void |save_lines |AV *array|SV *sv
s |OP* |doeval |int gimme|OP** startop
s |PerlIO *|doopen_pmc |const char *name|const char *mode
s |void |qsortsv |SV ** array|size_t num_elts|SVCOMPARE_t f
-s |I32 |sortcv |SV *a|SV *b
-s |I32 |sv_ncmp |SV *a|SV *b
-s |I32 |sv_i_ncmp |SV *a|SV *b
-s |I32 |amagic_ncmp |SV *a|SV *b
-s |I32 |amagic_i_ncmp |SV *a|SV *b
-s |I32 |amagic_cmp |SV *str1|SV *str2
-s |I32 |amagic_cmp_locale|SV *str1|SV *str2
#endif
#if defined(PERL_IN_PP_HOT_C) || defined(PERL_DECL_PROT)
s |CV* |get_db_sub |SV **svp|CV *cv
-# if defined(USE_THREADS)
-s |void |unset_cvowner |void *cvarg
-# endif
#endif
#if defined(PERL_IN_PP_SYS_C) || defined(PERL_DECL_PROT)
@@ -1667,7 +1802,6 @@ s |I32 |add_data |I32 n|char *s
rs |void|re_croak2 |const char* pat1|const char* pat2|...
s |I32 |regpposixcc |I32 value
s |void |checkposixcc
-s |void |clear_re |void *r
#endif
#if defined(PERL_IN_REGEXEC_C) || defined(PERL_DECL_PROT)
@@ -1681,7 +1815,6 @@ s |CHECKPOINT|regcppush |I32 parenfloor
s |char*|regcppop
s |char*|regcp_set_to |I32 ss
s |void |cache_re |regexp *prog
-s |void |restore_pos |void *arg
s |U8* |reghop |U8 *pos|I32 off
s |U8* |reghopmaybe |U8 *pos|I32 off
#endif
@@ -1711,10 +1844,6 @@ s |void |del_xnv |XPVNV* p
s |void |del_xpv |XPV* p
s |void |del_xrv |XRV* p
s |void |sv_unglob |SV* sv
-s |void |do_report_used |SV *sv
-s |void |do_clean_objs |SV *sv
-s |void |do_clean_named_objs|SV *sv
-s |void |do_clean_all |SV *sv
s |void |not_a_number |SV *sv
s |void |visit |SVFUNC_t f
# if defined(PURIFY)
@@ -1770,9 +1899,6 @@ s |void |depcom
s |char* |incl_perldb
s |I32 |utf16_textfilter|int idx|SV *sv|int maxlen
s |I32 |utf16rev_textfilter|int idx|SV *sv|int maxlen
-s |void |restore_rsfp |void *f
-s |void |restore_expect |void *e
-s |void |restore_lex_expect |void *e
# if defined(CRIPPLED_CC)
s |int |uni |I32 f|char *s
# endif
View Lorry Controller Status