* XXX This advice seems to be widely ignored :-( --AD August 1996.
*/
+static char *
+S_write_no_mem(pTHX)
+{
+ /* 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;
+}
+
/* paranoid version of system's malloc() */
Malloc_t
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 S_write_no_mem(aTHX);
}
/*NOTREACHED*/
}
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 S_write_no_mem(aTHX);
}
/*NOTREACHED*/
}
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 S_write_no_mem(aTHX);
}
/*NOTREACHED*/
}
Perl_ninstr(pTHX_ register const char *big, register const char *bigend, const char *little, const char *lend)
{
register const I32 first = *little;
- register const char *littleend = lend;
+ register const char * const littleend = lend;
if (!first && little >= littleend)
return (char*)big;
{
register const char *bigbeg;
register const I32 first = *little;
- register const char *littleend = lend;
+ register const char * const littleend = lend;
if (!first && little >= littleend)
return (char*)bigend;
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;
+ register const unsigned char * const table = little + littlelen + FBM_TABLE_OFFSET;
register const unsigned char *oldlittle;
if (littlelen > (STRLEN)(bigend - big))
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 S_write_no_mem(aTHX);
}
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;
SV *
Perl_vmess(pTHX_ const char *pat, va_list *args)
{
- SV *sv = mess_alloc();
+ 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*));
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) {
if (val == NULL) {
(void)unsetenv(nam);
} else {
- int nlen = strlen(nam);
- int vlen = strlen(val);
- char *new_env =
+ 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;
- int nlen = strlen(nam), vlen;
+ const int nlen = strlen(nam);
+ int vlen;
if (!val) {
val = "";
}
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
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;
- const I32 len = my_sprintf(spid, "%"IVdf, (IV)pid);
-
- svp = hv_fetch(PL_pidstatus,spid,len,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);
- len = my_sprintf(spid, "%"IVdf, (IV)pid);
/* 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()
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)];
- const size_t len = my_sprintf(spid, "%"IVdf, (IV)pid);
- sv = *hv_fetch(PL_pidstatus,spid,len,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
/* additional extensions to try in each dir if scriptname not found */
#ifdef SEARCH_EXTS
- const char *const exts[] = { SEARCH_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;
# 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;
}
* 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 {
int saw_period = 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
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 */
#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)
{
#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
+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 */
+}
+
/*
* Local variables:
* c-indentation-style: bsd
projects / p5sagit/p5-mst-13.2.git / blobdiff