#ifdef PERL_TRACK_MEMPOOL
struct perl_memory_debug_header *const header
= (struct perl_memory_debug_header *)ptr;
+#endif
+
+#ifdef PERL_POISON
+ PoisonNew(((char *)ptr), size, char);
+#endif
+#ifdef PERL_TRACK_MEMPOOL
header->interpreter = aTHX;
/* Link us into the list. */
header->prev = &PL_memory_debug_header;
if (header->size > size) {
const MEM_SIZE freed_up = header->size - size;
char *start_of_freed = ((char *)where) + size;
- Poison(start_of_freed, freed_up, char);
+ PoisonFree(start_of_freed, freed_up, char);
}
header->size = size;
# endif
struct perl_memory_debug_header *const header
= (struct perl_memory_debug_header *)ptr;
+# ifdef PERL_POISON
+ if (header->size < size) {
+ const MEM_SIZE fresh = size - header->size;
+ char *start_of_fresh = ((char *)ptr) + size;
+ PoisonNew(start_of_fresh, fresh, char);
+ }
+# endif
+
header->next->prev = header;
header->prev->next = header;
header->next->prev = header->prev;
header->prev->next = header->next;
# ifdef PERL_POISON
- Poison(where, header->size, char);
+ PoisonNew(where, header->size, char);
# endif
/* Trigger the duplicate free warning. */
header->next = NULL;
Perl_delimcpy(pTHX_ register char *to, register const char *toend, register const char *from, register const char *fromend, register int delim, I32 *retlen)
{
register I32 tolen;
+ PERL_UNUSED_CONTEXT;
for (tolen = 0; from < fromend; from++, tolen++) {
if (*from == '\\') {
if (from[1] == delim)
Perl_instr(pTHX_ register const char *big, register const char *little)
{
register I32 first;
+ PERL_UNUSED_CONTEXT;
if (!little)
return (char*)big;
char *
Perl_ninstr(pTHX_ const char *big, const char *bigend, const char *little, const char *lend)
{
+ PERL_UNUSED_CONTEXT;
if (little >= lend)
return (char*)big;
{
register const char *bigbeg;
register const I32 first = *little;
register const char * const littleend = lend;
+ PERL_UNUSED_CONTEXT;
if (little >= littleend)
return (char*)bigend;
{
register const U8 *a = (const U8 *)s1;
register const U8 *b = (const U8 *)s2;
+ PERL_UNUSED_CONTEXT;
+
while (len--) {
if (*a != *b && *a != PL_fold[*b])
return 1;
dVAR;
register const U8 *a = (const U8 *)s1;
register const U8 *b = (const U8 *)s2;
+ PERL_UNUSED_CONTEXT;
+
while (len--) {
if (*a != *b && *a != PL_fold_locale[*b])
return 1;
char *
Perl_savepv(pTHX_ const char *pv)
{
+ PERL_UNUSED_CONTEXT;
if (!pv)
return NULL;
else {
Newx(newaddr,pvlen,char);
return memcpy(newaddr,pv,pvlen);
}
-
}
/* same thing but with a known length */
Perl's version of what C<strndup()> would be if it existed. Returns a
pointer to a newly allocated string which is a duplicate of the first
-C<len> bytes from C<pv>. The memory allocated for the new string can be
-freed with the C<Safefree()> function.
+C<len> bytes from C<pv>, plus a trailing NUL byte. The memory allocated for
+the new string can be freed with the C<Safefree()> function.
=cut
*/
Perl_savepvn(pTHX_ const char *pv, register I32 len)
{
register char *newaddr;
+ PERL_UNUSED_CONTEXT;
Newx(newaddr,len+1,char);
/* Give a meaning to NULL pointer mainly for the use in sv_magic() */
Perl_vform(pTHX_ const char *pat, va_list *args)
{
SV * const sv = mess_alloc();
- sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
+ sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
return SvPVX(sv);
}
;
}
+/* Set buffer=NULL to get a new one. */
+STRLEN *
+Perl_new_warnings_bitfield(pTHX_ STRLEN *buffer, const char *const bits,
+ STRLEN size) {
+ const MEM_SIZE len_wanted = sizeof(STRLEN) + size;
+ buffer = specialWARN(buffer) ? PerlMemShared_malloc(len_wanted)
+ : PerlMemShared_realloc(buffer, len_wanted);
+ buffer[0] = size;
+ Copy(bits, (buffer + 1), size, char);
+ return buffer;
+}
/* since we've already done strlen() for both nam and val
* we can use that info to make things faster than
}
else
safesysfree(environ[i]);
- nlen = strlen(nam);
- vlen = strlen(val);
+ nlen = strlen(nam);
+ vlen = strlen(val);
- environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char));
- /* all that work just for this */
- my_setenv_format(environ[i], nam, nlen, val, vlen);
+ environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char));
+ /* all that work just for this */
+ my_setenv_format(environ[i], nam, nlen, val, vlen);
} else {
# endif
-# if defined(__CYGWIN__) || defined(EPOC) || defined(__SYMBIAN32__)
+# if defined(__CYGWIN__) || defined(EPOC) || defined(__SYMBIAN32__) || defined(__riscos__)
# if defined(HAS_UNSETENV)
if (val == NULL) {
(void)unsetenv(nam);
{
register I32 i;
register const I32 len = strlen(nam);
+ PERL_UNUSED_CONTEXT;
for (i = 0; environ[i]; i++) {
if (
type value; \
char c[sizeof(type)]; \
} u; \
- register I32 i; \
- register I32 s = 0; \
+ register U32 i; \
+ register U32 s = 0; \
for (i = 0; i < sizeof(u.c); i++, s += 8) { \
u.c[i] = (n >> s) & 0xFF; \
} \
type value; \
char c[sizeof(type)]; \
} u; \
- register I32 i; \
- register I32 s = 0; \
+ register U32 i; \
+ register U32 s = 0; \
u.value = n; \
n = 0; \
for (i = 0; i < sizeof(u.c); i++, s += 8) { \
type value; \
char c[sizeof(type)]; \
} u; \
- register I32 i; \
- register I32 s = 8*(sizeof(u.c)-1); \
+ register U32 i; \
+ register U32 s = 8*(sizeof(u.c)-1); \
for (i = 0; i < sizeof(u.c); i++, s -= 8) { \
u.c[i] = (n >> s) & 0xFF; \
} \
type value; \
char c[sizeof(type)]; \
} u; \
- register I32 i; \
- register I32 s = 8*(sizeof(u.c)-1); \
+ register U32 i; \
+ register U32 s = 8*(sizeof(u.c)-1); \
u.value = n; \
n = 0; \
for (i = 0; i < sizeof(u.c); i++, s -= 8) { \
taint_proper("Insecure %s%s", "EXEC");
}
if (PerlProc_pipe(p) < 0)
- return Nullfp;
+ return NULL;
/* Try for another pipe pair for error return */
if (PerlProc_pipe(pp) >= 0)
did_pipes = 1;
PerlLIO_close(pp[0]);
PerlLIO_close(pp[1]);
}
- return Nullfp;
+ return NULL;
}
sleep(5);
}
/* If we managed to get status pipe check for exec fail */
if (did_pipes && pid > 0) {
int errkid;
- int n = 0, n1;
+ unsigned n = 0;
+ SSize_t n1;
while (n < sizeof(int)) {
n1 = PerlLIO_read(pp[0],
pid2 = wait4pid(pid, &status, 0);
} while (pid2 == -1 && errno == EINTR);
errno = errkid; /* Propagate errno from kid */
- return Nullfp;
+ return NULL;
}
}
if (did_pipes)
taint_proper("Insecure %s%s", "EXEC");
}
if (PerlProc_pipe(p) < 0)
- return Nullfp;
+ return NULL;
if (doexec && PerlProc_pipe(pp) >= 0)
did_pipes = 1;
while ((pid = PerlProc_fork()) < 0) {
}
if (!doexec)
Perl_croak(aTHX_ "Can't fork");
- return Nullfp;
+ return NULL;
}
sleep(5);
}
#ifdef PERL_USES_PL_PIDSTATUS
hv_clear(PL_pidstatus); /* we have no children */
#endif
- return Nullfp;
+ return NULL;
#undef THIS
#undef THAT
}
PL_forkprocess = pid;
if (did_pipes && pid > 0) {
int errkid;
- int n = 0, n1;
+ unsigned n = 0;
+ SSize_t n1;
while (n < sizeof(int)) {
n1 = PerlLIO_read(pp[0],
pid2 = wait4pid(pid, &status, 0);
} while (pid2 == -1 && errno == EINTR);
errno = errkid; /* Propagate errno from kid */
- return Nullfp;
+ return NULL;
}
}
if (did_pipes)
Perl_rsignal_state(pTHX_ int signo)
{
struct sigaction oact;
+ PERL_UNUSED_CONTEXT;
if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
return (Sighandler_t) SIG_ERR;
goto finish;
#endif
#if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
- result = wait4((pid==-1)?0:pid,statusp,flags,Null(struct rusage *));
+ result = wait4((pid==-1)?0:pid,statusp,flags,NULL);
goto finish;
#endif
#ifdef PERL_USES_PL_PIDSTATUS
{
register I32 todo;
register const char * const frombase = from;
+ PERL_UNUSED_CONTEXT;
if (len == 1) {
register const char c = *from;
if (len == 2 && tmpbuf[0] == '.')
seen_dot = 1;
#endif
+#ifdef HAS_STRLCAT
+ (void)strlcpy(tmpbuf + len, scriptname, sizeof(tmpbuf) - len);
+#else
/* FIXME? Convert to memcpy by storing previous strlen(scriptname)
*/
(void)strcpy(tmpbuf + len, scriptname);
+#endif /* #ifdef HAS_STRLCAT */
#endif /* !VMS */
#ifdef SEARCH_EXTS
char **
Perl_get_op_names(pTHX)
{
- return (char **)PL_op_name;
+ PERL_UNUSED_CONTEXT;
+ return (char **)PL_op_name;
}
char **
Perl_get_op_descs(pTHX)
{
- return (char **)PL_op_desc;
+ PERL_UNUSED_CONTEXT;
+ return (char **)PL_op_desc;
}
const char *
Perl_get_no_modify(pTHX)
{
- return PL_no_modify;
+ PERL_UNUSED_CONTEXT;
+ return PL_no_modify;
}
U32 *
Perl_get_opargs(pTHX)
{
- return (U32 *)PL_opargs;
+ PERL_UNUSED_CONTEXT;
+ return (U32 *)PL_opargs;
}
PPADDR_t*
Perl_get_ppaddr(pTHX)
{
- dVAR;
- return (PPADDR_t*)PL_ppaddr;
+ dVAR;
+ PERL_UNUSED_CONTEXT;
+ return (PPADDR_t*)PL_ppaddr;
}
#ifndef HAS_GETENV_LEN
Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
{
char * const env_trans = PerlEnv_getenv(env_elem);
+ PERL_UNUSED_CONTEXT;
if (env_trans)
*len = strlen(env_trans);
return env_trans;
Perl_get_vtbl(pTHX_ int vtbl_id)
{
const MGVTBL* result;
+ PERL_UNUSED_CONTEXT;
switch(vtbl_id) {
case want_vtbl_sv:
case want_vtbl_arylen:
result = &PL_vtbl_arylen;
break;
- case want_vtbl_glob:
- result = &PL_vtbl_glob;
- break;
case want_vtbl_mglob:
result = &PL_vtbl_mglob;
break;
result = &PL_vtbl_utf8;
break;
default:
- result = Null(MGVTBL*);
+ result = NULL;
break;
}
return (MGVTBL*)result;
void
Perl_report_evil_fh(pTHX_ const GV *gv, const IO *io, I32 op)
{
- 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 * const pars = OP_IS_FILETEST(op) ? "" : "()";
- const char * const type = OP_IS_SOCKET(op)
- || (gv && io && IoTYPE(io) == IoTYPE_SOCKET)
- ? "socket" : "filehandle";
const char * const name = gv && isGV(gv) ? GvENAME(gv) : NULL;
if (op == OP_phoney_OUTPUT_ONLY || op == OP_phoney_INPUT_ONLY) {
}
if (ckWARN(warn_type)) {
+ const char * const pars = OP_IS_FILETEST(op) ? "" : "()";
+ const char * const func =
+ op == OP_READLINE ? "readline" : /* "<HANDLE>" not nice */
+ op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */
+ op < 0 ? "" : /* handle phoney cases */
+ PL_op_desc[op];
+ const char * const type = OP_IS_SOCKET(op)
+ || (gv && io && IoTYPE(io) == IoTYPE_SOCKET)
+ ? "socket" : "filehandle";
if (name && *name) {
Perl_warner(aTHX_ packWARN(warn_type),
"%s%s on %s %s %s", func, pars, vile, type, name);
int secs;
int month, mday, year, jday;
int odd_cent, odd_year;
+ PERL_UNUSED_CONTEXT;
#define DAYS_PER_YEAR 365
#define DAYS_PER_QYEAR (4*DAYS_PER_YEAR+1)
if ( SvNOK(ver) ) /* may get too much accuracy */
{
char tbuf[64];
- const STRLEN len = my_sprintf(tbuf,"%.9"NVgf, SvNVX(ver));
+#ifdef USE_SNPRINTF
+ const STRLEN len = snprintf(tbuf, sizeof(tbuf), "%.9"NVgf, SvNVX(ver));
+#else
+ const STRLEN len = my_sprintf(tbuf, "%.9"NVgf, SvNVX(ver));
+#endif /* #ifdef USE_SNPRINTF */
version = savepvn(tbuf, len);
}
#ifdef SvVOK
void
Perl_sv_nosharing(pTHX_ SV *sv)
{
+ PERL_UNUSED_CONTEXT;
PERL_UNUSED_ARG(sv);
}
opt |= PERL_UNICODE_LOCALE_FLAG; break;
case PERL_UNICODE_ARGV:
opt |= PERL_UNICODE_ARGV_FLAG; break;
+ case PERL_UNICODE_UTF8CACHEASSERT:
+ opt |= PERL_UNICODE_UTF8CACHEASSERT_FLAG; break;
default:
if (*p != '\n' && *p != '\r')
Perl_croak(aTHX_
{
const char * const stashpv = CopSTASHPV(c);
const char * const name = HvNAME_get(hv);
+ PERL_UNUSED_CONTEXT;
if (stashpv == name)
return TRUE;
https://perl5.git.perl.org / perl5.git / blobdiff