* 'Very useful, no doubt, that was to Saruman; yet it seems that he was
* not content.' --Gandalf to Pippin
*
- * [p.598 of _The Lord of the Rings_, III/xi: "The Palantír"]
+ * [p.598 of _The Lord of the Rings_, III/xi: "The Palantír"]
*/
/* This file contains assorted utility routines.
#define PERL_IN_UTIL_C
#include "perl.h"
+#ifdef USE_PERLIO
+#include "perliol.h" /* For PerlIOUnix_refcnt */
+#endif
+
#ifndef PERL_MICRO
#include <signal.h>
#ifndef SIG_ERR
NORETURN_FUNCTION_END;
}
+#if defined (DEBUGGING) || defined(PERL_IMPLICIT_SYS) || defined (PERL_TRACK_MEMPOOL)
+# define ALWAYS_NEED_THX
+#endif
+
/* paranoid version of system's malloc() */
Malloc_t
Perl_safesysmalloc(MEM_SIZE size)
{
+#ifdef ALWAYS_NEED_THX
dTHX;
+#endif
Malloc_t ptr;
#ifdef HAS_64K_LIMIT
if (size > 0xffff) {
#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) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
if (ptr != NULL) {
#ifdef PERL_TRACK_MEMPOOL
struct perl_memory_debug_header *const header
# endif
ptr = (Malloc_t)((char*)ptr+sTHX);
#endif
+ DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
return ptr;
}
- else if (PL_nomemok)
- return NULL;
else {
- return write_no_mem();
+#ifndef ALWAYS_NEED_THX
+ dTHX;
+#endif
+ if (PL_nomemok)
+ return NULL;
+ else {
+ return write_no_mem();
+ }
}
/*NOTREACHED*/
}
Malloc_t
Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
{
+#ifdef ALWAYS_NEED_THX
dTHX;
+#endif
Malloc_t ptr;
#if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) && !defined(PERL_MICRO)
Malloc_t PerlMem_realloc();
if (ptr != NULL) {
return ptr;
}
- else if (PL_nomemok)
- return NULL;
else {
- return write_no_mem();
+#ifndef ALWAYS_NEED_THX
+ dTHX;
+#endif
+ if (PL_nomemok)
+ return NULL;
+ else {
+ return write_no_mem();
+ }
}
/*NOTREACHED*/
}
Free_t
Perl_safesysfree(Malloc_t where)
{
-#if defined(PERL_IMPLICIT_SYS) || defined(PERL_TRACK_MEMPOOL)
+#ifdef ALWAYS_NEED_THX
dTHX;
#else
dVAR;
Malloc_t
Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
{
+#ifdef ALWAYS_NEED_THX
dTHX;
+#endif
Malloc_t ptr;
+#if defined(PERL_TRACK_MEMPOOL) || defined(HAS_64K_LIMIT) || defined(DEBUGGING)
MEM_SIZE total_size = 0;
+#endif
/* Even though calloc() for zero bytes is strange, be robust. */
- if (size && (count <= MEM_SIZE_MAX / size))
+ if (size && (count <= MEM_SIZE_MAX / size)) {
+#if defined(PERL_TRACK_MEMPOOL) || defined(HAS_64K_LIMIT) || defined(DEBUGGING)
total_size = size * count;
+#endif
+ }
else
Perl_croak_nocontext("%s", PL_memory_wrap);
#ifdef PERL_TRACK_MEMPOOL
#endif
return ptr;
}
- else if (PL_nomemok)
- return NULL;
- return write_no_mem();
+ else {
+#ifndef ALWAYS_NEED_THX
+ dTHX;
+#endif
+ if (PL_nomemok)
+ return NULL;
+ return write_no_mem();
+ }
}
/* These must be defined when not using Perl's malloc for binary
/* copy a string up to some (non-backslashed) delimiter, if any */
char *
-Perl_delimcpy(pTHX_ register char *to, register const char *toend, register const char *from, register const char *fromend, register int delim, I32 *retlen)
+Perl_delimcpy(register char *to, register const char *toend, register const char *from, register const char *fromend, register int delim, I32 *retlen)
{
register I32 tolen;
- PERL_UNUSED_CONTEXT;
PERL_ARGS_ASSERT_DELIMCPY;
/* This routine was donated by Corey Satten. */
char *
-Perl_instr(pTHX_ register const char *big, register const char *little)
+Perl_instr(register const char *big, register const char *little)
{
register I32 first;
- PERL_UNUSED_CONTEXT;
PERL_ARGS_ASSERT_INSTR;
/* same as instr but allow embedded nulls */
char *
-Perl_ninstr(pTHX_ const char *big, const char *bigend, const char *little, const char *lend)
+Perl_ninstr(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;
{
/* reverse of the above--find last substring */
char *
-Perl_rninstr(pTHX_ register const char *big, const char *bigend, const char *little, const char *lend)
+Perl_rninstr(register const char *big, const char *bigend, const char *little, const char *lend)
{
register const char *bigbeg;
register const I32 first = *little;
register const char * const littleend = lend;
- PERL_UNUSED_CONTEXT;
PERL_ARGS_ASSERT_RNINSTR;
{
dVAR;
register const U8 *s;
- register U32 i;
+ STRLEN i;
STRLEN len;
- U32 rarest = 0;
+ STRLEN rarest = 0;
U32 frequency = 256;
+ MAGIC *mg;
PERL_ARGS_ASSERT_FBM_COMPILE;
+ /* Refuse to fbm_compile a studied scalar, as this gives more flexibility in
+ SV flag usage. No real-world code would ever end up using a studied
+ scalar as a compile-time second argument to index, so this isn't a real
+ pessimisation. */
+ if (SvSCREAM(sv))
+ return;
+
+ if (SvVALID(sv))
+ return;
+
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() */
s = (U8*)SvPV_force_mutable(sv, len);
if (len == 0) /* TAIL might be on a zero-length string. */
return;
- SvUPGRADE(sv, SVt_PVGV);
+ SvUPGRADE(sv, SVt_PVMG);
SvIOK_off(sv);
SvNOK_off(sv);
SvVALID_on(sv);
+
+ /* "deep magic", the comment used to add. The use of MAGIC itself isn't
+ really. MAGIC was originally added in 79072805bf63abe5 (perl 5.0 alpha 2)
+ to call SvVALID_off() if the scalar was assigned to.
+
+ The comment itself (and "deeper magic" below) date back to
+ 378cc40b38293ffc (perl 2.0). "deep magic" was an annotation on
+ str->str_pok |= 2;
+ where the magic (presumably) was that the scalar had a BM table hidden
+ inside itself.
+
+ As MAGIC is always present on BMs [in Perl 5 :-)], we can use it to store
+ the table instead of the previous (somewhat hacky) approach of co-opting
+ the string buffer and storing it after the string. */
+
+ assert(!mg_find(sv, PERL_MAGIC_bm));
+ mg = sv_magicext(sv, NULL, PERL_MAGIC_bm, &PL_vtbl_bm, NULL, 0);
+ assert(mg);
+
if (len > 2) {
- const unsigned char *sb;
+ /* Shorter strings are special-cased in Perl_fbm_instr(), and don't use
+ the BM table. */
const U8 mlen = (len>255) ? 255 : (U8)len;
+ const unsigned char *const sb = s + len - mlen; /* first char (maybe) */
register U8 *table;
- Sv_Grow(sv, len + 256 + PERL_FBM_TABLE_OFFSET);
- table
- = (unsigned char*)(SvPVX_mutable(sv) + len + PERL_FBM_TABLE_OFFSET);
- s = table - 1 - PERL_FBM_TABLE_OFFSET; /* last char */
+ Newx(table, 256, U8);
memset((void*)table, mlen, 256);
+ mg->mg_ptr = (char *)table;
+ mg->mg_len = 256;
+
+ s += len - 1; /* last char */
i = 0;
- sb = s - mlen + 1; /* first char (maybe) */
while (s >= sb) {
if (table[*s] == mlen)
table[*s] = (U8)i;
s--, i++;
}
- } else {
- Sv_Grow(sv, len + PERL_FBM_TABLE_OFFSET);
}
- sv_magic(sv, NULL, PERL_MAGIC_bm, NULL, 0); /* deep magic */
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(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 %lu\n",
- BmRARE(sv),(unsigned long)BmPREVIOUS(sv)));
+ DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %"UVuf"\n",
+ BmRARE(sv), BmPREVIOUS(sv)));
}
/* If SvTAIL(littlestr), it has a fake '\n' at end. */
return NULL;
}
- if (littlelen <= 2) { /* Special-cased */
-
- if (littlelen == 1) {
+ switch (littlelen) { /* Special cases for 0, 1 and 2 */
+ case 0:
+ return (char*)big; /* Cannot be SvTAIL! */
+ case 1:
if (SvTAIL(littlestr) && !multiline) { /* Anchor only! */
/* Know that bigend != big. */
if (bigend[-1] == '\n')
if (SvTAIL(littlestr))
return (char *) bigend;
return NULL;
- }
- if (!littlelen)
- return (char*)big; /* Cannot be SvTAIL! */
-
- /* littlelen is 2 */
+ case 2:
if (SvTAIL(littlestr) && !multiline) {
if (bigend[-1] == '\n' && bigend[-2] == *little)
return (char*)bigend - 2;
if (SvTAIL(littlestr) && (*bigend == *little))
return (char *)bigend; /* bigend is already decremented. */
return NULL;
+ default:
+ break; /* Only lengths 0 1 and 2 have special-case code. */
}
+
if (SvTAIL(littlestr) && !multiline) { /* tail anchored? */
s = bigend - littlelen;
if (s >= big && bigend[-1] == '\n' && *s == *little
return NULL;
{
- register const unsigned char * const table
- = little + littlelen + PERL_FBM_TABLE_OFFSET;
+ const MAGIC *const mg = mg_find(littlestr, PERL_MAGIC_bm);
+ const unsigned char * const table = (const unsigned char *) mg->mg_ptr;
register const unsigned char *oldlittle;
--littlelen; /* Last char found by table lookup */
}
check_end:
if ( s == bigend
- && (BmFLAGS(littlestr) & FBMcf_TAIL)
+ && SvTAIL(littlestr)
&& memEQ((char *)(bigend - littlelen),
(char *)(oldlittle - littlelen), littlelen) )
return (char*)bigend - littlelen;
{
dVAR;
register const unsigned char *big;
- register I32 pos;
+ U32 pos = 0; /* hush a gcc warning */
register I32 previous;
register I32 first;
register const unsigned char *little;
register I32 stop_pos;
register const unsigned char *littleend;
- I32 found = 0;
+ bool found = FALSE;
+ const MAGIC * mg;
+ const void *screamnext_raw = NULL; /* hush a gcc warning */
+ bool cant_find = FALSE; /* hush a gcc warning */
PERL_ARGS_ASSERT_SCREAMINSTR;
- assert(SvTYPE(littlestr) == SVt_PVGV);
+ assert(SvMAGICAL(bigstr));
+ mg = mg_find(bigstr, PERL_MAGIC_study);
+ assert(mg);
+ assert(SvTYPE(littlestr) == SVt_PVMG);
assert(SvVALID(littlestr));
- if (*old_posp == -1
- ? (pos = PL_screamfirst[BmRARE(littlestr)]) < 0
- : (((pos = *old_posp), pos += PL_screamnext[pos]) == 0)) {
+ if (mg->mg_private == 1) {
+ const U8 *const screamfirst = (U8 *)mg->mg_ptr;
+ const U8 *const screamnext = screamfirst + 256;
+
+ screamnext_raw = (const void *)screamnext;
+
+ pos = *old_posp == -1
+ ? screamfirst[BmRARE(littlestr)] : screamnext[*old_posp];
+ cant_find = pos == (U8)~0;
+ } else if (mg->mg_private == 2) {
+ const U16 *const screamfirst = (U16 *)mg->mg_ptr;
+ const U16 *const screamnext = screamfirst + 256;
+
+ screamnext_raw = (const void *)screamnext;
+
+ pos = *old_posp == -1
+ ? screamfirst[BmRARE(littlestr)] : screamnext[*old_posp];
+ cant_find = pos == (U16)~0;
+ } else if (mg->mg_private == 4) {
+ const U32 *const screamfirst = (U32 *)mg->mg_ptr;
+ const U32 *const screamnext = screamfirst + 256;
+
+ screamnext_raw = (const void *)screamnext;
+
+ pos = *old_posp == -1
+ ? screamfirst[BmRARE(littlestr)] : screamnext[*old_posp];
+ cant_find = pos == (U32)~0;
+ } else
+ Perl_croak(aTHX_ "panic: unknown study size %u", mg->mg_private);
+
+ if (cant_find) {
cant_find:
if ( BmRARE(littlestr) == '\n'
&& BmPREVIOUS(littlestr) == SvCUR(littlestr) - 1) {
#endif
return NULL;
}
- while (pos < previous + start_shift) {
- if (!(pos += PL_screamnext[pos]))
- goto cant_find;
+ if (mg->mg_private == 1) {
+ const U8 *const screamnext = (const U8 *const) screamnext_raw;
+ while ((I32)pos < previous + start_shift) {
+ pos = screamnext[pos];
+ if (pos == (U8)~0)
+ goto cant_find;
+ }
+ } else if (mg->mg_private == 2) {
+ const U16 *const screamnext = (const U16 *const) screamnext_raw;
+ while ((I32)pos < previous + start_shift) {
+ pos = screamnext[pos];
+ if (pos == (U16)~0)
+ goto cant_find;
+ }
+ } else if (mg->mg_private == 4) {
+ const U32 *const screamnext = (const U32 *const) screamnext_raw;
+ while ((I32)pos < previous + start_shift) {
+ pos = screamnext[pos];
+ if (pos == (U32)~0)
+ goto cant_find;
+ }
}
big -= previous;
- do {
- register const unsigned char *s, *x;
- if (pos >= stop_pos) break;
- if (big[pos] != first)
- continue;
- for (x=big+pos+1,s=little; s < littleend; /**/ ) {
- if (*s++ != *x++) {
- s--;
- break;
+ while (1) {
+ if ((I32)pos >= stop_pos) break;
+ if (big[pos] == first) {
+ const unsigned char *s = little;
+ const unsigned char *x = big + pos + 1;
+ while (s < littleend) {
+ if (*s != *x++)
+ break;
+ ++s;
+ }
+ if (s == littleend) {
+ *old_posp = (I32)pos;
+ if (!last) return (char *)(big+pos);
+ found = TRUE;
}
}
- if (s == littleend) {
- *old_posp = pos;
- if (!last) return (char *)(big+pos);
- found = 1;
+ if (mg->mg_private == 1) {
+ pos = ((const U8 *const)screamnext_raw)[pos];
+ if (pos == (U8)~0)
+ break;
+ } else if (mg->mg_private == 2) {
+ pos = ((const U16 *const)screamnext_raw)[pos];
+ if (pos == (U16)~0)
+ break;
+ } else if (mg->mg_private == 4) {
+ pos = ((const U32 *const)screamnext_raw)[pos];
+ if (pos == (U32)~0)
+ break;
}
- } while ( pos += PL_screamnext[pos] );
+ };
if (last && found)
return (char *)(big+(*old_posp));
check_tail:
return NULL;
}
+/*
+=for apidoc foldEQ
+
+Returns true if the leading len bytes of the strings s1 and s2 are the same
+case-insensitively; false otherwise. Uppercase and lowercase ASCII range bytes
+match themselves and their opposite case counterparts. Non-cased and non-ASCII
+range bytes match only themselves.
+
+=cut
+*/
+
+
I32
-Perl_ibcmp(pTHX_ const char *s1, const char *s2, register I32 len)
+Perl_foldEQ(const char *s1, const char *s2, register I32 len)
{
register const U8 *a = (const U8 *)s1;
register const U8 *b = (const U8 *)s2;
- PERL_UNUSED_CONTEXT;
- PERL_ARGS_ASSERT_IBCMP;
+ PERL_ARGS_ASSERT_FOLDEQ;
while (len--) {
if (*a != *b && *a != PL_fold[*b])
- return 1;
+ return 0;
a++,b++;
}
- return 0;
+ return 1;
+}
+I32
+Perl_foldEQ_latin1(const char *s1, const char *s2, register I32 len)
+{
+ /* Compare non-utf8 using Unicode (Latin1) semantics. Does not work on
+ * MICRO_SIGN, LATIN_SMALL_LETTER_SHARP_S, nor
+ * LATIN_SMALL_LETTER_Y_WITH_DIAERESIS, and does not check for these. Nor
+ * does it check that the strings each have at least 'len' characters */
+
+ register const U8 *a = (const U8 *)s1;
+ register const U8 *b = (const U8 *)s2;
+
+ PERL_ARGS_ASSERT_FOLDEQ_LATIN1;
+
+ while (len--) {
+ if (*a != *b && *a != PL_fold_latin1[*b]) {
+ return 0;
+ }
+ a++, b++;
+ }
+ return 1;
}
+/*
+=for apidoc foldEQ_locale
+
+Returns true if the leading len bytes of the strings s1 and s2 are the same
+case-insensitively in the current locale; false otherwise.
+
+=cut
+*/
+
I32
-Perl_ibcmp_locale(pTHX_ const char *s1, const char *s2, register I32 len)
+Perl_foldEQ_locale(const char *s1, const char *s2, register I32 len)
{
dVAR;
register const U8 *a = (const U8 *)s1;
register const U8 *b = (const U8 *)s2;
- PERL_UNUSED_CONTEXT;
- PERL_ARGS_ASSERT_IBCMP_LOCALE;
+ PERL_ARGS_ASSERT_FOLDEQ_LOCALE;
while (len--) {
if (*a != *b && *a != PL_fold_locale[*b])
- return 1;
+ return 0;
a++,b++;
}
- return 0;
+ return 1;
}
/* copy a string to a safe spot */
return (char *) CopyD(pv,newaddr,len,char);
}
+/*
+=for apidoc savesharedsvpv
+
+A version of C<savesharedpv()> which allocates the duplicate string in
+memory which is shared between threads.
+
+=cut
+*/
+
+char *
+Perl_savesharedsvpv(pTHX_ SV *sv)
+{
+ STRLEN len;
+ const char * const pv = SvPV_const(sv, len);
+
+ PERL_ARGS_ASSERT_SAVESHAREDSVPV;
+
+ return savesharedpvn(pv, len);
+}
/* the SV for Perl_form() and mess() is not kept in an arena */
SV *sv;
XPVMG *any;
- if (!PL_dirty)
+ if (PL_phase != PERL_PHASE_DESTRUCT)
return newSVpvs_flags("", SVs_TEMP);
if (PL_mess_sv)
return SvPVX(sv);
}
+/*
+=for apidoc Am|SV *|mess|const char *pat|...
+
+Take a sprintf-style format pattern and argument list. These are used to
+generate a string message. If the message does not end with a newline,
+then it will be extended with some indication of the current location
+in the code, as described for L</mess_sv>.
+
+Normally, the resulting message is returned in a new mortal SV.
+During global destruction a single SV may be shared between uses of
+this function.
+
+=cut
+*/
+
#if defined(PERL_IMPLICIT_CONTEXT)
SV *
Perl_mess_nocontext(const char *pat, ...)
return NULL;
}
+/*
+=for apidoc Am|SV *|mess_sv|SV *basemsg|bool consume
+
+Expands a message, intended for the user, to include an indication of
+the current location in the code, if the message does not already appear
+to be complete.
+
+C<basemsg> is the initial message or object. If it is a reference, it
+will be used as-is and will be the result of this function. Otherwise it
+is used as a string, and if it already ends with a newline, it is taken
+to be complete, and the result of this function will be the same string.
+If the message does not end with a newline, then a segment such as C<at
+foo.pl line 37> will be appended, and possibly other clauses indicating
+the current state of execution. The resulting message will end with a
+dot and a newline.
+
+Normally, the resulting message is returned in a new mortal SV.
+During global destruction a single SV may be shared between uses of this
+function. If C<consume> is true, then the function is permitted (but not
+required) to modify and return C<basemsg> instead of allocating a new SV.
+
+=cut
+*/
+
SV *
-Perl_vmess(pTHX_ const char *pat, va_list *args)
+Perl_mess_sv(pTHX_ SV *basemsg, bool consume)
{
dVAR;
- SV * const sv = mess_alloc();
+ SV *sv;
- PERL_ARGS_ASSERT_VMESS;
+ PERL_ARGS_ASSERT_MESS_SV;
+
+ if (SvROK(basemsg)) {
+ if (consume) {
+ sv = basemsg;
+ }
+ else {
+ sv = mess_alloc();
+ sv_setsv(sv, basemsg);
+ }
+ return sv;
+ }
+
+ if (SvPOK(basemsg) && consume) {
+ sv = basemsg;
+ }
+ else {
+ sv = mess_alloc();
+ sv_copypv(sv, basemsg);
+ }
- sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
/*
* Try and find the file and line for PL_op. This will usually be
line_mode ? "line" : "chunk",
(IV)IoLINES(GvIOp(PL_last_in_gv)));
}
- if (PL_dirty)
+ if (PL_phase == PERL_PHASE_DESTRUCT)
sv_catpvs(sv, " during global destruction");
sv_catpvs(sv, ".\n");
}
return sv;
}
+/*
+=for apidoc Am|SV *|vmess|const char *pat|va_list *args
+
+C<pat> and C<args> are a sprintf-style format pattern and encapsulated
+argument list. These are used to generate a string message. If the
+message does not end with a newline, then it will be extended with
+some indication of the current location in the code, as described for
+L</mess_sv>.
+
+Normally, the resulting message is returned in a new mortal SV.
+During global destruction a single SV may be shared between uses of
+this function.
+
+=cut
+*/
+
+SV *
+Perl_vmess(pTHX_ const char *pat, va_list *args)
+{
+ dVAR;
+ SV * const sv = mess_alloc();
+
+ PERL_ARGS_ASSERT_VMESS;
+
+ sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
+ return mess_sv(sv, 1);
+}
+
void
-Perl_write_to_stderr(pTHX_ const char* message, int msglen)
+Perl_write_to_stderr(pTHX_ SV* msv)
{
dVAR;
IO *io;
if (PL_stderrgv && SvREFCNT(PL_stderrgv)
&& (io = GvIO(PL_stderrgv))
&& (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
- {
- dSP;
- ENTER;
- SAVETMPS;
-
- save_re_context();
- SAVESPTR(PL_stderrgv);
- PL_stderrgv = NULL;
-
- PUSHSTACKi(PERLSI_MAGIC);
-
- PUSHMARK(SP);
- EXTEND(SP,2);
- PUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
- mPUSHp(message, msglen);
- PUTBACK;
- call_method("PRINT", G_SCALAR);
-
- POPSTACK;
- FREETMPS;
- LEAVE;
- }
+ Perl_magic_methcall(aTHX_ MUTABLE_SV(io), mg, "PRINT",
+ G_SCALAR | G_DISCARD | G_WRITING_TO_STDERR, 1, msv);
else {
#ifdef USE_SFIO
/* SFIO can really mess with your errno */
#endif
PerlIO * const serr = Perl_error_log;
- PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
+ do_print(msv, serr);
(void)PerlIO_flush(serr);
#ifdef USE_SFIO
RESTORE_ERRNO;
}
}
-/* Common code used by vcroak, vdie, vwarn and vwarner */
+/*
+=head1 Warning and Dieing
+*/
+
+/* Common code used in dieing and warning */
+
+STATIC SV *
+S_with_queued_errors(pTHX_ SV *ex)
+{
+ PERL_ARGS_ASSERT_WITH_QUEUED_ERRORS;
+ if (PL_errors && SvCUR(PL_errors) && !SvROK(ex)) {
+ sv_catsv(PL_errors, ex);
+ ex = sv_mortalcopy(PL_errors);
+ SvCUR_set(PL_errors, 0);
+ }
+ return ex;
+}
STATIC bool
-S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8, bool warn)
+S_invoke_exception_hook(pTHX_ SV *ex, bool warn)
{
dVAR;
HV *stash;
/* sv_2cv might call Perl_croak() or Perl_warner() */
SV * const oldhook = *hook;
- assert(oldhook);
+ if (!oldhook)
+ return FALSE;
ENTER;
SAVESPTR(*hook);
LEAVE;
if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
dSP;
- SV *msg;
+ SV *exarg;
ENTER;
save_re_context();
SAVESPTR(*hook);
*hook = NULL;
}
- if (warn || message) {
- msg = newSVpvn_flags(message, msglen, utf8);
- SvREADONLY_on(msg);
- SAVEFREESV(msg);
- }
- else {
- msg = ERRSV;
- }
+ exarg = newSVsv(ex);
+ SvREADONLY_on(exarg);
+ SAVEFREESV(exarg);
PUSHSTACKi(warn ? PERLSI_WARNHOOK : PERLSI_DIEHOOK);
PUSHMARK(SP);
- XPUSHs(msg);
+ XPUSHs(exarg);
PUTBACK;
call_sv(MUTABLE_SV(cv), G_DISCARD);
POPSTACK;
return FALSE;
}
-STATIC const char *
-S_vdie_croak_common(pTHX_ const char* pat, va_list* args, STRLEN* msglen,
- I32* utf8)
-{
- dVAR;
- const char *message;
+/*
+=for apidoc Am|OP *|die_sv|SV *baseex
- if (pat) {
- SV * const msv = vmess(pat, args);
- if (PL_errors && SvCUR(PL_errors)) {
- sv_catsv(PL_errors, msv);
- message = SvPV_const(PL_errors, *msglen);
- SvCUR_set(PL_errors, 0);
- }
- else
- message = SvPV_const(msv,*msglen);
- *utf8 = SvUTF8(msv);
- }
- else {
- message = NULL;
- }
+Behaves the same as L</croak_sv>, except for the return type.
+It should be used only where the C<OP *> return type is required.
+The function never actually returns.
- if (PL_diehook) {
- S_vdie_common(aTHX_ message, *msglen, *utf8, FALSE);
- }
- return message;
-}
+=cut
+*/
-static OP *
-S_vdie(pTHX_ const char* pat, va_list *args)
+OP *
+Perl_die_sv(pTHX_ SV *baseex)
{
- dVAR;
- const char *message;
- const int was_in_eval = PL_in_eval;
- STRLEN msglen;
- I32 utf8 = 0;
+ PERL_ARGS_ASSERT_DIE_SV;
+ croak_sv(baseex);
+ /* NOTREACHED */
+ return NULL;
+}
- message = vdie_croak_common(pat, args, &msglen, &utf8);
+/*
+=for apidoc Am|OP *|die|const char *pat|...
- PL_restartop = die_where(message, msglen);
- SvFLAGS(ERRSV) |= utf8;
- if ((!PL_restartop && was_in_eval) || PL_top_env->je_prev)
- JMPENV_JUMP(3);
- return PL_restartop;
-}
+Behaves the same as L</croak>, except for the return type.
+It should be used only where the C<OP *> return type is required.
+The function never actually returns.
+
+=cut
+*/
#if defined(PERL_IMPLICIT_CONTEXT)
OP *
Perl_die_nocontext(const char* pat, ...)
{
dTHX;
- OP *o;
va_list args;
- PERL_ARGS_ASSERT_DIE_NOCONTEXT;
va_start(args, pat);
- o = vdie(pat, &args);
+ vcroak(pat, &args);
+ /* NOTREACHED */
va_end(args);
- return o;
+ return NULL;
}
#endif /* PERL_IMPLICIT_CONTEXT */
OP *
Perl_die(pTHX_ const char* pat, ...)
{
- OP *o;
va_list args;
va_start(args, pat);
- o = vdie(pat, &args);
+ vcroak(pat, &args);
+ /* NOTREACHED */
va_end(args);
- return o;
+ return NULL;
}
+/*
+=for apidoc Am|void|croak_sv|SV *baseex
+
+This is an XS interface to Perl's C<die> function.
+
+C<baseex> is the error message or object. If it is a reference, it
+will be used as-is. Otherwise it is used as a string, and if it does
+not end with a newline then it will be extended with some indication of
+the current location in the code, as described for L</mess_sv>.
+
+The error message or object will be used as an exception, by default
+returning control to the nearest enclosing C<eval>, but subject to
+modification by a C<$SIG{__DIE__}> handler. In any case, the C<croak_sv>
+function never returns normally.
+
+To die with a simple string message, the L</croak> function may be
+more convenient.
+
+=cut
+*/
+
void
-Perl_vcroak(pTHX_ const char* pat, va_list *args)
+Perl_croak_sv(pTHX_ SV *baseex)
{
- dVAR;
- const char *message;
- STRLEN msglen;
- I32 utf8 = 0;
+ SV *ex = with_queued_errors(mess_sv(baseex, 0));
+ PERL_ARGS_ASSERT_CROAK_SV;
+ invoke_exception_hook(ex, FALSE);
+ die_unwind(ex);
+}
- message = S_vdie_croak_common(aTHX_ pat, args, &msglen, &utf8);
+/*
+=for apidoc Am|void|vcroak|const char *pat|va_list *args
- if (PL_in_eval) {
- PL_restartop = die_where(message, msglen);
- SvFLAGS(ERRSV) |= utf8;
- JMPENV_JUMP(3);
- }
- else if (!message)
- message = SvPVx_const(ERRSV, msglen);
+This is an XS interface to Perl's C<die> function.
+
+C<pat> and C<args> are a sprintf-style format pattern and encapsulated
+argument list. These are used to generate a string message. If the
+message does not end with a newline, then it will be extended with
+some indication of the current location in the code, as described for
+L</mess_sv>.
+
+The error message will be used as an exception, by default
+returning control to the nearest enclosing C<eval>, but subject to
+modification by a C<$SIG{__DIE__}> handler. In any case, the C<croak>
+function never returns normally.
- write_to_stderr(message, msglen);
- my_failure_exit();
+For historical reasons, if C<pat> is null then the contents of C<ERRSV>
+(C<$@>) will be used as an error message or object instead of building an
+error message from arguments. If you want to throw a non-string object,
+or build an error message in an SV yourself, it is preferable to use
+the L</croak_sv> function, which does not involve clobbering C<ERRSV>.
+
+=cut
+*/
+
+void
+Perl_vcroak(pTHX_ const char* pat, va_list *args)
+{
+ SV *ex = with_queued_errors(pat ? vmess(pat, args) : mess_sv(ERRSV, 0));
+ invoke_exception_hook(ex, FALSE);
+ die_unwind(ex);
}
+/*
+=for apidoc Am|void|croak|const char *pat|...
+
+This is an XS interface to Perl's C<die> function.
+
+Take a sprintf-style format pattern and argument list. These are used to
+generate a string message. If the message does not end with a newline,
+then it will be extended with some indication of the current location
+in the code, as described for L</mess_sv>.
+
+The error message will be used as an exception, by default
+returning control to the nearest enclosing C<eval>, but subject to
+modification by a C<$SIG{__DIE__}> handler. In any case, the C<croak>
+function never returns normally.
+
+For historical reasons, if C<pat> is null then the contents of C<ERRSV>
+(C<$@>) will be used as an error message or object instead of building an
+error message from arguments. If you want to throw a non-string object,
+or build an error message in an SV yourself, it is preferable to use
+the L</croak_sv> function, which does not involve clobbering C<ERRSV>.
+
+=cut
+*/
+
#if defined(PERL_IMPLICIT_CONTEXT)
void
Perl_croak_nocontext(const char *pat, ...)
}
#endif /* PERL_IMPLICIT_CONTEXT */
+void
+Perl_croak(pTHX_ const char *pat, ...)
+{
+ va_list args;
+ va_start(args, pat);
+ vcroak(pat, &args);
+ /* NOTREACHED */
+ va_end(args);
+}
+
/*
-=head1 Warning and Dieing
+=for apidoc Am|void|croak_no_modify
+
+Exactly equivalent to C<Perl_croak(aTHX_ "%s", PL_no_modify)>, but generates
+terser object code than using C<Perl_croak>. Less code used on exception code
+paths reduces CPU cache pressure.
+
+=cut
+*/
-=for apidoc croak
+void
+Perl_croak_no_modify(pTHX)
+{
+ Perl_croak(aTHX_ "%s", PL_no_modify);
+}
+
+/*
+=for apidoc Am|void|warn_sv|SV *baseex
-This is the XSUB-writer's interface to Perl's C<die> function.
-Normally call this function the same way you call the C C<printf>
-function. Calling C<croak> returns control directly to Perl,
-sidestepping the normal C order of execution. See C<warn>.
+This is an XS interface to Perl's C<warn> function.
-If you want to throw an exception object, assign the object to
-C<$@> and then pass C<NULL> to croak():
+C<baseex> is the error message or object. If it is a reference, it
+will be used as-is. Otherwise it is used as a string, and if it does
+not end with a newline then it will be extended with some indication of
+the current location in the code, as described for L</mess_sv>.
- errsv = get_sv("@", GV_ADD);
- sv_setsv(errsv, exception_object);
- croak(NULL);
+The error message or object will by default be written to standard error,
+but this is subject to modification by a C<$SIG{__WARN__}> handler.
+
+To warn with a simple string message, the L</warn> function may be
+more convenient.
=cut
*/
void
-Perl_croak(pTHX_ const char *pat, ...)
+Perl_warn_sv(pTHX_ SV *baseex)
{
- va_list args;
- va_start(args, pat);
- vcroak(pat, &args);
- /* NOTREACHED */
- va_end(args);
+ SV *ex = mess_sv(baseex, 0);
+ PERL_ARGS_ASSERT_WARN_SV;
+ if (!invoke_exception_hook(ex, TRUE))
+ write_to_stderr(ex);
}
+/*
+=for apidoc Am|void|vwarn|const char *pat|va_list *args
+
+This is an XS interface to Perl's C<warn> function.
+
+C<pat> and C<args> are a sprintf-style format pattern and encapsulated
+argument list. These are used to generate a string message. If the
+message does not end with a newline, then it will be extended with
+some indication of the current location in the code, as described for
+L</mess_sv>.
+
+The error message or object will by default be written to standard error,
+but this is subject to modification by a C<$SIG{__WARN__}> handler.
+
+Unlike with L</vcroak>, C<pat> is not permitted to be null.
+
+=cut
+*/
+
void
Perl_vwarn(pTHX_ const char* pat, va_list *args)
{
- dVAR;
- STRLEN msglen;
- SV * const msv = vmess(pat, args);
- const I32 utf8 = SvUTF8(msv);
- const char * const message = SvPV_const(msv, msglen);
-
+ SV *ex = vmess(pat, args);
PERL_ARGS_ASSERT_VWARN;
+ if (!invoke_exception_hook(ex, TRUE))
+ write_to_stderr(ex);
+}
- if (PL_warnhook) {
- if (vdie_common(message, msglen, utf8, TRUE))
- return;
- }
+/*
+=for apidoc Am|void|warn|const char *pat|...
- write_to_stderr(message, msglen);
-}
+This is an XS interface to Perl's C<warn> function.
+
+Take a sprintf-style format pattern and argument list. These are used to
+generate a string message. If the message does not end with a newline,
+then it will be extended with some indication of the current location
+in the code, as described for L</mess_sv>.
+
+The error message or object will by default be written to standard error,
+but this is subject to modification by a C<$SIG{__WARN__}> handler.
+
+Unlike with L</croak>, C<pat> is not permitted to be null.
+
+=cut
+*/
#if defined(PERL_IMPLICIT_CONTEXT)
void
}
#endif /* PERL_IMPLICIT_CONTEXT */
-/*
-=for apidoc warn
-
-This is the XSUB-writer's interface to Perl's C<warn> function. Call this
-function the same way you call the C C<printf> function. See C<croak>.
-
-=cut
-*/
-
void
Perl_warn(pTHX_ const char *pat, ...)
{
#endif /* PERL_IMPLICIT_CONTEXT */
void
+Perl_ck_warner_d(pTHX_ U32 err, const char* pat, ...)
+{
+ PERL_ARGS_ASSERT_CK_WARNER_D;
+
+ if (Perl_ckwarn_d(aTHX_ err)) {
+ va_list args;
+ va_start(args, pat);
+ vwarner(err, pat, &args);
+ va_end(args);
+ }
+}
+
+void
+Perl_ck_warner(pTHX_ U32 err, const char* pat, ...)
+{
+ PERL_ARGS_ASSERT_CK_WARNER;
+
+ if (Perl_ckwarn(aTHX_ err)) {
+ va_list args;
+ va_start(args, pat);
+ vwarner(err, pat, &args);
+ va_end(args);
+ }
+}
+
+void
Perl_warner(pTHX_ U32 err, const char* pat,...)
{
va_list args;
PERL_ARGS_ASSERT_VWARNER;
if (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) {
SV * const msv = vmess(pat, args);
- STRLEN msglen;
- const char * const message = SvPV_const(msv, msglen);
- const I32 utf8 = SvUTF8(msv);
- if (PL_diehook) {
- assert(message);
- S_vdie_common(aTHX_ message, msglen, utf8, FALSE);
- }
- if (PL_in_eval) {
- PL_restartop = die_where(message, msglen);
- SvFLAGS(ERRSV) |= utf8;
- JMPENV_JUMP(3);
- }
- write_to_stderr(message, msglen);
- my_failure_exit();
+ invoke_exception_hook(msv, FALSE);
+ die_unwind(msv);
}
else {
Perl_vwarn(aTHX_ pat, args);
Perl_ckwarn(pTHX_ U32 w)
{
dVAR;
- return
- (
- isLEXWARN_on
- && PL_curcop->cop_warnings != pWARN_NONE
- && (
- PL_curcop->cop_warnings == pWARN_ALL
- || isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w))
- || (unpackWARN2(w) &&
- isWARN_on(PL_curcop->cop_warnings, unpackWARN2(w)))
- || (unpackWARN3(w) &&
- isWARN_on(PL_curcop->cop_warnings, unpackWARN3(w)))
- || (unpackWARN4(w) &&
- isWARN_on(PL_curcop->cop_warnings, unpackWARN4(w)))
- )
- )
- ||
- (
- isLEXWARN_off && PL_dowarn & G_WARN_ON
- )
- ;
+ /* If lexical warnings have not been set, use $^W. */
+ if (isLEXWARN_off)
+ return PL_dowarn & G_WARN_ON;
+
+ return ckwarn_common(w);
}
/* implements the ckWARN?_d macro */
Perl_ckwarn_d(pTHX_ U32 w)
{
dVAR;
- return
- isLEXWARN_off
- || PL_curcop->cop_warnings == pWARN_ALL
- || (
- PL_curcop->cop_warnings != pWARN_NONE
- && (
- isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w))
- || (unpackWARN2(w) &&
- isWARN_on(PL_curcop->cop_warnings, unpackWARN2(w)))
- || (unpackWARN3(w) &&
- isWARN_on(PL_curcop->cop_warnings, unpackWARN3(w)))
- || (unpackWARN4(w) &&
- isWARN_on(PL_curcop->cop_warnings, unpackWARN4(w)))
- )
- )
- ;
+ /* If lexical warnings have not been set then default classes warn. */
+ if (isLEXWARN_off)
+ return TRUE;
+
+ return ckwarn_common(w);
+}
+
+static bool
+S_ckwarn_common(pTHX_ U32 w)
+{
+ if (PL_curcop->cop_warnings == pWARN_ALL)
+ return TRUE;
+
+ if (PL_curcop->cop_warnings == pWARN_NONE)
+ return FALSE;
+
+ /* Check the assumption that at least the first slot is non-zero. */
+ assert(unpackWARN1(w));
+
+ /* Check the assumption that it is valid to stop as soon as a zero slot is
+ seen. */
+ if (!unpackWARN2(w)) {
+ assert(!unpackWARN3(w));
+ assert(!unpackWARN4(w));
+ } else if (!unpackWARN3(w)) {
+ assert(!unpackWARN4(w));
+ }
+
+ /* Right, dealt with all the special cases, which are implemented as non-
+ pointers, so there is a pointer to a real warnings mask. */
+ do {
+ if (isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w)))
+ return TRUE;
+ } while (w >>= WARNshift);
+
+ return FALSE;
}
/* Set buffer=NULL to get a new one. */
}
return NULL;
}
- if (ckWARN(WARN_PIPE))
- Perl_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
+ Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
sleep(5);
}
if (pid == 0) {
else
PerlLIO_close(p[that]); /* close child's end of pipe */
- LOCK_FDPID_MUTEX;
sv = *av_fetch(PL_fdpid,p[This],TRUE);
- UNLOCK_FDPID_MUTEX;
SvUPGRADE(sv,SVt_IV);
SvIV_set(sv, pid);
PL_forkprocess = pid;
Perl_croak(aTHX_ "Can't fork: %s", Strerror(errno));
return NULL;
}
- if (ckWARN(WARN_PIPE))
- Perl_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
+ Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
sleep(5);
}
if (pid == 0) {
- GV* tmpgv;
#undef THIS
#undef THAT
default, binary, low-level mode; see PerlIOBuf_open(). */
PerlLIO_setmode((*mode == 'r'), O_BINARY);
#endif
-
- if ((tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV))) {
- SvREADONLY_off(GvSV(tmpgv));
- sv_setiv(GvSV(tmpgv), PerlProc_getpid());
- SvREADONLY_on(GvSV(tmpgv));
- }
#ifdef THREADS_HAVE_PIDS
PL_ppid = (IV)getppid();
#endif
else
PerlLIO_close(p[that]);
- LOCK_FDPID_MUTEX;
sv = *av_fetch(PL_fdpid,p[This],TRUE);
- UNLOCK_FDPID_MUTEX;
SvUPGRADE(sv,SVt_IV);
SvIV_set(sv, pid);
PL_forkprocess = pid;
int status;
SV **svp;
Pid_t pid;
- Pid_t pid2;
+ Pid_t pid2 = 0;
bool close_failed;
dSAVEDERRNO;
+ const int fd = PerlIO_fileno(ptr);
- LOCK_FDPID_MUTEX;
- svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE);
- UNLOCK_FDPID_MUTEX;
+#ifdef USE_PERLIO
+ /* Find out whether the refcount is low enough for us to wait for the
+ child proc without blocking. */
+ const bool should_wait = PerlIOUnix_refcnt(fd) == 1;
+#else
+ const bool should_wait = 1;
+#endif
+
+ svp = av_fetch(PL_fdpid,fd,TRUE);
pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
SvREFCNT_dec(*svp);
*svp = &PL_sv_undef;
rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &istat);
rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qstat);
#endif
- do {
+ if (should_wait) do {
pid2 = wait4pid(pid, &status, 0);
} while (pid2 == -1 && errno == EINTR);
#ifndef PERL_MICRO
RESTORE_ERRNO;
return -1;
}
- return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status));
+ return(
+ should_wait
+ ? pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status)
+ : 0
+ );
}
#else
#if defined(__LIBCATAMOUNT__)
}
#endif
+#define PERL_REPEATCPY_LINEAR 4
void
-Perl_repeatcpy(pTHX_ register char *to, register const char *from, I32 len, register I32 count)
+Perl_repeatcpy(register char *to, register const char *from, I32 len, register I32 count)
{
- register I32 todo;
- register const char * const frombase = from;
- PERL_UNUSED_CONTEXT;
-
PERL_ARGS_ASSERT_REPEATCPY;
- if (len == 1) {
- register const char c = *from;
- while (count-- > 0)
- *to++ = c;
- return;
- }
- while (count-- > 0) {
- for (todo = len; todo > 0; todo--) {
- *to++ = *from++;
+ if (len == 1)
+ memset(to, *from, count);
+ else if (count) {
+ register char *p = to;
+ I32 items, linear, half;
+
+ linear = count < PERL_REPEATCPY_LINEAR ? count : PERL_REPEATCPY_LINEAR;
+ for (items = 0; items < linear; ++items) {
+ register const char *q = from;
+ I32 todo;
+ for (todo = len; todo > 0; todo--)
+ *p++ = *q++;
+ }
+
+ half = count / 2;
+ while (items <= half) {
+ I32 size = items * len;
+ memcpy(p, to, size);
+ p += size;
+ items *= 2;
}
- from = frombase;
+
+ if (count > items)
+ memcpy(p, to, (count - items) * len);
}
}
if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
continue; /* don't search dir with too-long name */
if (len
-# if defined(atarist) || defined(__MINT__) || defined(DOSISH)
+# if defined(atarist) || defined(DOSISH)
&& tmpbuf[len - 1] != '/'
&& tmpbuf[len - 1] != '\\'
# endif
MGVTBL*
Perl_get_vtbl(pTHX_ int vtbl_id)
{
- const MGVTBL* result;
PERL_UNUSED_CONTEXT;
- switch(vtbl_id) {
- case want_vtbl_sv:
- result = &PL_vtbl_sv;
- break;
- case want_vtbl_env:
- result = &PL_vtbl_env;
- break;
- case want_vtbl_envelem:
- result = &PL_vtbl_envelem;
- break;
- case want_vtbl_sig:
- result = &PL_vtbl_sig;
- break;
- case want_vtbl_sigelem:
- result = &PL_vtbl_sigelem;
- break;
- case want_vtbl_pack:
- result = &PL_vtbl_pack;
- break;
- case want_vtbl_packelem:
- result = &PL_vtbl_packelem;
- break;
- case want_vtbl_dbline:
- result = &PL_vtbl_dbline;
- break;
- case want_vtbl_isa:
- result = &PL_vtbl_isa;
- break;
- case want_vtbl_isaelem:
- result = &PL_vtbl_isaelem;
- break;
- case want_vtbl_arylen:
- result = &PL_vtbl_arylen;
- break;
- case want_vtbl_mglob:
- result = &PL_vtbl_mglob;
- break;
- case want_vtbl_nkeys:
- result = &PL_vtbl_nkeys;
- break;
- case want_vtbl_taint:
- result = &PL_vtbl_taint;
- break;
- case want_vtbl_substr:
- result = &PL_vtbl_substr;
- break;
- case want_vtbl_vec:
- result = &PL_vtbl_vec;
- break;
- case want_vtbl_pos:
- result = &PL_vtbl_pos;
- break;
- case want_vtbl_bm:
- result = &PL_vtbl_bm;
- break;
- case want_vtbl_fm:
- result = &PL_vtbl_fm;
- break;
- case want_vtbl_uvar:
- result = &PL_vtbl_uvar;
- break;
- case want_vtbl_defelem:
- result = &PL_vtbl_defelem;
- break;
- case want_vtbl_regexp:
- result = &PL_vtbl_regexp;
- break;
- case want_vtbl_regdata:
- result = &PL_vtbl_regdata;
- break;
- case want_vtbl_regdatum:
- result = &PL_vtbl_regdatum;
- break;
-#ifdef USE_LOCALE_COLLATE
- case want_vtbl_collxfrm:
- result = &PL_vtbl_collxfrm;
- break;
-#endif
- case want_vtbl_amagic:
- result = &PL_vtbl_amagic;
- break;
- case want_vtbl_amagicelem:
- result = &PL_vtbl_amagicelem;
- break;
- case want_vtbl_backref:
- result = &PL_vtbl_backref;
- break;
- case want_vtbl_utf8:
- result = &PL_vtbl_utf8;
- break;
- default:
- result = NULL;
- break;
- }
- return (MGVTBL*)result;
+ return (vtbl_id < 0 || vtbl_id >= magic_vtable_max)
+ ? NULL : PL_magic_vtables + vtbl_id;
}
I32
}
void
-Perl_report_evil_fh(pTHX_ const GV *gv, const IO *io, I32 op)
-{
- const char * const name = gv && isGV(gv) ? GvENAME(gv) : NULL;
-
- if (op == OP_phoney_OUTPUT_ONLY || op == OP_phoney_INPUT_ONLY) {
- if (ckWARN(WARN_IO)) {
- const char * const direction =
- (const char *)((op == OP_phoney_INPUT_ONLY) ? "in" : "out");
- if (name && *name)
- Perl_warner(aTHX_ packWARN(WARN_IO),
- "Filehandle %s opened only for %sput",
- name, direction);
- else
- Perl_warner(aTHX_ packWARN(WARN_IO),
- "Filehandle opened only for %sput", direction);
- }
- }
- else {
- const char *vile;
- I32 warn_type;
-
- if (gv && io && IoTYPE(io) == IoTYPE_CLOSED) {
- vile = "closed";
- warn_type = WARN_CLOSED;
- }
- else {
- vile = "unopened";
- warn_type = WARN_UNOPENED;
- }
+Perl_report_wrongway_fh(pTHX_ const GV *gv, const char have)
+{
+ if (ckWARN(WARN_IO)) {
+ const char * const name
+ = gv && (isGV(gv) || isGV_with_GP(gv)) ? GvENAME(gv) : NULL;
+ const char * const direction = have == '>' ? "out" : "in";
- if (ckWARN(warn_type)) {
- const char * const pars =
- (const char *)(OP_IS_FILETEST(op) ? "" : "()");
- const char * const func =
- (const char *)
- (op == OP_READLINE ? "readline" : /* "<HANDLE>" not nice */
- op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */
- op < 0 ? "" : /* handle phoney cases */
- PL_op_desc[op]);
- const char * const type =
- (const char *)
- (OP_IS_SOCKET(op) ||
- (gv && io && IoTYPE(io) == IoTYPE_SOCKET) ?
- "socket" : "filehandle");
- if (name && *name) {
- Perl_warner(aTHX_ packWARN(warn_type),
- "%s%s on %s %s %s", func, pars, vile, type, name);
- if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
- Perl_warner(
- aTHX_ packWARN(warn_type),
- "\t(Are you trying to call %s%s on dirhandle %s?)\n",
- func, pars, name
- );
- }
- else {
- Perl_warner(aTHX_ packWARN(warn_type),
- "%s%s on %s %s", func, pars, vile, type);
- if (gv && io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
- Perl_warner(
- aTHX_ packWARN(warn_type),
- "\t(Are you trying to call %s%s on dirhandle?)\n",
- func, pars
- );
- }
- }
+ if (name && *name)
+ Perl_warner(aTHX_ packWARN(WARN_IO),
+ "Filehandle %s opened only for %sput",
+ name, direction);
+ else
+ Perl_warner(aTHX_ packWARN(WARN_IO),
+ "Filehandle opened only for %sput", direction);
}
}
-#ifdef EBCDIC
-/* in ASCII order, not that it matters */
-static const char controllablechars[] = "?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_";
-
-int
-Perl_ebcdic_control(pTHX_ int ch)
+void
+Perl_report_evil_fh(pTHX_ const GV *gv)
{
- if (ch > 'a') {
- const char *ctlp;
-
- if (islower(ch))
- ch = toupper(ch);
+ const IO *io = gv ? GvIO(gv) : NULL;
+ const PERL_BITFIELD16 op = PL_op->op_type;
+ const char *vile;
+ I32 warn_type;
- if ((ctlp = strchr(controllablechars, ch)) == 0) {
- Perl_die(aTHX_ "unrecognised control character '%c'\n", ch);
+ if (io && IoTYPE(io) == IoTYPE_CLOSED) {
+ vile = "closed";
+ warn_type = WARN_CLOSED;
+ }
+ else {
+ vile = "unopened";
+ warn_type = WARN_UNOPENED;
+ }
+
+ if (ckWARN(warn_type)) {
+ const char * const name
+ = gv && (isGV(gv) || isGV_with_GP(gv)) ? GvENAME(gv) : NULL;
+ const char * const pars =
+ (const char *)(OP_IS_FILETEST(op) ? "" : "()");
+ const char * const func =
+ (const char *)
+ (op == OP_READLINE ? "readline" : /* "<HANDLE>" not nice */
+ op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */
+ PL_op_desc[op]);
+ const char * const type =
+ (const char *)
+ (OP_IS_SOCKET(op) || (io && IoTYPE(io) == IoTYPE_SOCKET)
+ ? "socket" : "filehandle");
+ if (name && *name) {
+ Perl_warner(aTHX_ packWARN(warn_type),
+ "%s%s on %s %s %s", func, pars, vile, type, name);
+ if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
+ Perl_warner(
+ aTHX_ packWARN(warn_type),
+ "\t(Are you trying to call %s%s on dirhandle %s?)\n",
+ func, pars, name
+ );
+ }
+ else {
+ Perl_warner(aTHX_ packWARN(warn_type),
+ "%s%s on %s %s", func, pars, vile, type);
+ if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
+ Perl_warner(
+ aTHX_ packWARN(warn_type),
+ "\t(Are you trying to call %s%s on dirhandle?)\n",
+ func, pars
+ );
}
-
- if (ctlp == controllablechars)
- return('\177'); /* DEL */
- else
- return((unsigned char)(ctlp - controllablechars - 1));
- } else { /* Want uncontrol */
- if (ch == '\177' || ch == -1)
- return('?');
- else if (ch == '\157')
- return('\177');
- else if (ch == '\174')
- return('\000');
- else if (ch == '^') /* '\137' in 1047, '\260' in 819 */
- return('\036');
- else if (ch == '\155')
- return('\037');
- else if (0 < ch && ch < (sizeof(controllablechars) - 1))
- return(controllablechars[ch+1]);
- else
- Perl_die(aTHX_ "invalid control request: '\\%03o'\n", ch & 0xFF);
}
}
-#endif
/* To workaround core dumps from the uninitialised tm_zone we get the
* system to give us a reasonable struct to copy. This fix means that
* outside the scope for this routine. Since we convert back based on the
* same rules we used to build the yearday, you'll only get strange results
* for input which needed normalising, or for the 'odd' century years which
- * were leap years in the Julian calander but not in the Gregorian one.
+ * were leap years in the Julian calendar but not in the Gregorian one.
* I can live with that.
*
* This algorithm also fails to handle years before A.D. 1 gracefully, but
const int fmtlen = strlen(fmt);
int bufsize = fmtlen + buflen;
- Newx(buf, bufsize, char);
+ Renew(buf, bufsize, char);
while (buf) {
buflen = strftime(buf, bufsize, fmt, &mytm);
if (buflen > 0 && buflen < bufsize)
}
#define VERSION_MAX 0x7FFFFFFF
+
+/*
+=for apidoc prescan_version
+
+Validate that a given string can be parsed as a version object, but doesn't
+actually perform the parsing. Can use either strict or lax validation rules.
+Can optionally set a number of hint variables to save the parsing code
+some time when tokenizing.
+
+=cut
+*/
+const char *
+Perl_prescan_version(pTHX_ const char *s, bool strict,
+ const char **errstr,
+ bool *sqv, int *ssaw_decimal, int *swidth, bool *salpha) {
+ bool qv = (sqv ? *sqv : FALSE);
+ int width = 3;
+ int saw_decimal = 0;
+ bool alpha = FALSE;
+ const char *d = s;
+
+ PERL_ARGS_ASSERT_PRESCAN_VERSION;
+
+ if (qv && isDIGIT(*d))
+ goto dotted_decimal_version;
+
+ if (*d == 'v') { /* explicit v-string */
+ d++;
+ if (isDIGIT(*d)) {
+ qv = TRUE;
+ }
+ else { /* degenerate v-string */
+ /* requires v1.2.3 */
+ BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
+ }
+
+dotted_decimal_version:
+ if (strict && d[0] == '0' && isDIGIT(d[1])) {
+ /* no leading zeros allowed */
+ BADVERSION(s,errstr,"Invalid version format (no leading zeros)");
+ }
+
+ while (isDIGIT(*d)) /* integer part */
+ d++;
+
+ if (*d == '.')
+ {
+ saw_decimal++;
+ d++; /* decimal point */
+ }
+ else
+ {
+ if (strict) {
+ /* require v1.2.3 */
+ BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
+ }
+ else {
+ goto version_prescan_finish;
+ }
+ }
+
+ {
+ int i = 0;
+ int j = 0;
+ while (isDIGIT(*d)) { /* just keep reading */
+ i++;
+ while (isDIGIT(*d)) {
+ d++; j++;
+ /* maximum 3 digits between decimal */
+ if (strict && j > 3) {
+ BADVERSION(s,errstr,"Invalid version format (maximum 3 digits between decimals)");
+ }
+ }
+ if (*d == '_') {
+ if (strict) {
+ BADVERSION(s,errstr,"Invalid version format (no underscores)");
+ }
+ if ( alpha ) {
+ BADVERSION(s,errstr,"Invalid version format (multiple underscores)");
+ }
+ d++;
+ alpha = TRUE;
+ }
+ else if (*d == '.') {
+ if (alpha) {
+ BADVERSION(s,errstr,"Invalid version format (underscores before decimal)");
+ }
+ saw_decimal++;
+ d++;
+ }
+ else if (!isDIGIT(*d)) {
+ break;
+ }
+ j = 0;
+ }
+
+ if (strict && i < 2) {
+ /* requires v1.2.3 */
+ BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
+ }
+ }
+ } /* end if dotted-decimal */
+ else
+ { /* decimal versions */
+ /* special strict case for leading '.' or '0' */
+ if (strict) {
+ if (*d == '.') {
+ BADVERSION(s,errstr,"Invalid version format (0 before decimal required)");
+ }
+ if (*d == '0' && isDIGIT(d[1])) {
+ BADVERSION(s,errstr,"Invalid version format (no leading zeros)");
+ }
+ }
+
+ /* and we never support negative versions */
+ if ( *d == '-') {
+ BADVERSION(s,errstr,"Invalid version format (negative version number)");
+ }
+
+ /* consume all of the integer part */
+ while (isDIGIT(*d))
+ d++;
+
+ /* look for a fractional part */
+ if (*d == '.') {
+ /* we found it, so consume it */
+ saw_decimal++;
+ d++;
+ }
+ else if (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') {
+ if ( d == s ) {
+ /* found nothing */
+ BADVERSION(s,errstr,"Invalid version format (version required)");
+ }
+ /* found just an integer */
+ goto version_prescan_finish;
+ }
+ else if ( d == s ) {
+ /* didn't find either integer or period */
+ BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
+ }
+ else if (*d == '_') {
+ /* underscore can't come after integer part */
+ if (strict) {
+ BADVERSION(s,errstr,"Invalid version format (no underscores)");
+ }
+ else if (isDIGIT(d[1])) {
+ BADVERSION(s,errstr,"Invalid version format (alpha without decimal)");
+ }
+ else {
+ BADVERSION(s,errstr,"Invalid version format (misplaced underscore)");
+ }
+ }
+ else {
+ /* anything else after integer part is just invalid data */
+ BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
+ }
+
+ /* scan the fractional part after the decimal point*/
+
+ if (!isDIGIT(*d) && (strict || ! (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') )) {
+ /* strict or lax-but-not-the-end */
+ BADVERSION(s,errstr,"Invalid version format (fractional part required)");
+ }
+
+ while (isDIGIT(*d)) {
+ d++;
+ if (*d == '.' && isDIGIT(d[-1])) {
+ if (alpha) {
+ BADVERSION(s,errstr,"Invalid version format (underscores before decimal)");
+ }
+ if (strict) {
+ BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions must begin with 'v')");
+ }
+ d = (char *)s; /* start all over again */
+ qv = TRUE;
+ goto dotted_decimal_version;
+ }
+ if (*d == '_') {
+ if (strict) {
+ BADVERSION(s,errstr,"Invalid version format (no underscores)");
+ }
+ if ( alpha ) {
+ BADVERSION(s,errstr,"Invalid version format (multiple underscores)");
+ }
+ if ( ! isDIGIT(d[1]) ) {
+ BADVERSION(s,errstr,"Invalid version format (misplaced underscore)");
+ }
+ d++;
+ alpha = TRUE;
+ }
+ }
+ }
+
+version_prescan_finish:
+ while (isSPACE(*d))
+ d++;
+
+ if (!isDIGIT(*d) && (! (!*d || *d == ';' || *d == '{' || *d == '}') )) {
+ /* trailing non-numeric data */
+ BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
+ }
+
+ if (sqv)
+ *sqv = qv;
+ if (swidth)
+ *swidth = width;
+ if (ssaw_decimal)
+ *ssaw_decimal = saw_decimal;
+ if (salpha)
+ *salpha = alpha;
+ return d;
+}
+
/*
=for apidoc scan_version
const char *start;
const char *pos;
const char *last;
- int saw_period = 0;
- int alpha = 0;
+ const char *errstr = NULL;
+ int saw_decimal = 0;
int width = 3;
+ bool alpha = FALSE;
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
+
while (isSPACE(*s)) /* leading whitespace is OK */
s++;
- start = last = s;
-
- if (*s == 'v') {
- s++; /* get past 'v' */
- qv = 1; /* force quoted version processing */
- }
-
- pos = s;
-
- /* pre-scan the input string to check for decimals/underbars */
- while ( *pos == '.' || *pos == '_' || isDIGIT(*pos) )
- {
- if ( *pos == '.' )
- {
- if ( alpha )
- Perl_croak(aTHX_ "Invalid version format (underscores before decimal)");
- saw_period++ ;
- last = pos;
+ last = prescan_version(s, FALSE, &errstr, &qv, &saw_decimal, &width, &alpha);
+ if (errstr) {
+ /* "undef" is a special case and not an error */
+ if ( ! ( *s == 'u' && strEQ(s,"undef")) ) {
+ Perl_croak(aTHX_ "%s", errstr);
}
- else if ( *pos == '_' )
- {
- if ( alpha )
- Perl_croak(aTHX_ "Invalid version format (multiple underscores)");
- alpha = 1;
- width = pos - last - 1; /* natural width of sub-version */
- }
- 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;
+ start = s;
+ if (*s == 'v')
+ s++;
pos = s;
if ( qv )
* point of a version originally created with a bare
* floating point number, i.e. not quoted in any way
*/
- if ( !qv && s > start && saw_period == 1 ) {
+ if ( !qv && s > start && saw_decimal == 1 ) {
mult *= 100;
while ( s < end ) {
orev = rev;
mult /= 10;
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);
+ Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
+ "Integer overflow in version %d",VERSION_MAX);
s = end - 1;
rev = VERSION_MAX;
vinf = 1;
mult *= 10;
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");
+ Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
+ "Integer overflow in version");
end = s - 1;
rev = VERSION_MAX;
vinf = 1;
s = ++pos;
else if ( *pos == '_' && isDIGIT(pos[1]) )
s = ++pos;
+ else if ( *pos == ',' && isDIGIT(pos[1]) )
+ s = ++pos;
else if ( isDIGIT(*pos) )
s = pos;
else {
}
else if ( s > start ) {
SV * orig = newSVpvn(start,s-start);
- if ( qv && saw_period == 1 && *start != 'v' ) {
+ if ( qv && saw_decimal == 1 && *start != 'v' ) {
/* need to insert a v to be consistent */
sv_insert(orig, 0, 0, "v", 1);
}
/* 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);
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' )
+ if ( isDIGIT(*version) )
sv_insert(rv, 0, 0, "v", 1);
Safefree(version);
}
#ifdef SvVOK
else if ( (mg = SvVSTRING_mg(ver)) ) { /* already a v-string */
version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
- qv = 1;
+ qv = TRUE;
}
#endif
else /* must be a string or something like a string */
#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,"_") ) {
+ 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++;
- }
+ char *testv = (char *)version;
+ STRLEN tlen = len;
+ for (tlen=0; tlen < len; tlen++, testv++) {
+ /* if one of the characters is non-text assume v-string */
+ if (testv[0] < ' ') {
+ SV * const nsv = sv_newmortal();
+ const char *nver;
+ const char *pos;
+ int saw_decimal = 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_decimal++ ;
+ pos++;
+ }
- /* is definitely a v-string */
- if ( saw_period == 2 ) {
- Safefree(version);
- version = nver;
+ /* is definitely a v-string */
+ if ( saw_decimal >= 2 ) {
+ Safefree(version);
+ version = nver;
+ }
+ break;
+ }
}
}
# endif
s = scan_version(version, ver, qv);
if ( *s != '\0' )
- if(ckWARN(WARN_MISC))
- Perl_warner(aTHX_ packWARN(WARN_MISC),
- "Version string '%s' contains invalid data; "
- "ignoring: '%s'", version, s);
+ Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
+ "Version string '%s' contains invalid data; "
+ "ignoring: '%s'", version, s);
Safefree(version);
return ver;
}
/*
=for apidoc vverify
-Validates that the SV contains a valid version object.
+Validates that the SV contains valid internal structure for a version object.
+It may be passed either the version object (RV) or the hash itself (HV). If
+the structure is valid, it returns the HV. If the structure is invalid,
+it returns NULL.
- bool vverify(SV *vobj);
+ SV *hv = vverify(sv);
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 SV is an HV or a reference to an HV
=item * The hash contains a "version" key
-=item * The "version" key has [a reference to] an AV as its value
+=item * The "version" key has a reference to an AV as its value
=back
=cut
*/
-bool
+SV *
Perl_vverify(pTHX_ SV *vs)
{
SV *sv;
&& hv_exists(MUTABLE_HV(vs), "version", 7)
&& (sv = SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)))
&& SvTYPE(sv) == SVt_PVAV )
- return TRUE;
+ return vs;
else
- return FALSE;
+ return NULL;
}
/*
NOTE: you can pass either the object directly or the SV
contained within the RV.
+The SV returned has a refcount of 1.
+
=cut
*/
I32 i, len, digit;
int width;
bool alpha = FALSE;
- SV * const sv = newSV(0);
+ SV *sv;
AV *av;
PERL_ARGS_ASSERT_VNUMIFY;
- if ( SvROK(vs) )
- vs = SvRV(vs);
-
- if ( !vverify(vs) )
+ /* extract the HV from the object */
+ vs = vverify(vs);
+ if ( ! vs )
Perl_croak(aTHX_ "Invalid version object");
/* see if various flags exist */
/* attempt to retrieve the version array */
if ( !(av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE))) ) ) {
- sv_catpvs(sv,"0");
- return sv;
+ return newSVpvs("0");
}
len = av_len(av);
if ( len == -1 )
{
- sv_catpvs(sv,"0");
- return sv;
+ return newSVpvs("0");
}
digit = SvIV(*av_fetch(av, 0, 0));
- Perl_sv_setpvf(aTHX_ sv, "%d.", (int)PERL_ABS(digit));
+ sv = Perl_newSVpvf(aTHX_ "%d.", (int)PERL_ABS(digit));
for ( i = 1 ; i < len ; i++ )
{
digit = SvIV(*av_fetch(av, i, 0));
NOTE: you can pass either the object directly or the SV
contained within the RV.
+The SV returned has a refcount of 1.
+
=cut
*/
{
I32 i, len, digit;
bool alpha = FALSE;
- SV * const sv = newSV(0);
+ SV *sv;
AV *av;
PERL_ARGS_ASSERT_VNORMAL;
- if ( SvROK(vs) )
- vs = SvRV(vs);
-
- if ( !vverify(vs) )
+ /* extract the HV from the object */
+ vs = vverify(vs);
+ if ( ! vs )
Perl_croak(aTHX_ "Invalid version object");
if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
len = av_len(av);
if ( len == -1 )
{
- sv_catpvs(sv,"");
- return sv;
+ return newSVpvs("");
}
digit = SvIV(*av_fetch(av, 0, 0));
- Perl_sv_setpvf(aTHX_ sv, "v%"IVdf, (IV)digit);
+ sv = Perl_newSVpvf(aTHX_ "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);
In order to maintain maximum compatibility with earlier versions
of Perl, this function will return either the floating point
notation or the multiple dotted notation, depending on whether
-the original version contained 1 or more dots, respectively
+the original version contained 1 or more dots, respectively.
+
+The SV returned has a refcount of 1.
=cut
*/
{
PERL_ARGS_ASSERT_VSTRINGIFY;
- if ( SvROK(vs) )
- vs = SvRV(vs);
-
- if ( !vverify(vs) )
+ /* extract the HV from the object */
+ vs = vverify(vs);
+ if ( ! vs )
Perl_croak(aTHX_ "Invalid version object");
if (hv_exists(MUTABLE_HV(vs), "original", sizeof("original") - 1)) {
PERL_ARGS_ASSERT_VCMP;
- if ( SvROK(lhv) )
- lhv = SvRV(lhv);
- if ( SvROK(rhv) )
- rhv = SvRV(rhv);
-
- if ( !vverify(lhv) )
- Perl_croak(aTHX_ "Invalid version object");
-
- if ( !vverify(rhv) )
+ /* extract the HVs from the objects */
+ lhv = vverify(lhv);
+ rhv = vverify(rhv);
+ if ( ! ( lhv && rhv ) )
Perl_croak(aTHX_ "Invalid version object");
/* get the left hand term */
}
#else
/* In any case have a stub so that there's code corresponding
- * to the my_socketpair in global.sym. */
+ * to the my_socketpair in embed.fnc. */
int
Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
#ifdef HAS_SOCKETPAIR
opt = (U32) atoi(p);
while (isDIGIT(*p))
p++;
- if (*p && *p != '\n' && *p != '\r')
+ if (*p && *p != '\n' && *p != '\r') {
+ if(isSPACE(*p)) goto the_end_of_the_opts_parser;
+ else
Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
+ }
}
else {
for (; *p; p++) {
case PERL_UNICODE_UTF8CACHEASSERT:
opt |= PERL_UNICODE_UTF8CACHEASSERT_FLAG; break;
default:
- if (*p != '\n' && *p != '\r')
+ if (*p != '\n' && *p != '\r') {
+ if(isSPACE(*p)) goto the_end_of_the_opts_parser;
+ else
Perl_croak(aTHX_
"Unknown Unicode option letter '%c'", *p);
+ }
}
}
}
else
opt = PERL_UNICODE_DEFAULT_FLAGS;
+ the_end_of_the_opts_parser:
+
if (opt & ~PERL_UNICODE_ALL_FLAGS)
Perl_croak(aTHX_ "Unknown Unicode option value %"UVuf,
(UV) (opt & ~PERL_UNICODE_ALL_FLAGS));
* help. Sum in another random number that will
* fill in the low bits. */
myseed +=
- (UV)(Drand01() * (NV)((1 << ((UVSIZE * 8 - RANDBITS))) - 1));
+ (UV)(Drand01() * (NV)((((UV)1) << ((UVSIZE * 8 - RANDBITS))) - 1));
#endif /* RANDBITS < (UVSIZE * 8) */
if (myseed == 0) { /* Superparanoia. */
myseed = (UV)(Drand01() * (NV)UV_MAX); /* One more chance. */
# undef PERLVARA
# undef PERLVARI
# undef PERLVARIC
-# undef PERLVARISC
-# define PERLVAR(var,type) /**/
-# define PERLVARA(var,n,type) /**/
-# define PERLVARI(var,type,init) plvarsp->var = init;
-# define PERLVARIC(var,type,init) plvarsp->var = init;
-# define PERLVARISC(var,init) Copy(init, plvarsp->var, sizeof(init), char);
+# define PERLVAR(prefix,var,type) /**/
+# define PERLVARA(prefix,var,n,type) /**/
+# define PERLVARI(prefix,var,type,init) plvarsp->prefix##var = init;
+# define PERLVARIC(prefix,var,type,init) plvarsp->prefix##var = init;
# include "perlvars.h"
# undef PERLVAR
# undef PERLVARA
# undef PERLVARI
# undef PERLVARIC
-# undef PERLVARISC
# ifdef PERL_GLOBAL_STRUCT
plvarsp->Gppaddr =
(Perl_ppaddr_t*)
#ifdef PERL_MEM_LOG
-/*
- * PERL_MEM_LOG: the Perl_mem_log_..() will be compiled.
+/* -DPERL_MEM_LOG: the Perl_mem_log_..() is compiled, including the
+ * the default implementation, unless -DPERL_MEM_LOG_NOIMPL is also
+ * given, and you supply your own implementation.
*
- * PERL_MEM_LOG_ENV: if defined, during run time the environment
- * 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.)
+ * The default implementation reads a single env var, PERL_MEM_LOG,
+ * expecting one or more of the following:
*
- * 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.
+ * \d+ - fd fd to write to : must be 1st (atoi)
+ * 'm' - memlog was PERL_MEM_LOG=1
+ * 's' - svlog was PERL_SV_LOG=1
+ * 't' - timestamp was PERL_MEM_LOG_TIMESTAMP=1
+ *
+ * This makes the logger controllable enough that it can reasonably be
+ * added to the system perl.
*/
-/*
- * PERL_MEM_LOG_SPRINTF_BUF_SIZE: size of a (stack-allocated) buffer
+/* -DPERL_MEM_LOG_SPRINTF_BUF_SIZE=X: size of a (stack-allocated) buffer
* the Perl_mem_log_...() will use (either via sprintf or snprintf).
*/
#define PERL_MEM_LOG_SPRINTF_BUF_SIZE 128
-/*
- * PERL_MEM_LOG_FD: the file descriptor the Perl_mem_log_...() will
- * log to. You can also define in compile time PERL_MEM_LOG_ENV_FD,
- * in which case the environment variable PERL_MEM_LOG_FD will be
- * consulted for the file descriptor number to use.
+/* -DPERL_MEM_LOG_FD=N: the file descriptor the Perl_mem_log_...()
+ * writes to. In the default logger, this is settable at runtime.
*/
#ifndef PERL_MEM_LOG_FD
# define PERL_MEM_LOG_FD 2 /* If STDERR is too boring for you. */
#endif
-#ifdef PERL_MEM_LOG_STDERR
+#ifndef PERL_MEM_LOG_NOIMPL
# ifdef DEBUG_LEAKING_SCALARS
# define SV_LOG_SERIAL_FMT " [%lu]"
# 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)
+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)
- const char *s;
-# endif
+ const char *pmlenv;
PERL_ARGS_ASSERT_MEM_LOG_COMMON;
-# ifdef PERL_MEM_LOG_ENV
- s = PerlEnv_getenv(mlt < MLT_NEW_SV ? "PERL_MEM_LOG" : "PERL_SV_LOG");
- if (s ? atoi(s) : 0)
-# endif
+ pmlenv = PerlEnv_getenv("PERL_MEM_LOG");
+ if (!pmlenv)
+ return;
+ if (mlt < MLT_NEW_SV ? strchr(pmlenv,'m') : strchr(pmlenv,'s'))
{
/* 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
+
# ifdef HAS_GETTIMEOFDAY
# define MEM_LOG_TIME_FMT "%10d.%06d: "
# define MEM_LOG_TIME_ARG (int)tv.tv_sec, (int)tv.tv_usec
* gettimeofday() (see ext/Time-HiRes), the easiest way is
* probably that they would be used to fill in the struct
* timeval. */
-# endif
{
- int fd = PERL_MEM_LOG_FD;
STRLEN len;
+ int fd = atoi(pmlenv);
+ if (!fd)
+ fd = PERL_MEM_LOG_FD;
-# ifdef PERL_MEM_LOG_ENV_FD
- if ((s = PerlEnv_getenv("PERL_MEM_LOG_FD"))) {
- fd = atoi(s);
- }
-# endif
-# ifdef PERL_MEM_LOG_TIMESTAMP
- s = PerlEnv_getenv("PERL_MEM_LOG_TIMESTAMP");
- if (!s || atoi(s)) {
+ if (strchr(pmlenv, 't')) {
len = my_snprintf(buf, sizeof(buf),
MEM_LOG_TIME_FMT, MEM_LOG_TIME_ARG);
PerlLIO_write(fd, buf, len);
}
-# endif
switch (mlt) {
case MLT_ALLOC:
len = my_snprintf(buf, sizeof(buf),
filename, linenumber, funcname,
PTR2UV(sv) _SV_LOG_SERIAL_ARG(sv));
break;
+ default:
+ len = 0;
}
PerlLIO_write(fd, buf, len);
}
}
}
+#endif /* !PERL_MEM_LOG_NOIMPL */
+
+#ifndef PERL_MEM_LOG_NOIMPL
+# define \
+ mem_log_common_if(alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm) \
+ mem_log_common (alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm)
+#else
+/* this is suboptimal, but bug compatible. User is providing their
+ own implementation, but is getting these functions anyway, and they
+ do nothing. But _NOIMPL users should be able to cope or fix */
+# define \
+ mem_log_common_if(alty, num, tysz, tynm, u, oal, nal, flnm, ln, fnnm) \
+ /* mem_log_common_if_PERL_MEM_LOG_NOIMPL */
#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
+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)
+{
+ mem_log_common_if(MLT_ALLOC, n, typesize, type_name,
+ NULL, NULL, newalloc,
+ filename, linenumber, funcname);
return newalloc;
}
Malloc_t
-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
- mem_log_common(MLT_REALLOC, n, typesize, type_name, NULL, oldalloc, newalloc, filename, linenumber, funcname);
-#endif
+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)
+{
+ mem_log_common_if(MLT_REALLOC, n, typesize, type_name,
+ NULL, oldalloc, newalloc,
+ filename, linenumber, funcname);
return newalloc;
}
Malloc_t
-Perl_mem_log_free(Malloc_t oldalloc, const char *filename, const int linenumber, const char *funcname)
+Perl_mem_log_free(Malloc_t oldalloc,
+ const char *filename, const int linenumber,
+ const char *funcname)
{
-#ifdef PERL_MEM_LOG_STDERR
- mem_log_common(MLT_FREE, 0, 0, "", NULL, oldalloc, NULL, filename, linenumber, funcname);
-#endif
+ mem_log_common_if(MLT_FREE, 0, 0, "", NULL, oldalloc, NULL,
+ filename, linenumber, funcname);
return oldalloc;
}
void
-Perl_mem_log_new_sv(const SV *sv, const char *filename, const int linenumber, const char *funcname)
+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
+ mem_log_common_if(MLT_NEW_SV, 0, 0, "", sv, NULL, NULL,
+ filename, linenumber, funcname);
}
void
-Perl_mem_log_del_sv(const SV *sv, const char *filename, const int linenumber, const char *funcname)
+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
+ mem_log_common_if(MLT_DEL_SV, 0, 0, "", sv, NULL, NULL,
+ filename, linenumber, funcname);
}
#endif /* PERL_MEM_LOG */
retval = vsprintf(buffer, format, ap);
#endif
va_end(ap);
- /* vsnprintf() shows failure with >= len, vsprintf() with < 0 */
- if (retval < 0 || (len > 0 && (Size_t)retval >= len))
+ /* vsprintf() shows failure with < 0 */
+ if (retval < 0
+#ifdef HAS_VSNPRINTF
+ /* vsnprintf() shows failure with >= len */
+ ||
+ (len > 0 && (Size_t)retval >= len)
+#endif
+ )
Perl_croak(aTHX_ "panic: my_snprintf buffer overflow");
return retval;
}
retval = vsprintf(buffer, format, ap);
# endif
#endif /* #ifdef NEED_VA_COPY */
- /* vsnprintf() shows failure with >= len, vsprintf() with < 0 */
- if (retval < 0 || (len > 0 && (Size_t)retval >= len))
+ /* vsprintf() shows failure with < 0 */
+ if (retval < 0
+#ifdef HAS_VSNPRINTF
+ /* vsnprintf() shows failure with >= len */
+ ||
+ (len > 0 && (Size_t)retval >= len)
+#endif
+ )
Perl_croak(aTHX_ "panic: my_vsnprintf buffer overflow");
return retval;
}
PERL_ARGS_ASSERT_MY_CXT_INIT;
if (*index == -1) {
/* this module hasn't been allocated an index yet */
+#if defined(USE_ITHREADS)
MUTEX_LOCK(&PL_my_ctx_mutex);
+#endif
*index = PL_my_cxt_index++;
+#if defined(USE_ITHREADS)
MUTEX_UNLOCK(&PL_my_ctx_mutex);
+#endif
}
/* make sure the array is big enough */
index = Perl_my_cxt_index(aTHX_ my_cxt_key);
if (index == -1) {
/* this module hasn't been allocated an index yet */
+#if defined(USE_ITHREADS)
MUTEX_LOCK(&PL_my_ctx_mutex);
+#endif
index = PL_my_cxt_index++;
+#if defined(USE_ITHREADS)
MUTEX_UNLOCK(&PL_my_ctx_mutex);
+#endif
}
/* make sure the array is big enough */
#endif /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
#endif /* PERL_IMPLICIT_CONTEXT */
+void
+Perl_xs_version_bootcheck(pTHX_ U32 items, U32 ax, const char *xs_p,
+ STRLEN xs_len)
+{
+ SV *sv;
+ const char *vn = NULL;
+ SV *const module = PL_stack_base[ax];
+
+ PERL_ARGS_ASSERT_XS_VERSION_BOOTCHECK;
+
+ if (items >= 2) /* version supplied as bootstrap arg */
+ sv = PL_stack_base[ax + 1];
+ else {
+ /* XXX GV_ADDWARN */
+ vn = "XS_VERSION";
+ sv = get_sv(Perl_form(aTHX_ "%"SVf"::%s", module, vn), 0);
+ if (!sv || !SvOK(sv)) {
+ vn = "VERSION";
+ sv = get_sv(Perl_form(aTHX_ "%"SVf"::%s", module, vn), 0);
+ }
+ }
+ if (sv) {
+ SV *xssv = Perl_newSVpvn_flags(aTHX_ xs_p, xs_len, SVs_TEMP);
+ SV *pmsv = sv_derived_from(sv, "version")
+ ? sv : sv_2mortal(new_version(sv));
+ xssv = upg_version(xssv, 0);
+ if ( vcmp(pmsv,xssv) ) {
+ SV *string = vstringify(xssv);
+ SV *xpt = Perl_newSVpvf(aTHX_ "%"SVf" object version %"SVf
+ " does not match ", module, string);
+
+ SvREFCNT_dec(string);
+ string = vstringify(pmsv);
+
+ if (vn) {
+ Perl_sv_catpvf(aTHX_ xpt, "$%"SVf"::%s %"SVf, module, vn,
+ string);
+ } else {
+ Perl_sv_catpvf(aTHX_ xpt, "bootstrap parameter %"SVf, string);
+ }
+ SvREFCNT_dec(string);
+
+ Perl_sv_2mortal(aTHX_ xpt);
+ Perl_croak_sv(aTHX_ xpt);
+ }
+ }
+}
+
+void
+Perl_xs_apiversion_bootcheck(pTHX_ SV *module, const char *api_p,
+ STRLEN api_len)
+{
+ SV *xpt = NULL;
+ SV *compver = Perl_newSVpvn_flags(aTHX_ api_p, api_len, SVs_TEMP);
+ SV *runver;
+
+ PERL_ARGS_ASSERT_XS_APIVERSION_BOOTCHECK;
+
+ /* This might croak */
+ compver = upg_version(compver, 0);
+ /* This should never croak */
+ runver = new_version(PL_apiversion);
+ if (vcmp(compver, runver)) {
+ SV *compver_string = vstringify(compver);
+ SV *runver_string = vstringify(runver);
+ xpt = Perl_newSVpvf(aTHX_ "Perl API version %"SVf
+ " of %"SVf" does not match %"SVf,
+ compver_string, module, runver_string);
+ Perl_sv_2mortal(aTHX_ xpt);
+
+ SvREFCNT_dec(compver_string);
+ SvREFCNT_dec(runver_string);
+ }
+ SvREFCNT_dec(runver);
+ if (xpt)
+ Perl_croak_sv(aTHX_ xpt);
+}
+
#ifndef HAS_STRLCAT
Size_t
Perl_my_strlcat(char *dst, const char *src, Size_t size)
{
dVAR;
SV * const dbsv = GvSVn(PL_DBsub);
+ const bool save_taint = PL_tainted;
+
/* We do not care about using sv to call CV;
* it's for informational purposes only.
*/
PERL_ARGS_ASSERT_GET_DB_SUB;
+ PL_tainted = FALSE;
save_item(dbsv);
if (!PERLDB_SUB_NN) {
- GV * const gv = CvGV(cv);
+ GV *gv = CvGV(cv);
if ( svp && ((CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
|| strEQ(GvNAME(gv), "END")
|| ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
!( (SvTYPE(*svp) == SVt_PVGV)
- && (GvCV((const GV *)*svp) == cv) )))) {
+ && (GvCV((const GV *)*svp) == cv)
+ && (gv = (GV *)*svp)
+ )
+ )
+ )) {
/* Use GV from the stack as a fallback. */
/* GV is potentially non-unique, or contain different CV. */
SV * const tmp = newRV(MUTABLE_SV(cv));
(void)SvIOK_on(dbsv);
SvIV_set(dbsv, PTR2IV(cv)); /* Do it the quickest way */
}
+ TAINT_IF(save_taint);
}
int
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;
- }
+ if (SvROK(sv))
+ sv = MUTABLE_SV(SvRV(sv));
+ if (SvTYPE(sv) == SVt_REGEXP)
+ return (REGEXP*) sv;
}
return NULL;