This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
Move 'make check' in pods/ to using Pod::Checker
[perl5.git] / embed.pl
diff --git a/embed.pl b/embed.pl
index 7d4dbc4..3204f97 100755 (executable)
--- a/embed.pl
+++ b/embed.pl
@@ -23,7 +23,7 @@ sub do_not_edit ($)
 {
     my $file = shift;
 
 {
     my $file = shift;
 
-    my $years = '1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006';
+    my $years = '1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008';
 
     $years =~ s/1999,/1999,\n  / if length $years > 40;
 
 
     $years =~ s/1999,/1999,\n  / if length $years > 40;
 
@@ -39,7 +39,7 @@ sub do_not_edit ($)
 
 !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
 This file is built by embed.pl from data in embed.fnc, embed.pl,
 
 !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
 This file is built by embed.pl from data in embed.fnc, embed.pl,
-pp.sym, intrpvar.h, perlvars.h and thrdvar.h.
+pp.sym, intrpvar.h, and perlvars.h.
 Any changes made here will be lost!
 
 Edit those files and run 'make regen_headers' to effect changes.
 Any changes made here will be lost!
 
 Edit those files and run 'make regen_headers' to effect changes.
@@ -50,7 +50,9 @@ EOW
 
 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
 
 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.
+was the only entrance to the tower; ...
+
+    [p.577 of _The Lord of the Rings_, III/x: "The Voice of Saruman"]
 
 
 EOW
 
 
 EOW
@@ -79,15 +81,12 @@ sub walk_table (&@) {
     defined $leader or $leader = do_not_edit ($filename);
     my $trailer = shift;
     my $F;
     defined $leader or $leader = do_not_edit ($filename);
     my $trailer = shift;
     my $F;
-    local *F;
     if (ref $filename) {       # filehandle
        $F = $filename;
     }
     else {
     if (ref $filename) {       # filehandle
        $F = $filename;
     }
     else {
-       safer_unlink $filename if $filename ne '/dev/null';
-       open F, ">$filename" or die "Can't open $filename: $!";
-       binmode F;
-       $F = \*F;
+       # safer_unlink $filename if $filename ne '/dev/null';
+       $F = safer_open("$filename-new");
     }
     print $F $leader if $leader;
     seek IN, 0, 0;             # so we may restart
     }
     print $F $leader if $leader;
     seek IN, 0, 0;             # so we may restart
@@ -111,7 +110,8 @@ sub walk_table (&@) {
     }
     print $F $trailer if $trailer;
     unless (ref $filename) {
     }
     print $F $trailer if $trailer;
     unless (ref $filename) {
-       close $F or die "Error closing $filename: $!";
+       safer_close($F);
+       rename_if_different("$filename-new", $filename);
     }
 }
 
     }
 }
 
@@ -156,13 +156,15 @@ sub write_protos {
        $ret .= "$arg\n";
     }
     else {
        $ret .= "$arg\n";
     }
     else {
-       my ($flags,$retval,$func,@args) = @_;
+       my ($flags,$retval,$plain_func,@args) = @_;
        my @nonnull;
        my $has_context = ( $flags !~ /n/ );
        my $never_returns = ( $flags =~ /r/ );
        my $commented_out = ( $flags =~ /m/ );
        my $is_malloc = ( $flags =~ /a/ );
        my $can_ignore = ( $flags !~ /R/ ) && !$is_malloc;
        my @nonnull;
        my $has_context = ( $flags !~ /n/ );
        my $never_returns = ( $flags =~ /r/ );
        my $commented_out = ( $flags =~ /m/ );
        my $is_malloc = ( $flags =~ /a/ );
        my $can_ignore = ( $flags !~ /R/ ) && !$is_malloc;
+       my @names_of_nn;
+       my $func;
 
        my $splint_flags = "";
        if ( $SPLINT && !$commented_out ) {
 
        my $splint_flags = "";
        if ( $SPLINT && !$commented_out ) {
@@ -174,12 +176,14 @@ sub write_protos {
 
        if ($flags =~ /s/) {
            $retval = "STATIC $splint_flags$retval";
 
        if ($flags =~ /s/) {
            $retval = "STATIC $splint_flags$retval";
-           $func = "S_$func";
+           $func = "S_$plain_func";
        }
        else {
            $retval = "PERL_CALLCONV $splint_flags$retval";
        }
        else {
            $retval = "PERL_CALLCONV $splint_flags$retval";
-           if ($flags =~ /p/) {
-               $func = "Perl_$func";
+           if ($flags =~ /[bp]/) {
+               $func = "Perl_$plain_func";
+           } else {
+               $func = $plain_func;
            }
        }
        $ret .= "$retval\t$func(";
            }
        }
        $ret .= "$retval\t$func(";
@@ -205,12 +209,16 @@ sub write_protos {
                my $temp_arg = $arg;
                $temp_arg =~ s/\*//g;
                $temp_arg =~ s/\s*\bstruct\b\s*/ /g;
                my $temp_arg = $arg;
                $temp_arg =~ s/\*//g;
                $temp_arg =~ s/\s*\bstruct\b\s*/ /g;
-               if ( ($temp_arg ne "...") && ($temp_arg !~ /\w+\s+\w+/) ) {
-                   warn "$func: $arg doesn't have a name\n";
+               if ( ($temp_arg ne "...")
+                    && ($temp_arg !~ /\w+\s+(\w+)(?:\[\d+\])?\s*$/) ) {
+                   warn "$func: $arg ($n) doesn't have a name\n";
                }
                if ( $SPLINT && $nullok && !$commented_out ) {
                    $arg = '/*@null@*/ ' . $arg;
                }
                }
                if ( $SPLINT && $nullok && !$commented_out ) {
                    $arg = '/*@null@*/ ' . $arg;
                }
+               if (defined $1 && $nn) {
+                   push @names_of_nn, $1;
+               }
            }
            $ret .= join ", ", @args;
        }
            }
            $ret .= join ", ", @args;
        }
@@ -232,10 +240,14 @@ sub write_protos {
            push @attrs, "__attribute__pure__";
        }
        if( $flags =~ /f/ ) {
            push @attrs, "__attribute__pure__";
        }
        if( $flags =~ /f/ ) {
-           my $prefix = $has_context ? 'pTHX_' : '';
-           my $args = scalar @args;
-           push @attrs, sprintf "__attribute__format__(__printf__,%s%d,%s%d)",
-                                   $prefix, $args - 1, $prefix, $args;
+           my $prefix  = $has_context ? 'pTHX_' : '';
+           my $args    = scalar @args;
+           my $pat     = $args - 1;
+           my $macro   = @nonnull && $nonnull[-1] == $pat  
+                               ? '__attribute__format__'
+                               : '__attribute__format__null_ok__';
+           push @attrs, sprintf "%s(__printf__,%s%d,%s%d)", $macro,
+                               $prefix, $pat, $prefix, $args;
        }
        if ( @nonnull ) {
            my @pos = map { $has_context ? "pTHX_$_" : $_ } @nonnull;
        }
        if ( @nonnull ) {
            my @pos = map { $has_context ? "pTHX_$_" : $_ } @nonnull;
@@ -247,6 +259,10 @@ sub write_protos {
        }
        $ret .= ";";
        $ret = "/* $ret */" if $commented_out;
        }
        $ret .= ";";
        $ret = "/* $ret */" if $commented_out;
+       if (@names_of_nn) {
+           $ret .= "\n#define PERL_ARGS_ASSERT_\U$plain_func\E\t\\\n\t"
+               . join '; ', map "assert($_)", @names_of_nn;
+       }
        $ret .= @attrs ? "\n\n" : "\n";
     }
     $ret;
        $ret .= @attrs ? "\n\n" : "\n";
     }
     $ret;
@@ -308,7 +324,7 @@ sub readsyms (\%$) {
        s/[ \t]*#.*//;          # Delete comments.
        if (/^\s*(\S+)\s*$/) {
            my $sym = $1;
        s/[ \t]*#.*//;          # Delete comments.
        if (/^\s*(\S+)\s*$/) {
            my $sym = $1;
-           warn "duplicate symbol $sym while processing $file\n"
+           warn "duplicate symbol $sym while processing $file line $.\n"
                if exists $$syms{$sym};
            $$syms{$sym} = 1;
        }
                if exists $$syms{$sym};
            $$syms{$sym} = 1;
        }
@@ -329,7 +345,7 @@ sub readvars(\%$$@) {
        if (/PERLVARA?I?S?C?\($pre(\w+)/) {
            my $sym = $1;
            $sym = $pre . $sym if $keep_pre;
        if (/PERLVARA?I?S?C?\($pre(\w+)/) {
            my $sym = $1;
            $sym = $pre . $sym if $keep_pre;
-           warn "duplicate symbol $sym while processing $file\n"
+           warn "duplicate symbol $sym while processing $file line $.\n"
                if exists $$syms{$sym};
            $$syms{$sym} = $pre || 1;
        }
                if exists $$syms{$sym};
            $$syms{$sym} = $pre || 1;
        }
@@ -338,17 +354,12 @@ sub readvars(\%$$@) {
 }
 
 my %intrp;
 }
 
 my %intrp;
-my %thread;
 my %globvar;
 
 readvars %intrp,  'intrpvar.h','I';
 my %globvar;
 
 readvars %intrp,  'intrpvar.h','I';
-readvars %thread, 'thrdvar.h','T';
 readvars %globvar, 'perlvars.h','G';
 
 my $sym;
 readvars %globvar, 'perlvars.h','G';
 
 my $sym;
-foreach $sym (sort keys %thread) {
-  warn "$sym in intrpvar.h as well as thrdvar.h\n" if exists $intrp{$sym};
-}
 
 sub undefine ($) {
     my ($sym) = @_;
 
 sub undefine ($) {
     my ($sym) = @_;
@@ -377,11 +388,9 @@ sub multoff ($$) {
     return hide("PL_$pre$sym", "PL_$sym");
 }
 
     return hide("PL_$pre$sym", "PL_$sym");
 }
 
-safer_unlink 'embed.h';
-open(EM, '> embed.h') or die "Can't create embed.h: $!\n";
-binmode EM;
+my $em = safer_open('embed.h-new');
 
 
-print EM do_not_edit ("embed.h"), <<'END';
+print $em do_not_edit ("embed.h"), <<'END';
 
 /* (Doing namespace management portably in C is really gross.) */
 
 
 /* (Doing namespace management portably in C is really gross.) */
 
@@ -445,18 +454,18 @@ walk_table {
     # Remember the new state.
     $ifdef_state = $new_ifdef_state;
     $ret;
     # Remember the new state.
     $ifdef_state = $new_ifdef_state;
     $ret;
-} \*EM, "";
+} $em, "";
 
 if ($ifdef_state) {
 
 if ($ifdef_state) {
-    print EM "#endif\n";
+    print $em "#endif\n";
 }
 
 for $sym (sort keys %ppsym) {
     $sym =~ s/^Perl_//;
 }
 
 for $sym (sort keys %ppsym) {
     $sym =~ s/^Perl_//;
-    print EM hide($sym, "Perl_$sym");
+    print $em hide($sym, "Perl_$sym");
 }
 
 }
 
-print EM <<'END';
+print $em <<'END';
 
 #else  /* PERL_IMPLICIT_CONTEXT */
 
 
 #else  /* PERL_IMPLICIT_CONTEXT */
 
@@ -523,26 +532,26 @@ walk_table {
     # Remember the new state.
     $ifdef_state = $new_ifdef_state;
     $ret;
     # Remember the new state.
     $ifdef_state = $new_ifdef_state;
     $ret;
-} \*EM, "";
+} $em, "";
 
 if ($ifdef_state) {
 
 if ($ifdef_state) {
-    print EM "#endif\n";
+    print $em "#endif\n";
 }
 
 for $sym (sort keys %ppsym) {
     $sym =~ s/^Perl_//;
     if ($sym =~ /^ck_/) {
 }
 
 for $sym (sort keys %ppsym) {
     $sym =~ s/^Perl_//;
     if ($sym =~ /^ck_/) {
-       print EM hide("$sym(a)", "Perl_$sym(aTHX_ a)");
+       print $em hide("$sym(a)", "Perl_$sym(aTHX_ a)");
     }
     elsif ($sym =~ /^pp_/) {
     }
     elsif ($sym =~ /^pp_/) {
-       print EM hide("$sym()", "Perl_$sym(aTHX)");
+       print $em hide("$sym()", "Perl_$sym(aTHX)");
     }
     else {
        warn "Illegal symbol '$sym' in pp.sym";
     }
 }
 
     }
     else {
        warn "Illegal symbol '$sym' in pp.sym";
     }
 }
 
-print EM <<'END';
+print $em <<'END';
 
 #endif /* PERL_IMPLICIT_CONTEXT */
 
 
 #endif /* PERL_IMPLICIT_CONTEXT */
 
@@ -550,7 +559,7 @@ print EM <<'END';
 
 END
 
 
 END
 
-print EM <<'END';
+print $em <<'END';
 
 /* Compatibility stubs.  Compile extensions with -DPERL_NOCOMPAT to
    disable them.
 
 /* Compatibility stubs.  Compile extensions with -DPERL_NOCOMPAT to
    disable them.
@@ -630,14 +639,12 @@ print EM <<'END';
 /* ex: set ro: */
 END
 
 /* ex: set ro: */
 END
 
-close(EM) or die "Error closing EM: $!";
+safer_close($em);
+rename_if_different('embed.h-new', 'embed.h');
 
 
-safer_unlink 'embedvar.h';
-open(EM, '> embedvar.h')
-    or die "Can't create embedvar.h: $!\n";
-binmode EM;
+$em = safer_open('embedvar.h-new');
 
 
-print EM do_not_edit ("embedvar.h"), <<'END';
+print $em do_not_edit ("embedvar.h"), <<'END';
 
 /* (Doing namespace management portably in C is really gross.) */
 
 
 /* (Doing namespace management portably in C is really gross.) */
 
@@ -665,21 +672,11 @@ print EM do_not_edit ("embedvar.h"), <<'END';
 
 END
 
 
 END
 
-for $sym (sort keys %thread) {
-    print EM multon($sym,'T','vTHX->');
-}
-
-print EM <<'END';
-
-/* cases 2 and 3 above */
-
-END
-
 for $sym (sort keys %intrp) {
 for $sym (sort keys %intrp) {
-    print EM multon($sym,'I','vTHX->');
+    print $em multon($sym,'I','vTHX->');
 }
 
 }
 
-print EM <<'END';
+print $em <<'END';
 
 #else  /* !MULTIPLICITY */
 
 
 #else  /* !MULTIPLICITY */
 
@@ -688,18 +685,14 @@ print EM <<'END';
 END
 
 for $sym (sort keys %intrp) {
 END
 
 for $sym (sort keys %intrp) {
-    print EM multoff($sym,'I');
+    print $em multoff($sym,'I');
 }
 
 }
 
-print EM <<'END';
+print $em <<'END';
 
 END
 
 
 END
 
-for $sym (sort keys %thread) {
-    print EM multoff($sym,'T');
-}
-
-print EM <<'END';
+print $em <<'END';
 
 #endif /* MULTIPLICITY */
 
 
 #endif /* MULTIPLICITY */
 
@@ -708,21 +701,21 @@ print EM <<'END';
 END
 
 for $sym (sort keys %globvar) {
 END
 
 for $sym (sort keys %globvar) {
-    print EM multon($sym,   'G','my_vars->');
-    print EM multon("G$sym",'', 'my_vars->');
+    print $em multon($sym,   'G','my_vars->');
+    print $em multon("G$sym",'', 'my_vars->');
 }
 
 }
 
-print EM <<'END';
+print $em <<'END';
 
 #else /* !PERL_GLOBAL_STRUCT */
 
 END
 
 for $sym (sort keys %globvar) {
 
 #else /* !PERL_GLOBAL_STRUCT */
 
 END
 
 for $sym (sort keys %globvar) {
-    print EM multoff($sym,'G');
+    print $em multoff($sym,'G');
 }
 
 }
 
-print EM <<'END';
+print $em <<'END';
 
 #endif /* PERL_GLOBAL_STRUCT */
 
 
 #endif /* PERL_GLOBAL_STRUCT */
 
@@ -731,26 +724,23 @@ print EM <<'END';
 END
 
 for $sym (sort @extvars) {
 END
 
 for $sym (sort @extvars) {
-    print EM hide($sym,"PL_$sym");
+    print $em hide($sym,"PL_$sym");
 }
 
 }
 
-print EM <<'END';
+print $em <<'END';
 
 #endif /* PERL_POLLUTE */
 
 /* ex: set ro: */
 END
 
 
 #endif /* PERL_POLLUTE */
 
 /* ex: set ro: */
 END
 
-close(EM) or die "Error closing EM: $!";
+safer_close($em);
+rename_if_different('embedvar.h-new', 'embedvar.h');
 
 
-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;
+my $capi = safer_open('perlapi.c-new');
+my $capih = safer_open('perlapi.h-new');
 
 
-print CAPIH do_not_edit ("perlapi.h"), <<'EOT';
+print $capih do_not_edit ("perlapi.h"), <<'EOT';
 
 /* declare accessor functions for Perl variables */
 #ifndef __perlapi_h__
 
 /* declare accessor functions for Perl variables */
 #ifndef __perlapi_h__
@@ -773,7 +763,6 @@ START_EXTERN_C
 #define PERLVARISC(v,i)        typedef const char PL_##v##_t[sizeof(i)];       \
                        EXTERN_C PL_##v##_t* Perl_##v##_ptr(pTHX);
 
 #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"
 #include "perlvars.h"
 
 #include "intrpvar.h"
 #include "perlvars.h"
 
@@ -832,7 +821,6 @@ EXTCONST void * const PL_force_link_funcs[] = {
 #pragma message disable (nonstandcast)
 #endif
 
 #pragma message disable (nonstandcast)
 #endif
 
-#include "thrdvar.h"
 #include "intrpvar.h"
 #include "perlvars.h"
 
 #include "intrpvar.h"
 #include "perlvars.h"
 
@@ -857,18 +845,14 @@ END_EXTERN_C
 EOT
 
 foreach $sym (sort keys %intrp) {
 EOT
 
 foreach $sym (sort keys %intrp) {
-    print CAPIH bincompat_var('I',$sym);
-}
-
-foreach $sym (sort keys %thread) {
-    print CAPIH bincompat_var('T',$sym);
+    print $capih bincompat_var('I',$sym);
 }
 
 foreach $sym (sort keys %globvar) {
 }
 
 foreach $sym (sort keys %globvar) {
-    print CAPIH bincompat_var('G',$sym);
+    print $capih bincompat_var('G',$sym);
 }
 
 }
 
-print CAPIH <<'EOT';
+print $capih <<'EOT';
 
 #endif /* !PERL_CORE */
 #endif /* MULTIPLICITY */
 
 #endif /* !PERL_CORE */
 #endif /* MULTIPLICITY */
@@ -877,9 +861,10 @@ print CAPIH <<'EOT';
 
 /* ex: set ro: */
 EOT
 
 /* ex: set ro: */
 EOT
-close CAPIH or die "Error closing CAPIH: $!";
+safer_close($capih);
+rename_if_different('perlapi.h-new', 'perlapi.h');
 
 
-print CAPI do_not_edit ("perlapi.c"), <<'EOT';
+print $capi do_not_edit ("perlapi.c"), <<'EOT';
 
 #include "EXTERN.h"
 #include "perl.h"
 
 #include "EXTERN.h"
 #include "perl.h"
@@ -906,7 +891,6 @@ START_EXTERN_C
 #define PERLVARISC(v,i)        PL_##v##_t* Perl_##v##_ptr(pTHX)                \
                        { dVAR; PERL_UNUSED_CONTEXT; return &(aTHX->v); }
 
 #define PERLVARISC(v,i)        PL_##v##_t* Perl_##v##_ptr(pTHX)                \
                        { dVAR; PERL_UNUSED_CONTEXT; return &(aTHX->v); }
 
-#include "thrdvar.h"
 #include "intrpvar.h"
 
 #undef PERLVAR
 #include "intrpvar.h"
 
 #undef PERLVAR
@@ -959,7 +943,8 @@ END_EXTERN_C
 /* ex: set ro: */
 EOT
 
 /* ex: set ro: */
 EOT
 
-close(CAPI) or die "Error closing CAPI: $!";
+safer_close($capi);
+rename_if_different('perlapi.c-new', 'perlapi.c');
 
 # functions that take va_list* for implementing vararg functions
 # NOTE: makedef.pl must be updated if you add symbols to %vfuncs
 
 # functions that take va_list* for implementing vararg functions
 # NOTE: makedef.pl must be updated if you add symbols to %vfuncs
Unnamed repository; edit this file 'description' to name the repository.