/* util.c
*
* Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
+ * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
* XXX This advice seems to be widely ignored :-( --AD August 1996.
*/
+static char *
+S_write_no_mem(pTHX)
+{
+ dVAR;
+ /* Can't use PerlIO to write as it allocates memory */
+ PerlLIO_write(PerlIO_fileno(Perl_error_log),
+ PL_no_mem, strlen(PL_no_mem));
+ my_exit(1);
+ NORETURN_FUNCTION_END;
+}
+
/* paranoid version of system's malloc() */
Malloc_t
my_exit(1);
}
#endif /* HAS_64K_LIMIT */
+#ifdef PERL_TRACK_MEMPOOL
+ size += sTHX;
+#endif
#ifdef DEBUGGING
if ((long)size < 0)
Perl_croak_nocontext("panic: malloc");
ptr = (Malloc_t)PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */
PERL_ALLOC_CHECK(ptr);
DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
- if (ptr != Nullch)
+ if (ptr != Nullch) {
+#ifdef PERL_TRACK_MEMPOOL
+ ((struct perl_memory_debug_header *)ptr)->interpreter = aTHX;
+# ifdef PERL_POISON
+ ((struct perl_memory_debug_header *)ptr)->size = size;
+ ((struct perl_memory_debug_header *)ptr)->in_use = PERL_POISON_INUSE;
+# endif
+ ptr = (Malloc_t)((char*)ptr+sTHX);
+#endif
return ptr;
+}
else if (PL_nomemok)
return Nullch;
else {
- /* Can't use PerlIO to write as it allocates memory */
- PerlLIO_write(PerlIO_fileno(Perl_error_log),
- PL_no_mem, strlen(PL_no_mem));
- my_exit(1);
- return Nullch;
+ return write_no_mem();
}
/*NOTREACHED*/
}
if (!where)
return safesysmalloc(size);
+#ifdef PERL_TRACK_MEMPOOL
+ where = (Malloc_t)((char*)where-sTHX);
+ size += sTHX;
+ if (((struct perl_memory_debug_header *)where)->interpreter != aTHX) {
+ Perl_croak_nocontext("panic: realloc from wrong pool");
+ }
+# ifdef PERL_POISON
+ if (((struct perl_memory_debug_header *)where)->size > size) {
+ const MEM_SIZE freed_up =
+ ((struct perl_memory_debug_header *)where)->size - size;
+ char *start_of_freed = ((char *)where) + size;
+ Poison(start_of_freed, freed_up, char);
+ }
+ ((struct perl_memory_debug_header *)where)->size = size;
+# endif
+#endif
#ifdef DEBUGGING
if ((long)size < 0)
Perl_croak_nocontext("panic: realloc");
DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++));
DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
- if (ptr != Nullch)
+ if (ptr != Nullch) {
+#ifdef PERL_TRACK_MEMPOOL
+ ptr = (Malloc_t)((char*)ptr+sTHX);
+#endif
return ptr;
+ }
else if (PL_nomemok)
return Nullch;
else {
- /* Can't use PerlIO to write as it allocates memory */
- PerlLIO_write(PerlIO_fileno(Perl_error_log),
- PL_no_mem, strlen(PL_no_mem));
- my_exit(1);
- return Nullch;
+ return write_no_mem();
}
/*NOTREACHED*/
}
Free_t
Perl_safesysfree(Malloc_t where)
{
- dVAR;
-#ifdef PERL_IMPLICIT_SYS
+#if defined(PERL_IMPLICIT_SYS) || defined(PERL_TRACK_MEMPOOL)
dTHX;
+#else
+ dVAR;
#endif
DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) free\n",PTR2UV(where),(long)PL_an++));
if (where) {
+#ifdef PERL_TRACK_MEMPOOL
+ where = (Malloc_t)((char*)where-sTHX);
+ if (((struct perl_memory_debug_header *)where)->interpreter != aTHX) {
+ Perl_croak_nocontext("panic: free from wrong pool");
+ }
+# ifdef PERL_POISON
+ {
+ if (((struct perl_memory_debug_header *)where)->in_use
+ == PERL_POISON_FREE) {
+ Perl_croak_nocontext("panic: duplicate free");
+ }
+ if (((struct perl_memory_debug_header *)where)->in_use
+ != PERL_POISON_INUSE) {
+ Perl_croak_nocontext("panic: bad free ");
+ }
+ ((struct perl_memory_debug_header *)where)->in_use
+ = PERL_POISON_FREE;
+ }
+ Poison(where, ((struct perl_memory_debug_header *)where)->size, char);
+# endif
+#endif
PerlMem_free(where);
}
}
Perl_croak_nocontext("panic: calloc");
#endif
size *= count;
+#ifdef PERL_TRACK_MEMPOOL
+ size += sTHX;
+#endif
ptr = (Malloc_t)PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */
PERL_ALLOC_CHECK(ptr);
DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) calloc %ld x %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)count,(long)size));
if (ptr != Nullch) {
memset((void*)ptr, 0, size);
+#ifdef PERL_TRACK_MEMPOOL
+ ((struct perl_memory_debug_header *)ptr)->interpreter = aTHX;
+# ifdef PERL_POISON
+ ((struct perl_memory_debug_header *)ptr)->size = size;
+ ((struct perl_memory_debug_header *)ptr)->in_use = PERL_POISON_INUSE;
+# endif
+ ptr = (Malloc_t)((char*)ptr+sTHX);
+#endif
return ptr;
}
else if (PL_nomemok)
return Nullch;
- else {
- /* Can't use PerlIO to write as it allocates memory */
- PerlLIO_write(PerlIO_fileno(Perl_error_log),
- PL_no_mem, strlen(PL_no_mem));
- my_exit(1);
- return Nullch;
- }
- /*NOTREACHED*/
+ return write_no_mem();
}
/* These must be defined when not using Perl's malloc for binary
for (x=big,s=little; *s; /**/ ) {
if (!*x)
return Nullch;
- if (*s++ != *x++) {
- s--;
+ if (*s != *x)
break;
+ else {
+ s++;
+ x++;
}
}
if (!*s)
/* same as instr but allow embedded nulls */
char *
-Perl_ninstr(pTHX_ register const char *big, register const char *bigend, const char *little, const char *lend)
+Perl_ninstr(pTHX_ const char *big, const char *bigend, const char *little, const char *lend)
{
- register const I32 first = *little;
- register const char *littleend = lend;
-
- if (!first && little >= littleend)
- return (char*)big;
- if (bigend - big < littleend - little)
- return Nullch;
- bigend -= littleend - little++;
- while (big <= bigend) {
- register const char *s, *x;
- if (*big++ != first)
- continue;
- for (x=big,s=little; s < littleend; /**/ ) {
- if (*s++ != *x++) {
- s--;
- break;
- }
- }
- if (s >= littleend)
- return (char*)(big-1);
+ if (little >= lend)
+ return (char*)big;
+ {
+ char first = *little++;
+ const char *s, *x;
+ bigend -= lend - little;
+ OUTER:
+ while (big <= bigend) {
+ if (*big++ != first)
+ goto OUTER;
+ for (x=big,s=little; s < lend; x++,s++) {
+ if (*s != *x)
+ goto OUTER;
+ }
+ return (char*)(big-1);
+ }
}
return Nullch;
}
{
register const char *bigbeg;
register const I32 first = *little;
- register const char *littleend = lend;
+ register const char * const littleend = lend;
- if (!first && little >= littleend)
+ if (little >= littleend)
return (char*)bigend;
bigbeg = big;
big = bigend - (littleend - little++);
if (*big-- != first)
continue;
for (x=big+2,s=little; s < littleend; /**/ ) {
- if (*s++ != *x++) {
- s--;
+ if (*s != *x)
break;
+ else {
+ x++;
+ s++;
}
}
if (s >= littleend)
void
Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
{
- const register U8 *s;
+ dVAR;
+ register const U8 *s;
register U32 i;
STRLEN len;
I32 rarest = 0;
if (flags & FBMcf_TAIL) {
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() */
+ sv_catpvs(sv, "\n"); /* Taken into account in fbm_instr() */
if (mg && mg->mg_len >= 0)
mg->mg_len++;
}
return Nullch;
}
if (SvTYPE(littlestr) != SVt_PVBM || !SvVALID(littlestr)) {
- char *b = ninstr((char*)big,(char*)bigend,
+ char * const b = ninstr((char*)big,(char*)bigend,
(char*)little, (char*)little + littlelen);
if (!b && SvTAIL(littlestr)) { /* Automatically multiline! */
}
{ /* Do actual FBM. */
- register const unsigned char *table = little + littlelen + FBM_TABLE_OFFSET;
- const register unsigned char *oldlittle;
+ register const unsigned char * const table = little + littlelen + FBM_TABLE_OFFSET;
+ register const unsigned char *oldlittle;
if (littlelen > (STRLEN)(bigend - big))
return Nullch;
char *
Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last)
{
- const register unsigned char *big;
+ dVAR;
+ register const unsigned char *big;
register I32 pos;
register I32 previous;
register I32 first;
- const register unsigned char *little;
+ register const unsigned char *little;
register I32 stop_pos;
- const register unsigned char *littleend;
+ register const unsigned char *littleend;
I32 found = 0;
if (*old_posp == -1
}
big -= previous;
do {
- const register unsigned char *s, *x;
+ register const unsigned char *s, *x;
if (pos >= stop_pos) break;
if (big[pos] != first)
continue;
pvlen = strlen(pv)+1;
newaddr = (char*)PerlMemShared_malloc(pvlen);
if (!newaddr) {
- PerlLIO_write(PerlIO_fileno(Perl_error_log),
- PL_no_mem, strlen(PL_no_mem));
- my_exit(1);
+ return write_no_mem();
}
return memcpy(newaddr,pv,pvlen);
}
Perl_savesvpv(pTHX_ SV *sv)
{
STRLEN len;
- const char *pv = SvPV_const(sv, len);
+ const char * const pv = SvPV_const(sv, len);
register char *newaddr;
++len;
STATIC SV *
S_mess_alloc(pTHX)
{
+ dVAR;
SV *sv;
XPVMG *any;
if (!PL_dirty)
- return sv_2mortal(newSVpvn("",0));
+ return sv_2mortal(newSVpvs(""));
if (PL_mess_sv)
return PL_mess_sv;
STATIC COP*
S_closest_cop(pTHX_ COP *cop, const OP *o)
{
+ dVAR;
/* Look for PL_op starting from o. cop is the last COP we've seen. */
- if (!o || o == PL_op) return cop;
+ if (!o || o == PL_op)
+ return cop;
if (o->op_flags & OPf_KIDS) {
OP *kid;
- for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
- {
+ for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
COP *new_cop;
/* If the OP_NEXTSTATE has been optimised away we can still use it
/* Keep searching, and return when we've found something. */
new_cop = closest_cop(cop, kid);
- if (new_cop) return new_cop;
+ if (new_cop)
+ return new_cop;
}
}
SV *
Perl_vmess(pTHX_ const char *pat, va_list *args)
{
- SV *sv = mess_alloc();
+ dVAR;
+ SV * const sv = mess_alloc();
static const char dgd[] = " during global destruction.\n";
sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
STATIC void
S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8)
{
+ dVAR;
HV *stash;
GV *gv;
CV *cv;
OP *
Perl_vdie(pTHX_ const char* pat, va_list *args)
{
+ dVAR;
const char *message;
const int was_in_eval = PL_in_eval;
STRLEN msglen;
void
Perl_vcroak(pTHX_ const char* pat, va_list *args)
{
+ dVAR;
const char *message;
STRLEN msglen;
I32 utf8 = 0;
if (ckDEAD(err)) {
SV * const msv = vmess(pat, args);
STRLEN msglen;
- const char *message = SvPV_const(msv, msglen);
+ const char * const message = SvPV_const(msv, msglen);
const I32 utf8 = SvUTF8(msv);
if (PL_diehook) {
bool
Perl_ckwarn(pTHX_ U32 w)
{
+ dVAR;
return
(
isLEXWARN_on
bool
Perl_ckwarn_d(pTHX_ U32 w)
{
+ dVAR;
return
isLEXWARN_off
|| PL_curcop->cop_warnings == pWARN_ALL
my_setenv_format(environ[i], nam, nlen, val, vlen);
} else {
# endif
-# if defined(__CYGWIN__) || defined(EPOC) || defined(SYMBIAN)
- setenv(nam, val, 1);
+# if defined(__CYGWIN__) || defined(EPOC) || defined(__SYMBIAN32__)
+# if defined(HAS_UNSETENV)
+ if (val == NULL) {
+ (void)unsetenv(nam);
+ } else {
+ (void)setenv(nam, val, 1);
+ }
+# else /* ! HAS_UNSETENV */
+ (void)setenv(nam, val, 1);
+# endif /* HAS_UNSETENV */
# else
- char *new_env;
- const int nlen = strlen(nam);
- int vlen;
- if (!val) {
- val = "";
- }
- vlen = strlen(val);
- new_env = (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
- /* all that work just for this */
- my_setenv_format(new_env, nam, nlen, val, vlen);
- (void)putenv(new_env);
+# if defined(HAS_UNSETENV)
+ if (val == NULL) {
+ (void)unsetenv(nam);
+ } else {
+ const int nlen = strlen(nam);
+ const int vlen = strlen(val);
+ char * const new_env =
+ (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
+ my_setenv_format(new_env, nam, nlen, val, vlen);
+ (void)putenv(new_env);
+ }
+# else /* ! HAS_UNSETENV */
+ char *new_env;
+ const int nlen = strlen(nam);
+ int vlen;
+ if (!val) {
+ val = "";
+ }
+ vlen = strlen(val);
+ new_env = (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
+ /* all that work just for this */
+ my_setenv_format(new_env, nam, nlen, val, vlen);
+ (void)putenv(new_env);
+# endif /* HAS_UNSETENV */
# endif /* __CYGWIN__ */
#ifndef PERL_USE_SAFE_PUTENV
}
Perl_setenv_getix(pTHX_ const char *nam)
{
register I32 i;
- const register I32 len = strlen(nam);
+ register const I32 len = strlen(nam);
for (i = 0; environ[i]; i++) {
if (
Perl_my_popen_list(pTHX_ char *mode, int n, SV **args)
{
#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) && !defined(NETWARE)
+ dVAR;
int p[2];
register I32 This, that;
register Pid_t pid;
/* 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)
{
+ dVAR;
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];
PL_ppid = (IV)getppid();
#endif
PL_forkprocess = 0;
+#ifdef PERL_USES_PL_PIDSTATUS
hv_clear(PL_pidstatus); /* we have no children */
+#endif
return Nullfp;
#undef THIS
#undef THAT
return PerlProc_signal(signo, handler);
}
-static
-Signal_t
+static Signal_t
sig_trap(int signo)
{
dVAR;
I32
Perl_my_pclose(pTHX_ PerlIO *ptr)
{
+ dVAR;
Sigsave_t hstat, istat, qstat;
int status;
SV **svp;
I32
Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
{
+ dVAR;
I32 result = 0;
if (!pid)
return -1;
-#if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME)
+#ifdef PERL_USES_PL_PIDSTATUS
{
- char spid[TYPE_CHARS(IV)];
-
if (pid > 0) {
- SV** svp;
- sprintf(spid, "%"IVdf, (IV)pid);
- svp = hv_fetch(PL_pidstatus,spid,strlen(spid),FALSE);
+ /* The keys in PL_pidstatus are now the raw 4 (or 8) bytes of the
+ pid, rather than a string form. */
+ SV * const * const svp = hv_fetch(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),FALSE);
if (svp && *svp != &PL_sv_undef) {
*statusp = SvIVX(*svp);
- (void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD);
+ (void)hv_delete(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),
+ G_DISCARD);
return pid;
}
}
hv_iterinit(PL_pidstatus);
if ((entry = hv_iternext(PL_pidstatus))) {
- SV *sv = hv_iterval(PL_pidstatus,entry);
+ SV * const sv = hv_iterval(PL_pidstatus,entry);
+ I32 len;
+ const char * const spid = hv_iterkey(entry,&len);
- pid = atoi(hv_iterkey(entry,(I32*)statusp));
+ assert (len == sizeof(Pid_t));
+ memcpy((char *)&pid, spid, len);
*statusp = SvIVX(sv);
- sprintf(spid, "%"IVdf, (IV)pid);
- (void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD);
+ /* The hash iterator is currently on this entry, so simply
+ calling hv_delete would trigger the lazy delete, which on
+ aggregate does more work, beacuse next call to hv_iterinit()
+ would spot the flag, and have to call the delete routine,
+ while in the meantime any new entries can't re-use that
+ memory. */
+ hv_iterinit(PL_pidstatus);
+ (void)hv_delete(PL_pidstatus,spid,len,G_DISCARD);
return pid;
}
}
result = wait4((pid==-1)?0:pid,statusp,flags,Null(struct rusage *));
goto finish;
#endif
-#if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME)
+#ifdef PERL_USES_PL_PIDSTATUS
#if defined(HAS_WAITPID) && defined(HAS_WAITPID_RUNTIME)
hard_way:
#endif
}
#endif /* !DOSISH || OS2 || WIN32 || NETWARE */
+#ifdef PERL_USES_PL_PIDSTATUS
void
Perl_pidgone(pTHX_ Pid_t pid, int status)
{
register SV *sv;
- char spid[TYPE_CHARS(IV)];
- sprintf(spid, "%"IVdf, (IV)pid);
- sv = *hv_fetch(PL_pidstatus,spid,strlen(spid),TRUE);
+ sv = *hv_fetch(PL_pidstatus,(const char*)&pid,sizeof(Pid_t),TRUE);
SvUPGRADE(sv,SVt_IV);
SvIV_set(sv, status);
return;
}
+#endif
#if defined(atarist) || defined(OS2) || defined(EPOC)
int pclose();
#endif
{
/* Needs work for PerlIO ! */
- FILE *f = PerlIO_findFILE(ptr);
- I32 result = pclose(f);
+ FILE * const f = PerlIO_findFILE(ptr);
+ const I32 result = pclose(f);
PerlIO_releaseFILE(ptr,f);
return result;
}
Perl_my_pclose(pTHX_ PerlIO *ptr)
{
/* Needs work for PerlIO ! */
- FILE *f = PerlIO_findFILE(ptr);
+ FILE * const f = PerlIO_findFILE(ptr);
I32 result = djgpp_pclose(f);
result = (result << 8) & 0xff00;
PerlIO_releaseFILE(ptr,f);
Perl_repeatcpy(pTHX_ register char *to, register const char *from, I32 len, register I32 count)
{
register I32 todo;
- register const char *frombase = from;
+ register const char * const frombase = from;
if (len == 1) {
register const char c = *from;
char *fb = strrchr(b,'/');
Stat_t tmpstatbuf1;
Stat_t tmpstatbuf2;
- SV *tmpsv = sv_newmortal();
+ SV * const tmpsv = sv_newmortal();
if (fa)
fa++;
#endif /* !HAS_RENAME */
char*
-Perl_find_script(pTHX_ const char *scriptname, bool dosearch, const char **search_ext, I32 flags)
+Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
+ const char *const *const search_ext, I32 flags)
{
+ dVAR;
const char *xfound = Nullch;
char *xfailed = Nullch;
char tmpbuf[MAXPATHLEN];
#endif
/* additional extensions to try in each dir if scriptname not found */
#ifdef SEARCH_EXTS
- const char *exts[] = { SEARCH_EXTS };
- const char **ext = search_ext ? search_ext : exts;
+ static const char *const exts[] = { SEARCH_EXTS };
+ const char *const *const ext = search_ext ? search_ext : exts;
int extidx = 0, i = 0;
const char *curext = Nullch;
#else
# ifdef ALWAYS_DEFTYPES
len = strlen(scriptname);
if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
- int hasdir, idx = 0, deftypes = 1;
+ int idx = 0, deftypes = 1;
bool seen_dot = 1;
- hasdir = !dosearch || (strpbrk(scriptname,":[</") != Nullch) ;
+ const int hasdir = !dosearch || (strpbrk(scriptname,":[</") != Nullch);
# else
if (dosearch) {
- int hasdir, idx = 0, deftypes = 1;
+ int idx = 0, deftypes = 1;
bool seen_dot = 1;
- hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
+ const int hasdir = (strpbrk(scriptname,":[</") != Nullch);
# endif
/* The first time through, just add SEARCH_EXTS to whatever we
* already have, so we can check for default file types. */
MGVTBL*
Perl_get_vtbl(pTHX_ int vtbl_id)
{
- const MGVTBL* result = Null(MGVTBL*);
+ const MGVTBL* result;
switch(vtbl_id) {
case want_vtbl_sv:
case want_vtbl_utf8:
result = &PL_vtbl_utf8;
break;
+ default:
+ result = Null(MGVTBL*);
+ break;
}
return (MGVTBL*)result;
}
Perl_getcwd_sv(pTHX_ register SV *sv)
{
#ifndef PERL_MICRO
-
+ dVAR;
#ifndef INCOMPLETE_TAINTS
SvTAINTED_on(sv);
#endif
* size from the heap if they are given a NULL buffer pointer.
* The problem is that this behaviour is not portable. */
if (getcwd(buf, sizeof(buf) - 1)) {
- sv_setpvn(sv, buf, strlen(buf));
+ sv_setpv(sv, buf);
return TRUE;
}
else {
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 */
+ AV * const av = newAV();
+ SV * const 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 ( alpha && !saw_period )
+ Perl_croak(aTHX_ "Invalid version format (alpha without decimal)");
+
+ 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)
{
+ dVAR;
SV * const rv = newSV(0);
if ( sv_derived_from(ver,"version") ) /* can just copy directly */
{
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 */
- MAGIC* mg = mg_find(ver,PERL_MAGIC_vstring);
+ const MAGIC* const mg = mg_find(ver,PERL_MAGIC_vstring);
const STRLEN len = mg->mg_len;
char * const version = savepvn( (const char*)mg->mg_ptr, len);
sv_setpvn(rv,version,len);
if ( SvNOK(ver) ) /* may get too much accuracy */
{
char tbuf[64];
- sprintf(tbuf,"%.9"NVgf, SvNVX(ver));
- version = savepv(tbuf);
+ const STRLEN len = my_sprintf(tbuf,"%.9"NVgf, SvNVX(ver));
+ version = savepvn(tbuf, len);
}
#ifdef SvVOK
else if ( SvVOK(ver) ) { /* already a v-string */
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) ) ) {
- sv_catpvn(sv,"0",1);
+ if ( !(av = (AV *)SvRV(*hv_fetch((HV*)vs, "version", 7, FALSE)) ) ) {
+ sv_catpvs(sv,"0");
return sv;
}
len = av_len(av);
if ( len == -1 )
{
- sv_catpvn(sv,"0",1);
+ sv_catpvs(sv,"0");
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 int denom = (width == 2 ? 10 : 100);
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_catpvs(sv,"_");
+ Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
}
- else /* len == 1 */
+ else /* len == 0 */
{
- sv_catpvn(sv,"000",3);
+ sv_catpvs(sv, "000");
}
return sv;
}
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 ) {
- sv_catpvn(sv,"",0);
+ if ( len == -1 )
+ {
+ sv_catpvs(sv,"");
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 )
if ( len <= 2 ) { /* short version, must be at least three */
for ( len = 2 - len; len != 0; len-- )
- sv_catpvn(sv,".0",2);
+ sv_catpvs(sv,".0");
}
-
return sv;
}
{
if ( SvROK(vs) )
vs = SvRV(vs);
+
+ if ( !vverify(vs) )
+ Perl_croak(aTHX_ "Invalid version object");
+
if ( hv_exists((HV *)vs, "qv", 2) )
return vnormal(vs);
else
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
tidy_up_and_fail:
{
- int save_errno = errno;
+ const int save_errno = errno;
if (listener != -1)
PerlLIO_close(listener);
if (connector != -1)
=for apidoc sv_nosharing
Dummy routine which "shares" an SV when there is no sharing module present.
-Exists to avoid test for a NULL function pointer and because it could potentially warn under
-some level of strict-ness.
+Or "locks" it. Or "unlocks" it. In other words, ignores its single SV argument.
+Exists to avoid test for a NULL function pointer and because it could
+potentially warn under some level of strict-ness.
=cut
*/
PERL_UNUSED_ARG(sv);
}
-/*
-=for apidoc sv_nolocking
-
-Dummy routine which "locks" an SV when there is no locking module present.
-Exists to avoid test for a NULL function pointer and because it could potentially warn under
-some level of strict-ness.
-
-=cut
-*/
-
-void
-Perl_sv_nolocking(pTHX_ SV *sv)
-{
- PERL_UNUSED_ARG(sv);
-}
-
-
-/*
-=for apidoc sv_nounlocking
-
-Dummy routine which "unlocks" an SV when there is no locking module present.
-Exists to avoid test for a NULL function pointer and because it could potentially warn under
-some level of strict-ness.
-
-=cut
-*/
-
-void
-Perl_sv_nounlocking(pTHX_ SV *sv)
-{
- PERL_UNUSED_ARG(sv);
-}
-
U32
Perl_parse_unicode_opts(pTHX_ const char **popt)
{
U32
Perl_seed(pTHX)
{
+ dVAR;
/*
* This is really just a quick hack which grabs various garbage
* values. It really should be a real hash algorithm which
UV
Perl_get_hash_seed(pTHX)
{
+ dVAR;
const char *s = PerlEnv_getenv("PERL_HASH_SEED");
UV myseed = 0;
#ifdef PERL_GLOBAL_STRUCT
# define PERL_GLOBAL_STRUCT_INIT
# include "opcode.h" /* the ppaddr and check */
- IV nppaddr = sizeof(Gppaddr)/sizeof(Perl_ppaddr_t);
- IV ncheck = sizeof(Gcheck) /sizeof(Perl_check_t);
+ const IV nppaddr = sizeof(Gppaddr)/sizeof(Perl_ppaddr_t);
+ const IV ncheck = sizeof(Gcheck) /sizeof(Perl_check_t);
# ifdef PERL_GLOBAL_STRUCT_PRIVATE
/* PerlMem_malloc() because can't use even safesysmalloc() this early. */
plvarsp = (struct perl_vars*)PerlMem_malloc(sizeof(struct perl_vars));
#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));
+ const STRLEN len = my_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, len);
#endif
return newalloc;
}
#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));
+ const STRLEN len = my_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, len);
#endif
return newalloc;
}
#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));
+ const STRLEN len = my_sprintf(buf, "free: %s:%d:%s: %"UVxf"\n",
+ filename, linenumber, funcname,
+ PTR2UV(oldalloc));
+ PerlLIO_write(2, buf, len);
#endif
return oldalloc;
}
#endif /* PERL_MEM_LOG */
/*
+=for apidoc my_sprintf
+
+The C library C<sprintf>, wrapped if necessary, to ensure that it will return
+the length of the string written to the buffer. Only rare pre-ANSI systems
+need the wrapper function - usually this is a direct call to C<sprintf>.
+
+=cut
+*/
+#ifndef SPRINTF_RETURNS_STRLEN
+int
+Perl_my_sprintf(char *buffer, const char* pat, ...)
+{
+ va_list args;
+ va_start(args, pat);
+ vsprintf(buffer, pat, args);
+ va_end(args);
+ return strlen(buffer);
+}
+#endif
+
+void
+Perl_my_clearenv(pTHX)
+{
+ dVAR;
+#if ! defined(PERL_MICRO)
+# if defined(PERL_IMPLICIT_SYS) || defined(WIN32)
+ PerlEnv_clearenv();
+# else /* ! (PERL_IMPLICIT_SYS || WIN32) */
+# if defined(USE_ENVIRON_ARRAY)
+# if defined(USE_ITHREADS)
+ /* only the parent thread can clobber the process environment */
+ if (PL_curinterp == aTHX)
+# endif /* USE_ITHREADS */
+ {
+# if ! defined(PERL_USE_SAFE_PUTENV)
+ if ( !PL_use_safe_putenv) {
+ I32 i;
+ if (environ == PL_origenviron)
+ environ = (char**)safesysmalloc(sizeof(char*));
+ else
+ for (i = 0; environ[i]; i++)
+ (void)safesysfree(environ[i]);
+ }
+ environ[0] = NULL;
+# else /* PERL_USE_SAFE_PUTENV */
+# if defined(HAS_CLEARENV)
+ (void)clearenv();
+# elif defined(HAS_UNSETENV)
+ int bsiz = 80; /* Most envvar names will be shorter than this. */
+ char *buf = (char*)safesysmalloc(bsiz * sizeof(char));
+ while (*environ != NULL) {
+ char *e = strchr(*environ, '=');
+ int l = e ? e - *environ : strlen(*environ);
+ if (bsiz < l + 1) {
+ (void)safesysfree(buf);
+ bsiz = l + 1;
+ buf = (char*)safesysmalloc(bsiz * sizeof(char));
+ }
+ strncpy(buf, *environ, l);
+ *(buf + l) = '\0';
+ (void)unsetenv(buf);
+ }
+ (void)safesysfree(buf);
+# else /* ! HAS_CLEARENV && ! HAS_UNSETENV */
+ /* Just null environ and accept the leakage. */
+ *environ = NULL;
+# endif /* HAS_CLEARENV || HAS_UNSETENV */
+# endif /* ! PERL_USE_SAFE_PUTENV */
+ }
+# endif /* USE_ENVIRON_ARRAY */
+# endif /* PERL_IMPLICIT_SYS || WIN32 */
+#endif /* PERL_MICRO */
+}
+
+#ifdef PERL_IMPLICIT_CONTEXT
+
+/* implements the MY_CXT_INIT macro. The first time a module is loaded,
+the global PL_my_cxt_index is incremented, and that value is assigned to
+that module's static my_cxt_index (who's address is passed as an arg).
+Then, for each interpreter this function is called for, it makes sure a
+void* slot is available to hang the static data off, by allocating or
+extending the interpreter's PL_my_cxt_list array */
+
+void *
+Perl_my_cxt_init(pTHX_ int *index, size_t size)
+{
+ dVAR;
+ void *p;
+ if (*index == -1) {
+ /* this module hasn't been allocated an index yet */
+ MUTEX_LOCK(&PL_my_ctx_mutex);
+ *index = PL_my_cxt_index++;
+ MUTEX_UNLOCK(&PL_my_ctx_mutex);
+ }
+
+ /* make sure the array is big enough */
+ if (PL_my_cxt_size <= *index) {
+ if (PL_my_cxt_size) {
+ while (PL_my_cxt_size <= *index)
+ PL_my_cxt_size *= 2;
+ Renew(PL_my_cxt_list, PL_my_cxt_size, void *);
+ }
+ else {
+ PL_my_cxt_size = 16;
+ Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
+ }
+ }
+ /* newSV() allocates one more than needed */
+ p = (void*)SvPVX(newSV(size-1));
+ PL_my_cxt_list[*index] = p;
+ Zero(p, size, char);
+ return p;
+}
+#endif
+
+/*
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
https://perl5.git.perl.org / perl5.git / blobdiff