XPVMG *any;
if (!PL_dirty)
- return sv_2mortal(newSVpvs(""));
+ return newSVpvs_flags("", SVs_TEMP);
if (PL_mess_sv)
return PL_mess_sv;
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)
{
-#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
#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
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++;
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;
}
/* need to save off the current version string for later */
- if ( s > start ) {
+ 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);
}
- hv_store((HV *)hv, "original", 8, orig, 0);
+ (void)hv_stores((HV *)hv, "original", orig);
}
else {
- hv_store((HV *)hv, "original", 8, newSVpvn("0",1), 0);
+ (void)hv_stores((HV *)hv, "original", newSVpvn("0",1));
av_push(av, newSViv(0));
}
/* And finally, store the AV in the hash */
- hv_store((HV *)hv, "version", 7, newRV_noinc((SV *)av), 0);
+ (void)hv_stores((HV *)hv, "version", newRV_noinc((SV *)av));
/* fix RT#19517 - special case 'undef' as string */
if ( *s == 'u' && strEQ(s,"undef") ) {
/* 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);
- hv_store((HV *)hv, "original", 8, newSVsv(pv), 0);
+ (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
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)
{
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);
#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 tmpsv;
+ }
+ }
+
+ return NULL;
+}
+
/*
* Local variables:
* c-indentation-style: bsd