In perl.git, the branch maint-5.10 has been updated <http://perl5.git.perl.org/perl.git/commitdiff/dbadabac3485b259e6be66dfb16a9479eb1fabda?hp=0c976b83f13d154bc99b2b9c2eaa3e1c5e1fdd79>
- Log ----------------------------------------------------------------- commit dbadabac3485b259e6be66dfb16a9479eb1fabda Author: Nicholas Clark <[email protected]> Date: Tue Feb 12 13:15:20 2008 +0000 assert() that every NN argument is not NULL. Otherwise we have the ability to create landmines that will explode under someone in the future when they upgrade their compiler to one with better optimisation. We've already done this at least twice. (Yes, some of the assertions are after code that would already have SEGVd because it already deferences a pointer, but they are put in to make it easier to automate checking that each and every case is covered.) Add a tool, checkARGS_ASSERT.pl, to check that every case is covered. p4raw-id: //depot/p...@33291 (cherry-picked from commit 7918f24d20384771923d344a382e1d16d9552018) M MANIFEST M NetWare/nw5.c M av.c M deb.c M doio.c M doop.c M dump.c M embed.pl M gv.c M hv.c M locale.c M malloc.c M mathoms.c M mg.c M mro.c M numeric.c M op.c M pad.c M perl.c M perlio.c M pod/perlapi.pod M pp.c M pp_ctl.c M pp_hot.c M pp_pack.c M pp_sort.c M pp_sys.c M proto.h M reentr.c M reentr.pl M regcomp.c M regexec.c M scope.c M sv.c M taint.c M toke.c M universal.c M utf8.c M util.c M vms/vms.c M win32/win32.c M win32/wince.c commit 2adc30dde2b5718f011d803b7b56d68ee31a8a0e Author: David Mitchell <[email protected]> Date: Thu Mar 19 20:14:43 2009 +0000 undo some bleed-only embed.fnc parameter name renames M embed.fnc commit 3fc8c156ce3b393896131e0cffcfaf901576e0d2 Author: Nicholas Clark <[email protected]> Date: Sun Feb 10 19:17:13 2008 +0000 The sv argument to gv_stashsv() is not NULL. p4raw-id: //depot/p...@33273 (cherry-picked from commit 8798655dec8bb39ddfc6da720c750a733c8d3662) M embed.fnc M proto.h ----------------------------------------------------------------------- Summary of changes: MANIFEST | 1 + NetWare/nw5.c | 2 +- av.c | 34 +- deb.c | 7 + doio.c | 38 ++- doop.c | 37 +- dump.c | 72 +++- embed.fnc | 10 +- embed.pl | 22 +- gv.c | 65 ++- hv.c | 78 +++- locale.c | 7 + malloc.c | 7 + mathoms.c | 123 ++++ mg.c | 134 ++++- mro.c | 14 +- numeric.c | 36 +- op.c | 257 ++++++++- pad.c | 30 + perl.c | 83 +++- perlio.c | 6 + pod/perlapi.pod | 2 +- pp.c | 4 + pp_ctl.c | 40 ++- pp_hot.c | 9 + pp_pack.c | 35 +- pp_sort.c | 33 +- pp_sys.c | 6 + proto.h | 1886 ++++++++++++++++++++++++++++++++++++++++++++++++++++++- reentr.c | 5 + reentr.pl | 5 + regcomp.c | 142 ++++- regexec.c | 64 ++- scope.c | 83 +++ sv.c | 313 +++++++++- taint.c | 3 + toke.c | 106 +++- universal.c | 8 +- utf8.c | 127 ++++- util.c | 121 ++++- vms/vms.c | 4 + win32/win32.c | 10 + win32/wince.c | 8 + 43 files changed, 3981 insertions(+), 96 deletions(-) diff --git a/MANIFEST b/MANIFEST index d219137..150958f 100644 --- a/MANIFEST +++ b/MANIFEST @@ -3486,6 +3486,7 @@ Porting/add-package.pl Add/Update CPAN modules that are part of Core Porting/apply Apply patches sent by mail Porting/check83.pl Check whether we are 8.3-friendly Porting/checkansi.pl Check source code for ANSI-C violations +Porting/checkARGS_ASSERT.pl Check we use every PERL_ARGS_ASSERT* macro Porting/checkAUTHORS.pl Check that the AUTHORS file is complete Porting/checkcase.pl Check whether we are case-insensitive-fs-friendly Porting/checkcfgvar.pl Check that config scripts define all symbols diff --git a/NetWare/nw5.c b/NetWare/nw5.c index 552106a..56d3a62 100644 --- a/NetWare/nw5.c +++ b/NetWare/nw5.c @@ -843,7 +843,7 @@ sys_intern_clear(pTHX) void sys_intern_dup(pTHX_ struct interp_intern *src, struct interp_intern *dst) { - + PERL_ARGS_ASSERT_SYS_INTERN_DUP; } #endif /* HAVE_INTERP_INTERN */ diff --git a/av.c b/av.c index c2b3ec4..79d5755 100644 --- a/av.c +++ b/av.c @@ -29,7 +29,7 @@ Perl_av_reify(pTHX_ AV *av) dVAR; I32 key; - assert(av); + PERL_ARGS_ASSERT_AV_REIFY; if (AvREAL(av)) return; @@ -68,7 +68,7 @@ Perl_av_extend(pTHX_ AV *av, I32 key) dVAR; MAGIC *mg; - assert(av); + PERL_ARGS_ASSERT_AV_EXTEND; mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied); if (mg) { @@ -211,7 +211,7 @@ Perl_av_fetch(pTHX_ register AV *av, I32 key, I32 lval) { dVAR; - assert(av); + PERL_ARGS_ASSERT_AV_FETCH; if (SvRMAGICAL(av)) { const MAGIC * const tied_magic = mg_find((SV*)av, PERL_MAGIC_tied); @@ -294,7 +294,7 @@ Perl_av_store(pTHX_ register AV *av, I32 key, SV *val) dVAR; SV** ary; - assert(av); + PERL_ARGS_ASSERT_AV_STORE; /* S_regclass relies on being able to pass in a NULL sv (unicode_alternate may be NULL). @@ -385,6 +385,7 @@ Perl_av_make(pTHX_ register I32 size, register SV **strp) { register AV * const av = (AV*)newSV_type(SVt_PVAV); /* sv_upgrade does AvREAL_only() */ + PERL_ARGS_ASSERT_AV_MAKE; if (size) { /* "defined" was returning undef for size==0 anyway. */ register SV** ary; register I32 i; @@ -417,7 +418,7 @@ Perl_av_clear(pTHX_ register AV *av) dVAR; I32 extra; - assert(av); + PERL_ARGS_ASSERT_AV_CLEAR; #ifdef DEBUGGING if (SvREFCNT(av) == 0 && ckWARN_d(WARN_DEBUGGING)) { Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), "Attempt to clear deleted array"); @@ -470,7 +471,7 @@ Undefines the array. Frees the memory used by the array itself. void Perl_av_undef(pTHX_ register AV *av) { - assert(av); + PERL_ARGS_ASSERT_AV_UNDEF; /* Give any tie a chance to cleanup first */ if (SvTIED_mg((SV*)av, PERL_MAGIC_tied)) @@ -503,6 +504,7 @@ A small internal helper function to remove a commonly duplicated idiom. void Perl_av_create_and_push(pTHX_ AV **const avp, SV *const val) { + PERL_ARGS_ASSERT_AV_CREATE_AND_PUSH; if (!*avp) *avp = newAV(); av_push(*avp, val); @@ -522,7 +524,8 @@ Perl_av_push(pTHX_ register AV *av, SV *val) { dVAR; MAGIC *mg; - assert(av); + + PERL_ARGS_ASSERT_AV_PUSH; if (SvREADONLY(av)) Perl_croak(aTHX_ "%s", PL_no_modify); @@ -560,7 +563,7 @@ Perl_av_pop(pTHX_ register AV *av) SV *retval; MAGIC* mg; - assert(av); + PERL_ARGS_ASSERT_AV_POP; if (SvREADONLY(av)) Perl_croak(aTHX_ "%s", PL_no_modify); @@ -603,6 +606,7 @@ A small internal helper function to remove a commonly duplicated idiom. SV ** Perl_av_create_and_unshift_one(pTHX_ AV **const avp, SV *const val) { + PERL_ARGS_ASSERT_AV_CREATE_AND_UNSHIFT_ONE; if (!*avp) *avp = newAV(); av_unshift(*avp, 1); @@ -626,7 +630,7 @@ Perl_av_unshift(pTHX_ register AV *av, register I32 num) register I32 i; MAGIC* mg; - assert(av); + PERL_ARGS_ASSERT_AV_UNSHIFT; if (SvREADONLY(av)) Perl_croak(aTHX_ "%s", PL_no_modify); @@ -698,7 +702,7 @@ Perl_av_shift(pTHX_ register AV *av) SV *retval; MAGIC* mg; - assert(av); + PERL_ARGS_ASSERT_AV_SHIFT; if (SvREADONLY(av)) Perl_croak(aTHX_ "%s", PL_no_modify); @@ -743,7 +747,7 @@ array is C<av_len(av) + 1>. Returns -1 if the array is empty. I32 Perl_av_len(pTHX_ register const AV *av) { - assert(av); + PERL_ARGS_ASSERT_AV_LEN; return AvFILL(av); } @@ -767,7 +771,7 @@ Perl_av_fill(pTHX_ register AV *av, I32 fill) dVAR; MAGIC *mg; - assert(av); + PERL_ARGS_ASSERT_AV_FILL; if (fill < 0) fill = -1; @@ -825,7 +829,7 @@ Perl_av_delete(pTHX_ AV *av, I32 key, I32 flags) dVAR; SV *sv; - assert(av); + PERL_ARGS_ASSERT_AV_DELETE; if (SvREADONLY(av)) Perl_croak(aTHX_ "%s", PL_no_modify); @@ -911,7 +915,7 @@ bool Perl_av_exists(pTHX_ AV *av, I32 key) { dVAR; - assert(av); + PERL_ARGS_ASSERT_AV_EXISTS; if (SvRMAGICAL(av)) { const MAGIC * const tied_magic = mg_find((SV*)av, PERL_MAGIC_tied); @@ -967,7 +971,7 @@ Perl_av_arylen_p(pTHX_ AV *av) { dVAR; MAGIC *mg; - assert(av); + PERL_ARGS_ASSERT_AV_ARYLEN_P; mg = mg_find((SV*)av, PERL_MAGIC_arylen_p); diff --git a/deb.c b/deb.c index 61746d4..e68adcf 100644 --- a/deb.c +++ b/deb.c @@ -31,6 +31,7 @@ Perl_deb_nocontext(const char *pat, ...) #ifdef DEBUGGING dTHX; va_list args; + PERL_ARGS_ASSERT_DEB_NOCONTEXT; va_start(args, pat); vdeb(pat, &args); va_end(args); @@ -44,6 +45,7 @@ void Perl_deb(pTHX_ const char *pat, ...) { va_list args; + PERL_ARGS_ASSERT_DEB; va_start(args, pat); #ifdef DEBUGGING vdeb(pat, &args); @@ -62,6 +64,8 @@ Perl_vdeb(pTHX_ const char *pat, va_list *args) const char* const display_file = file ? file : "<free>"; const long line = PL_curcop ? (long)CopLINE(PL_curcop) : 0; + PERL_ARGS_ASSERT_VDEB; + if (DEBUG_v_TEST) PerlIO_printf(Perl_debug_log, "(%ld:%s:%ld)\t", (long)PerlProc_getpid(), display_file, line); @@ -112,6 +116,9 @@ S_deb_stack_n(pTHX_ SV** stack_base, I32 stack_min, I32 stack_max, dVAR; register I32 i = stack_max - 30; const I32 *markscan = PL_markstack + mark_min; + + PERL_ARGS_ASSERT_DEB_STACK_N; + if (i < stack_min) i = stack_min; diff --git a/doio.c b/doio.c index c4dca0f..40d4f66 100644 --- a/doio.c +++ b/doio.c @@ -81,6 +81,8 @@ Perl_do_openn(pTHX_ GV *gv, register const char *oname, I32 len, int as_raw, char mode[PERL_MODE_MAX]; /* file mode ("r\0", "rb\0", "ab\0" etc.) */ SV *namesv; + PERL_ARGS_ASSERT_DO_OPENN; + Zero(mode,sizeof(mode),char); PL_forkprocess = 1; /* assume true if no fork */ @@ -707,6 +709,8 @@ Perl_nextargv(pTHX_ register GV *gv) Gid_t filegid; IO * const io = GvIOp(gv); + PERL_ARGS_ASSERT_NEXTARGV; + if (!PL_argvoutgv) PL_argvoutgv = gv_fetchpvs("ARGVOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO); if (io && (IoFLAGS(io) & IOf_ARGV) && (IoFLAGS(io) & IOf_START)) { @@ -951,6 +955,8 @@ Perl_io_close(pTHX_ IO *io, bool not_implicit) dVAR; bool retval = FALSE; + PERL_ARGS_ASSERT_IO_CLOSE; + if (IoIFP(io)) { if (IoTYPE(io) == IoTYPE_PIPE) { const int status = PerlProc_pclose(IoIFP(io)); @@ -990,6 +996,8 @@ Perl_do_eof(pTHX_ GV *gv) dVAR; register IO * const io = GvIO(gv); + PERL_ARGS_ASSERT_DO_EOF; + if (!io) return TRUE; else if ((IoTYPE(io) == IoTYPE_WRONLY) && ckWARN(WARN_IO)) @@ -1034,6 +1042,8 @@ Perl_do_tell(pTHX_ GV *gv) register IO *io = NULL; register PerlIO *fp; + PERL_ARGS_ASSERT_DO_TELL; + if (gv && (io = GvIO(gv)) && (fp = IoIFP(io))) { #ifdef ULTRIX_STDIO_BOTCH if (PerlIO_eof(fp)) @@ -1074,6 +1084,8 @@ Perl_do_sysseek(pTHX_ GV *gv, Off_t pos, int whence) register IO *io = NULL; register PerlIO *fp; + PERL_ARGS_ASSERT_DO_SYSSEEK; + if (gv && (io = GvIO(gv)) && (fp = IoIFP(io))) return PerlLIO_lseek(PerlIO_fileno(fp), pos, whence); if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) @@ -1195,6 +1207,9 @@ bool Perl_do_print(pTHX_ register SV *sv, PerlIO *fp) { dVAR; + + PERL_ARGS_ASSERT_DO_PRINT; + /* assuming fp is checked earlier */ if (!sv) return TRUE; @@ -1365,6 +1380,7 @@ static void S_exec_failed(pTHX_ const char *cmd, int fd, int do_report) { const int e = errno; + PERL_ARGS_ASSERT_EXEC_FAILED; if (ckWARN(WARN_EXEC)) Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't exec \"%s\": %s", cmd, Strerror(e)); @@ -1379,6 +1395,7 @@ Perl_do_aexec5(pTHX_ SV *really, register SV **mark, register SV **sp, int fd, int do_report) { dVAR; + PERL_ARGS_ASSERT_DO_AEXEC5; #if defined(MACOS_TRADITIONAL) || defined(__SYMBIAN32__) || defined(__LIBCATAMOUNT__) Perl_croak(aTHX_ "exec? I'm not *that* kind of operating system"); #else @@ -1433,9 +1450,11 @@ Perl_do_exec3(pTHX_ const char *incmd, int fd, int do_report) register char *s; char *buf; char *cmd; - /* Make a copy so we can change it */ const Size_t cmdlen = strlen(incmd) + 1; + + PERL_ARGS_ASSERT_DO_EXEC3; + Newx(buf, cmdlen, char); cmd = buf; memcpy(cmd, incmd, cmdlen); @@ -1566,6 +1585,8 @@ Perl_apply(pTHX_ I32 type, register SV **mark, register SV **sp) const char *s; SV ** const oldmark = mark; + PERL_ARGS_ASSERT_APPLY; + /* Doing this ahead of the switch statement preserves the old behaviour, where attempting to use kill as a taint test test would fail on platforms where kill was not defined. */ @@ -1868,6 +1889,9 @@ Perl_cando(pTHX_ Mode_t mode, bool effective, register const Stat_t *statbufp) */ { dVAR; + + PERL_ARGS_ASSERT_CANDO; + #ifdef DOSISH /* [Comments and code from Len Reed] * MS-DOS "user" is similar to UNIX's "superuser," but can't write @@ -1961,6 +1985,7 @@ Perl_do_ipcget(pTHX_ I32 optype, SV **mark, SV **sp) const I32 n = (optype == OP_MSGGET) ? 0 : SvIVx(*++mark); const I32 flags = SvIVx(*++mark); + PERL_ARGS_ASSERT_DO_IPCGET; PERL_UNUSED_ARG(sp); SETERRNO(0,0); @@ -2001,6 +2026,7 @@ Perl_do_ipcctl(pTHX_ I32 optype, SV **mark, SV **sp) STRLEN infosize = 0; I32 getinfo = (cmd == IPC_STAT); + PERL_ARGS_ASSERT_DO_IPCCTL; PERL_UNUSED_ARG(sp); switch (optype) @@ -2123,6 +2149,7 @@ Perl_do_msgsnd(pTHX_ SV **mark, SV **sp) const char * const mbuf = SvPV_const(mstr, len); const I32 msize = len - sizeof(long); + PERL_ARGS_ASSERT_DO_MSGSND; PERL_UNUSED_ARG(sp); if (msize < 0) @@ -2146,6 +2173,8 @@ Perl_do_msgrcv(pTHX_ SV **mark, SV **sp) I32 msize, flags, ret; const I32 id = SvIVx(*++mark); SV * const mstr = *++mark; + + PERL_ARGS_ASSERT_DO_MSGRCV; PERL_UNUSED_ARG(sp); /* suppress warning when reading into undef var --jhi */ @@ -2184,6 +2213,8 @@ Perl_do_semop(pTHX_ SV **mark, SV **sp) const I32 id = SvIVx(*++mark); SV * const opstr = *++mark; const char * const opbuf = SvPV_const(opstr, opsize); + + PERL_ARGS_ASSERT_DO_SEMOP; PERL_UNUSED_ARG(sp); if (opsize < 3 * SHORTSIZE @@ -2238,6 +2269,8 @@ Perl_do_shmio(pTHX_ I32 optype, SV **mark, SV **sp) SV * const mstr = *++mark; const I32 mpos = SvIVx(*++mark); const I32 msize = SvIVx(*++mark); + + PERL_ARGS_ASSERT_DO_SHMIO; PERL_UNUSED_ARG(sp); SETERRNO(0,0); @@ -2304,6 +2337,9 @@ Perl_start_glob (pTHX_ SV *tmpglob, IO *io) dVAR; SV * const tmpcmd = newSV(0); PerlIO *fp; + + PERL_ARGS_ASSERT_START_GLOB; + ENTER; SAVEFREESV(tmpcmd); #ifdef VMS /* expand the wildcards right here, rather than opening a pipe, */ diff --git a/doop.c b/doop.c index b19632f..3b5cef3 100644 --- a/doop.c +++ b/doop.c @@ -35,8 +35,10 @@ S_do_trans_simple(pTHX_ SV * const sv) STRLEN len; U8 *s = (U8*)SvPV(sv,len); U8 * const send = s+len; - const short * const tbl = (short*)cPVOP->op_pv; + + PERL_ARGS_ASSERT_DO_TRANS_SIMPLE; + if (!tbl) Perl_croak(aTHX_ "panic: do_trans_simple line %d",__LINE__); @@ -102,8 +104,10 @@ S_do_trans_count(pTHX_ SV * const sv) const U8 *s = (const U8*)SvPV_const(sv, len); const U8 * const send = s + len; I32 matches = 0; - const short * const tbl = (short*)cPVOP->op_pv; + + PERL_ARGS_ASSERT_DO_TRANS_COUNT; + if (!tbl) Perl_croak(aTHX_ "panic: do_trans_count line %d",__LINE__); @@ -138,8 +142,10 @@ S_do_trans_complex(pTHX_ SV * const sv) U8 *s = (U8*)SvPV(sv, len); U8 * const send = s+len; I32 matches = 0; - const short * const tbl = (short*)cPVOP->op_pv; + + PERL_ARGS_ASSERT_DO_TRANS_COMPLEX; + if (!tbl) Perl_croak(aTHX_ "panic: do_trans_complex line %d",__LINE__); @@ -308,7 +314,6 @@ S_do_trans_simple_utf8(pTHX_ SV * const sv) I32 matches = 0; const I32 grows = PL_op->op_private & OPpTRANS_GROWS; STRLEN len; - SV* const rv = #ifdef USE_ITHREADS PAD_SVl(cPADOP->op_padix); @@ -322,6 +327,8 @@ S_do_trans_simple_utf8(pTHX_ SV * const sv) UV final = 0; U8 hibit = 0; + PERL_ARGS_ASSERT_DO_TRANS_SIMPLE_UTF8; + s = (U8*)SvPV(sv, len); if (!SvUTF8(sv)) { const U8 *t = s; @@ -409,7 +416,6 @@ S_do_trans_count_utf8(pTHX_ SV * const sv) const U8 *send; I32 matches = 0; STRLEN len; - SV* const rv = #ifdef USE_ITHREADS PAD_SVl(cPADOP->op_padix); @@ -422,6 +428,8 @@ S_do_trans_count_utf8(pTHX_ SV * const sv) const UV extra = none + 1; U8 hibit = 0; + PERL_ARGS_ASSERT_DO_TRANS_COUNT_UTF8; + s = (const U8*)SvPV_const(sv, len); if (!SvUTF8(sv)) { const U8 *t = s; @@ -474,8 +482,10 @@ S_do_trans_complex_utf8(pTHX_ SV * const sv) STRLEN len; U8 *dstart, *dend; U8 hibit = 0; - U8 *s = (U8*)SvPV(sv, len); + + PERL_ARGS_ASSERT_DO_TRANS_COMPLEX_UTF8; + if (!SvUTF8(sv)) { const U8 *t = s; const U8 * const e = s + len; @@ -623,6 +633,8 @@ Perl_do_trans(pTHX_ SV *sv) const I32 hasutf = (PL_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)); + PERL_ARGS_ASSERT_DO_TRANS; + if (SvREADONLY(sv) && !(PL_op->op_private & OPpTRANS_IDENTICAL)) { if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0); @@ -673,6 +685,8 @@ Perl_do_join(pTHX_ register SV *sv, SV *delim, register SV **mark, register SV * register STRLEN len; STRLEN delimlen; + PERL_ARGS_ASSERT_DO_JOIN; + (void) SvPV_const(delim, delimlen); /* stringify and get the delimlen */ /* SvCUR assumes it's SvPOK() and woe betide you if it's not. */ @@ -729,6 +743,8 @@ Perl_do_sprintf(pTHX_ SV *sv, I32 len, SV **sarg) const char * const pat = SvPV_const(*sarg, patlen); bool do_taint = FALSE; + PERL_ARGS_ASSERT_DO_SPRINTF; + SvUTF8_off(sv); if (DO_UTF8(*sarg)) SvUTF8_on(sv); @@ -747,6 +763,8 @@ Perl_do_vecget(pTHX_ SV *sv, I32 offset, I32 size) const unsigned char *s = (const unsigned char *) SvPV_const(sv, srclen); UV retnum = 0; + PERL_ARGS_ASSERT_DO_VECGET; + if (offset < 0) return 0; if (size < 1 || (size & (size-1))) /* size < 1 or not a power of two */ @@ -897,6 +915,8 @@ Perl_do_vecset(pTHX_ SV *sv) STRLEN len; SV * const targ = LvTARG(sv); + PERL_ARGS_ASSERT_DO_VECSET; + if (!targ) return; s = (unsigned char*)SvPV_force(targ, targlen); @@ -976,6 +996,8 @@ Perl_do_chop(pTHX_ register SV *astr, register SV *sv) STRLEN len; char *s; + PERL_ARGS_ASSERT_DO_CHOP; + if (SvTYPE(sv) == SVt_PVAV) { register I32 i; AV* const av = (AV*)sv; @@ -1055,6 +1077,8 @@ Perl_do_chomp(pTHX_ register SV *sv) char *temp_buffer = NULL; SV* svrecode = NULL; + PERL_ARGS_ASSERT_DO_CHOMP; + if (RsSNARF(PL_rs)) return 0; if (RsRECORD(PL_rs)) @@ -1203,6 +1227,7 @@ Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right) bool right_utf; STRLEN needlen = 0; + PERL_ARGS_ASSERT_DO_VOP; if (sv != left || (optype != OP_BIT_AND && !SvOK(sv) && !SvGMAGICAL(sv))) sv_setpvs(sv, ""); /* avoid undef warning on |= and ^= */ diff --git a/dump.c b/dump.c index ef7a303..14ebf9d 100644 --- a/dump.c +++ b/dump.c @@ -74,6 +74,7 @@ void Perl_dump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...) { va_list args; + PERL_ARGS_ASSERT_DUMP_INDENT; va_start(args, pat); dump_vindent(level, file, pat, &args); va_end(args); @@ -83,6 +84,7 @@ void Perl_dump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args) { dVAR; + PERL_ARGS_ASSERT_DUMP_VINDENT; PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), ""); PerlIO_vprintf(file, pat, *args); } @@ -103,6 +105,8 @@ Perl_dump_packsubs(pTHX_ const HV *stash) dVAR; I32 i; + PERL_ARGS_ASSERT_DUMP_PACKSUBS; + if (!HvARRAY(stash)) return; for (i = 0; i <= (I32) HvMAX(stash); i++) { @@ -129,6 +133,8 @@ Perl_dump_sub(pTHX_ const GV *gv) { SV * const sv = sv_newmortal(); + PERL_ARGS_ASSERT_DUMP_SUB; + gv_fullname3(sv, gv, NULL); Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %s = ", SvPVX_const(sv)); if (CvISXSUB(GvCV(gv))) @@ -146,6 +152,8 @@ Perl_dump_form(pTHX_ const GV *gv) { SV * const sv = sv_newmortal(); + PERL_ARGS_ASSERT_DUMP_FORM; + gv_fullname3(sv, gv, NULL); Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nFORMAT %s = ", SvPVX_const(sv)); if (CvROOT(GvFORM(gv))) @@ -219,6 +227,8 @@ Perl_pv_escape( pTHX_ SV *dsv, char const * const str, const char * const end = pv + count; /* end of string */ octbuf[0] = esc; + PERL_ARGS_ASSERT_PV_ESCAPE; + if (!(flags & PERL_PV_ESCAPE_NOCLEAR)) { /* This won't alter the UTF-8 flag */ sv_setpvs(dsv, ""); @@ -329,7 +339,9 @@ Perl_pv_pretty( pTHX_ SV *dsv, char const * const str, const STRLEN count, { const U8 dq = (flags & PERL_PV_PRETTY_QUOTE) ? '"' : '%'; STRLEN escaped; - + + PERL_ARGS_ASSERT_PV_PRETTY; + if (!(flags & PERL_PV_PRETTY_NOCLEAR)) { /* This won't alter the UTF-8 flag */ sv_setpvs(dsv, ""); @@ -377,6 +389,8 @@ Note that the final string may be up to 7 chars longer than pvlim. char * Perl_pv_display(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim) { + PERL_ARGS_ASSERT_PV_DISPLAY; + pv_pretty( dsv, pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP); if (len > cur && pv[cur] == '\0') sv_catpvs( dsv, "\\0"); @@ -528,6 +542,8 @@ Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, const PMOP *pm) { char ch; + PERL_ARGS_ASSERT_DO_PMOP_DUMP; + if (!pm) { Perl_dump_indent(aTHX_ level, file, "{}\n"); return; @@ -564,6 +580,8 @@ S_pm_description(pTHX_ const PMOP *pm) const REGEXP * const regex = PM_GETRE(pm); const U32 pmflags = pm->op_pmflags; + PERL_ARGS_ASSERT_PM_DESCRIPTION; + if (pmflags & PMf_ONCE) sv_catpv(desc, ",ONCE"); #ifdef USE_ITHREADS @@ -729,6 +747,8 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o) UV seq; const OPCODE optype = o->op_type; + PERL_ARGS_ASSERT_DO_OP_DUMP; + sequence(o); Perl_dump_indent(aTHX_ level, file, "{\n"); level++; @@ -1119,6 +1139,7 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o) void Perl_op_dump(pTHX_ const OP *o) { + PERL_ARGS_ASSERT_OP_DUMP; do_op_dump(0, Perl_debug_log, o); } @@ -1127,6 +1148,8 @@ Perl_gv_dump(pTHX_ GV *gv) { SV *sv; + PERL_ARGS_ASSERT_GV_DUMP; + if (!gv) { PerlIO_printf(Perl_debug_log, "{}\n"); return; @@ -1198,6 +1221,8 @@ static const struct { const char type; const char *name; } magic_names[] = { void Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim) { + PERL_ARGS_ASSERT_DO_MAGIC_DUMP; + for (; mg; mg = mg->mg_moremagic) { Perl_dump_indent(aTHX_ level, file, " MAGIC = 0x%"UVxf"\n", PTR2UV(mg)); @@ -1339,6 +1364,9 @@ void Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv) { const char *hvname; + + PERL_ARGS_ASSERT_DO_HV_DUMP; + Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv)); if (sv && (hvname = HvNAME_get(sv))) PerlIO_printf(file, "\t\"%s\"\n", hvname); @@ -1349,6 +1377,8 @@ Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv) void Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv) { + PERL_ARGS_ASSERT_DO_GV_DUMP; + Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv)); if (sv && GvNAME(sv)) PerlIO_printf(file, "\t\"%s\"\n", GvNAME(sv)); @@ -1359,6 +1389,8 @@ Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv) void Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv) { + PERL_ARGS_ASSERT_DO_GVGV_DUMP; + Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv)); if (sv && GvNAME(sv)) { const char *hvname; @@ -1380,6 +1412,8 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo U32 flags; U32 type; + PERL_ARGS_ASSERT_DO_SV_DUMP; + if (!sv) { Perl_dump_indent(aTHX_ level, file, "SV = 0\n"); return; @@ -1888,6 +1922,9 @@ void Perl_sv_dump(pTHX_ SV *sv) { dVAR; + + PERL_ARGS_ASSERT_SV_DUMP; + if (SvROK(sv)) do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0); else @@ -1937,6 +1974,9 @@ I32 Perl_debop(pTHX_ const OP *o) { dVAR; + + PERL_ARGS_ASSERT_DEBOP; + if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_) return 0; @@ -2015,6 +2055,9 @@ void Perl_watch(pTHX_ char **addr) { dVAR; + + PERL_ARGS_ASSERT_WATCH; + PL_watchaddr = addr; PL_watchok = *addr; PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n", @@ -2025,6 +2068,9 @@ STATIC void S_debprof(pTHX_ const OP *o) { dVAR; + + PERL_ARGS_ASSERT_DEBPROF; + if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash)) return; if (!PL_profiledata) @@ -2056,6 +2102,9 @@ STATIC void S_xmldump_attr(pTHX_ I32 level, PerlIO *file, const char* pat, ...) { va_list args; + + PERL_ARGS_ASSERT_XMLDUMP_ATTR; + PerlIO_printf(file, "\n "); va_start(args, pat); xmldump_vindent(level, file, pat, &args); @@ -2067,6 +2116,7 @@ void Perl_xmldump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...) { va_list args; + PERL_ARGS_ASSERT_XMLDUMP_INDENT; va_start(args, pat); xmldump_vindent(level, file, pat, &args); va_end(args); @@ -2075,6 +2125,8 @@ Perl_xmldump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...) void Perl_xmldump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args) { + PERL_ARGS_ASSERT_XMLDUMP_VINDENT; + PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), ""); PerlIO_vprintf(file, pat, *args); } @@ -2096,6 +2148,8 @@ Perl_xmldump_packsubs(pTHX_ const HV *stash) I32 i; HE *entry; + PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS; + if (!HvARRAY(stash)) return; for (i = 0; i <= (I32) HvMAX(stash); i++) { @@ -2120,6 +2174,8 @@ Perl_xmldump_sub(pTHX_ const GV *gv) { SV * const sv = sv_newmortal(); + PERL_ARGS_ASSERT_XMLDUMP_SUB; + gv_fullname3(sv, gv, NULL); Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nSUB %s = ", SvPVX(sv)); if (CvXSUB(GvCV(gv))) @@ -2137,6 +2193,8 @@ Perl_xmldump_form(pTHX_ const GV *gv) { SV * const sv = sv_newmortal(); + PERL_ARGS_ASSERT_XMLDUMP_FORM; + gv_fullname3(sv, gv, NULL); Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nFORMAT %s = ", SvPVX(sv)); if (CvROOT(GvFORM(gv))) @@ -2154,6 +2212,7 @@ Perl_xmldump_eval(pTHX) char * Perl_sv_catxmlsv(pTHX_ SV *dsv, SV *ssv) { + PERL_ARGS_ASSERT_SV_CATXMLSV; return sv_catxmlpvn(dsv, SvPVX(ssv), SvCUR(ssv), SvUTF8(ssv)); } @@ -2166,6 +2225,8 @@ Perl_sv_catxmlpvn(pTHX_ SV *dsv, const char *pv, STRLEN len, int utf8) STRLEN dsvcur; STRLEN cl; + PERL_ARGS_ASSERT_SV_CATXMLPVN; + sv_catpvs(dsv,""); dsvcur = SvCUR(dsv); /* in case we have to restart */ @@ -2289,6 +2350,8 @@ Perl_sv_xmlpeek(pTHX_ SV *sv) STRLEN n_a; int unref = 0; + PERL_ARGS_ASSERT_SV_XMLPEEK; + sv_utf8_upgrade(t); sv_setpvs(t, ""); /* retry: */ @@ -2449,6 +2512,8 @@ Perl_sv_xmlpeek(pTHX_ SV *sv) void Perl_do_pmop_xmldump(pTHX_ I32 level, PerlIO *file, const PMOP *pm) { + PERL_ARGS_ASSERT_DO_PMOP_XMLDUMP; + if (!pm) { Perl_xmldump_indent(aTHX_ level, file, "<pmop/>\n"); return; @@ -2497,6 +2562,9 @@ Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o) { UV seq; int contents = 0; + + PERL_ARGS_ASSERT_DO_OP_XMLDUMP; + if (!o) return; sequence(o); @@ -2922,6 +2990,8 @@ Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o) void Perl_op_xmldump(pTHX_ const OP *o) { + PERL_ARGS_ASSERT_OP_XMLDUMP; + do_op_xmldump(0, PL_xmlfp, o); } #endif diff --git a/embed.fnc b/embed.fnc index eebaaf9..85a4648 100644 --- a/embed.fnc +++ b/embed.fnc @@ -299,7 +299,7 @@ Ap |void |gv_init |NN GV* gv|NULLOK HV* stash|NN const char* name|STRLEN len|int Ap |void |gv_name_set |NN GV* gv|NN const char *name|U32 len|U32 flags Apd |HV* |gv_stashpv |NN const char* name|I32 flags Apd |HV* |gv_stashpvn |NN const char* name|U32 namelen|I32 flags -Apd |HV* |gv_stashsv |NULLOK SV* sv|I32 flags +Apd |HV* |gv_stashsv |NN SV* sv|I32 flags Apd |void |hv_clear |NULLOK HV* hv poM |HV * |hv_copy_hints_hv|NULLOK HV *const ohv Ap |void |hv_delayfree_ent|NN HV *hv|NULLOK HE *entry @@ -704,18 +704,18 @@ Ap |I32 |pregexec |NN REGEXP * const prog|NN char* stringarg \ |NN SV* screamer|U32 nosave Ap |void |pregfree |NULLOK REGEXP* r EXp |REGEXP*|reg_temp_copy |NN REGEXP* r -Ap |void |regfree_internal|NN REGEXP *const rx +Ap |void |regfree_internal|NN REGEXP *const r Ap |char * |reg_stringify |NN MAGIC *mg|NULLOK STRLEN *lp|NULLOK U32 *flags|NULLOK I32 *haseval #if defined(USE_ITHREADS) Ap |void* |regdupe_internal|NN REGEXP * const r|NN CLONE_PARAMS* param #endif Ap |REGEXP*|pregcomp |NN const SV * const pattern|const U32 flags Ap |REGEXP*|re_compile |NN const SV * const pattern|const U32 flags -Ap |char* |re_intuit_start|NN REGEXP * const rx|NULLOK SV* sv|NN char* strpos \ +Ap |char* |re_intuit_start|NN REGEXP * const prog|NULLOK SV* sv|NN char* strpos \ |NN char* strend|const U32 flags \ |NULLOK re_scream_pos_data *data -Ap |SV* |re_intuit_string|NN REGEXP *const r -Ap |I32 |regexec_flags |NN REGEXP *const rx|NN char *stringarg \ +Ap |SV* |re_intuit_string|NN REGEXP *const prog +Ap |I32 |regexec_flags |NN REGEXP *const prog|NN char *stringarg \ |NN char *strend|NN char *strbeg|I32 minend \ |NN SV *sv|NULLOK void *data|U32 flags ApR |regnode*|regnext |NULLOK regnode* p diff --git a/embed.pl b/embed.pl index 81e9de8..3204f97 100755 --- a/embed.pl +++ b/embed.pl @@ -156,13 +156,15 @@ sub write_protos { $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 @names_of_nn; + my $func; my $splint_flags = ""; if ( $SPLINT && !$commented_out ) { @@ -174,12 +176,14 @@ sub write_protos { if ($flags =~ /s/) { $retval = "STATIC $splint_flags$retval"; - $func = "S_$func"; + $func = "S_$plain_func"; } else { $retval = "PERL_CALLCONV $splint_flags$retval"; if ($flags =~ /[bp]/) { - $func = "Perl_$func"; + $func = "Perl_$plain_func"; + } else { + $func = $plain_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; - 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 (defined $1 && $nn) { + push @names_of_nn, $1; + } } $ret .= join ", ", @args; } @@ -251,6 +259,10 @@ sub write_protos { } $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; diff --git a/gv.c b/gv.c index c7c9385..18cf509 100644 --- a/gv.c +++ b/gv.c @@ -45,6 +45,8 @@ static const STRLEN S_autolen = sizeof(S_autoload)-1; GV * Perl_gv_SVadd(pTHX_ GV *gv) { + PERL_ARGS_ASSERT_GV_SVADD; + if (!gv || SvTYPE((SV*)gv) != SVt_PVGV) Perl_croak(aTHX_ "Bad symbol for scalar"); if (!GvSV(gv)) @@ -56,6 +58,8 @@ Perl_gv_SVadd(pTHX_ GV *gv) GV * Perl_gv_AVadd(pTHX_ register GV *gv) { + PERL_ARGS_ASSERT_GV_AVADD; + if (!gv || SvTYPE((SV*)gv) != SVt_PVGV) **** PATCH TRUNCATED AT 1000 LINES -- 14115 NOT SHOWN **** -- Perl5 Master Repository
