/* util.c
*
- * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
+ * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001,
+ * 2002, 2003, 2004, 2005, 2006, 2007, 2008 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.
ptr = (Malloc_t)PerlMem_realloc(where,size);
PERL_ALLOC_CHECK(ptr);
- 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 != NULL) {
+ /* MUST do this fixup first, before doing ANYTHING else, as anything else
+ might allocate memory/free/move memory, and until we do the fixup, it
+ may well be chasing (and writing to) free memory. */
#ifdef PERL_TRACK_MEMPOOL
+ if (ptr != NULL) {
struct perl_memory_debug_header *const header
= (struct perl_memory_debug_header *)ptr;
header->prev->next = header;
ptr = (Malloc_t)((char*)ptr+sTHX);
+ }
#endif
+
+ /* In particular, must do that fixup above before logging anything via
+ *printf(), as it can reallocate memory, which can cause SEGVs. */
+
+ 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 != NULL) {
return ptr;
}
else if (PL_nomemok)
{
dTHX;
Malloc_t ptr;
+ MEM_SIZE total_size = 0;
+ /* Even though calloc() for zero bytes is strange, be robust. */
+ if (size && (count <= MEM_SIZE_MAX / size))
+ total_size = size * count;
+ else
+ Perl_croak_nocontext(PL_memory_wrap);
+#ifdef PERL_TRACK_MEMPOOL
+ if (sTHX <= MEM_SIZE_MAX - (MEM_SIZE)total_size)
+ total_size += sTHX;
+ else
+ Perl_croak_nocontext(PL_memory_wrap);
+#endif
#ifdef HAS_64K_LIMIT
- if (size * count > 0xffff) {
+ if (total_size > 0xffff) {
PerlIO_printf(Perl_error_log,
- "Allocation too large: %lx\n", size * count) FLUSH;
+ "Allocation too large: %lx\n", total_size) FLUSH;
my_exit(1);
}
#endif /* HAS_64K_LIMIT */
if ((long)size < 0 || (long)count < 0)
Perl_croak_nocontext("panic: calloc");
#endif
- size *= count;
#ifdef PERL_TRACK_MEMPOOL
- size += sTHX;
+ /* Have to use malloc() because we've added some space for our tracking
+ header. */
+ /* malloc(0) is non-portable. */
+ ptr = (Malloc_t)PerlMem_malloc(total_size ? total_size : 1);
+#else
+ /* Use calloc() because it might save a memset() if the memory is fresh
+ and clean from the OS. */
+ if (count && size)
+ ptr = (Malloc_t)PerlMem_calloc(count, size);
+ else /* calloc(0) is non-portable. */
+ ptr = (Malloc_t)PerlMem_calloc(count ? count : 1, size ? size : 1);
#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));
+ DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) calloc %ld x %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)count,(long)total_size));
if (ptr != NULL) {
- memset((void*)ptr, 0, size);
#ifdef PERL_TRACK_MEMPOOL
{
struct perl_memory_debug_header *const header
= (struct perl_memory_debug_header *)ptr;
+ memset((void*)ptr, 0, total_size);
header->interpreter = aTHX;
/* Link us into the list. */
header->prev = &PL_memory_debug_header;
PL_memory_debug_header.next = header;
header->next->prev = header;
# ifdef PERL_POISON
- header->size = size;
+ header->size = total_size;
# endif
ptr = (Malloc_t)((char*)ptr+sTHX);
}
register I32 tolen;
PERL_UNUSED_CONTEXT;
+ PERL_ARGS_ASSERT_DELIMCPY;
+
for (tolen = 0; from < fromend; from++, tolen++) {
if (*from == '\\') {
if (from[1] != delim) {
register I32 first;
PERL_UNUSED_CONTEXT;
+ PERL_ARGS_ASSERT_INSTR;
+
if (!little)
return (char*)big;
first = *little++;
char *
Perl_ninstr(pTHX_ const char *big, const char *bigend, const char *little, const char *lend)
{
+ PERL_ARGS_ASSERT_NINSTR;
PERL_UNUSED_CONTEXT;
if (little >= lend)
return (char*)big;
{
- char first = *little++;
+ const char first = *little;
const char *s, *x;
- bigend -= lend - little;
+ 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;
+ if (*big++ == first) {
+ for (x=big,s=little; s < lend; x++,s++) {
+ if (*s != *x)
+ goto OUTER;
+ }
+ return (char*)(big-1);
}
- return (char*)(big-1);
}
}
return NULL;
register const char * const littleend = lend;
PERL_UNUSED_CONTEXT;
+ PERL_ARGS_ASSERT_RNINSTR;
+
if (little >= littleend)
return (char*)bigend;
bigbeg = big;
register const U8 *s;
register U32 i;
STRLEN len;
- I32 rarest = 0;
+ U32 rarest = 0;
U32 frequency = 256;
+ PERL_ARGS_ASSERT_FBM_COMPILE;
+
if (flags & FBMcf_TAIL) {
MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
sv_catpvs(sv, "\n"); /* Taken into account in fbm_instr() */
return;
SvUPGRADE(sv, SVt_PVGV);
SvIOK_off(sv);
+ SvNOK_off(sv);
+ SvVALID_on(sv);
if (len > 2) {
const unsigned char *sb;
const U8 mlen = (len>255) ? 255 : (U8)len;
= (unsigned char*)(SvPVX_mutable(sv) + len + PERL_FBM_TABLE_OFFSET);
s = table - 1 - PERL_FBM_TABLE_OFFSET; /* last char */
memset((void*)table, mlen, 256);
- table[PERL_FBM_FLAGS_OFFSET_FROM_TABLE] = (U8)flags;
i = 0;
sb = s - mlen + 1; /* first char (maybe) */
while (s >= sb) {
Sv_Grow(sv, len + PERL_FBM_TABLE_OFFSET);
}
sv_magic(sv, NULL, PERL_MAGIC_bm, NULL, 0); /* deep magic */
- SvVALID_on(sv);
s = (const unsigned char*)(SvPVX_const(sv)); /* deeper magic */
for (i = 0; i < len; i++) {
frequency = PL_freq[s[i]];
}
}
+ BmFLAGS(sv) = (U8)flags;
BmRARE(sv) = s[rarest];
- BmPREVIOUS_set(sv, rarest);
+ BmPREVIOUS(sv) = rarest;
BmUSEFUL(sv) = 100; /* Initial value */
if (flags & FBMcf_TAIL)
SvTAIL_on(sv);
- DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %d\n",
- BmRARE(sv),BmPREVIOUS(sv)));
+ DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %lu\n",
+ BmRARE(sv),(unsigned long)BmPREVIOUS(sv)));
}
/* If SvTAIL(littlestr), it has a fake '\n' at end. */
register STRLEN littlelen = l;
register const I32 multiline = flags & FBMrf_MULTILINE;
+ PERL_ARGS_ASSERT_FBM_INSTR;
+
if ((STRLEN)(bigend - big) < littlelen) {
if ( SvTAIL(littlestr)
&& ((STRLEN)(bigend - big) == littlelen - 1)
}
check_end:
if ( s == bigend
- && (table[PERL_FBM_FLAGS_OFFSET_FROM_TABLE] & FBMcf_TAIL)
+ && (BmFLAGS(littlestr) & FBMcf_TAIL)
&& memEQ((char *)(bigend - littlelen),
(char *)(oldlittle - littlelen), littlelen) )
return (char*)bigend - littlelen;
register const unsigned char *littleend;
I32 found = 0;
+ PERL_ARGS_ASSERT_SCREAMINSTR;
+
assert(SvTYPE(littlestr) == SVt_PVGV);
assert(SvVALID(littlestr));
: (((pos = *old_posp), pos += PL_screamnext[pos]) == 0)) {
cant_find:
if ( BmRARE(littlestr) == '\n'
- && BmPREVIOUS(littlestr) == (U8)SvCUR(littlestr) - 1) {
+ && BmPREVIOUS(littlestr) == SvCUR(littlestr) - 1) {
little = (const unsigned char *)(SvPVX_const(littlestr));
littleend = little + SvCUR(littlestr);
first = *little++;
register const U8 *b = (const U8 *)s2;
PERL_UNUSED_CONTEXT;
+ PERL_ARGS_ASSERT_IBCMP;
+
while (len--) {
if (*a != *b && *a != PL_fold[*b])
return 1;
register const U8 *b = (const U8 *)s2;
PERL_UNUSED_CONTEXT;
+ PERL_ARGS_ASSERT_IBCMP_LOCALE;
+
while (len--) {
if (*a != *b && *a != PL_fold_locale[*b])
return 1;
}
/*
+=for apidoc savesharedpvn
+
+A version of C<savepvn()> which allocates the duplicate string in memory
+which is shared between threads. (With the specific difference that a NULL
+pointer is not acceptable)
+
+=cut
+*/
+char *
+Perl_savesharedpvn(pTHX_ const char *const pv, const STRLEN len)
+{
+ char *const newaddr = (char*)PerlMemShared_malloc(len + 1);
+
+ PERL_ARGS_ASSERT_SAVESHAREDPVN;
+
+ if (!newaddr) {
+ return write_no_mem();
+ }
+ newaddr[len] = '\0';
+ return (char*)memcpy(newaddr, pv, len);
+}
+
+/*
=for apidoc savesvpv
A version of C<savepv()>/C<savepvn()> which gets the string to duplicate from
const char * const pv = SvPV_const(sv, len);
register char *newaddr;
+ PERL_ARGS_ASSERT_SAVESVPV;
+
++len;
Newx(newaddr,len,char);
return (char *) CopyD(pv,newaddr,len,char);
XPVMG *any;
if (!PL_dirty)
- return sv_2mortal(newSVpvs(""));
+ return newSVpvs_flags("", SVs_TEMP);
if (PL_mess_sv)
return PL_mess_sv;
dTHX;
char *retval;
va_list args;
+ PERL_ARGS_ASSERT_FORM_NOCONTEXT;
va_start(args, pat);
retval = vform(pat, &args);
va_end(args);
{
char *retval;
va_list args;
+ PERL_ARGS_ASSERT_FORM;
va_start(args, pat);
retval = vform(pat, &args);
va_end(args);
Perl_vform(pTHX_ const char *pat, va_list *args)
{
SV * const sv = mess_alloc();
+ PERL_ARGS_ASSERT_VFORM;
sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
return SvPVX(sv);
}
dTHX;
SV *retval;
va_list args;
+ PERL_ARGS_ASSERT_MESS_NOCONTEXT;
va_start(args, pat);
retval = vmess(pat, &args);
va_end(args);
{
SV *retval;
va_list args;
+ PERL_ARGS_ASSERT_MESS;
va_start(args, pat);
retval = vmess(pat, &args);
va_end(args);
dVAR;
/* Look for PL_op starting from o. cop is the last COP we've seen. */
+ PERL_ARGS_ASSERT_CLOSEST_COP;
+
if (!o || o == PL_op)
return cop;
dVAR;
SV * const sv = mess_alloc();
+ PERL_ARGS_ASSERT_VMESS;
+
sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
/*
if (CopLINE(cop))
Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf,
OutCopFILE(cop), (IV)CopLINE(cop));
- if (GvIO(PL_last_in_gv) && IoLINES(GvIOp(PL_last_in_gv))) {
+ /* Seems that GvIO() can be untrustworthy during global destruction. */
+ if (GvIO(PL_last_in_gv) && (SvTYPE(GvIOp(PL_last_in_gv)) == SVt_PVIO)
+ && IoLINES(GvIOp(PL_last_in_gv)))
+ {
const bool line_mode = (RsSIMPLE(PL_rs) &&
SvCUR(PL_rs) == 1 && *SvPVX_const(PL_rs) == '\n');
Perl_sv_catpvf(aTHX_ sv, ", <%s> %s %"IVdf,
IO *io;
MAGIC *mg;
+ PERL_ARGS_ASSERT_WRITE_TO_STDERR;
+
if (PL_stderrgv && SvREFCNT(PL_stderrgv)
&& (io = GvIO(PL_stderrgv))
- && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
+ && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
{
dSP;
ENTER;
PUSHMARK(SP);
EXTEND(SP,2);
- PUSHs(SvTIED_obj((SV*)io, mg));
- PUSHs(sv_2mortal(newSVpvn(message, msglen)));
+ PUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
+ mPUSHp(message, msglen);
PUTBACK;
call_method("PRINT", G_SCALAR);
*hook = NULL;
}
if (warn || message) {
- msg = newSVpvn(message, msglen);
- SvFLAGS(msg) |= utf8;
+ msg = newSVpvn_flags(message, msglen, utf8);
SvREADONLY_on(msg);
SAVEFREESV(msg);
}
PUSHMARK(SP);
XPUSHs(msg);
PUTBACK;
- call_sv((SV*)cv, G_DISCARD);
+ call_sv(MUTABLE_SV(cv), G_DISCARD);
POPSTACK;
LEAVE;
return TRUE;
message = NULL;
}
- DEBUG_S(PerlIO_printf(Perl_debug_log,
- "%p: die/croak: message = %s\ndiehook = %p\n",
- thr, message, PL_diehook));
if (PL_diehook) {
S_vdie_common(aTHX_ message, *msglen, *utf8, FALSE);
}
STRLEN msglen;
I32 utf8 = 0;
- DEBUG_S(PerlIO_printf(Perl_debug_log,
- "%p: die: curstack = %p, mainstack = %p\n",
- thr, PL_curstack, PL_mainstack));
-
message = vdie_croak_common(pat, args, &msglen, &utf8);
PL_restartop = die_where(message, msglen);
SvFLAGS(ERRSV) |= utf8;
- DEBUG_S(PerlIO_printf(Perl_debug_log,
- "%p: die: restartop = %p, was_in_eval = %d, top_env = %p\n",
- thr, PL_restartop, was_in_eval, PL_top_env));
if ((!PL_restartop && was_in_eval) || PL_top_env->je_prev)
JMPENV_JUMP(3);
return PL_restartop;
dTHX;
OP *o;
va_list args;
+ PERL_ARGS_ASSERT_DIE_NOCONTEXT;
va_start(args, pat);
o = vdie(pat, &args);
va_end(args);
const I32 utf8 = SvUTF8(msv);
const char * const message = SvPV_const(msv, msglen);
+ PERL_ARGS_ASSERT_VWARN;
+
if (PL_warnhook) {
if (vdie_common(message, msglen, utf8, TRUE))
return;
{
dTHX;
va_list args;
+ PERL_ARGS_ASSERT_WARN_NOCONTEXT;
va_start(args, pat);
vwarn(pat, &args);
va_end(args);
Perl_warn(pTHX_ const char *pat, ...)
{
va_list args;
+ PERL_ARGS_ASSERT_WARN;
va_start(args, pat);
vwarn(pat, &args);
va_end(args);
{
dTHX;
va_list args;
+ PERL_ARGS_ASSERT_WARNER_NOCONTEXT;
va_start(args, pat);
vwarner(err, pat, &args);
va_end(args);
Perl_warner(pTHX_ U32 err, const char* pat,...)
{
va_list args;
+ PERL_ARGS_ASSERT_WARNER;
va_start(args, pat);
vwarner(err, pat, &args);
va_end(args);
Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args)
{
dVAR;
+ PERL_ARGS_ASSERT_VWARNER;
if (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) {
SV * const msv = vmess(pat, args);
STRLEN msglen;
STRLEN size) {
const MEM_SIZE len_wanted = sizeof(STRLEN) + size;
PERL_UNUSED_CONTEXT;
+ PERL_ARGS_ASSERT_NEW_WARNINGS_BITFIELD;
buffer = (STRLEN*)
(specialWARN(buffer) ?
{
register I32 i;
register const I32 len = strlen(nam);
+
+ PERL_ARGS_ASSERT_SETENV_GETIX;
PERL_UNUSED_CONTEXT;
for (i = 0; environ[i]; i++) {
{
I32 retries = 0;
+ PERL_ARGS_ASSERT_UNLNK;
+
while (PerlLIO_unlink(f) >= 0)
retries++;
return retries ? 0 : -1;
{
char * const retval = to;
+ PERL_ARGS_ASSERT_MY_BCOPY;
+
if (from - to >= 0) {
while (len--)
*to++ = *from++;
{
char * const retval = loc;
+ PERL_ARGS_ASSERT_MY_MEMSET;
+
while (len--)
*loc++ = ch;
return retval;
{
char * const retval = loc;
+ PERL_ARGS_ASSERT_MY_BZERO;
+
while (len--)
*loc++ = 0;
return retval;
register const U8 *b = (const U8 *)s2;
register I32 tmp;
+ PERL_ARGS_ASSERT_MY_MEMCMP;
+
while (len--) {
if ((tmp = *a++ - *b++))
return tmp;
#endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */
#ifndef HAS_VPRINTF
+/* This vsprintf replacement should generally never get used, since
+ vsprintf was available in both System V and BSD 2.11. (There may
+ be some cross-compilation or embedded set-ups where it is needed,
+ however.)
+
+ If you encounter a problem in this function, it's probably a symptom
+ that Configure failed to detect your system's vprintf() function.
+ See the section on "item vsprintf" in the INSTALL file.
+
+ This version may compile on systems with BSD-ish <stdio.h>,
+ but probably won't on others.
+*/
#ifdef USE_CHAR_VSPRINTF
char *
#else
int
#endif
-vsprintf(char *dest, const char *pat, char *args)
+vsprintf(char *dest, const char *pat, void *args)
{
FILE fakebuf;
+#if defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE)
+ FILE_ptr(&fakebuf) = (STDCHAR *) dest;
+ FILE_cnt(&fakebuf) = 32767;
+#else
+ /* These probably won't compile -- If you really need
+ this, you'll have to figure out some other method. */
fakebuf._ptr = dest;
fakebuf._cnt = 32767;
+#endif
#ifndef _IOSTRG
#define _IOSTRG 0
#endif
fakebuf._flag = _IOWRT|_IOSTRG;
_doprnt(pat, args, &fakebuf); /* what a kludge */
- (void)putc('\0', &fakebuf);
+#if defined(STDIO_PTR_LVALUE)
+ *(FILE_ptr(&fakebuf)++) = '\0';
+#else
+ /* PerlIO has probably #defined away fputc, but we want it here. */
+# ifdef fputc
+# undef fputc /* XXX Should really restore it later */
+# endif
+ (void)fputc('\0', &fakebuf);
+#endif
#ifdef USE_CHAR_VSPRINTF
return(dest);
#else
char c[sizeof(long)];
} u;
-#if BYTEORDER == 0x1234
+#if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678
+#if BYTEORDER == 0x12345678
+ u.result = 0;
+#endif
u.c[0] = (l >> 24) & 255;
u.c[1] = (l >> 16) & 255;
u.c[2] = (l >> 8) & 255;
register char *e = s + (n-1);
register char tc;
+ PERL_ARGS_ASSERT_MY_SWABN;
+
for (n /= 2; n > 0; s++, e--, n--) {
tc = *s;
*s = *e;
}
PerlIO *
-Perl_my_popen_list(pTHX_ char *mode, int n, SV **args)
+Perl_my_popen_list(pTHX_ const 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)
+#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) && !defined(NETWARE) && !defined(__LIBCATAMOUNT__)
dVAR;
int p[2];
register I32 This, that;
I32 did_pipes = 0;
int pp[2];
+ PERL_ARGS_ASSERT_MY_POPEN_LIST;
+
PERL_FLUSHALL_FOR_CHILD;
This = (*mode == 'w');
that = !This;
PerlLIO_close(pp[0]);
return PerlIO_fdopen(p[This], mode);
#else
+# ifdef OS2 /* Same, without fork()ing and all extra overhead... */
+ return my_syspopen4(aTHX_ NULL, mode, n, args);
+# else
Perl_croak(aTHX_ "List form of piped open not implemented");
return (PerlIO *) NULL;
+# endif
#endif
}
/* 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)
+#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) && !defined(__LIBCATAMOUNT__)
PerlIO *
Perl_my_popen(pTHX_ const char *cmd, const char *mode)
{
I32 did_pipes = 0;
int pp[2];
+ PERL_ARGS_ASSERT_MY_POPEN;
+
PERL_FLUSHALL_FOR_CHILD;
#ifdef OS2
if (doexec) {
#if defined(atarist) || defined(EPOC)
FILE *popen();
PerlIO *
-Perl_my_popen((pTHX_ const char *cmd, const char *mode)
+Perl_my_popen(pTHX_ const char *cmd, const char *mode)
{
+ PERL_ARGS_ASSERT_MY_POPEN;
PERL_FLUSHALL_FOR_CHILD;
/* Call system's popen() to get a FILE *, then import it.
used 0 for 2nd parameter to PerlIO_importFILE;
#if defined(DJGPP)
FILE *djgpp_popen();
PerlIO *
-Perl_my_popen((pTHX_ const char *cmd, const char *mode)
+Perl_my_popen(pTHX_ const char *cmd, const char *mode)
{
PERL_FLUSHALL_FOR_CHILD;
/* Call system's popen() to get a FILE *, then import it.
*/
return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
}
+#else
+#if defined(__LIBCATAMOUNT__)
+PerlIO *
+Perl_my_popen(pTHX_ const char *cmd, const char *mode)
+{
+ return NULL;
+}
+#endif
#endif
#endif
#ifdef DUMP_FDS
void
-Perl_dump_fds(pTHX_ char *s)
+Perl_dump_fds(pTHX_ const char *const s)
{
int fd;
Stat_t tmpstatbuf;
+ PERL_ARGS_ASSERT_DUMP_FDS;
+
PerlIO_printf(Perl_debug_log,"%s", s);
for (fd = 0; fd < 32; fd++) {
if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0)
dVAR;
struct sigaction act;
+ PERL_ARGS_ASSERT_RSIGNAL_SAVE;
+
#ifdef USE_ITHREADS
/* only "parent" interpreter can diddle signals */
if (PL_curinterp != aTHX)
#endif /* !PERL_MICRO */
/* VMS' my_pclose() 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)
+#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) && !defined(__LIBCATAMOUNT__)
I32
Perl_my_pclose(pTHX_ PerlIO *ptr)
{
}
return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status));
}
+#else
+#if defined(__LIBCATAMOUNT__)
+I32
+Perl_my_pclose(pTHX_ PerlIO *ptr)
+{
+ return -1;
+}
+#endif
#endif /* !DOSISH */
-#if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(MACOS_TRADITIONAL)
+#if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(MACOS_TRADITIONAL) && !defined(__LIBCATAMOUNT__)
I32
Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
{
dVAR;
I32 result = 0;
+ PERL_ARGS_ASSERT_WAIT4PID;
if (!pid)
return -1;
#ifdef PERL_USES_PL_PIDSTATUS
#endif
if (result < 0 && errno == EINTR) {
PERL_ASYNC_CHECK();
+ errno = EINTR; /* reset in case a signal handler changed $! */
}
return result;
}
register const char * const frombase = from;
PERL_UNUSED_CONTEXT;
+ PERL_ARGS_ASSERT_REPEATCPY;
+
if (len == 1) {
register const char c = *from;
while (count-- > 0)
Stat_t tmpstatbuf2;
SV * const tmpsv = sv_newmortal();
+ PERL_ARGS_ASSERT_SAME_DIRENT;
+
if (fa)
fa++;
else
if (strNE(a,b))
return FALSE;
if (fa == a)
- sv_setpvn(tmpsv, ".", 1);
+ sv_setpvs(tmpsv, ".");
else
sv_setpvn(tmpsv, a, fa - a);
if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0)
return FALSE;
if (fb == b)
- sv_setpvn(tmpsv, ".", 1);
+ sv_setpvs(tmpsv, ".");
else
sv_setpvn(tmpsv, b, fb - b);
if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0)
register char *s;
I32 len = 0;
int retval;
+ char *bufend;
#if defined(DOSISH) && !defined(OS2) && !defined(atarist)
# define SEARCH_EXTS ".bat", ".cmd", NULL
# define MAX_EXT_LEN 4
# define MAX_EXT_LEN 0
#endif
+ PERL_ARGS_ASSERT_FIND_SCRIPT;
+
/*
* If dosearch is true and if scriptname does not contain path
* delimiters, search the PATH for scriptname.
{
bool seen_dot = 0;
- PL_bufend = s + strlen(s);
- while (s < PL_bufend) {
+ bufend = s + strlen(s);
+ while (s < bufend) {
#ifdef MACOS_TRADITIONAL
- s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
+ s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend,
',',
&len);
#else
if (len < sizeof tmpbuf)
tmpbuf[len] = '\0';
#else /* ! (atarist || DOSISH) */
- s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
+ s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend,
':',
&len);
#endif /* ! (atarist || DOSISH) */
#endif /* MACOS_TRADITIONAL */
- if (s < PL_bufend)
+ if (s < bufend)
s++;
if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
continue; /* don't search dir with too-long name */
Perl_set_context(void *t)
{
dVAR;
+ PERL_ARGS_ASSERT_SET_CONTEXT;
#if defined(USE_ITHREADS)
# ifdef I_MACH_CTHREADS
cthread_set_data(cthread_self(), t);
{
char * const env_trans = PerlEnv_getenv(env_elem);
PERL_UNUSED_CONTEXT;
+ PERL_ARGS_ASSERT_GETENV_LEN;
if (env_trans)
*len = strlen(env_trans);
return env_trans;
#ifdef HAS_TM_TM_ZONE
Time_t now;
const struct tm* my_tm;
+ PERL_ARGS_ASSERT_INIT_TM;
(void)time(&now);
my_tm = localtime(&now);
if (my_tm)
Copy(my_tm, ptm, 1, struct tm);
#else
+ PERL_ARGS_ASSERT_INIT_TM;
PERL_UNUSED_ARG(ptm);
#endif
}
int odd_cent, odd_year;
PERL_UNUSED_CONTEXT;
+ PERL_ARGS_ASSERT_MINI_MKTIME;
+
#define DAYS_PER_YEAR 365
#define DAYS_PER_QYEAR (4*DAYS_PER_YEAR+1)
#define DAYS_PER_CENT (25*DAYS_PER_QYEAR-1)
struct tm mytm;
int len;
+ PERL_ARGS_ASSERT_MY_STRFTIME;
+
init_tm(&mytm); /* XXX workaround - see init_tm() above */
mytm.tm_sec = sec;
mytm.tm_min = min;
SvTAINTED_on(sv);
#endif
+ PERL_ARGS_ASSERT_GETCWD_SV;
+
#ifdef HAS_GETCWD
{
char buf[MAXPATHLEN];
#endif
}
+#define VERSION_MAX 0x7FFFFFFF
/*
=for apidoc scan_version
Function must be called with an already existing SV like
sv = newSV(0);
- s = scan_version(s,SV *sv, bool qv);
+ s = scan_version(s, SV *sv, bool qv);
Performs some preprocessing to the string to ensure that
it has the correct characteristics of a version. Flags the
object if it contains an underscore (which denotes this
-is a alpha version). The boolean qv denotes that the version
+is an alpha version). The boolean qv denotes that the version
should be interpreted as if it had multiple decimals, even if
it doesn't.
int saw_period = 0;
int alpha = 0;
int width = 3;
+ bool vinf = FALSE;
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
+ PERL_ARGS_ASSERT_SCAN_VERSION;
+
+ (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
while (isSPACE(*s)) /* leading whitespace is OK */
s++;
+ start = last = s;
+
if (*s == 'v') {
s++; /* get past 'v' */
qv = 1; /* force quoted version processing */
}
- start = last = pos = s;
+ pos = s;
/* pre-scan the input string to check for decimals/underbars */
while ( *pos == '.' || *pos == '_' || isDIGIT(*pos) )
if ( alpha && !saw_period )
Perl_croak(aTHX_ "Invalid version format (alpha without decimal)");
+ if ( alpha && saw_period && width == 0 )
+ Perl_croak(aTHX_ "Invalid version format (misplaced _ in number)");
+
if ( saw_period > 1 )
qv = 1; /* force quoted version processing */
+ last = pos;
pos = s;
if ( qv )
- hv_store((HV *)hv, "qv", 2, newSViv(qv), 0);
+ (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(qv));
if ( alpha )
- hv_store((HV *)hv, "alpha", 5, newSViv(alpha), 0);
+ (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(alpha));
if ( !qv && width < 3 )
- hv_store((HV *)hv, "width", 5, newSViv(width), 0);
+ (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
while (isDIGIT(*pos))
pos++;
/* this is atoi() that delimits on underscores */
const char *end = pos;
I32 mult = 1;
- I32 orev;
+ I32 orev;
/* the following if() will only be true after the decimal
* point of a version originally created with a bare
if ( !qv && s > start && saw_period == 1 ) {
mult *= 100;
while ( s < end ) {
- orev = rev;
+ orev = rev;
rev += (*s - '0') * mult;
mult /= 10;
- if ( PERL_ABS(orev) > PERL_ABS(rev) )
- Perl_croak(aTHX_ "Integer overflow in version");
+ if ( (PERL_ABS(orev) > PERL_ABS(rev))
+ || (PERL_ABS(rev) > VERSION_MAX )) {
+ if(ckWARN(WARN_OVERFLOW))
+ Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
+ "Integer overflow in version %d",VERSION_MAX);
+ s = end - 1;
+ rev = VERSION_MAX;
+ vinf = 1;
+ }
s++;
if ( *s == '_' )
s++;
}
else {
while (--end >= s) {
- orev = rev;
+ orev = rev;
rev += (*end - '0') * mult;
mult *= 10;
- if ( PERL_ABS(orev) > PERL_ABS(rev) )
- Perl_croak(aTHX_ "Integer overflow in version");
+ if ( (PERL_ABS(orev) > PERL_ABS(rev))
+ || (PERL_ABS(rev) > VERSION_MAX )) {
+ if(ckWARN(WARN_OVERFLOW))
+ Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
+ "Integer overflow in version");
+ end = s - 1;
+ rev = VERSION_MAX;
+ vinf = 1;
+ }
}
}
}
/* Append revision */
av_push(av, newSViv(rev));
- if ( *pos == '.' )
+ if ( vinf ) {
+ s = last;
+ break;
+ }
+ else if ( *pos == '.' )
s = ++pos;
else if ( *pos == '_' && isDIGIT(pos[1]) )
s = ++pos;
Compiler in question is:
gcc version 3.3 20030304 (Apple Computer, Inc. build 1640)
for ( len = 2 - len; len > 0; len-- )
- av_push((AV *)sv, newSViv(0));
+ av_push(MUTABLE_AV(sv), newSViv(0));
*/
len = 2 - len;
while (len-- > 0)
av_push(av, newSViv(0));
}
- if ( av_len(av) == -1 ) /* oops, someone forgot to pass a value */
+ /* need to save off the current version string for later */
+ if ( vinf ) {
+ SV * orig = newSVpvn("v.Inf", sizeof("v.Inf")-1);
+ (void)hv_stores(MUTABLE_HV(hv), "original", orig);
+ (void)hv_stores(MUTABLE_HV(hv), "vinf", newSViv(1));
+ }
+ else if ( s > start ) {
+ SV * orig = newSVpvn(start,s-start);
+ if ( qv && saw_period == 1 && *start != 'v' ) {
+ /* need to insert a v to be consistent */
+ sv_insert(orig, 0, 0, "v", 1);
+ }
+ (void)hv_stores(MUTABLE_HV(hv), "original", orig);
+ }
+ else {
+ (void)hv_stores(MUTABLE_HV(hv), "original", newSVpvs("0"));
av_push(av, newSViv(0));
+ }
+
+ /* And finally, store the AV in the hash */
+ (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av)));
/* fix RT#19517 - special case 'undef' as string */
if ( *s == 'u' && strEQ(s,"undef") ) {
s += 5;
}
- /* And finally, store the AV in the hash */
- hv_store((HV *)hv, "version", 7, newRV_noinc((SV *)av), 0);
return s;
}
{
dVAR;
SV * const rv = newSV(0);
+ PERL_ARGS_ASSERT_NEW_VERSION;
if ( sv_derived_from(ver,"version") ) /* can just copy directly */
{
I32 key;
/* This will get reblessed later if a derived class*/
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 */
-#endif
if ( SvROK(ver) )
ver = SvRV(ver);
/* Begin copying all of the elements */
- if ( hv_exists((HV *)ver, "qv", 2) )
- hv_store((HV *)hv, "qv", 2, &PL_sv_yes, 0);
+ if ( hv_exists(MUTABLE_HV(ver), "qv", 2) )
+ (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(1));
- if ( hv_exists((HV *)ver, "alpha", 5) )
- hv_store((HV *)hv, "alpha", 5, &PL_sv_yes, 0);
+ if ( hv_exists(MUTABLE_HV(ver), "alpha", 5) )
+ (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(1));
- if ( hv_exists((HV*)ver, "width", 5 ) )
+ if ( hv_exists(MUTABLE_HV(ver), "width", 5 ) )
{
- const I32 width = SvIV(*hv_fetchs((HV*)ver, "width", FALSE));
- hv_store((HV *)hv, "width", 5, newSViv(width), 0);
+ const I32 width = SvIV(*hv_fetchs(MUTABLE_HV(ver), "width", FALSE));
+ (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
}
- sav = (AV *)SvRV(*hv_fetchs((HV*)ver, "version", FALSE));
+ if ( hv_exists(MUTABLE_HV(ver), "original", 8 ) )
+ {
+ SV * pv = *hv_fetchs(MUTABLE_HV(ver), "original", FALSE);
+ (void)hv_stores(MUTABLE_HV(hv), "original", newSVsv(pv));
+ }
+
+ sav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(ver), "version", 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, newRV_noinc((SV *)av), 0);
+ (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av)));
return rv;
}
#ifdef SvVOK
const STRLEN len = mg->mg_len;
char * const version = savepvn( (const char*)mg->mg_ptr, len);
sv_setpvn(rv,version,len);
+ /* this is for consistency with the pure Perl class */
+ if ( *version != 'v' )
+ sv_insert(rv, 0, 0, "v", 1);
Safefree(version);
}
else {
}
}
#endif
- return upg_version(rv);
+ return upg_version(rv, FALSE);
}
/*
In-place upgrade of the supplied SV to a version object.
- SV *sv = upg_version(SV *sv);
+ SV *sv = upg_version(SV *sv, bool qv);
-Returns a pointer to the upgraded SV.
+Returns a pointer to the upgraded SV. Set the boolean qv if you want
+to force this SV to be interpreted as an "extended" version.
=cut
*/
SV *
-Perl_upg_version(pTHX_ SV *ver)
+Perl_upg_version(pTHX_ SV *ver, bool qv)
{
const char *version, *s;
- bool qv = 0;
#ifdef SvVOK
const MAGIC *mg;
#endif
- if ( SvNOK(ver) ) /* may get too much accuracy */
+ PERL_ARGS_ASSERT_UPG_VERSION;
+
+ if ( SvNOK(ver) && !( SvPOK(ver) && sv_len(ver) == 3 ) )
{
+ /* may get too much accuracy */
char tbuf[64];
#ifdef USE_LOCALE_NUMERIC
char *loc = setlocale(LC_NUMERIC, "C");
setlocale(LC_NUMERIC, loc);
#endif
while (tbuf[len-1] == '0' && len > 0) len--;
+ if ( tbuf[len-1] == '.' ) len--; /* eat the trailing decimal */
version = savepvn(tbuf, len);
}
#ifdef SvVOK
#endif
else /* must be a string or something like a string */
{
- version = savepv(SvPV_nolen(ver));
+ STRLEN len;
+ version = savepv(SvPV(ver,len));
+#ifndef SvVOK
+# if PERL_VERSION > 5
+ /* This will only be executed for 5.6.0 - 5.8.0 inclusive */
+ if ( len == 3 && !instr(version,".") && !instr(version,"_") ) {
+ /* may be a v-string */
+ SV * const nsv = sv_newmortal();
+ const char *nver;
+ const char *pos;
+ int saw_period = 0;
+ sv_setpvf(nsv,"v%vd",ver);
+ pos = nver = savepv(SvPV_nolen(nsv));
+
+ /* scan the resulting formatted string */
+ pos++; /* skip the leading 'v' */
+ while ( *pos == '.' || isDIGIT(*pos) ) {
+ if ( *pos == '.' )
+ saw_period++ ;
+ pos++;
+ }
+
+ /* is definitely a v-string */
+ if ( saw_period == 2 ) {
+ Safefree(version);
+ version = nver;
+ }
+ }
+# endif
+#endif
}
s = scan_version(version, ver, qv);
Perl_vverify(pTHX_ SV *vs)
{
SV *sv;
+
+ PERL_ARGS_ASSERT_VVERIFY;
+
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_fetchs((HV*)vs, "version", FALSE)))
+ && hv_exists(MUTABLE_HV(vs), "version", 7)
+ && (sv = SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)))
&& SvTYPE(sv) == SVt_PVAV )
return TRUE;
else
bool alpha = FALSE;
SV * const sv = newSV(0);
AV *av;
+
+ PERL_ARGS_ASSERT_VNUMIFY;
+
if ( SvROK(vs) )
vs = SvRV(vs);
Perl_croak(aTHX_ "Invalid version object");
/* see if various flags exist */
- if ( hv_exists((HV*)vs, "alpha", 5 ) )
+ if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
alpha = TRUE;
- if ( hv_exists((HV*)vs, "width", 5 ) )
- width = SvIV(*hv_fetchs((HV*)vs, "width", FALSE));
+ if ( hv_exists(MUTABLE_HV(vs), "width", 5 ) )
+ width = SvIV(*hv_fetchs(MUTABLE_HV(vs), "width", FALSE));
else
width = 3;
/* attempt to retrieve the version array */
- if ( !(av = (AV *)SvRV(*hv_fetchs((HV*)vs, "version", FALSE)) ) ) {
+ if ( !(av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE))) ) ) {
sv_catpvs(sv,"0");
return sv;
}
bool alpha = FALSE;
SV * const sv = newSV(0);
AV *av;
+
+ PERL_ARGS_ASSERT_VNORMAL;
+
if ( SvROK(vs) )
vs = SvRV(vs);
if ( !vverify(vs) )
Perl_croak(aTHX_ "Invalid version object");
- if ( hv_exists((HV*)vs, "alpha", 5 ) )
+ if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
alpha = TRUE;
- av = (AV *)SvRV(*hv_fetchs((HV*)vs, "version", FALSE));
+ av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)));
len = av_len(av);
if ( len == -1 )
SV *
Perl_vstringify(pTHX_ SV *vs)
{
+ PERL_ARGS_ASSERT_VSTRINGIFY;
+
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
- return vnumify(vs);
+ if (hv_exists(MUTABLE_HV(vs), "original", sizeof("original") - 1)) {
+ SV *pv;
+ pv = *hv_fetchs(MUTABLE_HV(vs), "original", FALSE);
+ if ( SvPOK(pv) )
+ return newSVsv(pv);
+ else
+ return &PL_sv_undef;
+ }
+ else {
+ if ( hv_exists(MUTABLE_HV(vs), "qv", 2) )
+ return vnormal(vs);
+ else
+ return vnumify(vs);
+ }
}
/*
I32 left = 0;
I32 right = 0;
AV *lav, *rav;
+
+ PERL_ARGS_ASSERT_VCMP;
+
if ( SvROK(lhv) )
lhv = SvRV(lhv);
if ( SvROK(rhv) )
Perl_croak(aTHX_ "Invalid version object");
/* get the left hand term */
- lav = (AV *)SvRV(*hv_fetchs((HV*)lhv, "version", FALSE));
- if ( hv_exists((HV*)lhv, "alpha", 5 ) )
+ lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(lhv), "version", FALSE)));
+ if ( hv_exists(MUTABLE_HV(lhv), "alpha", 5 ) )
lalpha = TRUE;
/* and the right hand term */
- rav = (AV *)SvRV(*hv_fetchs((HV*)rhv, "version", FALSE));
- if ( hv_exists((HV*)rhv, "alpha", 5 ) )
+ rav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(rhv), "version", FALSE)));
+ if ( hv_exists(MUTABLE_HV(rhv), "alpha", 5 ) )
ralpha = TRUE;
l = av_len(lav);
PERL_UNUSED_ARG(sv);
}
+/*
+
+=for apidoc sv_destroyable
+
+Dummy routine which reports that object can be destroyed when there is no
+sharing module present. It ignores its single SV argument, and returns
+'true'. Exists to avoid test for a NULL function pointer and because it
+could potentially warn under some level of strict-ness.
+
+=cut
+*/
+
+bool
+Perl_sv_destroyable(pTHX_ SV *sv)
+{
+ PERL_UNUSED_CONTEXT;
+ PERL_UNUSED_ARG(sv);
+ return TRUE;
+}
+
U32
Perl_parse_unicode_opts(pTHX_ const char **popt)
{
const char *p = *popt;
U32 opt = 0;
+ PERL_ARGS_ASSERT_PARSE_UNICODE_OPTS;
+
if (*p) {
if (isDIGIT(*p)) {
opt = (U32) atoi(p);
const char * const stashpv = CopSTASHPV(c);
const char * const name = HvNAME_get(hv);
PERL_UNUSED_CONTEXT;
+ PERL_ARGS_ASSERT_STASHPV_HVNAME_MATCH;
if (stashpv == name)
return TRUE;
#ifdef PERL_GLOBAL_STRUCT
+#define PERL_GLOBAL_STRUCT_INIT
+#include "opcode.h" /* the ppaddr and check */
+
struct perl_vars *
Perl_init_global_struct(pTHX)
{
struct perl_vars *plvarsp = NULL;
-#ifdef PERL_GLOBAL_STRUCT
-# define PERL_GLOBAL_STRUCT_INIT
-# include "opcode.h" /* the ppaddr and check */
+# ifdef PERL_GLOBAL_STRUCT
const IV nppaddr = sizeof(Gppaddr)/sizeof(Perl_ppaddr_t);
const IV ncheck = sizeof(Gcheck) /sizeof(Perl_check_t);
# ifdef PERL_GLOBAL_STRUCT_PRIVATE
# undef PERLVARIC
# undef PERLVARISC
# ifdef PERL_GLOBAL_STRUCT
- plvarsp->Gppaddr = PerlMem_malloc(nppaddr * sizeof(Perl_ppaddr_t));
+ plvarsp->Gppaddr =
+ (Perl_ppaddr_t*)
+ PerlMem_malloc(nppaddr * sizeof(Perl_ppaddr_t));
if (!plvarsp->Gppaddr)
exit(1);
- plvarsp->Gcheck = PerlMem_malloc(ncheck * sizeof(Perl_check_t));
+ plvarsp->Gcheck =
+ (Perl_check_t*)
+ PerlMem_malloc(ncheck * sizeof(Perl_check_t));
if (!plvarsp->Gcheck)
exit(1);
Copy(Gppaddr, plvarsp->Gppaddr, nppaddr, Perl_ppaddr_t);
# ifdef PERL_SET_VARS
PERL_SET_VARS(plvarsp);
# endif
-# undef PERL_GLOBAL_STRUCT_INIT
-#endif
+# undef PERL_GLOBAL_STRUCT_INIT
+# endif
return plvarsp;
}
void
Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp)
{
-#ifdef PERL_GLOBAL_STRUCT
+ PERL_ARGS_ASSERT_FREE_GLOBAL_STRUCT;
+# ifdef PERL_GLOBAL_STRUCT
# ifdef PERL_UNSET_VARS
PERL_UNSET_VARS(plvarsp);
# endif
free(plvarsp->Gppaddr);
free(plvarsp->Gcheck);
-# ifdef PERL_GLOBAL_STRUCT_PRIVATE
+# ifdef PERL_GLOBAL_STRUCT_PRIVATE
free(plvarsp);
-# endif
-#endif
+# endif
+# endif
}
#endif /* PERL_GLOBAL_STRUCT */
* PERL_MEM_LOG: the Perl_mem_log_..() will be compiled.
*
* PERL_MEM_LOG_ENV: if defined, during run time the environment
- * variable PERL_MEM_LOG will be consulted, and if the integer value
- * of that is true, the logging will happen. (The default is to
- * always log if the PERL_MEM_LOG define was in effect.)
+ * variables PERL_MEM_LOG and PERL_SV_LOG will be consulted, and
+ * if the integer value of that is true, the logging will happen.
+ * (The default is to always log if the PERL_MEM_LOG define was
+ * in effect.)
+ *
+ * PERL_MEM_LOG_TIMESTAMP: if defined, a timestamp will be logged
+ * before every memory logging entry. This can be turned off at run
+ * time by setting the environment variable PERL_MEM_LOG_TIMESTAMP
+ * to zero.
*/
/*
# define PERL_MEM_LOG_FD 2 /* If STDERR is too boring for you. */
#endif
-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
+
+# ifdef DEBUG_LEAKING_SCALARS
+# define SV_LOG_SERIAL_FMT " [%lu]"
+# define _SV_LOG_SERIAL_ARG(sv) , (unsigned long) (sv)->sv_debug_serial
+# else
+# define SV_LOG_SERIAL_FMT
+# define _SV_LOG_SERIAL_ARG(sv)
+# endif
+
+static void
+S_mem_log_common(enum mem_log_type mlt, const UV n, const UV typesize, const char *type_name, const SV *sv, Malloc_t oldalloc, Malloc_t newalloc, const char *filename, const int linenumber, const char *funcname)
+{
# if defined(PERL_MEM_LOG_ENV) || defined(PERL_MEM_LOG_ENV_FD)
- char *s;
+ const char *s;
# endif
+
+ PERL_ARGS_ASSERT_MEM_LOG_COMMON;
+
# ifdef PERL_MEM_LOG_ENV
- s = getenv("PERL_MEM_LOG");
+ s = PerlEnv_getenv(mlt < MLT_NEW_SV ? "PERL_MEM_LOG" : "PERL_SV_LOG");
if (s ? atoi(s) : 0)
# endif
{
* so we'll use stdio and low-level IO instead. */
char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
# ifdef PERL_MEM_LOG_TIMESTAMP
- struct timeval tv;
# ifdef HAS_GETTIMEOFDAY
+# define MEM_LOG_TIME_FMT "%10d.%06d: "
+# define MEM_LOG_TIME_ARG (int)tv.tv_sec, (int)tv.tv_usec
+ struct timeval tv;
gettimeofday(&tv, 0);
+# else
+# define MEM_LOG_TIME_FMT "%10d: "
+# define MEM_LOG_TIME_ARG (int)when
+ Time_t when;
+ (void)time(&when);
# endif
/* If there are other OS specific ways of hires time than
* gettimeofday() (see ext/Time/HiRes), the easiest way is
* timeval. */
# endif
{
- const STRLEN len =
- my_snprintf(buf,
- sizeof(buf),
-# ifdef PERL_MEM_LOG_TIMESTAMP
- "%10d.%06d: "
+ int fd = PERL_MEM_LOG_FD;
+ STRLEN len;
+
+# ifdef PERL_MEM_LOG_ENV_FD
+ if ((s = PerlEnv_getenv("PERL_MEM_LOG_FD"))) {
+ fd = atoi(s);
+ }
# endif
- "alloc: %s:%d:%s: %"IVdf" %"UVuf
- " %s = %"IVdf": %"UVxf"\n",
-# ifdef PERL_MEM_LOG_TIMESTAMP
- (int)tv.tv_sec, (int)tv.tv_usec,
+# ifdef PERL_MEM_LOG_TIMESTAMP
+ s = PerlEnv_getenv("PERL_MEM_LOG_TIMESTAMP");
+ if (!s || atoi(s)) {
+ len = my_snprintf(buf, sizeof(buf),
+ MEM_LOG_TIME_FMT, MEM_LOG_TIME_ARG);
+ PerlLIO_write(fd, buf, len);
+ }
# endif
- filename, linenumber, funcname, n, typesize,
- typename, n * typesize, PTR2UV(newalloc));
-# ifdef PERL_MEM_LOG_ENV_FD
- s = PerlEnv_getenv("PERL_MEM_LOG_FD");
- PerlLIO_write(s ? atoi(s) : PERL_MEM_LOG_FD, buf, len);
-# else
- PerlLIO_write(PERL_MEM_LOG_FD, buf, len);
-#endif
+ switch (mlt) {
+ case MLT_ALLOC:
+ len = my_snprintf(buf, sizeof(buf),
+ "alloc: %s:%d:%s: %"IVdf" %"UVuf
+ " %s = %"IVdf": %"UVxf"\n",
+ filename, linenumber, funcname, n, typesize,
+ type_name, n * typesize, PTR2UV(newalloc));
+ break;
+ case MLT_REALLOC:
+ len = my_snprintf(buf, sizeof(buf),
+ "realloc: %s:%d:%s: %"IVdf" %"UVuf
+ " %s = %"IVdf": %"UVxf" -> %"UVxf"\n",
+ filename, linenumber, funcname, n, typesize,
+ type_name, n * typesize, PTR2UV(oldalloc),
+ PTR2UV(newalloc));
+ break;
+ case MLT_FREE:
+ len = my_snprintf(buf, sizeof(buf),
+ "free: %s:%d:%s: %"UVxf"\n",
+ filename, linenumber, funcname,
+ PTR2UV(oldalloc));
+ break;
+ case MLT_NEW_SV:
+ case MLT_DEL_SV:
+ len = my_snprintf(buf, sizeof(buf),
+ "%s_SV: %s:%d:%s: %"UVxf SV_LOG_SERIAL_FMT "\n",
+ mlt == MLT_NEW_SV ? "new" : "del",
+ filename, linenumber, funcname,
+ PTR2UV(sv) _SV_LOG_SERIAL_ARG(sv));
+ break;
+ }
+ PerlLIO_write(fd, buf, len);
}
}
+}
+#endif
+
+Malloc_t
+Perl_mem_log_alloc(const UV n, const UV typesize, const char *type_name, Malloc_t newalloc, const char *filename, const int linenumber, const char *funcname)
+{
+#ifdef PERL_MEM_LOG_STDERR
+ mem_log_common(MLT_ALLOC, n, typesize, type_name, NULL, NULL, newalloc, filename, linenumber, funcname);
#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)
+Perl_mem_log_realloc(const UV n, const UV typesize, const char *type_name, Malloc_t oldalloc, Malloc_t newalloc, const char *filename, const int linenumber, const char *funcname)
{
#ifdef PERL_MEM_LOG_STDERR
-# if defined(PERL_MEM_LOG_ENV) || defined(PERL_MEM_LOG_ENV_FD)
- char *s;
-# endif
-# ifdef PERL_MEM_LOG_ENV
- s = PerlEnv_getenv("PERL_MEM_LOG");
- if (s ? atoi(s) : 0)
-# endif
- {
- /* We can't use SVs or PerlIO for obvious reasons,
- * so we'll use stdio and low-level IO instead. */
- char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
-# ifdef PERL_MEM_LOG_TIMESTAMP
- struct timeval tv;
- gettimeofday(&tv, 0);
-# endif
- {
- const STRLEN len =
- my_snprintf(buf,
- sizeof(buf),
-# ifdef PERL_MEM_LOG_TIMESTAMP
- "%10d.%06d: "
-# endif
- "realloc: %s:%d:%s: %"IVdf" %"UVuf
- " %s = %"IVdf": %"UVxf" -> %"UVxf"\n",
-# ifdef PERL_MEM_LOG_TIMESTAMP
- (int)tv.tv_sec, (int)tv.tv_usec,
-# endif
- filename, linenumber, funcname, n, typesize,
- typename, n * typesize, PTR2UV(oldalloc),
- PTR2UV(newalloc));
-# ifdef PERL_MEM_LOG_ENV_FD
- s = PerlEnv_getenv("PERL_MEM_LOG_FD");
- PerlLIO_write(s ? atoi(s) : PERL_MEM_LOG_FD, buf, len);
-# else
- PerlLIO_write(PERL_MEM_LOG_FD, buf, len);
-# endif
- }
- }
+ mem_log_common(MLT_REALLOC, n, typesize, type_name, NULL, oldalloc, newalloc, filename, linenumber, funcname);
#endif
return newalloc;
}
Perl_mem_log_free(Malloc_t oldalloc, const char *filename, const int linenumber, const char *funcname)
{
#ifdef PERL_MEM_LOG_STDERR
-# if defined(PERL_MEM_LOG_ENV) || defined(PERL_MEM_LOG_ENV_FD)
- char *s;
-# endif
-# ifdef PERL_MEM_LOG_ENV
- s = PerlEnv_getenv("PERL_MEM_LOG");
- if (s ? atoi(s) : 0)
-# endif
- {
- /* We can't use SVs or PerlIO for obvious reasons,
- * so we'll use stdio and low-level IO instead. */
- char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
-# ifdef PERL_MEM_LOG_TIMESTAMP
- struct timeval tv;
- gettimeofday(&tv, 0);
-# endif
- {
- const STRLEN len =
- my_snprintf(buf,
- sizeof(buf),
-# ifdef PERL_MEM_LOG_TIMESTAMP
- "%10d.%06d: "
-# endif
- "free: %s:%d:%s: %"UVxf"\n",
-# ifdef PERL_MEM_LOG_TIMESTAMP
- (int)tv.tv_sec, (int)tv.tv_usec,
-# endif
- filename, linenumber, funcname,
- PTR2UV(oldalloc));
-# ifdef PERL_MEM_LOG_ENV_FD
- s = PerlEnv_getenv("PERL_MEM_LOG_FD");
- PerlLIO_write(s ? atoi(s) : PERL_MEM_LOG_FD, buf, len);
-# else
- PerlLIO_write(PERL_MEM_LOG_FD, buf, len);
-# endif
- }
- }
+ mem_log_common(MLT_FREE, 0, 0, "", NULL, oldalloc, NULL, filename, linenumber, funcname);
#endif
return oldalloc;
}
+void
+Perl_mem_log_new_sv(const SV *sv, const char *filename, const int linenumber, const char *funcname)
+{
+#ifdef PERL_MEM_LOG_STDERR
+ mem_log_common(MLT_NEW_SV, 0, 0, "", sv, NULL, NULL, filename, linenumber, funcname);
+#endif
+}
+
+void
+Perl_mem_log_del_sv(const SV *sv, const char *filename, const int linenumber, const char *funcname)
+{
+#ifdef PERL_MEM_LOG_STDERR
+ mem_log_common(MLT_DEL_SV, 0, 0, "", sv, NULL, NULL, filename, linenumber, funcname);
+#endif
+}
+
#endif /* PERL_MEM_LOG */
/*
Perl_my_sprintf(char *buffer, const char* pat, ...)
{
va_list args;
+ PERL_ARGS_ASSERT_MY_SPRINTF;
va_start(args, pat);
vsprintf(buffer, pat, args);
va_end(args);
dTHX;
int retval;
va_list ap;
+ PERL_ARGS_ASSERT_MY_SNPRINTF;
va_start(ap, format);
#ifdef HAS_VSNPRINTF
retval = vsnprintf(buffer, len, format, ap);
int retval;
#ifdef NEED_VA_COPY
va_list apc;
+
+ PERL_ARGS_ASSERT_MY_VSNPRINTF;
+
Perl_va_copy(ap, apc);
# ifdef HAS_VSNPRINTF
retval = vsnprintf(buffer, len, format, apc);
bsiz = l + 1; /* + 1 for the \0. */
buf = (char*)safesysmalloc(bufsiz);
}
- my_strlcpy(buf, *environ, l + 1);
+ memcpy(buf, *environ, l);
+ buf[l] = '\0';
(void)unsetenv(buf);
}
(void)safesysfree(buf);
#ifdef PERL_IMPLICIT_CONTEXT
-/* implements the MY_CXT_INIT macro. The first time a module is loaded,
+/* 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 */
+#ifndef PERL_GLOBAL_STRUCT_PRIVATE
void *
Perl_my_cxt_init(pTHX_ int *index, size_t size)
{
dVAR;
void *p;
+ PERL_ARGS_ASSERT_MY_CXT_INIT;
if (*index == -1) {
/* this module hasn't been allocated an index yet */
MUTEX_LOCK(&PL_my_ctx_mutex);
Zero(p, size, char);
return p;
}
-#endif
+
+#else /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
+
+int
+Perl_my_cxt_index(pTHX_ const char *my_cxt_key)
+{
+ dVAR;
+ int index;
+
+ PERL_ARGS_ASSERT_MY_CXT_INDEX;
+
+ for (index = 0; index < PL_my_cxt_index; index++) {
+ const char *key = PL_my_cxt_keys[index];
+ /* try direct pointer compare first - there are chances to success,
+ * and it's much faster.
+ */
+ if ((key == my_cxt_key) || strEQ(key, my_cxt_key))
+ return index;
+ }
+ return -1;
+}
+
+void *
+Perl_my_cxt_init(pTHX_ const char *my_cxt_key, size_t size)
+{
+ dVAR;
+ void *p;
+ int index;
+
+ PERL_ARGS_ASSERT_MY_CXT_INIT;
+
+ index = Perl_my_cxt_index(aTHX_ my_cxt_key);
+ 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) {
+ int old_size = PL_my_cxt_size;
+ int i;
+ 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 *);
+ Renew(PL_my_cxt_keys, PL_my_cxt_size, const char *);
+ }
+ else {
+ PL_my_cxt_size = 16;
+ Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
+ Newx(PL_my_cxt_keys, PL_my_cxt_size, const char *);
+ }
+ for (i = old_size; i < PL_my_cxt_size; i++) {
+ PL_my_cxt_keys[i] = 0;
+ PL_my_cxt_list[i] = 0;
+ }
+ }
+ PL_my_cxt_keys[index] = my_cxt_key;
+ /* 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 /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
+#endif /* PERL_IMPLICIT_CONTEXT */
#ifndef HAS_STRLCAT
Size_t
}
#endif
+#if defined(_MSC_VER) && (_MSC_VER >= 1300) && (_MSC_VER < 1400) && (WINVER < 0x0500)
+/* VC7 or 7.1, building with pre-VC7 runtime libraries. */
+long _ftol( double ); /* Defined by VC6 C libs. */
+long _ftol2( double dblSource ) { return _ftol( dblSource ); }
+#endif
+
void
Perl_get_db_sub(pTHX_ SV **svp, CV *cv)
{
* it's for informational purposes only.
*/
+ PERL_ARGS_ASSERT_GET_DB_SUB;
+
save_item(dbsv);
if (!PERLDB_SUB_NN) {
GV * const gv = CvGV(cv);
!( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv) )))) {
/* Use GV from the stack as a fallback. */
/* GV is potentially non-unique, or contain different CV. */
- SV * const tmp = newRV((SV*)cv);
+ SV * const tmp = newRV(MUTABLE_SV(cv));
sv_setsv(dbsv, tmp);
SvREFCNT_dec(tmp);
}
}
}
+int
+Perl_my_dirfd(pTHX_ DIR * dir) {
+
+ /* Most dirfd implementations have problems when passed NULL. */
+ if(!dir)
+ return -1;
+#ifdef HAS_DIRFD
+ return dirfd(dir);
+#elif defined(HAS_DIR_DD_FD)
+ return dir->dd_fd;
+#else
+ Perl_die(aTHX_ PL_no_func, "dirfd");
+ /* NOT REACHED */
+ return 0;
+#endif
+}
+
+REGEXP *
+Perl_get_re_arg(pTHX_ SV *sv) {
+ SV *tmpsv;
+
+ if (sv) {
+ if (SvMAGICAL(sv))
+ mg_get(sv);
+ if (SvROK(sv) &&
+ (tmpsv = MUTABLE_SV(SvRV(sv))) && /* assign deliberate */
+ SvTYPE(tmpsv) == SVt_REGEXP)
+ {
+ return (REGEXP*) tmpsv;
+ }
+ }
+
+ return NULL;
+}
+
/*
* Local variables:
* c-indentation-style: bsd
https://perl5.git.perl.org / perl5.git / blobdiff