* '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.
int putenv(char *);
#endif
-#ifdef I_SYS_WAIT
-# include <sys/wait.h>
-#endif
-
#ifdef HAS_SELECT
# ifdef I_SYS_SELECT
# include <sys/select.h>
size += sTHX;
#endif
#ifdef DEBUGGING
- if ((long)size < 0)
+ if ((SSize_t)size < 0)
Perl_croak_nocontext("panic: malloc");
#endif
ptr = (Malloc_t)PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */
}
#endif
#ifdef DEBUGGING
- if ((long)size < 0)
+ if ((SSize_t)size < 0)
Perl_croak_nocontext("panic: realloc");
#endif
ptr = (Malloc_t)PerlMem_realloc(where,size);
}
#endif /* HAS_64K_LIMIT */
#ifdef DEBUGGING
- if ((long)size < 0 || (long)count < 0)
+ if ((SSize_t)size < 0 || (SSize_t)count < 0)
Perl_croak_nocontext("panic: calloc");
#endif
#ifdef PERL_TRACK_MEMPOOL
{
dVAR;
register const unsigned char *big;
- U32 pos;
+ U32 pos = 0; /* hush a gcc warning */
register I32 previous;
register I32 first;
register const unsigned char *little;
register const unsigned char *littleend;
bool found = FALSE;
const MAGIC * mg;
- U32 *screamfirst;
- U32 *screamnext;
- U32 const nope = ~0;
+ 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_PVMG);
assert(SvVALID(littlestr));
- screamfirst = (U32 *)mg->mg_ptr;
- screamnext = screamfirst + 256;
+ 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];
- if (pos == nope) {
+ 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 ((I32)pos < previous + start_shift) {
- pos = screamnext[pos];
- if (pos == nope)
- 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 {
+ while (1) {
if ((I32)pos >= stop_pos) break;
if (big[pos] == first) {
const unsigned char *s = little;
found = TRUE;
}
}
- pos = screamnext[pos];
- } while (pos != nope);
+ 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;
+ }
+ };
if (last && found)
return (char *)(big+(*old_posp));
check_tail:
{
const bool line_mode = (RsSIMPLE(PL_rs) &&
SvCUR(PL_rs) == 1 && *SvPVX_const(PL_rs) == '\n');
- Perl_sv_catpvf(aTHX_ sv, ", <%s> %s %"IVdf,
- PL_last_in_gv == PL_argvgv ? "" : GvNAME(PL_last_in_gv),
+ Perl_sv_catpvf(aTHX_ sv, ", <%"SVf"> %s %"IVdf,
+ SVfARG(PL_last_in_gv == PL_argvgv
+ ? &PL_sv_no
+ : sv_2mortal(newSVhek(GvNAME_HEK(PL_last_in_gv)))),
line_mode ? "line" : "chunk",
(IV)IoLINES(GvIOp(PL_last_in_gv)));
}
#define PERL_REPEATCPY_LINEAR 4
void
-Perl_repeatcpy(register char *to, register const char *from, I32 len, register I32 count)
+Perl_repeatcpy(register char *to, register const char *from, I32 len, register IV count)
{
PERL_ARGS_ASSERT_REPEATCPY;
memset(to, *from, count);
else if (count) {
register char *p = to;
- I32 items, linear, half;
+ IV 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;
+ IV todo;
for (todo = len; todo > 0; todo--)
*p++ = *q++;
}
half = count / 2;
while (items <= half) {
- I32 size = items * len;
+ IV size = items * len;
memcpy(p, to, size);
p += size;
items *= 2;
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;
+ SV * const name
+ = gv && (isGV(gv) || isGV_with_GP(gv))
+ ? sv_2mortal(newSVhek(GvENAME_HEK((gv))))
+ : NULL;
const char * const direction = have == '>' ? "out" : "in";
- if (name && *name)
+ if (name && SvPOK(name) && *SvPV_nolen(name))
Perl_warner(aTHX_ packWARN(WARN_IO),
- "Filehandle %s opened only for %sput",
+ "Filehandle %"SVf" opened only for %sput",
name, direction);
else
Perl_warner(aTHX_ packWARN(WARN_IO),
}
if (ckWARN(warn_type)) {
- const char * const name
- = gv && (isGV(gv) || isGV_with_GP(gv)) ? GvENAME(gv) : NULL;
+ SV * const name
+ = gv && (isGV(gv) || isGV_with_GP(gv)) && GvENAMELEN(gv) ?
+ sv_2mortal(newSVhek(GvENAME_HEK(gv))) : NULL;
const char * const pars =
(const char *)(OP_IS_FILETEST(op) ? "" : "()");
const char * const func =
(const char *)
(OP_IS_SOCKET(op) || (io && IoTYPE(io) == IoTYPE_SOCKET)
? "socket" : "filehandle");
- if (name && *name) {
+ if (name && SvPOK(name) && *SvPV_nolen(name)) {
Perl_warner(aTHX_ packWARN(warn_type),
- "%s%s on %s %s %s", func, pars, vile, type, name);
+ "%s%s on %s %s %"SVf, func, pars, vile, type, SVfARG(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
+ "\t(Are you trying to call %s%s on dirhandle %"SVf"?)\n",
+ func, pars, SVfARG(name)
);
}
else {
}
}
+ /* 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++;
/* found just an integer */
goto version_prescan_finish;
}
- else if ( *d == '-') {
- BADVERSION(s,errstr,"Invalid version format (negative version number)");
- }
else if ( d == s ) {
/* didn't find either integer or period */
BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
}
#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
bool
Perl_stashpv_hvname_match(pTHX_ const COP *c, const HV *hv)
{
- const char * const stashpv = CopSTASHPV(c);
- const char * const name = HvNAME_get(hv);
+ const char * stashpv = CopSTASHPV(c);
+ const char * name = HvNAME_get(hv);
PERL_UNUSED_CONTEXT;
PERL_ARGS_ASSERT_STASHPV_HVNAME_MATCH;
- if (stashpv == name)
- return TRUE;
- if (stashpv && name)
- if (strEQ(stashpv, name))
- return TRUE;
+ if (!stashpv || !name)
+ return stashpv == name;
+ if ( HvNAMEUTF8(hv) && !(CopSTASH_flags(c) & SVf_UTF8 ? 1 : 0) ) {
+ if (CopSTASH_flags(c) & SVf_UTF8) {
+ return (bytes_cmp_utf8(
+ (const U8*)stashpv, strlen(stashpv),
+ (const U8*)name, HEK_LEN(HvNAME_HEK(hv))) == 0);
+ } else {
+ return (bytes_cmp_utf8(
+ (const U8*)name, HEK_LEN(HvNAME_HEK(hv)),
+ (const U8*)stashpv, strlen(stashpv)) == 0);
+ }
+ }
+ else
+ return (stashpv == name
+ || strEQ(stashpv, name));
return FALSE;
}
#endif
# undef PERLVARA
# undef PERLVARI
# undef PERLVARIC
-# 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 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
long _ftol2( double dblSource ) { return _ftol( dblSource ); }
#endif
+PERL_STATIC_INLINE bool
+S_gv_has_usable_name(pTHX_ GV *gv)
+{
+ GV **gvp;
+ return GvSTASH(gv)
+ && HvENAME(GvSTASH(gv))
+ && (gvp = (GV **)hv_fetch(
+ GvSTASH(gv), GvNAME(gv),
+ GvNAMEUTF8(gv) ? -GvNAMELEN(gv) : GvNAMELEN(gv), 0
+ ))
+ && *gvp == gv;
+}
+
void
Perl_get_db_sub(pTHX_ SV **svp, CV *cv)
{
SV * const dbsv = GvSVn(PL_DBsub);
const bool save_taint = PL_tainted;
- /* We do not care about using sv to call CV;
+ /* When we are called from pp_goto (svp is null),
+ * we do not care about using dbsv to call CV;
* it's for informational purposes only.
*/
if (!PERLDB_SUB_NN) {
GV *gv = CvGV(cv);
- if ( svp && ((CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
+ if (!svp) {
+ gv_efullname3(dbsv, gv, NULL);
+ }
+ else if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
|| strEQ(GvNAME(gv), "END")
- || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
+ || ( /* Could be imported, and old sub redefined. */
+ (GvCV(gv) != cv || !S_gv_has_usable_name(aTHX_ gv))
+ &&
!( (SvTYPE(*svp) == SVt_PVGV)
&& (GvCV((const GV *)*svp) == cv)
- && (gv = (GV *)*svp)
+ /* Use GV from the stack as a fallback. */
+ && S_gv_has_usable_name(aTHX_ 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));
sv_setsv(dbsv, tmp);
SvREFCNT_dec(tmp);
}
else {
- gv_efullname3(dbsv, gv, NULL);
+ sv_sethek(dbsv, HvENAME_HEK(GvSTASH(gv)));
+ sv_catpvs(dbsv, "::");
+ sv_catpvn_flags(
+ dbsv, GvNAME(gv), GvNAMELEN(gv),
+ GvNAMEUTF8(gv) ? SV_CATUTF8 : SV_CATBYTES
+ );
}
}
else {
https://perl5.git.perl.org / perl5.git / blobdiff