X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=embed.pl;h=612e19c44555ea15d35e7d8cc8758e22cae04017;hb=2af232bd5d3f6bd1ea08b47ef83cc57f75149871;hp=d66311b01330dbf431a9f4223902adcc661de1ff;hpb=b445a7d9de59a3c21efaf046071b5c6b77dbd8b2;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/embed.pl b/embed.pl
index d66311b..612e19c 100755
--- a/embed.pl
+++ b/embed.pl
@@ -3,6 +3,11 @@
 require 5.003;	# keep this compatible, an old perl is all we may have before
                 # we build the new one
 
+BEGIN {
+    # Get function prototypes
+    require 'regen_lib.pl';
+}
+
 #
 # See database of global and static function prototypes in embed.fnc
 # This is used to generate prototype headers under various configurations,
@@ -13,11 +18,16 @@ require 5.003;	# keep this compatible, an old perl is all we may have before
 sub do_not_edit ($)
 {
     my $file = shift;
+    
+    my $years = '1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005';
+
+    $years =~ s/1999,/1999,\n  / if length $years > 40;
+
     my $warning = <<EOW;
 
    $file
 
-   Copyright (c) 1997-2002, Larry Wall
+   Copyright (C) $years, by Larry Wall and others
 
    You may distribute under the terms of either the GNU General Public
    License or the Artistic License, as specified in the README file.
@@ -31,6 +41,15 @@ Edit those files and run 'make regen_headers' to effect changes.
 
 EOW
 
+    $warning .= <<EOW if $file eq 'perlapi.c';
+
+Up to the threshold of the door there mounted a flight of twenty-seven
+broad stairs, hewn by some unknown art of the same black stone.  This
+was the only entrance to the tower.
+
+
+EOW
+
     if ($file =~ m:\.[ch]$:) {
 	$warning =~ s:^: * :gm;
 	$warning =~ s: +$::gm;
@@ -60,8 +79,9 @@ sub walk_table (&@) {
 	$F = $filename;
     }
     else {
-	unlink $filename;
+	safer_unlink $filename;
 	open F, ">$filename" or die "Can't open $filename: $!";
+	binmode F;
 	$F = \*F;
     }
     print $F $leader if $leader;
@@ -73,6 +93,7 @@ sub walk_table (&@) {
 	    $_ .= <IN>;
 	    chomp;
 	}
+	s/\s+$//;
 	my @args;
 	if (/^\s*(#|$)/) {
 	    @args = $_;
@@ -84,7 +105,9 @@ sub walk_table (&@) {
         print $F @outs; # $function->(@args) is not 5.003
     }
     print $F $trailer if $trailer;
-    close $F unless ref $filename;
+    unless (ref $filename) {
+	close $F or die "Error closing $filename: $!";
+    }
 }
 
 sub munge_c_files () {
@@ -176,10 +199,8 @@ sub write_protos {
 	if( $flags =~ /f/ ) {
 	    my $prefix = $flags =~ /n/ ? '' : 'pTHX_';
 	    my $args = scalar @args;
-	    $ret .= "\n#ifdef CHECK_FORMAT\n";
-	    $ret .= sprintf " __attribute__((format(printf,%s%d,%s%d)))",
+	    $ret .= sprintf "\n\t__attribute__format__(__printf__,%s%d,%s%d)",
 				    $prefix, $args - 1, $prefix, $args;
-	    $ret .= "\n#endif\n";
 	}
 	$ret .= ";";
 	$ret .= ' */' if $flags =~ /m/;
@@ -193,8 +214,9 @@ sub write_global_sym {
     my $ret = "";
     if (@_ > 1) {
 	my ($flags,$retval,$func,@args) = @_;
-	if ($flags =~ /A/ && $flags !~ /[xm]/) { # public API, so export
-	    $func = "Perl_$func" if $flags =~ /p/;
+	if ($flags =~ /[AX]/ && $flags !~ /[xm]/
+	    || $flags =~ /b/) { # public API, so export
+	    $func = "Perl_$func" if $flags =~ /[pbX]/;
 	    $ret = "$func\n";
 	}
     }
@@ -212,7 +234,7 @@ my @extvars = qw(sv_undef sv_yes sv_no na dowarn
                  curcop compiling
                  tainting tainted stack_base stack_sp sv_arenaroot
 		 no_modify
-                 curstash DBsub DBsingle debstash
+                 curstash DBsub DBsingle DBassertion debstash
                  rsfp
                  stdingv
 		 defgv
@@ -252,7 +274,7 @@ sub readvars(\%$$@) {
 	or die "embed.pl: Can't open $file: $!\n";
     while (<FILE>) {
 	s/[ \t]*#.*//;		# Delete comments.
-	if (/PERLVARA?I?C?\($pre(\w+)/) {
+	if (/PERLVARA?I?S?C?\($pre(\w+)/) {
 	    my $sym = $1;
 	    $sym = $pre . $sym if $keep_pre;
 	    warn "duplicate symbol $sym while processing $file\n"
@@ -302,14 +324,19 @@ sub multoff ($$) {
     return hide("PL_$pre$sym", "PL_$sym");
 }
 
-unlink 'embed.h';
+safer_unlink 'embed.h';
 open(EM, '> embed.h') or die "Can't create embed.h: $!\n";
+binmode EM;
 
 print EM do_not_edit ("embed.h"), <<'END';
 
 /* (Doing namespace management portably in C is really gross.) */
 
-/* NO_EMBED is no longer supported. i.e. EMBED is always active. */
+/* By defining PERL_NO_SHORT_NAMES (not done by default) the short forms
+ * (like warn instead of Perl_warn) for the API are not defined.
+ * Not defining the short forms is a good thing for cleaner embedding. */
+
+#ifndef PERL_NO_SHORT_NAMES
 
 /* Hide global symbols */
 
@@ -317,8 +344,19 @@ print EM do_not_edit ("embed.h"), <<'END';
 
 END
 
+# Try to elimiate lots of repeated
+# #ifdef PERL_CORE
+# foo
+# #endif
+# #ifdef PERL_CORE
+# bar
+# #endif
+# by tracking state and merging foo and bar into one block.
+my $ifdef_state = '';
+
 walk_table {
     my $ret = "";
+    my $new_ifdef_state = '';
     if (@_ == 1) {
 	my $arg = shift;
 	$ret .= "$arg\n" if $arg =~ /^#\s*(if|ifn?def|else|endif)\b/;
@@ -333,10 +371,33 @@ walk_table {
 		$ret .= hide($func,"Perl_$func");
 	    }
 	}
+	if ($ret ne '' && $flags !~ /A/) {
+	    if ($flags =~ /E/) {
+		$new_ifdef_state
+		    = "#if defined(PERL_CORE) || defined(PERL_EXT)\n";
+	    }
+	    else {
+		$new_ifdef_state = "#ifdef PERL_CORE\n";
+	    }
+
+	    if ($new_ifdef_state ne $ifdef_state) {
+		$ret = $new_ifdef_state . $ret;
+	    }
+        }
+    }
+    if ($ifdef_state && $new_ifdef_state ne $ifdef_state) {
+	# Close the old one ahead of opening the new one.
+	$ret = "#endif\n$ret";
     }
+    # Remember the new state.
+    $ifdef_state = $new_ifdef_state;
     $ret;
 } \*EM, "";
 
+if ($ifdef_state) {
+    print EM "#endif\n";
+}
+
 for $sym (sort keys %ppsym) {
     $sym =~ s/^Perl_//;
     print EM hide($sym, "Perl_$sym");
@@ -350,8 +411,10 @@ END
 
 my @az = ('a'..'z');
 
+$ifdef_state = '';
 walk_table {
     my $ret = "";
+    my $new_ifdef_state = '';
     if (@_ == 1) {
 	my $arg = shift;
 	$ret .= "$arg\n" if $arg =~ /^#\s*(if|ifn?def|else|endif)\b/;
@@ -386,10 +449,33 @@ walk_table {
 		$ret .= $alist . ")\n";
 	    }
 	}
+	unless ($flags =~ /A/) {
+	    if ($flags =~ /E/) {
+		$new_ifdef_state
+		    = "#if defined(PERL_CORE) || defined(PERL_EXT)\n";
+	    }
+	    else {
+		$new_ifdef_state = "#ifdef PERL_CORE\n";
+	    }
+
+	    if ($new_ifdef_state ne $ifdef_state) {
+		$ret = $new_ifdef_state . $ret;
+	    }
+        }
     }
+    if ($ifdef_state && $new_ifdef_state ne $ifdef_state) {
+	# Close the old one ahead of opening the new one.
+	$ret = "#endif\n$ret";
+    }
+    # Remember the new state.
+    $ifdef_state = $new_ifdef_state;
     $ret;
 } \*EM, "";
 
+if ($ifdef_state) {
+    print EM "#endif\n";
+}
+
 for $sym (sort keys %ppsym) {
     $sym =~ s/^Perl_//;
     if ($sym =~ /^ck_/) {
@@ -407,6 +493,8 @@ print EM <<'END';
 
 #endif	/* PERL_IMPLICIT_CONTEXT */
 
+#endif	/* #ifndef PERL_NO_SHORT_NAMES */
+
 END
 
 print EM <<'END';
@@ -451,7 +539,7 @@ print EM <<'END';
    an extra argument but grab the context pointer using the macro
    dTHX.
  */
-#if defined(PERL_IMPLICIT_CONTEXT)
+#if defined(PERL_IMPLICIT_CONTEXT) && !defined(PERL_NO_SHORT_NAMES)
 #  define croak				Perl_croak_nocontext
 #  define deb				Perl_deb_nocontext
 #  define die				Perl_die_nocontext
@@ -488,11 +576,12 @@ print EM <<'END';
 
 END
 
-close(EM);
+close(EM) or die "Error closing EM: $!";
 
-unlink 'embedvar.h';
+safer_unlink 'embedvar.h';
 open(EM, '> embedvar.h')
     or die "Can't create embedvar.h: $!\n";
+binmode EM;
 
 print EM do_not_edit ("embedvar.h"), <<'END';
 
@@ -565,7 +654,8 @@ print EM <<'END';
 END
 
 for $sym (sort keys %globvar) {
-    print EM multon($sym,'G','PL_Vars.');
+    print EM multon($sym,   'G','my_vars->');
+    print EM multon("G$sym",'', 'my_vars->');
 }
 
 print EM <<'END';
@@ -595,12 +685,14 @@ print EM <<'END';
 #endif /* PERL_POLLUTE */
 END
 
-close(EM);
+close(EM) or die "Error closing EM: $!";
 
-unlink 'perlapi.h';
-unlink 'perlapi.c';
+safer_unlink 'perlapi.h';
+safer_unlink 'perlapi.c';
 open(CAPI, '> perlapi.c') or die "Can't create perlapi.c: $!\n";
+binmode CAPI;
 open(CAPIH, '> perlapi.h') or die "Can't create perlapi.h: $!\n";
+binmode CAPIH;
 
 print CAPIH do_not_edit ("perlapi.h"), <<'EOT';
 
@@ -616,11 +708,14 @@ START_EXTERN_C
 #undef PERLVARA
 #undef PERLVARI
 #undef PERLVARIC
+#undef PERLVARISC
 #define PERLVAR(v,t)	EXTERN_C t* Perl_##v##_ptr(pTHX);
 #define PERLVARA(v,n,t)	typedef t PL_##v##_t[n];			\
 			EXTERN_C PL_##v##_t* Perl_##v##_ptr(pTHX);
 #define PERLVARI(v,t,i)	PERLVAR(v,t)
 #define PERLVARIC(v,t,i) PERLVAR(v, const t)
+#define PERLVARISC(v,i)	typedef const char PL_##v##_t[sizeof(i)];	\
+			EXTERN_C PL_##v##_t* Perl_##v##_ptr(pTHX);
 
 #include "thrdvar.h"
 #include "intrpvar.h"
@@ -630,6 +725,16 @@ START_EXTERN_C
 #undef PERLVARA
 #undef PERLVARI
 #undef PERLVARIC
+#undef PERLVARISC
+
+#ifndef PERL_GLOBAL_STRUCT
+EXTERN_C Perl_ppaddr_t** Perl_Gppaddr_ptr(pTHX);
+EXTERN_C Perl_check_t**  Perl_Gcheck_ptr(pTHX);
+EXTERN_C unsigned char** Perl_Gfold_locale_ptr(pTHX);
+#define Perl_ppaddr_ptr      Perl_Gppaddr_ptr
+#define Perl_check_ptr       Perl_Gcheck_ptr
+#define Perl_fold_locale_ptr Perl_Gfold_locale_ptr
+#endif
 
 END_EXTERN_C
 
@@ -645,9 +750,9 @@ END_EXTERN_C
 START_EXTERN_C
 
 #ifndef DOINIT
-EXT void *PL_force_link_funcs[];
+EXTCONST void * const PL_force_link_funcs[];
 #else
-EXT void *PL_force_link_funcs[] = {
+EXTCONST void * const PL_force_link_funcs[] = {
 #undef PERLVAR
 #undef PERLVARA
 #undef PERLVARI
@@ -656,6 +761,7 @@ EXT void *PL_force_link_funcs[] = {
 #define PERLVARA(v,n,t)	PERLVAR(v,t)
 #define PERLVARI(v,t,i)	PERLVAR(v,t)
 #define PERLVARIC(v,t,i) PERLVAR(v,t)
+#define PERLVARISC(v,i) PERLVAR(v,char)
 
 #include "thrdvar.h"
 #include "intrpvar.h"
@@ -665,6 +771,7 @@ EXT void *PL_force_link_funcs[] = {
 #undef PERLVARA
 #undef PERLVARI
 #undef PERLVARIC
+#undef PERLVARISC
 };
 #endif	/* DOINIT */
 
@@ -696,7 +803,7 @@ print CAPIH <<'EOT';
 #endif /* __perlapi_h__ */
 
 EOT
-close CAPIH;
+close CAPIH or die "Error closing CAPIH: $!";
 
 print CAPI do_not_edit ("perlapi.c"), <<'EOT';
 
@@ -713,14 +820,17 @@ START_EXTERN_C
 #undef PERLVARA
 #undef PERLVARI
 #undef PERLVARIC
+#undef PERLVARISC
 
 #define PERLVAR(v,t)	t* Perl_##v##_ptr(pTHX)				\
-			{ return &(aTHX->v); }
+			{ dVAR; return &(aTHX->v); }
 #define PERLVARA(v,n,t)	PL_##v##_t* Perl_##v##_ptr(pTHX)		\
-			{ return &(aTHX->v); }
+			{ dVAR; return &(aTHX->v); }
 
 #define PERLVARI(v,t,i)	PERLVAR(v,t)
 #define PERLVARIC(v,t,i) PERLVAR(v, const t)
+#define PERLVARISC(v,i)	PL_##v##_t* Perl_##v##_ptr(pTHX)		\
+			{ dVAR; return &(aTHX->v); }
 
 #include "thrdvar.h"
 #include "intrpvar.h"
@@ -728,25 +838,49 @@ START_EXTERN_C
 #undef PERLVAR
 #undef PERLVARA
 #define PERLVAR(v,t)	t* Perl_##v##_ptr(pTHX)				\
-			{ return &(PL_##v); }
+			{ dVAR; return &(PL_##v); }
 #define PERLVARA(v,n,t)	PL_##v##_t* Perl_##v##_ptr(pTHX)		\
-			{ return &(PL_##v); }
+			{ dVAR; return &(PL_##v); }
 #undef PERLVARIC
-#define PERLVARIC(v,t,i)	const t* Perl_##v##_ptr(pTHX)		\
+#undef PERLVARISC
+#define PERLVARIC(v,t,i)	\
+			const t* Perl_##v##_ptr(pTHX)		\
 			{ return (const t *)&(PL_##v); }
+#define PERLVARISC(v,i)	PL_##v##_t* Perl_##v##_ptr(pTHX)	\
+			{ dVAR; return &(PL_##v); }
 #include "perlvars.h"
 
 #undef PERLVAR
 #undef PERLVARA
 #undef PERLVARI
 #undef PERLVARIC
+#undef PERLVARISC
+
+#ifndef PERL_GLOBAL_STRUCT
+/* A few evil special cases.  Could probably macrofy this. */
+#undef PL_ppaddr
+#undef PL_check
+#undef PL_fold_locale
+Perl_ppaddr_t** Perl_Gppaddr_ptr(pTHX) {
+    static const Perl_ppaddr_t* ppaddr_ptr = PL_ppaddr;
+    return (Perl_ppaddr_t**)&ppaddr_ptr;
+}
+Perl_check_t**  Perl_Gcheck_ptr(pTHX) {
+    static const Perl_check_t* check_ptr  = PL_check;
+    return (Perl_check_t**)&check_ptr;
+}
+unsigned char** Perl_Gfold_locale_ptr(pTHX) {
+    static const unsigned char* fold_locale_ptr = PL_fold_locale;
+    return (unsigned char**)&fold_locale_ptr;
+}
+#endif
 
 END_EXTERN_C
 
 #endif /* MULTIPLICITY */
 EOT
 
-close(CAPI);
+close(CAPI) or die "Error closing CAPI: $!";
 
 # functions that take va_list* for implementing vararg functions
 # NOTE: makedef.pl must be updated if you add symbols to %vfuncs