#endif
#ifdef DEBUGGING
if ((SSize_t)size < 0)
- Perl_croak_nocontext("panic: malloc, size=%"UVuf, (UV) size);
+ Perl_croak_nocontext("panic: malloc, size=%" UVuf, (UV) size);
#endif
if (!size) size = 1; /* malloc(0) is NASTY on our system */
#ifdef PERL_DEBUG_READONLY_COW
header->size = size;
#endif
ptr = (Malloc_t)((char*)ptr+PERL_MEMORY_DEBUG_HEADER_SIZE);
- DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
+ DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%" UVxf ": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
}
else {
#endif
#ifdef DEBUGGING
if ((SSize_t)size < 0)
- Perl_croak_nocontext("panic: realloc, size=%"UVuf, (UV)size);
+ Perl_croak_nocontext("panic: realloc, size=%" UVuf, (UV)size);
#endif
#ifdef PERL_DEBUG_READONLY_COW
if ((ptr = mmap(0, size, PROT_READ|PROT_WRITE,
/* 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));
+ 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) {
#ifdef USE_MDH
#ifdef ALWAYS_NEED_THX
dTHX;
#endif
- DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) free\n",PTR2UV(where),(long)PL_an++));
+ DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%" UVxf ": (%05ld) free\n",PTR2UV(where),(long)PL_an++));
if (where) {
#ifdef USE_MDH
Malloc_t where_intrn = (Malloc_t)((char*)where-PERL_MEMORY_DEBUG_HEADER_SIZE);
#endif
#ifdef DEBUGGING
if ((SSize_t)size < 0 || (SSize_t)count < 0)
- Perl_croak_nocontext("panic: calloc, size=%"UVuf", count=%"UVuf,
+ Perl_croak_nocontext("panic: calloc, size=%" UVuf ", count=%" UVuf,
(UV)size, (UV)count);
#endif
#ifdef PERL_DEBUG_READONLY_COW
ptr = (Malloc_t)PerlMem_calloc(count ? count : 1, size ? size : 1);
#endif
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)total_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) {
#ifdef USE_MDH
{
return (char*)big;
{
const char first = *little;
- const char *s, *x;
bigend -= lend - little++;
OUTER:
while (big <= bigend) {
if (*big++ == first) {
+ const char *s, *x;
for (x=big,s=little; s < lend; x++,s++) {
if (*s != *x)
goto OUTER;
}
BmUSEFUL(sv) = 100; /* Initial value */
((XPVNV*)SvANY(sv))->xnv_u.xnv_bm_tail = cBOOL(flags & FBMcf_TAIL);
- DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %"UVuf"\n",
+ DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %" UVuf "\n",
s[rarest], (UV)rarest));
}
char * const b = ninstr((char*)big,(char*)bigend,
(char*)little, (char*)little + littlelen);
- if (!b && tail) { /* Automatically multiline! */
- /* Chop \n from littlestr: */
- s = bigend - littlelen + 1;
- if (*s == *little
- && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
- {
- return (char*)s;
- }
- return NULL;
- }
+ assert(!tail); /* valid => FBM; tail only set on SvVALID SVs */
return b;
}
}
}
-
-/*
-=for apidoc foldEQ
-
-Returns true if the leading C<len> bytes of the strings C<s1> and C<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_foldEQ(const char *s1, const char *s2, I32 len)
-{
- const U8 *a = (const U8 *)s1;
- const U8 *b = (const U8 *)s2;
-
- PERL_ARGS_ASSERT_FOLDEQ;
-
- assert(len >= 0);
-
- while (len--) {
- if (*a != *b && *a != PL_fold[*b])
- return 0;
- a++,b++;
- }
- return 1;
-}
-I32
-Perl_foldEQ_latin1(const char *s1, const char *s2, 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 */
-
- const U8 *a = (const U8 *)s1;
- const U8 *b = (const U8 *)s2;
-
- PERL_ARGS_ASSERT_FOLDEQ_LATIN1;
-
- assert(len >= 0);
-
- 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 C<len> bytes of the strings C<s1> and C<s2> are the
-same case-insensitively in the current locale; false otherwise.
-
-=cut
-*/
-
-I32
-Perl_foldEQ_locale(const char *s1, const char *s2, I32 len)
-{
- dVAR;
- const U8 *a = (const U8 *)s1;
- const U8 *b = (const U8 *)s2;
-
- PERL_ARGS_ASSERT_FOLDEQ_LOCALE;
-
- assert(len >= 0);
-
- while (len--) {
- if (*a != *b && *a != PL_fold_locale[*b])
- return 0;
- a++,b++;
- }
- return 1;
-}
-
/* copy a string to a safe spot */
/*
* from the sibling of PL_curcop.
*/
- const COP *cop =
- closest_cop(PL_curcop, OpSIBLING(PL_curcop), PL_op, FALSE);
- if (!cop)
- cop = PL_curcop;
+ if (PL_curcop) {
+ const COP *cop =
+ closest_cop(PL_curcop, OpSIBLING(PL_curcop), PL_op, FALSE);
+ if (!cop)
+ cop = PL_curcop;
+
+ if (CopLINE(cop))
+ Perl_sv_catpvf(aTHX_ sv, " at %s line %" IVdf,
+ OutCopFILE(cop), (IV)CopLINE(cop));
+ }
- if (CopLINE(cop))
- Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf,
- OutCopFILE(cop), (IV)CopLINE(cop));
/* 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)))
STRLEN l;
const bool line_mode = (RsSIMPLE(PL_rs) &&
*SvPV_const(PL_rs,l) == '\n' && l == 1);
- Perl_sv_catpvf(aTHX_ sv, ", <%"SVf"> %s %"IVdf,
+ 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)))),
if (did_pipes && pid > 0) {
int errkid;
unsigned n = 0;
- SSize_t n1;
while (n < sizeof(int)) {
- n1 = PerlLIO_read(pp[0],
+ const SSize_t n1 = PerlLIO_read(pp[0],
(void*)(((char*)&errkid)+n),
(sizeof(int)) - n);
if (n1 <= 0)
if (did_pipes && pid > 0) {
int errkid;
unsigned n = 0;
- SSize_t n1;
while (n < sizeof(int)) {
- n1 = PerlLIO_read(pp[0],
+ const SSize_t n1 = PerlLIO_read(pp[0],
(void*)(((char*)&errkid)+n),
(sizeof(int)) - n);
if (n1 <= 0)
if (name && HEK_LEN(name))
Perl_warner(aTHX_ packWARN(WARN_IO),
- "Filehandle %"HEKf" opened only for %sput",
+ "Filehandle %" HEKf " opened only for %sput",
HEKfARG(name), direction);
else
Perl_warner(aTHX_ packWARN(WARN_IO),
? "socket" : "filehandle");
const bool have_name = name && SvCUR(name);
Perl_warner(aTHX_ packWARN(warn_type),
- "%s%s on %s %s%s%"SVf, func, pars, vile, type,
+ "%s%s on %s %s%s%" SVf, func, pars, vile, type,
have_name ? " " : "",
SVfARG(have_name ? name : &PL_sv_no));
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%"SVf"?)\n",
+ "\t(Are you trying to call %s%s on dirhandle%s%" SVf "?)\n",
func, pars, have_name ? " " : "",
SVfARG(have_name ? name : &PL_sv_no)
);
#define SV_CWD_RETURN_UNDEF \
-sv_setsv(sv, &PL_sv_undef); \
-return FALSE
+ sv_set_undef(sv); \
+ return FALSE
#define SV_CWD_ISDOT(dp) \
(dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
return TRUE;
}
else {
- sv_setsv(sv, &PL_sv_undef);
- return FALSE;
+ SV_CWD_RETURN_UNDEF;
}
}
the_end_of_the_opts_parser:
if (opt & ~PERL_UNICODE_ALL_FLAGS)
- Perl_croak(aTHX_ "Unknown Unicode option value %"UVuf,
+ Perl_croak(aTHX_ "Unknown Unicode option value %" UVuf,
(UV) (opt & ~PERL_UNICODE_ALL_FLAGS));
*popt = p;
void
Perl_get_hash_seed(pTHX_ unsigned char * const seed_buffer)
{
+#ifndef NO_PERL_HASH_ENV
const char *env_pv;
+#endif
unsigned long i;
PERL_ARGS_ASSERT_GET_HASH_SEED;
+#ifndef NO_PERL_HASH_ENV
env_pv= PerlEnv_getenv("PERL_HASH_SEED");
if ( env_pv )
-#ifndef USE_HASH_SEED_EXPLICIT
+# ifndef USE_HASH_SEED_EXPLICIT
{
/* ignore leading spaces */
while (isSPACE(*env_pv))
env_pv++;
-#ifdef USE_PERL_PERTURB_KEYS
+# ifdef USE_PERL_PERTURB_KEYS
/* if they set it to "0" we disable key traversal randomization completely */
if (strEQ(env_pv,"0")) {
PL_hash_rand_bits_enabled= 0;
/* otherwise switch to deterministic mode */
PL_hash_rand_bits_enabled= 2;
}
-#endif
+# endif
/* ignore a leading 0x... if it is there */
if (env_pv[0] == '0' && env_pv[1] == 'x')
env_pv += 2;
/* should we warn about insufficient hex? */
}
else
+# endif
#endif
{
(void)seedDrand01((Rand_seed_t)seed());
PL_hash_rand_bits = ROTL_UV(PL_hash_rand_bits,8);
}
}
+# ifndef NO_PERL_HASH_ENV
env_pv= PerlEnv_getenv("PERL_PERTURB_KEYS");
if (env_pv) {
if (strEQ(env_pv,"0") || strEQ(env_pv,"NO")) {
Perl_warn(aTHX_ "perl: warning: strange setting in '$ENV{PERL_PERTURB_KEYS}': '%s'\n", env_pv);
}
}
+# endif
#endif
}
switch (mlt) {
case MLT_ALLOC:
len = my_snprintf(buf, sizeof(buf),
- "alloc: %s:%d:%s: %"IVdf" %"UVuf
- " %s = %"IVdf": %"UVxf"\n",
+ "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",
+ "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",
+ "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",
+ "%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));
if (qfmt) {
/* If the format looked promising, use it as quadmath. */
retval = quadmath_snprintf(buffer, len, qfmt, va_arg(ap, NV));
- if (retval == -1)
+ if (retval == -1) {
+ if (qfmt != format) {
+ dTHX;
+ SAVEFREEPV(qfmt);
+ }
Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", qfmt);
+ }
quadmath_valid = TRUE;
if (qfmt != format)
Safefree(qfmt);
/* make sure the array is big enough */
if (PL_my_cxt_size <= *index) {
if (PL_my_cxt_size) {
- while (PL_my_cxt_size <= *index)
- PL_my_cxt_size *= 2;
- Renew(PL_my_cxt_list, PL_my_cxt_size, void *);
+ IV new_size = PL_my_cxt_size;
+ while (new_size <= *index)
+ new_size *= 2;
+ Renew(PL_my_cxt_list, new_size, void *);
+ PL_my_cxt_size = new_size;
}
else {
PL_my_cxt_size = 16;
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 *);
+ IV new_size = PL_my_cxt_size;
+ while (new_size <= index)
+ new_size *= 2;
+ Renew(PL_my_cxt_list, new_size, void *);
+ Renew(PL_my_cxt_keys, new_size, const char *);
+ PL_my_cxt_size = new_size;
}
else {
PL_my_cxt_size = 16;
if(apiverlen != sizeof("v" PERL_API_VERSION_STRING)-1
|| memNE(api_p, "v" PERL_API_VERSION_STRING,
sizeof("v" PERL_API_VERSION_STRING)-1))
- Perl_croak_nocontext("Perl API version %s of %"SVf" does not match %s",
+ Perl_croak_nocontext("Perl API version %s of %" SVf " does not match %s",
api_p, SVfARG(PL_stack_base[ax + 0]),
"v" PERL_API_VERSION_STRING);
}
else {
/* XXX GV_ADDWARN */
vn = "XS_VERSION";
- sv = get_sv(Perl_form(aTHX_ "%"SVf"::%s", SVfARG(module), vn), 0);
+ sv = get_sv(Perl_form(aTHX_ "%" SVf "::%s", SVfARG(module), vn), 0);
if (!sv || !SvOK(sv)) {
vn = "VERSION";
- sv = get_sv(Perl_form(aTHX_ "%"SVf"::%s", SVfARG(module), vn), 0);
+ sv = get_sv(Perl_form(aTHX_ "%" SVf "::%s", SVfARG(module), vn), 0);
}
}
if (sv) {
xssv = upg_version(xssv, 0);
if ( vcmp(pmsv,xssv) ) {
SV *string = vstringify(xssv);
- SV *xpt = Perl_newSVpvf(aTHX_ "%"SVf" object version %"SVf
+ SV *xpt = Perl_newSVpvf(aTHX_ "%" SVf " object version %" SVf
" does not match ", SVfARG(module), SVfARG(string));
SvREFCNT_dec(string);
string = vstringify(pmsv);
if (vn) {
- Perl_sv_catpvf(aTHX_ xpt, "$%"SVf"::%s %"SVf, SVfARG(module), vn,
+ Perl_sv_catpvf(aTHX_ xpt, "$%" SVf "::%s %" SVf, SVfARG(module), vn,
SVfARG(string));
} else {
- Perl_sv_catpvf(aTHX_ xpt, "bootstrap parameter %"SVf, SVfARG(string));
+ Perl_sv_catpvf(aTHX_ xpt, "bootstrap parameter %" SVf, SVfARG(string));
}
SvREFCNT_dec(string);
if (frame->source_name_size &&
frame->source_name_offset &&
frame->source_line_number) {
- Perl_sv_catpvf(aTHX_ dsv, "\t%s:%"UVuf,
+ Perl_sv_catpvf(aTHX_ dsv, "\t%s:%" UVuf,
(char*)bt + frame->source_name_offset,
(UV)frame->source_line_number);
} else {
sv_catpvs(dsv, "\n");
}
- Perl_free_c_backtrace(aTHX_ bt);
+ Perl_free_c_backtrace(bt);
return dsv;
}
https://perl5.git.perl.org / perl5.git / blobdiff