#endif
#ifdef DEBUGGING
if ((SSize_t)size < 0)
- Perl_croak_nocontext("panic: malloc");
+ Perl_croak_nocontext("panic: malloc, size=%"UVuf, (UV) size);
#endif
ptr = (Malloc_t)PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */
PERL_ALLOC_CHECK(ptr);
= (struct perl_memory_debug_header *)where;
if (header->interpreter != aTHX) {
- Perl_croak_nocontext("panic: realloc from wrong pool");
+ Perl_croak_nocontext("panic: realloc from wrong pool, %p!=%p",
+ header->interpreter, aTHX);
}
assert(header->next->prev == header);
assert(header->prev->next == header);
#endif
#ifdef DEBUGGING
if ((SSize_t)size < 0)
- Perl_croak_nocontext("panic: realloc");
+ Perl_croak_nocontext("panic: realloc, size=%"UVuf, (UV)size);
#endif
ptr = (Malloc_t)PerlMem_realloc(where,size);
PERL_ALLOC_CHECK(ptr);
= (struct perl_memory_debug_header *)where;
if (header->interpreter != aTHX) {
- Perl_croak_nocontext("panic: free from wrong pool");
+ Perl_croak_nocontext("panic: free from wrong pool, %p!=%p",
+ header->interpreter, aTHX);
}
if (!header->prev) {
Perl_croak_nocontext("panic: duplicate free");
}
- if (!(header->next) || header->next->prev != header
- || header->prev->next != header) {
- Perl_croak_nocontext("panic: bad free");
+ if (!(header->next))
+ Perl_croak_nocontext("panic: bad free, header->next==NULL");
+ if (header->next->prev != header || header->prev->next != header) {
+ Perl_croak_nocontext("panic: bad free, ->next->prev=%p, "
+ "header=%p, ->prev->next=%p",
+ header->next->prev, header,
+ header->prev->next);
}
/* Unlink us from the chain. */
header->next->prev = header->prev;
#endif /* HAS_64K_LIMIT */
#ifdef DEBUGGING
if ((SSize_t)size < 0 || (SSize_t)count < 0)
- Perl_croak_nocontext("panic: calloc");
+ Perl_croak_nocontext("panic: calloc, size=%"UVuf", count=%"UVuf,
+ (UV)size, (UV)count);
#endif
#ifdef PERL_TRACK_MEMPOOL
/* Have to use malloc() because we've added some space for our tracking
return NULL;
}
-/* same as instr but allow embedded nulls */
+/* same as instr but allow embedded nulls. The end pointers point to 1 beyond
+ * the final character desired to be checked */
char *
Perl_ninstr(const char *big, const char *bigend, const char *little, const char *lend)
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))
+ if (isGV_with_GP(sv))
return;
if (SvVALID(sv))
/*
=for apidoc fbm_instr
-Returns the location of the SV in the string delimited by C<str> and
-C<strend>. It returns C<NULL> if the string can't be found. The C<sv>
+Returns the location of the SV in the string delimited by C<big> and
+C<bigend>. It returns C<NULL> if the string can't be found. The C<sv>
does not have to be fbm_compiled, but the search will not be as fast
then.
}
}
-/* start_shift, end_shift are positive quantities which give offsets
- of ends of some substring of bigstr.
- If "last" we want the last occurrence.
- old_posp is the way of communication between consequent calls if
- the next call needs to find the .
- The initial *old_posp should be -1.
-
- Note that we take into account SvTAIL, so one can get extra
- optimizations if _ALL flag is set.
- */
-
-/* If SvTAIL is actually due to \Z or \z, this gives false positives
- if PL_multiline. In fact if !PL_multiline the authoritative answer
- is not supported yet. */
-
char *
Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last)
{
dVAR;
- register const unsigned char *big;
- 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;
- 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(SvMAGICAL(bigstr));
- mg = mg_find(bigstr, PERL_MAGIC_study);
- assert(mg);
- assert(SvTYPE(littlestr) == SVt_PVMG);
- assert(SvVALID(littlestr));
-
- 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) {
- little = (const unsigned char *)(SvPVX_const(littlestr));
- littleend = little + SvCUR(littlestr);
- first = *little++;
- goto check_tail;
- }
- return NULL;
- }
-
- little = (const unsigned char *)(SvPVX_const(littlestr));
- littleend = little + SvCUR(littlestr);
- first = *little++;
- /* The value of pos we can start at: */
- previous = BmPREVIOUS(littlestr);
- big = (const unsigned char *)(SvPVX_const(bigstr));
- /* The value of pos we can stop at: */
- stop_pos = SvCUR(bigstr) - end_shift - (SvCUR(littlestr) - 1 - previous);
- if (previous + start_shift > stop_pos) {
-/*
- stop_pos does not include SvTAIL in the count, so this check is incorrect
- (I think) - see [ID 20010618.006] and t/op/study.t. HVDS 2001/06/19
-*/
-#if 0
- if (previous + start_shift == stop_pos + 1) /* A fake '\n'? */
- goto check_tail;
-#endif
- return NULL;
- }
- 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;
- 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 (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:
- if (!SvTAIL(littlestr) || (end_shift > 0))
- return NULL;
- /* Ignore the trailing "\n". This code is not microoptimized */
- big = (const unsigned char *)(SvPVX_const(bigstr) + SvCUR(bigstr));
- stop_pos = littleend - little; /* Actual littlestr len */
- if (stop_pos == 0)
- return (char*)big;
- big -= stop_pos;
- if (*big == first
- && ((stop_pos == 1) ||
- memEQ((char *)(big + 1), (char *)little, stop_pos - 1)))
- return (char*)big;
+ PERL_UNUSED_ARG(bigstr);
+ PERL_UNUSED_ARG(littlestr);
+ PERL_UNUSED_ARG(start_shift);
+ PERL_UNUSED_ARG(end_shift);
+ PERL_UNUSED_ARG(old_posp);
+ PERL_UNUSED_ARG(last);
+
+ /* This function must only ever be called on a scalar with study magic,
+ but those do not happen any more. */
+ Perl_croak(aTHX_ "panic: screaminstr");
return NULL;
}
{
char *const newaddr = (char*)PerlMemShared_malloc(len + 1);
- PERL_ARGS_ASSERT_SAVESHAREDPVN;
+ /* PERL_ARGS_ASSERT_SAVESHAREDPVN; */
if (!newaddr) {
return write_no_mem();
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) &&
- SvCUR(PL_rs) == 1 && *SvPVX_const(PL_rs) == '\n');
+ *SvPV_const(PL_rs,l) == '\n' && l == 1);
Perl_sv_catpvf(aTHX_ sv, ", <%"SVf"> %s %"IVdf,
SVfARG(PL_last_in_gv == PL_argvgv
? &PL_sv_no
STRLEN *
Perl_new_warnings_bitfield(pTHX_ STRLEN *buffer, const char *const bits,
STRLEN size) {
- const MEM_SIZE len_wanted = sizeof(STRLEN) + size;
+ const MEM_SIZE len_wanted =
+ sizeof(STRLEN) + (size > WARNsize ? size : WARNsize);
PERL_UNUSED_CONTEXT;
PERL_ARGS_ASSERT_NEW_WARNINGS_BITFIELD;
PerlMemShared_realloc(buffer, len_wanted));
buffer[0] = size;
Copy(bits, (buffer + 1), size, char);
+ if (size < WARNsize)
+ Zero((char *)(buffer + 1) + size, WARNsize - size, char);
return buffer;
}
int pid2, status;
PerlLIO_close(p[This]);
if (n != sizeof(int))
- Perl_croak(aTHX_ "panic: kid popen errno read");
+ Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", n);
do {
pid2 = wait4pid(pid, &status, 0);
} while (pid2 == -1 && errno == EINTR);
default, binary, low-level mode; see PerlIOBuf_open(). */
PerlLIO_setmode((*mode == 'r'), O_BINARY);
#endif
-#ifdef THREADS_HAVE_PIDS
- PL_ppid = (IV)getppid();
-#endif
PL_forkprocess = 0;
#ifdef PERL_USES_PL_PIDSTATUS
hv_clear(PL_pidstatus); /* we have no children */
int pid2, status;
PerlLIO_close(p[This]);
if (n != sizeof(int))
- Perl_croak(aTHX_ "panic: kid popen errno read");
+ Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", n);
do {
pid2 = wait4pid(pid, &status, 0);
} while (pid2 == -1 && errno == EINTR);
seen_dot = 1; /* Disable message. */
if (!xfound) {
if (flags & 1) { /* do or die? */
+ /* diag_listed_as: Can't execute %s */
Perl_croak(aTHX_ "Can't %s %s%s%s",
(xfailed ? "execute" : "find"),
(xfailed ? xfailed : scriptname),
#if defined(USE_ITHREADS)
# ifdef OLD_PTHREADS_API
pthread_addr_t t;
- if (pthread_getspecific(PL_thr_key, &t))
- Perl_croak_nocontext("panic: pthread_getspecific");
+ int error = pthread_getspecific(PL_thr_key, &t)
+ if (error)
+ Perl_croak_nocontext("panic: pthread_getspecific, error=%d", error);
return (void*)t;
# else
# ifdef I_MACH_CTHREADS
# ifdef I_MACH_CTHREADS
cthread_set_data(cthread_self(), t);
# else
- if (pthread_setspecific(PL_thr_key, t))
- Perl_croak_nocontext("panic: pthread_setspecific");
+ {
+ const int error = pthread_setspecific(PL_thr_key, t);
+ if (error)
+ Perl_croak_nocontext("panic: pthread_setspecific, error=%d", error);
+ }
# endif
#else
PERL_UNUSED_ARG(t);
Perl_report_wrongway_fh(pTHX_ const GV *gv, const char have)
{
if (ckWARN(WARN_IO)) {
- SV * const name
- = gv && (isGV(gv) || isGV_with_GP(gv))
- ? sv_2mortal(newSVhek(GvENAME_HEK((gv))))
+ HEK * const name
+ = gv && (isGV_with_GP(gv))
+ ? GvENAME_HEK((gv))
: NULL;
const char * const direction = have == '>' ? "out" : "in";
- if (name && SvPOK(name) && *SvPV_nolen(name))
+ if (name && HEK_LEN(name))
Perl_warner(aTHX_ packWARN(WARN_IO),
- "Filehandle %"SVf" opened only for %sput",
+ "Filehandle %"HEKf" opened only for %sput",
name, direction);
else
Perl_warner(aTHX_ packWARN(WARN_IO),
if (ckWARN(warn_type)) {
SV * const name
- = gv && (isGV(gv) || isGV_with_GP(gv)) && GvENAMELEN(gv) ?
+ = 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 *)
(OP_IS_SOCKET(op) || (io && IoTYPE(io) == IoTYPE_SOCKET)
? "socket" : "filehandle");
- if (name && SvPOK(name) && *SvPV_nolen(name)) {
- Perl_warner(aTHX_ packWARN(warn_type),
- "%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 %"SVf"?)\n",
- func, pars, SVfARG(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))
+ const bool have_name = name && *SvPV_nolen(name);
+ Perl_warner(aTHX_ packWARN(warn_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?)\n",
- func, pars
+ "\t(Are you trying to call %s%s on dirhandle%s%"SVf"?)\n",
+ func, pars, have_name ? " " : "",
+ SVfARG(have_name ? name : &PL_sv_no)
);
- }
}
}
/* and we never support negative versions */
if ( *d == '-') {
- BADVERSION(s,errstr,"Invalid version format (negative version number)");
+ BADVERSION(s,errstr,"Invalid version format (negative version number)");
}
/* consume all of the integer part */
dVAR;
SV * const rv = newSV(0);
PERL_ARGS_ASSERT_NEW_VERSION;
- if ( sv_derived_from(ver,"version") ) /* can just copy directly */
+ if ( sv_isobject(ver) && sv_derived_from(ver, "version") )
+ /* can just copy directly */
{
I32 key;
AV * const av = newAV();
if ( SvNOK(ver) && !( SvPOK(ver) && sv_len(ver) == 3 ) )
{
+ STRLEN len;
+
/* may get too much accuracy */
char tbuf[64];
+ SV *sv = SvNVX(ver) > 10e50 ? newSV(64) : 0;
+ char *buf;
#ifdef USE_LOCALE_NUMERIC
- char *loc = setlocale(LC_NUMERIC, "C");
+ char *loc = savepv(setlocale(LC_NUMERIC, NULL));
+ setlocale(LC_NUMERIC, "C");
#endif
- STRLEN len = my_snprintf(tbuf, sizeof(tbuf), "%.9"NVff, SvNVX(ver));
+ if (sv) {
+ Perl_sv_setpvf(aTHX_ sv, "%.9"NVff, SvNVX(ver));
+ buf = SvPV(sv, len);
+ }
+ else {
+ len = my_snprintf(tbuf, sizeof(tbuf), "%.9"NVff, SvNVX(ver));
+ buf = tbuf;
+ }
#ifdef USE_LOCALE_NUMERIC
setlocale(LC_NUMERIC, loc);
+ Safefree(loc);
#endif
- while (tbuf[len-1] == '0' && len > 0) len--;
- if ( tbuf[len-1] == '.' ) len--; /* eat the trailing decimal */
- version = savepvn(tbuf, len);
+ while (buf[len-1] == '0' && len > 0) len--;
+ if ( buf[len-1] == '.' ) len--; /* eat the trailing decimal */
+ version = savepvn(buf, len);
+ SvREFCNT_dec(sv);
}
#ifdef SvVOK
else if ( (mg = SvVSTRING_mg(ver)) ) { /* already a v-string */
return opt;
}
+#ifdef VMS
+# include <starlet.h>
+#endif
+
U32
Perl_seed(pTHX)
{
#endif
U32 u;
#ifdef VMS
-# include <starlet.h>
/* when[] = (low 32 bits, high 32 bits) of time since epoch
* in 100-ns units, typically incremented ever 10 ms. */
unsigned int when[2];
return myseed;
}
-#ifdef USE_ITHREADS
-bool
-Perl_stashpv_hvname_match(pTHX_ const COP *c, const HV *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 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
-
-
#ifdef PERL_GLOBAL_STRUCT
#define PERL_GLOBAL_STRUCT_INIT
}
if (sv) {
SV *xssv = Perl_newSVpvn_flags(aTHX_ xs_p, xs_len, SVs_TEMP);
- SV *pmsv = sv_derived_from(sv, "version")
+ SV *pmsv = sv_isobject(sv) && sv_derived_from(sv, "version")
? sv : sv_2mortal(new_version(sv));
xssv = upg_version(xssv, 0);
if ( vcmp(pmsv,xssv) ) {
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
https://perl5.git.perl.org / perl5.git / blobdiff