From 894356b32151f778d4d2915c6db38e5d049b115a Mon Sep 17 00:00:00 2001 From: Gurusamy Sarathy Date: Sat, 22 Jan 2000 10:06:53 +0000 Subject: [PATCH] add patch for printf-style format typechecks (from Robin Barker ); fixes for problems so identified p4raw-id: //depot/perl@4836 --- XSUB.h | 2 +- doio.c | 2 +- dump.c | 16 +++---- embed.pl | 61 +++++++++++++----------- gv.c | 2 +- op.c | 20 ++++---- perl.c | 10 ++-- perl.h | 16 +++++++ pp_ctl.c | 9 ++-- pp_hot.c | 2 +- pp_sys.c | 4 +- proto.h | 156 +++++++++++++++++++++++++++++++++++++++++++++++++++----------- regcomp.c | 10 ++-- sv.c | 2 +- toke.c | 4 +- 15 files changed, 224 insertions(+), 92 deletions(-) diff --git a/XSUB.h b/XSUB.h index 53ff98d..a1d2257 100644 --- a/XSUB.h +++ b/XSUB.h @@ -77,7 +77,7 @@ vn = "VERSION"), FALSE); \ } \ if (tmpsv && (!SvOK(tmpsv) || strNE(XS_VERSION, SvPV(tmpsv, n_a)))) \ - Perl_croak(aTHX_ "%s object version %s does not match %s%s%s%s %_", \ + Perl_croak(aTHX_ "%s object version %s does not match %s%s%s%s %"SVf,\ module, XS_VERSION, \ vn ? "$" : "", vn ? module : "", vn ? "::" : "", \ vn ? vn : "bootstrap parameter", tmpsv); \ diff --git a/doio.c b/doio.c index d2385f0..08264a9 100644 --- a/doio.c +++ b/doio.c @@ -217,7 +217,7 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, if (*type == '|') { if (num_svs && (tlen != 2 || type[1] != '-')) { unknown_desr: - Perl_croak(aTHX_ "Unknown open() mode '%.*s'", olen, oname); + Perl_croak(aTHX_ "Unknown open() mode '%.*s'", (int)olen, oname); } /*SUPPRESS 530*/ for (type++, tlen--; isSPACE(*type); type++, tlen--) ; diff --git a/dump.c b/dump.c index ee64af5..e3648ea 100644 --- a/dump.c +++ b/dump.c @@ -78,9 +78,9 @@ Perl_dump_sub(pTHX_ GV *gv) gv_fullname3(sv, gv, Nullch); Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %s = ", SvPVX(sv)); if (CvXSUB(GvCV(gv))) - Perl_dump_indent(aTHX_ 0, Perl_debug_log, "(xsub 0x%x %d)\n", + Perl_dump_indent(aTHX_ 0, Perl_debug_log, "(xsub 0x%lx %d)\n", (long)CvXSUB(GvCV(gv)), - CvXSUBANY(GvCV(gv)).any_i32); + (int)CvXSUBANY(GvCV(gv)).any_i32); else if (CvROOT(GvCV(gv))) op_dump(CvROOT(GvCV(gv))); else @@ -392,7 +392,7 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, OP *o) if (o->op_type == OP_NULL) Perl_dump_indent(aTHX_ level, file, " (was %s)\n", PL_op_name[o->op_targ]); else - Perl_dump_indent(aTHX_ level, file, "TARG = %d\n", o->op_targ); + Perl_dump_indent(aTHX_ level, file, "TARG = %ld\n", (long)o->op_targ); } #ifdef DUMPADDR Perl_dump_indent(aTHX_ level, file, "ADDR = 0x%"UVxf" => 0x%"UVxf"\n", (UV)o, (UV)o->op_next); @@ -701,7 +701,7 @@ Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, MAGIC *mg, I32 nest, I32 maxne do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */ } if (mg->mg_len) - Perl_dump_indent(aTHX_ level, file, " MG_LEN = %d\n", mg->mg_len); + Perl_dump_indent(aTHX_ level, file, " MG_LEN = %ld\n", (long)mg->mg_len); if (mg->mg_ptr) { Perl_dump_indent(aTHX_ level, file, " MG_PTR = 0x%"UVxf, PTR2UV(mg->mg_ptr)); if (mg->mg_len >= 0) { @@ -782,8 +782,8 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo Perl_sv_setpvf(aTHX_ d, "(0x%"UVxf") at 0x%"UVxf"\n%*s REFCNT = %"IVdf"\n%*s FLAGS = (", PTR2UV(SvANY(sv)), PTR2UV(sv), - PL_dumpindent*level, "", (IV)SvREFCNT(sv), - PL_dumpindent*level, ""); + (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv), + (int)(PL_dumpindent*level), ""); if (flags & SVs_PADBUSY) sv_catpv(d, "PADBUSY,"); if (flags & SVs_PADTMP) sv_catpv(d, "PADTMP,"); @@ -1089,7 +1089,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo Perl_dump_indent(aTHX_ level, file, " MUTEXP = 0x%"UVxf"\n", PTR2UV(CvMUTEXP(sv))); Perl_dump_indent(aTHX_ level, file, " OWNER = 0x%"UVxf"\n", PTR2UV(CvOWNER(sv))); #endif /* USE_THREADS */ - Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", CvFLAGS(sv)); + Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv)); if (type == SVt_PVFM) Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)FmLINES(sv)); Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv))); @@ -1107,7 +1107,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo /* %5d below is enough whitespace. */ file, "%5d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n", - ix, PTR2UV(ppad[ix]), + (int)ix, PTR2UV(ppad[ix]), SvFAKE(pname[ix]) ? "FAKE " : "", SvPVX(pname[ix]), (IV)SvNVX(pname[ix]), diff --git a/embed.pl b/embed.pl index f235ffb..52ab63a 100755 --- a/embed.pl +++ b/embed.pl @@ -134,6 +134,14 @@ sub write_protos { } $ret .= ")"; $ret .= " __attribute__((noreturn))" if $flags =~ /r/; + 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)))", + $prefix, $args - 1, $prefix, $args; + $ret .= "\n#endif\n"; + } $ret .= ";\n"; } $ret; @@ -1006,6 +1014,7 @@ __END__ : file : n has no implicit interpreter/thread context argument : p function has a Perl_ prefix +: f function takes printf style format string, varargs : r function never returns : o has no compatibility macro (#define foo Perl_foo) : j not a member of CPerlObj @@ -1124,22 +1133,22 @@ p |I32 |my_chsize |int fd|Off_t length p |MAGIC* |condpair_magic |SV *sv #endif p |OP* |convert |I32 optype|I32 flags|OP* o -pr |void |croak |const char* pat|... +fpr |void |croak |const char* pat|... pr |void |vcroak |const char* pat|va_list* args #if defined(PERL_IMPLICIT_CONTEXT) -nrp |void |croak_nocontext|const char* pat|... -np |OP* |die_nocontext |const char* pat|... -np |void |deb_nocontext |const char* pat|... -np |char* |form_nocontext |const char* pat|... -np |SV* |mess_nocontext |const char* pat|... -np |void |warn_nocontext |const char* pat|... -np |void |warner_nocontext|U32 err|const char* pat|... -np |SV* |newSVpvf_nocontext|const char* pat|... -np |void |sv_catpvf_nocontext|SV* sv|const char* pat|... -np |void |sv_setpvf_nocontext|SV* sv|const char* pat|... -np |void |sv_catpvf_mg_nocontext|SV* sv|const char* pat|... -np |void |sv_setpvf_mg_nocontext|SV* sv|const char* pat|... -np |int |fprintf_nocontext|PerlIO* stream|const char* fmt|... +fnrp |void |croak_nocontext|const char* pat|... +fnp |OP* |die_nocontext |const char* pat|... +fnp |void |deb_nocontext |const char* pat|... +fnp |char* |form_nocontext |const char* pat|... +fnp |SV* |mess_nocontext |const char* pat|... +fnp |void |warn_nocontext |const char* pat|... +fnp |void |warner_nocontext|U32 err|const char* pat|... +fnp |SV* |newSVpvf_nocontext|const char* pat|... +fnp |void |sv_catpvf_nocontext|SV* sv|const char* pat|... +fnp |void |sv_setpvf_nocontext|SV* sv|const char* pat|... +fnp |void |sv_catpvf_mg_nocontext|SV* sv|const char* pat|... +fnp |void |sv_setpvf_mg_nocontext|SV* sv|const char* pat|... +fnp |int |fprintf_nocontext|PerlIO* stream|const char* fmt|... #endif p |void |cv_ckproto |CV* cv|GV* gv|char* p p |CV* |cv_clone |CV* proto @@ -1156,7 +1165,7 @@ p |char* |get_no_modify p |U32* |get_opargs p |PPADDR_t*|get_ppaddr p |I32 |cxinc -p |void |deb |const char* pat|... +fp |void |deb |const char* pat|... p |void |vdeb |const char* pat|va_list* args p |void |debprofdump p |I32 |debop |OP* o @@ -1165,7 +1174,7 @@ p |I32 |debstackptrs p |char* |delimcpy |char* to|char* toend|char* from \ |char* fromend|int delim|I32* retlen p |void |deprecate |char* s -p |OP* |die |const char* pat|... +fp |OP* |die |const char* pat|... p |OP* |vdie |const char* pat|va_list* args p |OP* |die_where |char* message|STRLEN msglen p |void |dounwind |I32 cxix @@ -1230,7 +1239,7 @@ p |PADOFFSET|find_threadsv|const char *name #endif p |OP* |force_list |OP* arg p |OP* |fold_constants |OP* arg -p |char* |form |const char* pat|... +fp |char* |form |const char* pat|... p |char* |vform |const char* pat|va_list* args p |void |free_tmps p |OP* |gen_constant_list|OP* o @@ -1405,7 +1414,7 @@ p |void |markstack_grow #if defined(USE_LOCALE_COLLATE) p |char* |mem_collxfrm |const char* s|STRLEN len|STRLEN* xlen #endif -p |SV* |mess |const char* pat|... +fp |SV* |mess |const char* pat|... p |SV* |vmess |const char* pat|va_list* args p |void |qerror |SV* err p |int |mg_clear |SV* sv @@ -1493,7 +1502,7 @@ p |SV* |newSViv |IV i p |SV* |newSVnv |NV n p |SV* |newSVpv |const char* s|STRLEN len p |SV* |newSVpvn |const char* s|STRLEN len -p |SV* |newSVpvf |const char* pat|... +fp |SV* |newSVpvf |const char* pat|... p |SV* |vnewSVpvf |const char* pat|va_list* args p |SV* |newSVrv |SV* rv|const char* classname p |SV* |newSVsv |SV* old @@ -1668,7 +1677,7 @@ p |I32 |sv_true |SV *sv p |void |sv_add_arena |char* ptr|U32 size|U32 flags p |int |sv_backoff |SV* sv p |SV* |sv_bless |SV* sv|HV* stash -p |void |sv_catpvf |SV* sv|const char* pat|... +fp |void |sv_catpvf |SV* sv|const char* pat|... p |void |sv_vcatpvf |SV* sv|const char* pat|va_list* args p |void |sv_catpv |SV* sv|const char* ptr p |void |sv_catpvn |SV* sv|const char* ptr|STRLEN len @@ -1713,7 +1722,7 @@ p |char* |sv_reftype |SV* sv|int ob p |void |sv_replace |SV* sv|SV* nsv p |void |sv_report_used p |void |sv_reset |char* s|HV* stash -p |void |sv_setpvf |SV* sv|const char* pat|... +fp |void |sv_setpvf |SV* sv|const char* pat|... p |void |sv_vsetpvf |SV* sv|const char* pat|va_list* args p |void |sv_setiv |SV* sv|IV num p |void |sv_setpviv |SV* sv|IV num @@ -1768,9 +1777,9 @@ p |void |vivify_ref |SV* sv|U32 to_what p |I32 |wait4pid |Pid_t pid|int* statusp|int flags p |void |report_closed_fh|GV *gv|IO *io|const char *func|const char *obj p |void |report_uninit -p |void |warn |const char* pat|... +fp |void |warn |const char* pat|... p |void |vwarn |const char* pat|va_list* args -p |void |warner |U32 err|const char* pat|... +fp |void |warner |U32 err|const char* pat|... p |void |vwarner |U32 err|const char* pat|va_list* args p |void |watch |char** addr p |I32 |whichsig |char* sig @@ -1800,12 +1809,12 @@ p |struct perl_vars *|GetVars #endif p |int |runops_standard p |int |runops_debug -p |void |sv_catpvf_mg |SV *sv|const char* pat|... +fp |void |sv_catpvf_mg |SV *sv|const char* pat|... p |void |sv_vcatpvf_mg |SV* sv|const char* pat|va_list* args p |void |sv_catpv_mg |SV *sv|const char *ptr p |void |sv_catpvn_mg |SV *sv|const char *ptr|STRLEN len p |void |sv_catsv_mg |SV *dstr|SV *sstr -p |void |sv_setpvf_mg |SV *sv|const char* pat|... +fp |void |sv_setpvf_mg |SV *sv|const char* pat|... p |void |sv_vsetpvf_mg |SV* sv|const char* pat|va_list* args p |void |sv_setiv_mg |SV *sv|IV i p |void |sv_setpviv_mg |SV *sv|IV iv @@ -1818,7 +1827,7 @@ p |void |sv_usepvn_mg |SV *sv|char *ptr|STRLEN len p |MGVTBL*|get_vtbl |int vtbl_id p |char* |pv_display |SV *sv|char *pv|STRLEN cur|STRLEN len \ |STRLEN pvlim -p |void |dump_indent |I32 level|PerlIO *file|const char* pat|... +fp |void |dump_indent |I32 level|PerlIO *file|const char* pat|... p |void |dump_vindent |I32 level|PerlIO *file|const char* pat \ |va_list *args p |void |do_gv_dump |I32 level|PerlIO *file|char *name|GV *sv diff --git a/gv.c b/gv.c index 0305ad5..907620b 100644 --- a/gv.c +++ b/gv.c @@ -1365,7 +1365,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) if (amtp && amtp->fallback >= AMGfallYES) { DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX(msg)) ); } else { - Perl_croak(aTHX_ "%_", msg); + Perl_croak(aTHX_ "%"SVf, msg); } return NULL; } diff --git a/op.c b/op.c index 961fe50..823960b 100644 --- a/op.c +++ b/op.c @@ -2686,15 +2686,19 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) if (rfirst == 0xffffffff) { diff = tdiff; /* oops, pretend rdiff is infinite */ if (diff > 0) - Perl_sv_catpvf(aTHX_ listsv, "%04x\t%04x\tXXXX\n", tfirst, tlast); + Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n", + (long)tfirst, (long)tlast); else - Perl_sv_catpvf(aTHX_ listsv, "%04x\t\tXXXX\n", tfirst); + Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst); } else { if (diff > 0) - Perl_sv_catpvf(aTHX_ listsv, "%04x\t%04x\t%04x\n", tfirst, tfirst + diff, rfirst); + Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n", + (long)tfirst, (long)(tfirst + diff), + (long)rfirst); else - Perl_sv_catpvf(aTHX_ listsv, "%04x\t\t%04x\n", tfirst, rfirst); + Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n", + (long)tfirst, (long)rfirst); if (rfirst + diff > max) max = rfirst + diff; @@ -4023,7 +4027,7 @@ S_cv_dump(pTHX_ CV *cv) if (SvPOK(pname[ix])) PerlIO_printf(Perl_debug_log, "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n", - ix, PTR2UV(ppad[ix]), + (int)ix, PTR2UV(ppad[ix]), SvFAKE(pname[ix]) ? "FAKE " : "", SvPVX(pname[ix]), (IV)I_32(SvNVX(pname[ix])), @@ -4190,7 +4194,7 @@ Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p) gv_efullname3(name = sv_newmortal(), gv, Nullch); sv_setpv(msg, "Prototype mismatch:"); if (name) - Perl_sv_catpvf(aTHX_ msg, " sub %_", name); + Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name); if (SvPOK(cv)) Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv)); sv_catpv(msg, " vs "); @@ -4198,7 +4202,7 @@ Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p) Perl_sv_catpvf(aTHX_ msg, "(%s)", p); else sv_catpv(msg, "none"); - Perl_warner(aTHX_ WARN_UNSAFE, "%_", msg); + Perl_warner(aTHX_ WARN_UNSAFE, "%"SVf, msg); } } @@ -5567,7 +5571,7 @@ Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */ break; /* Globals via GV can be undef */ case OP_PADHV: Perl_warner(aTHX_ WARN_DEPRECATED, - "defined(%hash) is deprecated"); + "defined(%%hash) is deprecated"); Perl_warner(aTHX_ WARN_DEPRECATED, "(Maybe you should just omit the defined()?)\n"); break; diff --git a/perl.c b/perl.c index 1b9dac2..4b912e9 100644 --- a/perl.c +++ b/perl.c @@ -2194,7 +2194,7 @@ sed %s -e \"/^[^#]/b\" \ -e \"/^#[ ]*undef[ ]/b\" \ -e \"/^#[ ]*endif/b\" \ -e \"s/^#.*//\" \ - %s | %_ -C %_ %s", + %s | %"SVf" -C %"SVf" %s", (PL_doextract ? "-e \"1,/^#/d\n\"" : ""), #else # ifdef __OPEN_VM @@ -2210,7 +2210,7 @@ sed %s -e \"/^[^#]/b\" \ -e '/^#[ ]*undef[ ]/b' \ -e '/^#[ ]*endif/b' \ -e 's/^[ ]*#.*//' \ - %s | %_ %_ %s", + %s | %"SVf" %"SVf" %s", # else Perl_sv_setpvf(aTHX_ cmd, "\ %s %s -e '/^[^#]/b' \ @@ -2224,7 +2224,7 @@ sed %s -e \"/^[^#]/b\" \ -e '/^#[ ]*undef[ ]/b' \ -e '/^#[ ]*endif/b' \ -e 's/^[ ]*#.*//' \ - %s | %_ -C %_ %s", + %s | %"SVf" -C %"SVf" %s", # endif #ifdef LOC_SED LOC_SED, @@ -3054,7 +3054,7 @@ S_incpush(pTHX_ char *p, int addsubdirs) SvPV(libdir,len)); #endif /* .../archname/version if -d .../archname/version/auto */ - Perl_sv_setpvf(aTHX_ subdir, "%_/%s/"PERL_FS_VER_FMT"/auto", libdir, + Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/%s/"PERL_FS_VER_FMT"/auto", libdir, ARCHNAME, (int)PERL_REVISION, (int)PERL_VERSION, (int)PERL_SUBVERSION); if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 && @@ -3063,7 +3063,7 @@ S_incpush(pTHX_ char *p, int addsubdirs) newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto")); /* .../archname if -d .../archname/auto */ - Perl_sv_setpvf(aTHX_ subdir, "%_/%s/auto", libdir, ARCHNAME); + Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/%s/auto", libdir, ARCHNAME); if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode)) av_push(GvAVn(PL_incgv), diff --git a/perl.h b/perl.h index 30130fd..2da6910 100644 --- a/perl.h +++ b/perl.h @@ -189,6 +189,10 @@ struct perl_thread; # define dTHX dTHXa(PERL_GET_THX) # define pTHX_ pTHX, # define aTHX_ aTHX, +# define pTHX_1 2 +# define pTHX_2 3 +# define pTHX_3 4 +# define pTHX_4 5 #endif #define STATIC static @@ -221,6 +225,10 @@ struct perl_thread; # define aTHX_ # define dTHXa(a) dNOOP # define dTHX dNOOP +# define pTHX_1 1 +# define pTHX_2 2 +# define pTHX_3 3 +# define pTHX_4 4 #endif #ifndef pTHXo @@ -1674,6 +1682,14 @@ typedef pthread_key_t perl_key; # endif #endif +#ifndef SVf +# ifdef CHECK_FORMAT +# define SVf "p" +# else +# define SVf "_" +# endif +#endif + /* Some unistd.h's give a prototype for pause() even though HAS_PAUSE ends up undefined. This causes the #define below to be rejected by the compmiler. Sigh. diff --git a/pp_ctl.c b/pp_ctl.c index 34e18b5..af8b947 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -1302,7 +1302,7 @@ Perl_qerror(pTHX_ SV *err) else if (PL_errors) sv_catsv(PL_errors, err); else - Perl_warn(aTHX_ "%_", err); + Perl_warn(aTHX_ "%"SVf, err); ++PL_error_count; } @@ -2391,8 +2391,7 @@ PP(pp_goto) /* Eventually we may want to stack the needed arguments * for each op. For now, we punt on the hard ones. */ if (PL_op->op_type == OP_ENTERITER) - DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop", - label); + DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop"); CALL_FPTR(PL_op->op_ppaddr)(aTHX); } PL_op = oldop; @@ -2869,7 +2868,7 @@ PP(pp_require) && PERL_SUBVERSION < sver)))) { DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only version " - "v%"UVuf".%"UVuf".%"UVuf", stopped", rev, ver, sver, PERL_REVISION, + "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION, PERL_VERSION, PERL_SUBVERSION); } } @@ -2884,7 +2883,7 @@ PP(pp_require) + 0.00000099 < SvNV(sv)) { DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only version " - "v%"UVuf".%"UVuf".%"UVuf", stopped", rev, ver, sver, PERL_REVISION, + "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION, PERL_VERSION, PERL_SUBVERSION); } } diff --git a/pp_hot.c b/pp_hot.c index cd7b6e0..18d717b 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -1305,7 +1305,7 @@ Perl_do_readline(pTHX) if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_CLOSED)) { Perl_warner(aTHX_ WARN_CLOSED, "glob failed (child exited with status %d%s)", - STATUS_CURRENT >> 8, + (int)(STATUS_CURRENT >> 8), (STATUS_CURRENT & 0x80) ? ", core dumped" : ""); } } diff --git a/pp_sys.c b/pp_sys.c index 58271c8..ea34bae 100644 --- a/pp_sys.c +++ b/pp_sys.c @@ -442,7 +442,7 @@ PP(pp_warn) if (!tmps || !len) tmpsv = sv_2mortal(newSVpvn("Warning: something's wrong", 26)); - Perl_warn(aTHX_ "%_", tmpsv); + Perl_warn(aTHX_ "%"SVf, tmpsv); RETSETYES; } @@ -500,7 +500,7 @@ PP(pp_die) if (!tmps || !len) tmpsv = sv_2mortal(newSVpvn("Died", 4)); - DIE(aTHX_ "%_", tmpsv); + DIE(aTHX_ "%"SVf, tmpsv); } /* I/O. */ diff --git a/proto.h b/proto.h index 6f60109..f00531c 100644 --- a/proto.h +++ b/proto.h @@ -99,22 +99,78 @@ PERL_CALLCONV I32 Perl_my_chsize(pTHX_ int fd, Off_t length); PERL_CALLCONV MAGIC* Perl_condpair_magic(pTHX_ SV *sv); #endif PERL_CALLCONV OP* Perl_convert(pTHX_ I32 optype, I32 flags, OP* o); -PERL_CALLCONV void Perl_croak(pTHX_ const char* pat, ...) __attribute__((noreturn)); +PERL_CALLCONV void Perl_croak(pTHX_ const char* pat, ...) __attribute__((noreturn)) +#ifdef CHECK_FORMAT + __attribute__((format(printf,pTHX_1,pTHX_2))) +#endif +; PERL_CALLCONV void Perl_vcroak(pTHX_ const char* pat, va_list* args) __attribute__((noreturn)); #if defined(PERL_IMPLICIT_CONTEXT) -PERL_CALLCONV void Perl_croak_nocontext(const char* pat, ...) __attribute__((noreturn)); -PERL_CALLCONV OP* Perl_die_nocontext(const char* pat, ...); -PERL_CALLCONV void Perl_deb_nocontext(const char* pat, ...); -PERL_CALLCONV char* Perl_form_nocontext(const char* pat, ...); -PERL_CALLCONV SV* Perl_mess_nocontext(const char* pat, ...); -PERL_CALLCONV void Perl_warn_nocontext(const char* pat, ...); -PERL_CALLCONV void Perl_warner_nocontext(U32 err, const char* pat, ...); -PERL_CALLCONV SV* Perl_newSVpvf_nocontext(const char* pat, ...); -PERL_CALLCONV void Perl_sv_catpvf_nocontext(SV* sv, const char* pat, ...); -PERL_CALLCONV void Perl_sv_setpvf_nocontext(SV* sv, const char* pat, ...); -PERL_CALLCONV void Perl_sv_catpvf_mg_nocontext(SV* sv, const char* pat, ...); -PERL_CALLCONV void Perl_sv_setpvf_mg_nocontext(SV* sv, const char* pat, ...); -PERL_CALLCONV int Perl_fprintf_nocontext(PerlIO* stream, const char* fmt, ...); +PERL_CALLCONV void Perl_croak_nocontext(const char* pat, ...) __attribute__((noreturn)) +#ifdef CHECK_FORMAT + __attribute__((format(printf,1,2))) +#endif +; +PERL_CALLCONV OP* Perl_die_nocontext(const char* pat, ...) +#ifdef CHECK_FORMAT + __attribute__((format(printf,1,2))) +#endif +; +PERL_CALLCONV void Perl_deb_nocontext(const char* pat, ...) +#ifdef CHECK_FORMAT + __attribute__((format(printf,1,2))) +#endif +; +PERL_CALLCONV char* Perl_form_nocontext(const char* pat, ...) +#ifdef CHECK_FORMAT + __attribute__((format(printf,1,2))) +#endif +; +PERL_CALLCONV SV* Perl_mess_nocontext(const char* pat, ...) +#ifdef CHECK_FORMAT + __attribute__((format(printf,1,2))) +#endif +; +PERL_CALLCONV void Perl_warn_nocontext(const char* pat, ...) +#ifdef CHECK_FORMAT + __attribute__((format(printf,1,2))) +#endif +; +PERL_CALLCONV void Perl_warner_nocontext(U32 err, const char* pat, ...) +#ifdef CHECK_FORMAT + __attribute__((format(printf,2,3))) +#endif +; +PERL_CALLCONV SV* Perl_newSVpvf_nocontext(const char* pat, ...) +#ifdef CHECK_FORMAT + __attribute__((format(printf,1,2))) +#endif +; +PERL_CALLCONV void Perl_sv_catpvf_nocontext(SV* sv, const char* pat, ...) +#ifdef CHECK_FORMAT + __attribute__((format(printf,2,3))) +#endif +; +PERL_CALLCONV void Perl_sv_setpvf_nocontext(SV* sv, const char* pat, ...) +#ifdef CHECK_FORMAT + __attribute__((format(printf,2,3))) +#endif +; +PERL_CALLCONV void Perl_sv_catpvf_mg_nocontext(SV* sv, const char* pat, ...) +#ifdef CHECK_FORMAT + __attribute__((format(printf,2,3))) +#endif +; +PERL_CALLCONV void Perl_sv_setpvf_mg_nocontext(SV* sv, const char* pat, ...) +#ifdef CHECK_FORMAT + __attribute__((format(printf,2,3))) +#endif +; +PERL_CALLCONV int Perl_fprintf_nocontext(PerlIO* stream, const char* fmt, ...) +#ifdef CHECK_FORMAT + __attribute__((format(printf,2,3))) +#endif +; #endif PERL_CALLCONV void Perl_cv_ckproto(pTHX_ CV* cv, GV* gv, char* p); PERL_CALLCONV CV* Perl_cv_clone(pTHX_ CV* proto); @@ -131,7 +187,11 @@ PERL_CALLCONV char* Perl_get_no_modify(pTHX); PERL_CALLCONV U32* Perl_get_opargs(pTHX); PERL_CALLCONV PPADDR_t* Perl_get_ppaddr(pTHX); PERL_CALLCONV I32 Perl_cxinc(pTHX); -PERL_CALLCONV void Perl_deb(pTHX_ const char* pat, ...); +PERL_CALLCONV void Perl_deb(pTHX_ const char* pat, ...) +#ifdef CHECK_FORMAT + __attribute__((format(printf,pTHX_1,pTHX_2))) +#endif +; PERL_CALLCONV void Perl_vdeb(pTHX_ const char* pat, va_list* args); PERL_CALLCONV void Perl_debprofdump(pTHX); PERL_CALLCONV I32 Perl_debop(pTHX_ OP* o); @@ -139,7 +199,11 @@ PERL_CALLCONV I32 Perl_debstack(pTHX); PERL_CALLCONV I32 Perl_debstackptrs(pTHX); PERL_CALLCONV char* Perl_delimcpy(pTHX_ char* to, char* toend, char* from, char* fromend, int delim, I32* retlen); PERL_CALLCONV void Perl_deprecate(pTHX_ char* s); -PERL_CALLCONV OP* Perl_die(pTHX_ const char* pat, ...); +PERL_CALLCONV OP* Perl_die(pTHX_ const char* pat, ...) +#ifdef CHECK_FORMAT + __attribute__((format(printf,pTHX_1,pTHX_2))) +#endif +; PERL_CALLCONV OP* Perl_vdie(pTHX_ const char* pat, va_list* args); PERL_CALLCONV OP* Perl_die_where(pTHX_ char* message, STRLEN msglen); PERL_CALLCONV void Perl_dounwind(pTHX_ I32 cxix); @@ -199,7 +263,11 @@ PERL_CALLCONV PADOFFSET Perl_find_threadsv(pTHX_ const char *name); #endif PERL_CALLCONV OP* Perl_force_list(pTHX_ OP* arg); PERL_CALLCONV OP* Perl_fold_constants(pTHX_ OP* arg); -PERL_CALLCONV char* Perl_form(pTHX_ const char* pat, ...); +PERL_CALLCONV char* Perl_form(pTHX_ const char* pat, ...) +#ifdef CHECK_FORMAT + __attribute__((format(printf,pTHX_1,pTHX_2))) +#endif +; PERL_CALLCONV char* Perl_vform(pTHX_ const char* pat, va_list* args); PERL_CALLCONV void Perl_free_tmps(pTHX); PERL_CALLCONV OP* Perl_gen_constant_list(pTHX_ OP* o); @@ -369,7 +437,11 @@ PERL_CALLCONV void Perl_markstack_grow(pTHX); #if defined(USE_LOCALE_COLLATE) PERL_CALLCONV char* Perl_mem_collxfrm(pTHX_ const char* s, STRLEN len, STRLEN* xlen); #endif -PERL_CALLCONV SV* Perl_mess(pTHX_ const char* pat, ...); +PERL_CALLCONV SV* Perl_mess(pTHX_ const char* pat, ...) +#ifdef CHECK_FORMAT + __attribute__((format(printf,pTHX_1,pTHX_2))) +#endif +; PERL_CALLCONV SV* Perl_vmess(pTHX_ const char* pat, va_list* args); PERL_CALLCONV void Perl_qerror(pTHX_ SV* err); PERL_CALLCONV int Perl_mg_clear(pTHX_ SV* sv); @@ -456,7 +528,11 @@ PERL_CALLCONV SV* Perl_newSViv(pTHX_ IV i); PERL_CALLCONV SV* Perl_newSVnv(pTHX_ NV n); PERL_CALLCONV SV* Perl_newSVpv(pTHX_ const char* s, STRLEN len); PERL_CALLCONV SV* Perl_newSVpvn(pTHX_ const char* s, STRLEN len); -PERL_CALLCONV SV* Perl_newSVpvf(pTHX_ const char* pat, ...); +PERL_CALLCONV SV* Perl_newSVpvf(pTHX_ const char* pat, ...) +#ifdef CHECK_FORMAT + __attribute__((format(printf,pTHX_1,pTHX_2))) +#endif +; PERL_CALLCONV SV* Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args); PERL_CALLCONV SV* Perl_newSVrv(pTHX_ SV* rv, const char* classname); PERL_CALLCONV SV* Perl_newSVsv(pTHX_ SV* old); @@ -620,7 +696,11 @@ PERL_CALLCONV I32 Perl_sv_true(pTHX_ SV *sv); PERL_CALLCONV void Perl_sv_add_arena(pTHX_ char* ptr, U32 size, U32 flags); PERL_CALLCONV int Perl_sv_backoff(pTHX_ SV* sv); PERL_CALLCONV SV* Perl_sv_bless(pTHX_ SV* sv, HV* stash); -PERL_CALLCONV void Perl_sv_catpvf(pTHX_ SV* sv, const char* pat, ...); +PERL_CALLCONV void Perl_sv_catpvf(pTHX_ SV* sv, const char* pat, ...) +#ifdef CHECK_FORMAT + __attribute__((format(printf,pTHX_2,pTHX_3))) +#endif +; PERL_CALLCONV void Perl_sv_vcatpvf(pTHX_ SV* sv, const char* pat, va_list* args); PERL_CALLCONV void Perl_sv_catpv(pTHX_ SV* sv, const char* ptr); PERL_CALLCONV void Perl_sv_catpvn(pTHX_ SV* sv, const char* ptr, STRLEN len); @@ -663,7 +743,11 @@ PERL_CALLCONV char* Perl_sv_reftype(pTHX_ SV* sv, int ob); PERL_CALLCONV void Perl_sv_replace(pTHX_ SV* sv, SV* nsv); PERL_CALLCONV void Perl_sv_report_used(pTHX); PERL_CALLCONV void Perl_sv_reset(pTHX_ char* s, HV* stash); -PERL_CALLCONV void Perl_sv_setpvf(pTHX_ SV* sv, const char* pat, ...); +PERL_CALLCONV void Perl_sv_setpvf(pTHX_ SV* sv, const char* pat, ...) +#ifdef CHECK_FORMAT + __attribute__((format(printf,pTHX_2,pTHX_3))) +#endif +; PERL_CALLCONV void Perl_sv_vsetpvf(pTHX_ SV* sv, const char* pat, va_list* args); PERL_CALLCONV void Perl_sv_setiv(pTHX_ SV* sv, IV num); PERL_CALLCONV void Perl_sv_setpviv(pTHX_ SV* sv, IV num); @@ -712,9 +796,17 @@ PERL_CALLCONV void Perl_vivify_ref(pTHX_ SV* sv, U32 to_what); PERL_CALLCONV I32 Perl_wait4pid(pTHX_ Pid_t pid, int* statusp, int flags); PERL_CALLCONV void Perl_report_closed_fh(pTHX_ GV *gv, IO *io, const char *func, const char *obj); PERL_CALLCONV void Perl_report_uninit(pTHX); -PERL_CALLCONV void Perl_warn(pTHX_ const char* pat, ...); +PERL_CALLCONV void Perl_warn(pTHX_ const char* pat, ...) +#ifdef CHECK_FORMAT + __attribute__((format(printf,pTHX_1,pTHX_2))) +#endif +; PERL_CALLCONV void Perl_vwarn(pTHX_ const char* pat, va_list* args); -PERL_CALLCONV void Perl_warner(pTHX_ U32 err, const char* pat, ...); +PERL_CALLCONV void Perl_warner(pTHX_ U32 err, const char* pat, ...) +#ifdef CHECK_FORMAT + __attribute__((format(printf,pTHX_2,pTHX_3))) +#endif +; PERL_CALLCONV void Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args); PERL_CALLCONV void Perl_watch(pTHX_ char** addr); PERL_CALLCONV I32 Perl_whichsig(pTHX_ char* sig); @@ -744,12 +836,20 @@ PERL_CALLCONV struct perl_vars * Perl_GetVars(pTHX); #endif PERL_CALLCONV int Perl_runops_standard(pTHX); PERL_CALLCONV int Perl_runops_debug(pTHX); -PERL_CALLCONV void Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...); +PERL_CALLCONV void Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...) +#ifdef CHECK_FORMAT + __attribute__((format(printf,pTHX_2,pTHX_3))) +#endif +; PERL_CALLCONV void Perl_sv_vcatpvf_mg(pTHX_ SV* sv, const char* pat, va_list* args); PERL_CALLCONV void Perl_sv_catpv_mg(pTHX_ SV *sv, const char *ptr); PERL_CALLCONV void Perl_sv_catpvn_mg(pTHX_ SV *sv, const char *ptr, STRLEN len); PERL_CALLCONV void Perl_sv_catsv_mg(pTHX_ SV *dstr, SV *sstr); -PERL_CALLCONV void Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...); +PERL_CALLCONV void Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...) +#ifdef CHECK_FORMAT + __attribute__((format(printf,pTHX_2,pTHX_3))) +#endif +; PERL_CALLCONV void Perl_sv_vsetpvf_mg(pTHX_ SV* sv, const char* pat, va_list* args); PERL_CALLCONV void Perl_sv_setiv_mg(pTHX_ SV *sv, IV i); PERL_CALLCONV void Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv); @@ -761,7 +861,11 @@ PERL_CALLCONV void Perl_sv_setsv_mg(pTHX_ SV *dstr, SV *sstr); PERL_CALLCONV void Perl_sv_usepvn_mg(pTHX_ SV *sv, char *ptr, STRLEN len); PERL_CALLCONV MGVTBL* Perl_get_vtbl(pTHX_ int vtbl_id); PERL_CALLCONV char* Perl_pv_display(pTHX_ SV *sv, char *pv, STRLEN cur, STRLEN len, STRLEN pvlim); -PERL_CALLCONV void Perl_dump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...); +PERL_CALLCONV void Perl_dump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...) +#ifdef CHECK_FORMAT + __attribute__((format(printf,pTHX_3,pTHX_4))) +#endif +; PERL_CALLCONV void Perl_dump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args); PERL_CALLCONV void Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, char *name, GV *sv); PERL_CALLCONV void Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, char *name, GV *sv); diff --git a/regcomp.c b/regcomp.c index 90500a4..77a4bfc 100644 --- a/regcomp.c +++ b/regcomp.c @@ -1602,7 +1602,7 @@ Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm) r->reganch &= ~ROPT_SKIP; /* Used in find_byclass(). */ DEBUG_r((sv = sv_newmortal(), regprop(sv, (regnode*)data.start_class), - PerlIO_printf(Perl_debug_log, "synthetic stclass.\n", + PerlIO_printf(Perl_debug_log, "synthetic stclass `%s'.\n", SvPVX(sv)))); } @@ -1651,7 +1651,7 @@ Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm) r->reganch &= ~ROPT_SKIP; /* Used in find_byclass(). */ DEBUG_r((sv = sv_newmortal(), regprop(sv, (regnode*)data.start_class), - PerlIO_printf(Perl_debug_log, "synthetic stclass.\n", + PerlIO_printf(Perl_debug_log, "synthetic stclass `%s'.\n", SvPVX(sv)))); } } @@ -3372,10 +3372,10 @@ S_regclassutf8(pTHX) if (!SIZE_ONLY) { if (value == 'p') Perl_sv_catpvf(aTHX_ listsv, - "+utf8::%.*s\n", n, PL_regcomp_parse); + "+utf8::%.*s\n", (int)n, PL_regcomp_parse); else Perl_sv_catpvf(aTHX_ listsv, - "!utf8::%.*s\n", n, PL_regcomp_parse); + "!utf8::%.*s\n", (int)n, PL_regcomp_parse); } PL_regcomp_parse = e + 1; lastvalue = OOB_UTF8; @@ -3936,7 +3936,7 @@ Perl_regprop(pTHX_ SV *sv, regnode *o) else if (k == WHILEM && o->flags) /* Ordinal/of */ Perl_sv_catpvf(aTHX_ sv, "[%d/%d]", o->flags & 0xf, o->flags>>4); else if (k == REF || k == OPEN || k == CLOSE || k == GROUPP ) - Perl_sv_catpvf(aTHX_ sv, "%d", ARG(o)); /* Parenth number */ + Perl_sv_catpvf(aTHX_ sv, "%d", (int)ARG(o)); /* Parenth number */ else if (k == LOGICAL) Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags); /* 2: embedded, otherwise 1 */ else if (k == ANYOF) { diff --git a/sv.c b/sv.c index 010ce2e..2d075b8 100644 --- a/sv.c +++ b/sv.c @@ -5617,7 +5617,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV (UV)c & 0xFF); } else sv_catpv(msg, "end of string"); - Perl_warner(aTHX_ WARN_PRINTF, "%_", msg); /* yes, this is reentrant */ + Perl_warner(aTHX_ WARN_PRINTF, "%"SVf, msg); /* yes, this is reentrant */ } /* output mangled stuff ... */ diff --git a/toke.c b/toke.c index a38f58f..f2e01d6 100644 --- a/toke.c +++ b/toke.c @@ -1384,7 +1384,7 @@ S_scan_const(pTHX_ char *start) if (ckWARN(WARN_UTF8)) Perl_warner(aTHX_ WARN_UTF8, "\\x%.*s will produce malformed UTF-8 character; use \\x{%.*s} for that", - len,s,len,s); + (int)len,s,(int)len,s); } *d++ = (char)uv; } @@ -7122,7 +7122,7 @@ Perl_yyerror(pTHX_ char *s) PL_multi_end = 0; } if (PL_in_eval & EVAL_WARNONLY) - Perl_warn(aTHX_ "%_", msg); + Perl_warn(aTHX_ "%"SVf, msg); else qerror(msg); if (PL_error_count >= 10) -- 2.7.4