Tweaks to get Test::Builder::Tester's tests to work in the core.

[p5sagit/p5-mst-13.2.git] / embed.pl

diff --git a/embed.pl b/embed.pl
index 50ec17f..a88016c 100755 (executable)
--- a/embed.pl
+++ b/embed.pl
@@ -24,6 +24,7 @@ sub do_not_edit ($)
     $years =~ s/1999,/1999,\n  / if length $years > 40;
 
     my $warning = <<EOW;
+ -*- buffer-read-only: t -*-
 
    $file
 
@@ -79,7 +80,7 @@ sub walk_table (&@) {
        $F = $filename;
     }
     else {
-       safer_unlink $filename;
+       safer_unlink $filename if $filename ne '/dev/null';
        open F, ">$filename" or die "Can't open $filename: $!";
        binmode F;
        $F = \*F;
@@ -120,7 +121,7 @@ sub munge_c_files () {
        if (@_ > 1) {
            $functions->{$_[2]} = \@_ if $_[@_-1] =~ /\.\.\./;
        }
-    } '/dev/null', '';
+    } '/dev/null', '', '';
     local $^I = '.bak';
     while (<>) {
 #      if (/^#\s*include\s+"perl.h"/) {
@@ -193,7 +194,13 @@ sub write_protos {
            my $n;
            for my $arg ( @args ) {
                ++$n;
+               if ( $arg =~ /\*/ && $arg !~ /\b(NN|NULLOK)\b/ ) {
+                   warn "$func: $arg needs NN or NULLOK\n";
+                   our $unflagged_pointers;
+                   ++$unflagged_pointers;
+               }
                push( @nonnull, $n ) if ( $arg =~ s/\s*\bNN\b\s+// );
+               $arg =~ s/\s*\bNULLOK\b\s+//; # strip NULLOK with no effect
            }
            $ret .= join ", ", @args;
        }
@@ -201,23 +208,37 @@ sub write_protos {
            $ret .= "void" if !$has_context;
        }
        $ret .= ")";
-       $ret .= " __attribute__((noreturn))" if $flags =~ /r/;
-       $ret .= "\n\t\t\t__attribute__((malloc)) __attribute__((warn_unused_result))" if $flags =~ /a/;
-       $ret .= "\n\t\t\t__attribute__((pure))" if $flags =~ /P/;
+       my @attrs;
+       if ( $flags =~ /r/ ) {
+           push @attrs, "__attribute__noreturn__";
+       }
+       if ( $flags =~ /a/ ) {
+           push @attrs, "__attribute__malloc__";
+           $flags .= "R"; # All allocing must check return value
+       }
+       if ( $flags =~ /R/ ) {
+           push @attrs, "__attribute__warn_unused_result__";
+       }
+       if ( $flags =~ /P/ ) {
+           push @attrs, "__attribute__pure__";
+       }
        if( $flags =~ /f/ ) {
            my $prefix = $has_context ? 'pTHX_' : '';
            my $args = scalar @args;
-           $ret .= sprintf "\n\t\t\t__attribute__format__(__printf__,%s%d,%s%d)",
+           push @attrs, sprintf "__attribute__format__(__printf__,%s%d,%s%d)",
                                    $prefix, $args - 1, $prefix, $args;
        }
-       $ret .= "\n\t\t\t__attribute__((nonnull))" if $flags =~ /N/;
        if ( @nonnull ) {
            my @pos = map { $has_context ? "pTHX_$_" : $_ } @nonnull;
-           $ret .= sprintf( "\n\t\t\t__attribute__((nonnull(%s)))", join( ",", @pos ) );
+           push @attrs, map { sprintf( "__attribute__nonnull__(%s)", $_ ) } @pos;
+       }
+       if ( @attrs ) {
+           $ret .= "\n";
+           $ret .= join( "\n", map { "\t\t\t$_" } @attrs );
        }
        $ret .= ";";
        $ret .= ' */' if $flags =~ /m/;
-       $ret .= "\n";
+       $ret .= @attrs ? "\n\n" : "\n";
     }
     $ret;
 }
@@ -236,8 +257,10 @@ sub write_global_sym {
     $ret;
 }
 
-walk_table(\&write_protos,     "proto.h", undef);
-walk_table(\&write_global_sym, "global.sym", undef);
+our $unflagged_pointers;
+walk_table(\&write_protos,     "proto.h", undef, "/* ex: set ro: */\n");
+warn "$unflagged_pointers pointer arguments to clean up\n" if $unflagged_pointers;
+walk_table(\&write_global_sym, "global.sym", undef, "# ex: set ro:\n");
 
 # XXX others that may need adding
 #       warnhook
@@ -587,6 +610,7 @@ print EM <<'END';
 #  define Perl_sv_setpvf_mg_nocontext  Perl_sv_setpvf_mg
 #endif
 
+/* ex: set ro: */
 END
 
 close(EM) or die "Error closing EM: $!";
@@ -696,6 +720,8 @@ for $sym (sort @extvars) {
 print EM <<'END';
 
 #endif /* PERL_POLLUTE */
+
+/* ex: set ro: */
 END
 
 close(EM) or die "Error closing EM: $!";
@@ -776,10 +802,27 @@ EXTCONST void * const PL_force_link_funcs[] = {
 #define PERLVARIC(v,t,i) PERLVAR(v,t)
 #define PERLVARISC(v,i) PERLVAR(v,char)
 
+/* In Tru64 (__DEC && __osf__) the cc option -std1 causes that one
+ * cannot cast between void pointers and function pointers without
+ * info level warnings.  The PL_force_link_funcs[] would cause a few
+ * hundred of those warnings.  In code one can circumnavigate this by using
+ * unions that overlay the different pointers, but in declarations one
+ * cannot use this trick.  Therefore we just disable the warning here
+ * for the duration of the PL_force_link_funcs[] declaration. */
+
+#if defined(__DECC) && defined(__osf__)
+#pragma message save
+#pragma message disable (nonstandcast)
+#endif
+
 #include "thrdvar.h"
 #include "intrpvar.h"
 #include "perlvars.h"
 
+#if defined(__DECC) && defined(__osf__)
+#pragma message restore
+#endif
+
 #undef PERLVAR
 #undef PERLVARA
 #undef PERLVARI
@@ -815,6 +858,7 @@ print CAPIH <<'EOT';
 
 #endif /* __perlapi_h__ */
 
+/* ex: set ro: */
 EOT
 close CAPIH or die "Error closing CAPIH: $!";
 
@@ -891,6 +935,8 @@ unsigned char** Perl_Gfold_locale_ptr(pTHX) {
 END_EXTERN_C
 
 #endif /* MULTIPLICITY */
+
+/* ex: set ro: */
 EOT
 
 close(CAPI) or die "Error closing CAPI: $!";
@@ -915,3 +961,5 @@ my %vfuncs = qw(
     Perl_dump_indent           Perl_dump_vindent
     Perl_default_protect       Perl_vdefault_protect
 );
+
+# ex: set ts=8 sts=4 sw=4 noet: