Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
{
const register U8 *s;
- register U8 *table;
register U32 i;
STRLEN len;
I32 rarest = 0;
U32 frequency = 256;
if (flags & FBMcf_TAIL) {
- MAGIC *mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
+ MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
sv_catpvn(sv, "\n", 1); /* Taken into account in fbm_instr() */
if (mg && mg->mg_len >= 0)
mg->mg_len++;
if (len > 2) {
const unsigned char *sb;
const U8 mlen = (len>255) ? 255 : (U8)len;
+ register U8 *table;
Sv_Grow(sv, len + 256 + FBM_TABLE_OFFSET);
table = (unsigned char*)(SvPVX_mutable(sv) + len + FBM_TABLE_OFFSET);
else {
char *newaddr;
const STRLEN pvlen = strlen(pv)+1;
- New(902,newaddr,pvlen,char);
+ Newx(newaddr,pvlen,char);
return memcpy(newaddr,pv,pvlen);
}
{
register char *newaddr;
- New(903,newaddr,len+1,char);
+ Newx(newaddr,len+1,char);
/* Give a meaning to NULL pointer mainly for the use in sv_magic() */
if (pv) {
/* might not be null terminated */
register char *newaddr;
++len;
- New(903,newaddr,len,char);
+ Newx(newaddr,len,char);
return (char *) CopyD(pv,newaddr,len,char);
}
return PL_mess_sv;
/* Create as PVMG now, to avoid any upgrading later */
- New(905, sv, 1, SV);
- Newz(905, any, 1, XPVMG);
+ Newx(sv, 1, SV);
+ Newxz(any, 1, XPVMG);
SvFLAGS(sv) = SVt_PVMG;
SvANY(sv) = (void*)any;
SvPV_set(sv, 0);
char *
Perl_vform(pTHX_ const char *pat, va_list *args)
{
- SV *sv = mess_alloc();
+ SV * const sv = mess_alloc();
sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
return SvPVX(sv);
}
GV *gv;
CV *cv;
/* sv_2cv might call Perl_croak() */
- SV *olddiehook = PL_diehook;
+ SV * const olddiehook = PL_diehook;
assert(PL_diehook);
ENTER;
const char *message;
if (pat) {
- SV *msv = vmess(pat, args);
+ SV * const msv = vmess(pat, args);
if (PL_errors && SvCUR(PL_errors)) {
sv_catsv(PL_errors, msv);
message = SvPV_const(PL_errors, *msglen);
"%p: die: curstack = %p, mainstack = %p\n",
thr, PL_curstack, PL_mainstack));
- message = S_vdie_croak_common(aTHX_ pat, args, &msglen, &utf8);
+ message = vdie_croak_common(pat, args, &msglen, &utf8);
PL_restartop = die_where(message, msglen);
SvFLAGS(ERRSV) |= utf8;
SV *msg;
ENTER;
+ SAVESPTR(PL_warnhook);
+ PL_warnhook = Nullsv;
save_re_context();
msg = newSVpvn(message, msglen);
SvFLAGS(msg) |= utf8;
val = "";
}
vlen = strlen(val);
- New(904, envstr, nlen+vlen+2, char);
+ Newx(envstr, nlen+vlen+2, char);
my_setenv_format(envstr, nam, nlen, val, vlen);
(void)PerlEnv_putenv(envstr);
Safefree(envstr);
#ifdef UNLINK_ALL_VERSIONS
I32
-Perl_unlnk(pTHX_ char *f) /* unlink all versions of a file */
+Perl_unlnk(pTHX_ const char *f) /* unlink all versions of a file */
{
I32 i;
char *
Perl_my_bcopy(register const char *from,register char *to,register I32 len)
{
- char *retval = to;
+ char * const retval = to;
if (from - to >= 0) {
while (len--)
void *
Perl_my_memset(register char *loc, register I32 ch, register I32 len)
{
- char *retval = loc;
+ char * const retval = loc;
while (len--)
*loc++ = ch;
char *
Perl_my_bzero(register char *loc, register I32 len)
{
- char *retval = loc;
+ char * const retval = loc;
while (len--)
*loc++ = 0;
/* VMS' my_popen() is in VMS.c, same with OS/2. */
#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
PerlIO *
-Perl_my_popen(pTHX_ char *cmd, char *mode)
+Perl_my_popen(pTHX_ const char *cmd, const char *mode)
{
int p[2];
register I32 This, that;
register Pid_t pid;
SV *sv;
- I32 doexec = !(*cmd == '-' && cmd[1] == '\0');
+ const I32 doexec = !(*cmd == '-' && cmd[1] == '\0');
I32 did_pipes = 0;
int pp[2];
#ifdef USE_ITHREADS
/* only "parent" interpreter can diddle signals */
if (PL_curinterp != aTHX)
- return SIG_ERR;
+ return (Sighandler_t) SIG_ERR;
#endif
- act.sa_handler = handler;
+ act.sa_handler = (void(*)(int))handler;
sigemptyset(&act.sa_mask);
act.sa_flags = 0;
#ifdef SA_RESTART
act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
#endif
#if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
- if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN)
+ if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
act.sa_flags |= SA_NOCLDWAIT;
#endif
if (sigaction(signo, &act, &oact) == -1)
- return SIG_ERR;
+ return (Sighandler_t) SIG_ERR;
else
- return oact.sa_handler;
+ return (Sighandler_t) oact.sa_handler;
}
Sighandler_t
struct sigaction oact;
if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
- return SIG_ERR;
+ return (Sighandler_t) SIG_ERR;
else
- return oact.sa_handler;
+ return (Sighandler_t) oact.sa_handler;
}
int
return -1;
#endif
- act.sa_handler = handler;
+ act.sa_handler = (void(*)(int))handler;
sigemptyset(&act.sa_mask);
act.sa_flags = 0;
#ifdef SA_RESTART
act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
#endif
#if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
- if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN)
+ if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
act.sa_flags |= SA_NOCLDWAIT;
#endif
return sigaction(signo, &act, save);
#if defined(USE_ITHREADS) && !defined(WIN32)
/* only "parent" interpreter can diddle signals */
if (PL_curinterp != aTHX)
- return SIG_ERR;
+ return (Sighandler_t) SIG_ERR;
#endif
return PerlProc_signal(signo, handler);
#if defined(USE_ITHREADS) && !defined(WIN32)
/* only "parent" interpreter can diddle signals */
if (PL_curinterp != aTHX)
- return SIG_ERR;
+ return (Sighandler_t) SIG_ERR;
#endif
PL_sig_trapped = 0;
return -1;
#endif
*save = PerlProc_signal(signo, handler);
- return (*save == SIG_ERR) ? -1 : 0;
+ return (*save == (Sighandler_t) SIG_ERR) ? -1 : 0;
}
int
if (PL_curinterp != aTHX)
return -1;
#endif
- return (PerlProc_signal(signo, *save) == SIG_ERR) ? -1 : 0;
+ return (PerlProc_signal(signo, *save) == (Sighandler_t) SIG_ERR) ? -1 : 0;
}
#endif /* !HAS_SIGACTION */
if(PerlProc_kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */
#endif
#ifndef PERL_MICRO
- rsignal_save(SIGHUP, SIG_IGN, &hstat);
- rsignal_save(SIGINT, SIG_IGN, &istat);
- rsignal_save(SIGQUIT, SIG_IGN, &qstat);
+ rsignal_save(SIGHUP, (Sighandler_t) SIG_IGN, &hstat);
+ rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &istat);
+ rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qstat);
#endif
do {
pid2 = wait4pid(pid, &status, 0);
void
Perl_report_evil_fh(pTHX_ const GV *gv, const IO *io, I32 op)
{
- const char *func =
+ const char * const func =
op == OP_READLINE ? "readline" : /* "<HANDLE>" not nice */
op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */
PL_op_desc[op];
- const char *pars = OP_IS_FILETEST(op) ? "" : "()";
- const char *type = OP_IS_SOCKET(op)
+ const char * const pars = OP_IS_FILETEST(op) ? "" : "()";
+ const char * const type = OP_IS_SOCKET(op)
|| (gv && io && IoTYPE(io) == IoTYPE_SOCKET)
? "socket" : "filehandle";
- const char *name = NULL;
-
- if (gv && isGV(gv)) {
- name = GvENAME(gv);
- }
+ const char * const name = gv && isGV(gv) ? GvENAME(gv) : NULL;
if (op == OP_phoney_OUTPUT_ONLY || op == OP_phoney_INPUT_ONLY) {
if (ckWARN(WARN_IO)) {
- const char *direction = (op == OP_phoney_INPUT_ONLY) ? "in" : "out";
+ const char * const direction = (op == OP_phoney_INPUT_ONLY) ? "in" : "out";
if (name && *name)
Perl_warner(aTHX_ packWARN(WARN_IO),
"Filehandle %s opened only for %sput",
} STMT_END;
#endif
buflen = 64;
- New(0, buf, buflen, char);
+ Newx(buf, buflen, char);
len = strftime(buf, buflen, fmt, &mytm);
/*
** The following is needed to handle to the situation where
const int fmtlen = strlen(fmt);
const int bufsize = fmtlen + buflen;
- New(0, buf, bufsize, char);
+ Newx(buf, bufsize, char);
while (buf) {
buflen = strftime(buf, bufsize, fmt, &mytm);
if (buflen > 0 && buflen < bufsize)
const char *
Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
{
- const char *start = s;
+ const char *start;
const char *pos;
const char *last;
int saw_period = 0;
- int saw_under = 0;
+ int alpha = 0;
int width = 3;
AV *av = newAV();
- SV* hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
+ SV *hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
(void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
+
#ifndef NODEFAULT_SHAREKEYS
HvSHAREKEYS_on(hv); /* key-sharing on by default */
#endif
+ while (isSPACE(*s)) /* leading whitespace is OK */
+ s++;
+
if (*s == 'v') {
s++; /* get past 'v' */
qv = 1; /* force quoted version processing */
}
- last = pos = s;
+ start = last = pos = s;
/* pre-scan the input string to check for decimals/underbars */
while ( *pos == '.' || *pos == '_' || isDIGIT(*pos) )
{
if ( *pos == '.' )
{
- if ( saw_under )
+ if ( alpha )
Perl_croak(aTHX_ "Invalid version format (underscores before decimal)");
saw_period++ ;
last = pos;
}
else if ( *pos == '_' )
{
- if ( saw_under )
+ if ( alpha )
Perl_croak(aTHX_ "Invalid version format (multiple underscores)");
- saw_under = 1;
+ alpha = 1;
width = pos - last - 1; /* natural width of sub-version */
}
pos++;
}
- if ( saw_period > 1 ) {
+ if ( saw_period > 1 )
qv = 1; /* force quoted version processing */
- }
pos = s;
if ( qv )
- hv_store((HV *)hv, "qv", 2, &PL_sv_yes, 0);
- if ( saw_under ) {
- hv_store((HV *)hv, "alpha", 5, &PL_sv_yes, 0);
- }
+ hv_store((HV *)hv, "qv", 2, newSViv(qv), 0);
+ if ( alpha )
+ hv_store((HV *)hv, "alpha", 5, newSViv(alpha), 0);
if ( !qv && width < 3 )
hv_store((HV *)hv, "width", 5, newSViv(width), 0);
* point of a version originally created with a bare
* floating point number, i.e. not quoted in any way
*/
- if ( !qv && s > start+1 && saw_period == 1 ) {
+ if ( !qv && s > start && saw_period == 1 ) {
mult *= 100;
while ( s < end ) {
orev = rev;
av_push(av, newSViv(0));
/* And finally, store the AV in the hash */
- hv_store((HV *)hv, "version", 7, (SV *)av, 0);
+ hv_store((HV *)hv, "version", 7, newRV_noinc((SV *)av), 0);
return s;
}
SV *
Perl_new_version(pTHX_ SV *ver)
{
- SV *rv = newSV(0);
+ SV * const rv = newSV(0);
if ( sv_derived_from(ver,"version") ) /* can just copy directly */
{
I32 key;
AV * const av = newAV();
AV *sav;
/* This will get reblessed later if a derived class*/
- SV* const hv = newSVrv(rv, "version");
+ SV * const hv = newSVrv(rv, "version");
(void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
#ifndef NODEFAULT_SHAREKEYS
HvSHAREKEYS_on(hv); /* key-sharing on by default */
hv_store((HV *)hv, "width", 5, newSViv(width), 0);
}
- sav = (AV *)*hv_fetch((HV*)ver, "version", 7, FALSE);
+ sav = (AV *)SvRV(*hv_fetch((HV*)ver, "version", 7, FALSE));
/* This will get reblessed later if a derived class*/
for ( key = 0; key <= av_len(sav); key++ )
{
av_push(av, newSViv(rev));
}
- hv_store((HV *)hv, "version", 7, (SV *)av, 0);
+ hv_store((HV *)hv, "version", 7, newRV_noinc((SV *)av), 0);
return rv;
}
#ifdef SvVOK
if ( SvVOK(ver) ) { /* already a v-string */
- char *version;
- MAGIC* mg = mg_find(ver,PERL_MAGIC_vstring);
+ const MAGIC* const mg = mg_find(ver,PERL_MAGIC_vstring);
const STRLEN len = mg->mg_len;
- version = savepvn( (const char*)mg->mg_ptr, len);
+ char * const version = savepvn( (const char*)mg->mg_ptr, len);
sv_setpvn(rv,version,len);
Safefree(version);
}
}
#ifdef SvVOK
else if ( SvVOK(ver) ) { /* already a v-string */
- MAGIC* mg = mg_find(ver,PERL_MAGIC_vstring);
+ const MAGIC* const mg = mg_find(ver,PERL_MAGIC_vstring);
version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
qv = 1;
}
return ver;
}
+/*
+=for apidoc vverify
+
+Validates that the SV contains a valid version object.
+
+ bool vverify(SV *vobj);
+
+Note that it only confirms the bare minimum structure (so as not to get
+confused by derived classes which may contain additional hash entries):
+
+=over 4
+
+=item * The SV contains a [reference to a] hash
+
+=item * The hash contains a "version" key
+
+=item * The "version" key has [a reference to] an AV as its value
+
+=back
+
+=cut
+*/
+
+bool
+Perl_vverify(pTHX_ SV *vs)
+{
+ SV *sv;
+ if ( SvROK(vs) )
+ vs = SvRV(vs);
+
+ /* see if the appropriate elements exist */
+ if ( SvTYPE(vs) == SVt_PVHV
+ && hv_exists((HV*)vs, "version", 7)
+ && (sv = SvRV(*hv_fetch((HV*)vs, "version", 7, FALSE)))
+ && SvTYPE(sv) == SVt_PVAV )
+ return TRUE;
+ else
+ return FALSE;
+}
/*
=for apidoc vnumify
if ( SvROK(vs) )
vs = SvRV(vs);
+ if ( !vverify(vs) )
+ Perl_croak(aTHX_ "Invalid version object");
+
/* see if various flags exist */
if ( hv_exists((HV*)vs, "alpha", 5 ) )
alpha = TRUE;
/* attempt to retrieve the version array */
- if ( !(av = (AV *)*hv_fetch((HV*)vs, "version", 7, FALSE) ) ) {
+ if ( !(av = (AV *)SvRV(*hv_fetch((HV*)vs, "version", 7, FALSE)) ) ) {
sv_catpvn(sv,"0",1);
return sv;
}
}
digit = SvIV(*av_fetch(av, 0, 0));
- Perl_sv_setpvf(aTHX_ sv,"%d.", (int)PERL_ABS(digit));
+ Perl_sv_setpvf(aTHX_ sv, "%d.", (int)PERL_ABS(digit));
for ( i = 1 ; i < len ; i++ )
{
digit = SvIV(*av_fetch(av, i, 0));
if ( width < 3 ) {
const int denom = (int)pow(10,(3-width));
const div_t term = div((int)PERL_ABS(digit),denom);
- Perl_sv_catpvf(aTHX_ sv,"%0*d_%d", width, term.quot, term.rem);
+ Perl_sv_catpvf(aTHX_ sv, "%0*d_%d", width, term.quot, term.rem);
}
else {
- Perl_sv_catpvf(aTHX_ sv,"%0*d", width, (int)digit);
+ Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
}
}
{
digit = SvIV(*av_fetch(av, len, 0));
if ( alpha && width == 3 ) /* alpha version */
- Perl_sv_catpv(aTHX_ sv,"_");
- /* Don't display additional trailing zeros */
- if ( digit > 0 )
- Perl_sv_catpvf(aTHX_ sv,"%0*d", width, (int)digit);
+ sv_catpvn(sv,"_",1);
+ Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
}
- else /* len == 1 */
+ else /* len == 0 */
{
- sv_catpvn(sv,"000",3);
+ sv_catpvn(sv,"000",3);
}
return sv;
}
{
I32 i, len, digit;
bool alpha = FALSE;
- SV *sv = newSV(0);
+ SV * const sv = newSV(0);
AV *av;
if ( SvROK(vs) )
vs = SvRV(vs);
+ if ( !vverify(vs) )
+ Perl_croak(aTHX_ "Invalid version object");
+
if ( hv_exists((HV*)vs, "alpha", 5 ) )
alpha = TRUE;
- av = (AV *)*hv_fetch((HV*)vs, "version", 7, FALSE);
+ av = (AV *)SvRV(*hv_fetch((HV*)vs, "version", 7, FALSE));
len = av_len(av);
- if ( len == -1 ) {
+ if ( len == -1 )
+ {
sv_catpvn(sv,"",0);
return sv;
}
digit = SvIV(*av_fetch(av, 0, 0));
- Perl_sv_setpvf(aTHX_ sv,"v%"IVdf,(IV)digit);
- for ( i = 1 ; i <= len-1 ; i++ ) {
+ Perl_sv_setpvf(aTHX_ sv, "v%"IVdf, (IV)digit);
+ for ( i = 1 ; i < len ; i++ ) {
digit = SvIV(*av_fetch(av, i, 0));
Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
}
- if ( len > 0 ) {
+ if ( len > 0 )
+ {
/* handle last digit specially */
digit = SvIV(*av_fetch(av, len, 0));
if ( alpha )
for ( len = 2 - len; len != 0; len-- )
sv_catpvn(sv,".0",2);
}
-
return sv;
}
SV *
Perl_vstringify(pTHX_ SV *vs)
{
- I32 qv = 0;
if ( SvROK(vs) )
vs = SvRV(vs);
+ if ( !vverify(vs) )
+ Perl_croak(aTHX_ "Invalid version object");
+
if ( hv_exists((HV *)vs, "qv", 2) )
- qv = 1;
-
- if ( qv )
return vnormal(vs);
else
return vnumify(vs);
if ( SvROK(rhv) )
rhv = SvRV(rhv);
+ if ( !vverify(lhv) )
+ Perl_croak(aTHX_ "Invalid version object");
+
+ if ( !vverify(rhv) )
+ Perl_croak(aTHX_ "Invalid version object");
+
/* get the left hand term */
- lav = (AV *)*hv_fetch((HV*)lhv, "version", 7, FALSE);
+ lav = (AV *)SvRV(*hv_fetch((HV*)lhv, "version", 7, FALSE));
if ( hv_exists((HV*)lhv, "alpha", 5 ) )
lalpha = TRUE;
/* and the right hand term */
- rav = (AV *)*hv_fetch((HV*)rhv, "version", 7, FALSE);
+ rav = (AV *)SvRV(*hv_fetch((HV*)rhv, "version", 7, FALSE));
if ( hv_exists((HV*)rhv, "alpha", 5 ) )
ralpha = TRUE;
#endif /* PERL_GLOBAL_STRUCT */
+#ifdef PERL_MEM_LOG
+
+#define PERL_MEM_LOG_SPRINTF_BUF_SIZE 128
+
+Malloc_t
+Perl_mem_log_alloc(const UV n, const UV typesize, const char *typename, Malloc_t newalloc, const char *filename, const int linenumber, const char *funcname)
+{
+#ifdef PERL_MEM_LOG_STDERR
+ /* We can't use PerlIO for obvious reasons. */
+ char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
+ sprintf(buf,
+ "alloc: %s:%d:%s: %"IVdf" %"UVuf" %s = %"IVdf": %"UVxf"\n",
+ filename, linenumber, funcname,
+ n, typesize, typename, n * typesize, PTR2UV(newalloc));
+ PerlLIO_write(2, buf, strlen(buf));
+#endif
+ return newalloc;
+}
+
+Malloc_t
+Perl_mem_log_realloc(const UV n, const UV typesize, const char *typename, Malloc_t oldalloc, Malloc_t newalloc, const char *filename, const int linenumber, const char *funcname)
+{
+#ifdef PERL_MEM_LOG_STDERR
+ /* We can't use PerlIO for obvious reasons. */
+ char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
+ sprintf(buf,
+ "realloc: %s:%d:%s: %"IVdf" %"UVuf" %s = %"IVdf": %"UVxf" -> %"UVxf"\n",
+ filename, linenumber, funcname,
+ n, typesize, typename, n * typesize, PTR2UV(oldalloc), PTR2UV(newalloc));
+ PerlLIO_write(2, buf, strlen(buf));
+#endif
+ return newalloc;
+}
+
+Malloc_t
+Perl_mem_log_free(Malloc_t oldalloc, const char *filename, const int linenumber, const char *funcname)
+{
+#ifdef PERL_MEM_LOG_STDERR
+ /* We can't use PerlIO for obvious reasons. */
+ char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
+ sprintf(buf, "free: %s:%d:%s: %"UVxf"\n",
+ filename, linenumber, funcname, PTR2UV(oldalloc));
+ PerlLIO_write(2, buf, strlen(buf));
+#endif
+ return oldalloc;
+}
+
+#endif /* PERL_MEM_LOG */
+
/*
* Local variables:
* c-indentation-style: bsd
https://perl5.git.perl.org / perl5.git / blobdiff