was RE: Perl_die() / Perl_croak()

From: "Robin Barker" <Robin.Barker@npl.co.uk>
Message-ID: <2C2E01334A940D4792B3E115F95B7226149377@exchsvr1.npl.ad.local>

p4raw-id: //depot/perl@29259

diff --git a/embed.fnc b/embed.fnc
index 3ac4bc4..0c82dfa 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -131,7 +131,7 @@ ApR |I32    |my_chsize      |int fd|Off_t length
 pR     |OP*    |convert        |I32 optype|I32 flags|NULLOK OP* o
 pM     |PERL_CONTEXT*  |create_eval_scope|U32 flags
 : croak()'s first parm can be NULL.  Otherwise, mod_perl breaks.
-Aprd   |void   |croak          |NULLOK const char* pat|...
+Afprd  |void   |croak          |NULLOK const char* pat|...
 Apr    |void   |vcroak         |NN const char* pat|NULLOK va_list* args
 #if defined(PERL_IMPLICIT_CONTEXT)
 Afnrp  |void   |croak_nocontext|NN const char* pat|...
@@ -180,7 +180,7 @@ Ap  |char*  |delimcpy       |NN char* to|NN const char* toend|NN const char* from \
 pM     |void   |delete_eval_scope
 p      |void   |deprecate      |NN const char* s
 p      |void   |deprecate_old  |NN const char* s
-Ap     |OP*    |die            |NULLOK const char* pat|...
+Afp    |OP*    |die            |NULLOK const char* pat|...
 p      |OP*    |vdie           |NULLOK const char* pat|NULLOK va_list* args
 p      |OP*    |die_where      |NULLOK const char* message|STRLEN msglen
 Ap     |void   |dounwind       |I32 cxix

diff --git a/embed.pl b/embed.pl
index 7d4dbc4..90b5f79 100755 (executable)
--- a/embed.pl
+++ b/embed.pl
@@ -232,10 +232,14 @@ sub write_protos {
            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;

diff --git a/perl.h b/perl.h
index 51f26e4..5fa0da3 100644 (file)
--- a/perl.h
+++ b/perl.h
@@ -3101,6 +3101,13 @@ typedef pthread_key_t    perl_key;
 #  define NORETURN_FUNCTION_END /* NOTREACHED */ return 0
 #endif
 
+/* Some OS warn on NULL format to printf */
+#ifdef PRINTF_FORMAT_NULL_OK
+#  define __attribute__format__null_ok__(x,y,z)  __attribute__format__(x,y,z)
+#else
+#  define __attribute__format__null_ok__(x,y,z)  
+#endif
+
 #ifdef HAS_BUILTIN_EXPECT
 #  define EXPECT(expr,val)                  __builtin_expect(expr,val)
 #else

diff --git a/proto.h b/proto.h
index 11a5fc4..d3a623f 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -226,7 +226,8 @@ PERL_CALLCONV OP*   Perl_convert(pTHX_ I32 optype, I32 flags, OP* o)
 
 PERL_CALLCONV PERL_CONTEXT*    Perl_create_eval_scope(pTHX_ U32 flags);
 PERL_CALLCONV void     Perl_croak(pTHX_ const char* pat, ...)
-                       __attribute__noreturn__;
+                       __attribute__noreturn__
+                       __attribute__format__null_ok__(__printf__,pTHX_1,pTHX_2);
 
 PERL_CALLCONV void     Perl_vcroak(pTHX_ const char* pat, va_list* args)
                        __attribute__noreturn__
@@ -383,7 +384,9 @@ PERL_CALLCONV void  Perl_deprecate(pTHX_ const char* s)
 PERL_CALLCONV void     Perl_deprecate_old(pTHX_ const char* s)
                        __attribute__nonnull__(pTHX_1);
 
-PERL_CALLCONV OP*      Perl_die(pTHX_ const char* pat, ...);
+PERL_CALLCONV OP*      Perl_die(pTHX_ const char* pat, ...)
+                       __attribute__format__null_ok__(__printf__,pTHX_1,pTHX_2);
+
 PERL_CALLCONV OP*      Perl_vdie(pTHX_ const char* pat, va_list* args);
 PERL_CALLCONV OP*      Perl_die_where(pTHX_ const char* message, STRLEN msglen);
 PERL_CALLCONV void     Perl_dounwind(pTHX_ I32 cxix);