{
dTHX;
Malloc_t ptr;
+ MEM_SIZE total_size = 0;
+ /* Even though calloc() for zero bytes is strange, be robust. */
+ if (size && (count <= MEM_SIZE_MAX / size))
+ total_size = size * count;
+ else
+ Perl_croak_nocontext(PL_memory_wrap);
+#ifdef PERL_TRACK_MEMPOOL
+ if (sTHX <= MEM_SIZE_MAX - (MEM_SIZE)total_size)
+ total_size += sTHX;
+ else
+ Perl_croak_nocontext(PL_memory_wrap);
+#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. */
+ /* malloc(0) is non-portable. */
+ ptr = (Malloc_t)PerlMem_malloc(total_size ? total_size : 1);
+#else
+ /* Use calloc() because it might save a memset() if the memory is fresh
+ and clean from the OS. */
+ if (count && size)
+ ptr = (Malloc_t)PerlMem_calloc(count, size);
+ else /* calloc(0) is non-portable. */
+ ptr = (Malloc_t)PerlMem_calloc(count ? count : 1, size ? size : 1);
#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);
}
if (little >= lend)
return (char*)big;
{
- char first = *little++;
+ const char first = *little++;
const char *s, *x;
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;
XPVMG *any;
if (!PL_dirty)
- return sv_2mortal(newSVpvs(""));
+ return newSVpvs_flags("", SVs_TEMP);
if (PL_mess_sv)
return PL_mess_sv;
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,
PUSHMARK(SP);
EXTEND(SP,2);
PUSHs(SvTIED_obj((SV*)io, mg));
- PUSHs(sv_2mortal(newSVpvn(message, msglen)));
+ mPUSHp(message, msglen);
PUTBACK;
call_method("PRINT", G_SCALAR);
*hook = NULL;
}
if (warn || message) {
- msg = newSVpvn(message, msglen);
- SvFLAGS(msg) |= utf8;
+ msg = newSVpvn_flags(message, msglen, utf8);
SvREADONLY_on(msg);
SAVEFREESV(msg);
}
#endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */
#ifndef HAS_VPRINTF
+/* This vsprintf replacement should generally never get used, since
+ vsprintf was available in both System V and BSD 2.11. (There may
+ be some cross-compilation or embedded set-ups where it is needed,
+ however.)
+
+ If you encounter a problem in this function, it's probably a symptom
+ that Configure failed to detect your system's vprintf() function.
+ See the section on "item vsprintf" in the INSTALL file.
+
+ This version may compile on systems with BSD-ish <stdio.h>,
+ but probably won't on others.
+*/
#ifdef USE_CHAR_VSPRINTF
char *
#else
int
#endif
-vsprintf(char *dest, const char *pat, char *args)
+vsprintf(char *dest, const char *pat, void *args)
{
FILE fakebuf;
+#if defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE)
+ FILE_ptr(&fakebuf) = (STDCHAR *) dest;
+ FILE_cnt(&fakebuf) = 32767;
+#else
+ /* These probably won't compile -- If you really need
+ this, you'll have to figure out some other method. */
fakebuf._ptr = dest;
fakebuf._cnt = 32767;
+#endif
#ifndef _IOSTRG
#define _IOSTRG 0
#endif
fakebuf._flag = _IOWRT|_IOSTRG;
_doprnt(pat, args, &fakebuf); /* what a kludge */
- (void)putc('\0', &fakebuf);
+#if defined(STDIO_PTR_LVALUE)
+ *(FILE_ptr(&fakebuf)++) = '\0';
+#else
+ /* PerlIO has probably #defined away fputc, but we want it here. */
+# ifdef fputc
+# undef fputc /* XXX Should really restore it later */
+# endif
+ (void)fputc('\0', &fakebuf);
+#endif
#ifdef USE_CHAR_VSPRINTF
return(dest);
#else
char c[sizeof(long)];
} u;
-#if BYTEORDER == 0x1234
+#if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678
+#if BYTEORDER == 0x12345678
+ u.result = 0;
+#endif
u.c[0] = (l >> 24) & 255;
u.c[1] = (l >> 16) & 255;
u.c[2] = (l >> 8) & 255;
}
PerlIO *
-Perl_my_popen_list(pTHX_ char *mode, int n, SV **args)
+Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
{
-#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) && !defined(NETWARE)
+#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) && !defined(NETWARE) && !defined(__LIBCATAMOUNT__)
dVAR;
int p[2];
register I32 This, that;
return PerlIO_fdopen(p[This], mode);
#else
# ifdef OS2 /* Same, without fork()ing and all extra overhead... */
- return my_syspopen4(aTHX_ Nullch, mode, n, args);
+ return my_syspopen4(aTHX_ NULL, mode, n, args);
# else
Perl_croak(aTHX_ "List form of piped open not implemented");
return (PerlIO *) NULL;
}
/* VMS' my_popen() is in VMS.c, same with OS/2. */
-#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
+#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) && !defined(__LIBCATAMOUNT__)
PerlIO *
Perl_my_popen(pTHX_ const char *cmd, const char *mode)
{
#if defined(atarist) || defined(EPOC)
FILE *popen();
PerlIO *
-Perl_my_popen((pTHX_ const char *cmd, const char *mode)
+Perl_my_popen(pTHX_ const char *cmd, const char *mode)
{
PERL_FLUSHALL_FOR_CHILD;
/* Call system's popen() to get a FILE *, then import it.
#if defined(DJGPP)
FILE *djgpp_popen();
PerlIO *
-Perl_my_popen((pTHX_ const char *cmd, const char *mode)
+Perl_my_popen(pTHX_ const char *cmd, const char *mode)
{
PERL_FLUSHALL_FOR_CHILD;
/* Call system's popen() to get a FILE *, then import it.
*/
return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
}
+#else
+#if defined(__LIBCATAMOUNT__)
+PerlIO *
+Perl_my_popen(pTHX_ const char *cmd, const char *mode)
+{
+ return NULL;
+}
+#endif
#endif
#endif
#ifdef DUMP_FDS
void
-Perl_dump_fds(pTHX_ char *s)
+Perl_dump_fds(pTHX_ const char *const s)
{
int fd;
Stat_t tmpstatbuf;
#endif /* !PERL_MICRO */
/* VMS' my_pclose() is in VMS.c; same with OS/2 */
-#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
+#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) && !defined(__LIBCATAMOUNT__)
I32
Perl_my_pclose(pTHX_ PerlIO *ptr)
{
}
return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status));
}
+#else
+#if defined(__LIBCATAMOUNT__)
+I32
+Perl_my_pclose(pTHX_ PerlIO *ptr)
+{
+ return -1;
+}
+#endif
#endif /* !DOSISH */
-#if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(MACOS_TRADITIONAL)
+#if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(MACOS_TRADITIONAL) && !defined(__LIBCATAMOUNT__)
I32
Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
{
register char *s;
I32 len = 0;
int retval;
+ char *bufend;
#if defined(DOSISH) && !defined(OS2) && !defined(atarist)
# define SEARCH_EXTS ".bat", ".cmd", NULL
# define MAX_EXT_LEN 4
{
bool seen_dot = 0;
- PL_bufend = s + strlen(s);
- while (s < PL_bufend) {
+ bufend = s + strlen(s);
+ while (s < bufend) {
#ifdef MACOS_TRADITIONAL
- s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
+ s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend,
',',
&len);
#else
if (len < sizeof tmpbuf)
tmpbuf[len] = '\0';
#else /* ! (atarist || DOSISH) */
- s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
+ s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend,
':',
&len);
#endif /* ! (atarist || DOSISH) */
#endif /* MACOS_TRADITIONAL */
- if (s < PL_bufend)
+ if (s < bufend)
s++;
if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
continue; /* don't search dir with too-long name */
#endif
}
+#define VERSION_MAX 0x7FFFFFFF
/*
=for apidoc scan_version
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.
int saw_period = 0;
int alpha = 0;
int width = 3;
+ 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 */
}
- start = last = pos = s;
+ pos = s;
/* pre-scan the input string to check for decimals/underbars */
while ( *pos == '.' || *pos == '_' || isDIGIT(*pos) )
if ( saw_period > 1 )
qv = 1; /* force quoted version processing */
+ last = pos;
pos = s;
if ( qv )
- hv_store((HV *)hv, "qv", 2, newSViv(qv), 0);
+ (void)hv_stores((HV *)hv, "qv", newSViv(qv));
if ( alpha )
- hv_store((HV *)hv, "alpha", 5, newSViv(alpha), 0);
+ (void)hv_stores((HV *)hv, "alpha", newSViv(alpha));
if ( !qv && width < 3 )
- hv_store((HV *)hv, "width", 5, newSViv(width), 0);
+ (void)hv_stores((HV *)hv, "width", newSViv(width));
while (isDIGIT(*pos))
pos++;
/* this is atoi() that delimits on underscores */
const char *end = pos;
I32 mult = 1;
- I32 orev;
+ I32 orev;
/* the following if() will only be true after the decimal
* point of a version originally created with a bare
if ( !qv && s > start && saw_period == 1 ) {
mult *= 100;
while ( s < end ) {
- orev = rev;
+ orev = rev;
rev += (*s - '0') * mult;
mult /= 10;
- if ( PERL_ABS(orev) > PERL_ABS(rev) )
- Perl_croak(aTHX_ "Integer overflow in version");
+ 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);
+ s = end - 1;
+ rev = VERSION_MAX;
+ vinf = 1;
+ }
s++;
if ( *s == '_' )
s++;
}
else {
while (--end >= s) {
- orev = rev;
+ orev = rev;
rev += (*end - '0') * mult;
mult *= 10;
- if ( PERL_ABS(orev) > PERL_ABS(rev) )
- Perl_croak(aTHX_ "Integer overflow in version");
+ 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");
+ end = s - 1;
+ rev = VERSION_MAX;
+ vinf = 1;
+ }
}
}
}
/* Append revision */
av_push(av, newSViv(rev));
- if ( *pos == '.' )
+ if ( vinf ) {
+ s = last;
+ break;
+ }
+ else if ( *pos == '.' )
s = ++pos;
else if ( *pos == '_' && isDIGIT(pos[1]) )
s = ++pos;
av_push(av, newSViv(0));
}
- if ( av_len(av) == -1 ) /* oops, someone forgot to pass a value */
+ /* need to save off the current version string for later */
+ if ( vinf ) {
+ SV * orig = newSVpvn("v.Inf", sizeof("v.Inf")-1);
+ (void)hv_stores((HV *)hv, "original", orig);
+ (void)hv_stores((HV *)hv, "vinf", newSViv(1));
+ }
+ else if ( s > start ) {
+ SV * orig = newSVpvn(start,s-start);
+ if ( qv && saw_period == 1 && *start != 'v' ) {
+ /* need to insert a v to be consistent */
+ sv_insert(orig, 0, 0, "v", 1);
+ }
+ (void)hv_stores((HV *)hv, "original", orig);
+ }
+ else {
+ (void)hv_stores((HV *)hv, "original", newSVpvn("0",1));
av_push(av, newSViv(0));
+ }
+
+ /* And finally, store the AV in the hash */
+ (void)hv_stores((HV *)hv, "version", newRV_noinc((SV *)av));
/* fix RT#19517 - special case 'undef' as string */
if ( *s == 'u' && strEQ(s,"undef") ) {
s += 5;
}
- /* And finally, store the AV in the hash */
- hv_store((HV *)hv, "version", 7, newRV_noinc((SV *)av), 0);
return s;
}
/* 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);
/* Begin copying all of the elements */
if ( hv_exists((HV *)ver, "qv", 2) )
- hv_store((HV *)hv, "qv", 2, &PL_sv_yes, 0);
+ (void)hv_stores((HV *)hv, "qv", newSViv(1));
if ( hv_exists((HV *)ver, "alpha", 5) )
- hv_store((HV *)hv, "alpha", 5, &PL_sv_yes, 0);
+ (void)hv_stores((HV *)hv, "alpha", newSViv(1));
if ( hv_exists((HV*)ver, "width", 5 ) )
{
const I32 width = SvIV(*hv_fetchs((HV*)ver, "width", FALSE));
- hv_store((HV *)hv, "width", 5, newSViv(width), 0);
+ (void)hv_stores((HV *)hv, "width", newSViv(width));
+ }
+
+ if ( hv_exists((HV*)ver, "original", 8 ) )
+ {
+ SV * pv = *hv_fetchs((HV*)ver, "original", FALSE);
+ (void)hv_stores((HV *)hv, "original", newSVsv(pv));
}
sav = (AV *)SvRV(*hv_fetchs((HV*)ver, "version", FALSE));
av_push(av, newSViv(rev));
}
- hv_store((HV *)hv, "version", 7, newRV_noinc((SV *)av), 0);
+ (void)hv_stores((HV *)hv, "version", newRV_noinc((SV *)av));
return rv;
}
#ifdef SvVOK
const STRLEN len = mg->mg_len;
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' )
+ sv_insert(rv, 0, 0, "v", 1);
Safefree(version);
}
else {
}
}
#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");
setlocale(LC_NUMERIC, loc);
#endif
while (tbuf[len-1] == '0' && len > 0) len--;
+ if ( tbuf[len-1] == '.' ) len--; /* eat the trailing decimal */
version = savepvn(tbuf, len);
}
#ifdef SvVOK
#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,"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++;
+ }
+
+ /* is definitely a v-string */
+ if ( saw_period == 2 ) {
+ Safefree(version);
+ version = nver;
+ }
+ }
+# endif
+#endif
}
s = scan_version(version, ver, qv);
SV *
Perl_vstringify(pTHX_ SV *vs)
{
+ SV *pv;
if ( SvROK(vs) )
vs = SvRV(vs);
if ( !vverify(vs) )
Perl_croak(aTHX_ "Invalid version object");
- if ( hv_exists((HV *)vs, "qv", 2) )
- return vnormal(vs);
+ pv = *hv_fetchs((HV*)vs, "original", FALSE);
+ if ( SvPOK(pv) )
+ return newSVsv(pv);
else
- return vnumify(vs);
+ return &PL_sv_undef;
}
/*
PERL_UNUSED_ARG(sv);
}
+/*
+
+=for apidoc sv_destroyable
+
+Dummy routine which reports that object can be destroyed when there is no
+sharing module present. It ignores its single SV argument, and returns
+'true'. Exists to avoid test for a NULL function pointer and because it
+could potentially warn under some level of strict-ness.
+
+=cut
+*/
+
+bool
+Perl_sv_destroyable(pTHX_ SV *sv)
+{
+ PERL_UNUSED_CONTEXT;
+ PERL_UNUSED_ARG(sv);
+ return TRUE;
+}
+
U32
Perl_parse_unicode_opts(pTHX_ const char **popt)
{
#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 */
bsiz = l + 1; /* + 1 for the \0. */
buf = (char*)safesysmalloc(bufsiz);
}
- my_strlcpy(buf, *environ, l + 1);
+ memcpy(buf, *environ, l);
+ buf[l] = '\0';
(void)unsetenv(buf);
}
(void)safesysfree(buf);
}
}
+int
+Perl_my_dirfd(pTHX_ DIR * dir) {
+
+ /* Most dirfd implementations have problems when passed NULL. */
+ if(!dir)
+ return -1;
+#ifdef HAS_DIRFD
+ return dirfd(dir);
+#elif defined(HAS_DIR_DD_FD)
+ return dir->dd_fd;
+#else
+ Perl_die(aTHX_ PL_no_func, "dirfd");
+ /* NOT REACHED */
+ return 0;
+#endif
+}
+
+REGEXP *
+Perl_get_re_arg(pTHX_ SV *sv) {
+ SV *tmpsv;
+
+ if (sv) {
+ if (SvMAGICAL(sv))
+ mg_get(sv);
+ if (SvROK(sv) &&
+ (tmpsv = (SV*)SvRV(sv)) && /* assign deliberate */
+ SvTYPE(tmpsv) == SVt_REGEXP)
+ {
+ return (REGEXP*) tmpsv;
+ }
+ }
+
+ return NULL;
+}
+
/*
* Local variables:
* c-indentation-style: bsd