{
dTHX;
Malloc_t ptr;
+#if defined(DEBUGGING) || defined(HAS_64K_LIMIT) || defined(PERL_TRACK_MEMPOOL)
+ const MEM_SIZE total_size = size * count
+#ifdef PERL_TRACK_MEMPOOL
+ + sTHX
+#endif
+ ;
+#endif
#ifdef HAS_64K_LIMIT
- if (size * count > 0xffff) {
+ if (total_size > 0xffff) {
PerlIO_printf(Perl_error_log,
- "Allocation too large: %lx\n", size * count) FLUSH;
+ "Allocation too large: %lx\n", total_size) FLUSH;
my_exit(1);
}
#endif /* HAS_64K_LIMIT */
if ((long)size < 0 || (long)count < 0)
Perl_croak_nocontext("panic: calloc");
#endif
- size *= count;
#ifdef PERL_TRACK_MEMPOOL
- size += sTHX;
+ /* Have to use malloc() because we've added some space for our tracking
+ header. */
+ ptr = (Malloc_t)PerlMem_malloc(total_size);
+#else
+ /* Use calloc() because it might save a memset() if the memory is fresh
+ and clean from the OS. */
+ ptr = (Malloc_t)PerlMem_calloc(count, size);
#endif
- ptr = (Malloc_t)PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */
PERL_ALLOC_CHECK(ptr);
- DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) calloc %ld x %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)count,(long)size));
+ DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) calloc %ld x %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)count,(long)total_size));
if (ptr != NULL) {
- memset((void*)ptr, 0, size);
#ifdef PERL_TRACK_MEMPOOL
{
struct perl_memory_debug_header *const header
= (struct perl_memory_debug_header *)ptr;
+ memset((void*)ptr, 0, total_size);
header->interpreter = aTHX;
/* Link us into the list. */
header->prev = &PL_memory_debug_header;
PL_memory_debug_header.next = header;
header->next->prev = header;
# ifdef PERL_POISON
- header->size = size;
+ header->size = total_size;
# endif
ptr = (Malloc_t)((char*)ptr+sTHX);
}
bigend -= lend - little;
OUTER:
while (big <= bigend) {
- if (*big++ != first)
- goto OUTER;
- for (x=big,s=little; s < lend; x++,s++) {
- if (*s != *x)
- goto OUTER;
+ if (*big++ == first) {
+ for (x=big,s=little; s < lend; x++,s++) {
+ if (*s != *x)
+ goto OUTER;
+ }
+ return (char*)(big-1);
}
- return (char*)(big-1);
}
}
return NULL;
if (CopLINE(cop))
Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf,
OutCopFILE(cop), (IV)CopLINE(cop));
- if (GvIO(PL_last_in_gv) && IoLINES(GvIOp(PL_last_in_gv))) {
+ /* Seems that GvIO() can be untrustworthy during global destruction. */
+ if (GvIO(PL_last_in_gv) && (SvTYPE(GvIOp(PL_last_in_gv)) == SVt_PVIO)
+ && IoLINES(GvIOp(PL_last_in_gv)))
+ {
const bool line_mode = (RsSIMPLE(PL_rs) &&
SvCUR(PL_rs) == 1 && *SvPVX_const(PL_rs) == '\n');
Perl_sv_catpvf(aTHX_ sv, ", <%s> %s %"IVdf,
Function must be called with an already existing SV like
sv = newSV(0);
- s = scan_version(s,SV *sv, bool qv);
+ s = scan_version(s, SV *sv, bool qv);
Performs some preprocessing to the string to ensure that
it has the correct characteristics of a version. Flags the
object if it contains an underscore (which denotes this
-is a alpha version). The boolean qv denotes that the version
+is an alpha version). The boolean qv denotes that the version
should be interpreted as if it had multiple decimals, even if
it doesn't.
}
}
#endif
- return upg_version(rv);
+ return upg_version(rv, FALSE);
}
/*
In-place upgrade of the supplied SV to a version object.
- SV *sv = upg_version(SV *sv);
+ SV *sv = upg_version(SV *sv, bool qv);
-Returns a pointer to the upgraded SV.
+Returns a pointer to the upgraded SV. Set the boolean qv if you want
+to force this SV to be interpreted as an "extended" version.
=cut
*/
SV *
-Perl_upg_version(pTHX_ SV *ver)
+Perl_upg_version(pTHX_ SV *ver, bool qv)
{
const char *version, *s;
- bool qv = 0;
#ifdef SvVOK
const MAGIC *mg;
#endif
- if ( SvNOK(ver) ) /* may get too much accuracy */
+ if ( SvNOK(ver) && !( SvPOK(ver) && sv_len(ver) == 3 ) )
{
+ /* may get too much accuracy */
char tbuf[64];
#ifdef USE_LOCALE_NUMERIC
char *loc = setlocale(LC_NUMERIC, "C");
#endif
else /* must be a string or something like a string */
{
- version = savepv(SvPV_nolen(ver));
+ STRLEN len;
+ version = savepv(SvPV(ver,len));
+#ifndef SvVOK
+# if PERL_VERSION > 5
+ /* This will only be executed for 5.6.0 - 5.8.0 inclusive */
+ if ( len == 3 && !instr(version,".") && !instr(version,"_") ) {
+ /* may be a v-string */
+ SV * const nsv = sv_newmortal();
+ const char *nver;
+ const char *pos;
+ int saw_period = 0;
+ sv_setpvf(nsv,"%vd",ver);
+ pos = nver = savepv(SvPV_nolen(nsv));
+
+ /* scan the resulting formatted string */
+ while ( *pos == '.' || isDIGIT(*pos) ) {
+ if ( *pos == '.' )
+ saw_period++ ;
+ pos++;
+ }
+
+ /* is definitely a v-string */
+ if ( saw_period == 2 ) {
+ Safefree(version);
+ version = nver;
+ }
+ }
+# endif
+#endif
}
s = scan_version(version, ver, qv);
#ifdef PERL_GLOBAL_STRUCT
+#define PERL_GLOBAL_STRUCT_INIT
+#include "opcode.h" /* the ppaddr and check */
+
struct perl_vars *
Perl_init_global_struct(pTHX)
{
struct perl_vars *plvarsp = NULL;
-#ifdef PERL_GLOBAL_STRUCT
-# define PERL_GLOBAL_STRUCT_INIT
-# include "opcode.h" /* the ppaddr and check */
+# ifdef PERL_GLOBAL_STRUCT
const IV nppaddr = sizeof(Gppaddr)/sizeof(Perl_ppaddr_t);
const IV ncheck = sizeof(Gcheck) /sizeof(Perl_check_t);
# ifdef PERL_GLOBAL_STRUCT_PRIVATE
# undef PERLVARIC
# undef PERLVARISC
# ifdef PERL_GLOBAL_STRUCT
- plvarsp->Gppaddr = PerlMem_malloc(nppaddr * sizeof(Perl_ppaddr_t));
+ plvarsp->Gppaddr =
+ (Perl_ppaddr_t*)
+ PerlMem_malloc(nppaddr * sizeof(Perl_ppaddr_t));
if (!plvarsp->Gppaddr)
exit(1);
- plvarsp->Gcheck = PerlMem_malloc(ncheck * sizeof(Perl_check_t));
+ plvarsp->Gcheck =
+ (Perl_check_t*)
+ PerlMem_malloc(ncheck * sizeof(Perl_check_t));
if (!plvarsp->Gcheck)
exit(1);
Copy(Gppaddr, plvarsp->Gppaddr, nppaddr, Perl_ppaddr_t);
# ifdef PERL_SET_VARS
PERL_SET_VARS(plvarsp);
# endif
-# undef PERL_GLOBAL_STRUCT_INIT
-#endif
+# undef PERL_GLOBAL_STRUCT_INIT
+# endif
return plvarsp;
}
void
Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp)
{
-#ifdef PERL_GLOBAL_STRUCT
+# ifdef PERL_GLOBAL_STRUCT
# ifdef PERL_UNSET_VARS
PERL_UNSET_VARS(plvarsp);
# endif
free(plvarsp->Gppaddr);
free(plvarsp->Gcheck);
-# ifdef PERL_GLOBAL_STRUCT_PRIVATE
+# ifdef PERL_GLOBAL_STRUCT_PRIVATE
free(plvarsp);
-# endif
-#endif
+# endif
+# endif
}
#endif /* PERL_GLOBAL_STRUCT */