#endif
DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) free\n",PTR2UV(where),(long)PL_an++));
if (where) {
- /*SUPPRESS 701*/
PerlMem_free(where);
}
}
char *
Perl_instr(pTHX_ register const char *big, register const char *little)
{
- register const char *s, *x;
register I32 first;
if (!little)
if (!first)
return (char*)big;
while (*big) {
+ register const char *s, *x;
if (*big++ != first)
continue;
for (x=big,s=little; *s; /**/ ) {
char *
Perl_ninstr(pTHX_ register const char *big, register const char *bigend, const char *little, const char *lend)
{
- register const char *s, *x;
register const I32 first = *little;
register const char *littleend = lend;
return Nullch;
bigend -= littleend - little++;
while (big <= bigend) {
+ register const char *s, *x;
if (*big++ != first)
continue;
for (x=big,s=little; s < littleend; /**/ ) {
Perl_rninstr(pTHX_ register const char *big, const char *bigend, const char *little, const char *lend)
{
register const char *bigbeg;
- register const char *s, *x;
register const I32 first = *little;
register const char *littleend = lend;
bigbeg = big;
big = bigend - (littleend - little++);
while (big >= bigbeg) {
+ register const char *s, *x;
if (*big-- != first)
continue;
for (x=big+2,s=little; s < littleend; /**/ ) {
void
Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
{
- register U8 *s;
- register U8 *table;
+ register const U8 *s;
register U32 i;
STRLEN len;
I32 rarest = 0;
U32 frequency = 256;
if (flags & FBMcf_TAIL) {
- MAGIC *mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
+ MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
sv_catpvn(sv, "\n", 1); /* Taken into account in fbm_instr() */
if (mg && mg->mg_len >= 0)
mg->mg_len++;
}
- s = (U8*)SvPV_force(sv, len);
- (void)SvUPGRADE(sv, SVt_PVBM);
+ s = (U8*)SvPV_force_mutable(sv, len);
+ SvUPGRADE(sv, SVt_PVBM);
if (len == 0) /* TAIL might be on a zero-length string. */
return;
if (len > 2) {
- U8 mlen;
- unsigned char *sb;
+ const unsigned char *sb;
+ const U8 mlen = (len>255) ? 255 : (U8)len;
+ register U8 *table;
- if (len > 255)
- mlen = 255;
- else
- mlen = (U8)len;
Sv_Grow(sv, len + 256 + FBM_TABLE_OFFSET);
- table = (unsigned char*)(SvPVX(sv) + len + FBM_TABLE_OFFSET);
+ table = (unsigned char*)(SvPVX_mutable(sv) + len + FBM_TABLE_OFFSET);
s = table - 1 - FBM_TABLE_OFFSET; /* last char */
memset((void*)table, mlen, 256);
table[-1] = (U8)flags;
sv_magic(sv, Nullsv, PERL_MAGIC_bm, Nullch, 0); /* deep magic */
SvVALID_on(sv);
- s = (unsigned char*)(SvPVX(sv)); /* deeper magic */
+ s = (const unsigned char*)(SvPVX_const(sv)); /* deeper magic */
for (i = 0; i < len; i++) {
if (PL_freq[s[i]] < frequency) {
rarest = i;
{
register unsigned char *s;
STRLEN l;
- register unsigned char *little = (unsigned char *)SvPV(littlestr,l);
+ register const unsigned char *little
+ = (const unsigned char *)SvPV_const(littlestr,l);
register STRLEN littlelen = l;
register const I32 multiline = flags & FBMrf_MULTILINE;
/* This should be better than FBM if c1 == c2, and almost
as good otherwise: maybe better since we do less indirection.
And we save a lot of memory by caching no table. */
- register unsigned char c1 = little[0];
- register unsigned char c2 = little[1];
+ const unsigned char c1 = little[0];
+ const unsigned char c2 = little[1];
s = big + 1;
bigend--;
{ /* Do actual FBM. */
register const unsigned char *table = little + littlelen + FBM_TABLE_OFFSET;
- register unsigned char *oldlittle;
+ register const unsigned char *oldlittle;
if (littlelen > (STRLEN)(bigend - big))
return Nullch;
register I32 tmp;
top2:
- /*SUPPRESS 560*/
if ((tmp = table[*s])) {
if ((s += tmp) < bigend)
goto top2;
goto check_end;
}
else { /* less expensive than calling strncmp() */
- register unsigned char *olds = s;
+ register unsigned char * const olds = s;
tmp = littlelen;
char *
Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last)
{
- register unsigned char *s, *x;
- register unsigned char *big;
+ register const unsigned char *big;
register I32 pos;
register I32 previous;
register I32 first;
- register unsigned char *little;
+ register const unsigned char *little;
register I32 stop_pos;
- register unsigned char *littleend;
+ register const unsigned char *littleend;
I32 found = 0;
if (*old_posp == -1
cant_find:
if ( BmRARE(littlestr) == '\n'
&& BmPREVIOUS(littlestr) == SvCUR(littlestr) - 1) {
- little = (unsigned char *)(SvPVX(littlestr));
+ little = (const unsigned char *)(SvPVX_const(littlestr));
littleend = little + SvCUR(littlestr);
first = *little++;
goto check_tail;
return Nullch;
}
- little = (unsigned char *)(SvPVX(littlestr));
+ 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 = (unsigned char *)(SvPVX(bigstr));
+ 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) {
}
big -= previous;
do {
+ register const unsigned char *s, *x;
if (pos >= stop_pos) break;
if (big[pos] != first)
continue;
if (!SvTAIL(littlestr) || (end_shift > 0))
return Nullch;
/* Ignore the trailing "\n". This code is not microoptimized */
- big = (unsigned char *)(SvPVX(bigstr) + SvCUR(bigstr));
+ big = (const unsigned char *)(SvPVX_const(bigstr) + SvCUR(bigstr));
stop_pos = littleend - little; /* Actual littlestr len */
if (stop_pos == 0)
return (char*)big;
char *
Perl_savepv(pTHX_ const char *pv)
{
- register char *newaddr;
-#ifdef PERL_MALLOC_WRAP
- STRLEN pvlen;
-#endif
if (!pv)
return Nullch;
+ else {
+ char *newaddr;
+ const STRLEN pvlen = strlen(pv)+1;
+ Newx(newaddr,pvlen,char);
+ return memcpy(newaddr,pv,pvlen);
+ }
-#ifdef PERL_MALLOC_WRAP
- pvlen = strlen(pv)+1;
- New(902,newaddr,pvlen,char);
-#else
- New(902,newaddr,strlen(pv)+1,char);
-#endif
- return strcpy(newaddr,pv);
}
/* same thing but with a known length */
{
register char *newaddr;
- New(903,newaddr,len+1,char);
+ Newx(newaddr,len+1,char);
/* Give a meaning to NULL pointer mainly for the use in sv_magic() */
if (pv) {
/* might not be null terminated */
Perl_savesharedpv(pTHX_ const char *pv)
{
register char *newaddr;
+ STRLEN pvlen;
if (!pv)
return Nullch;
- newaddr = (char*)PerlMemShared_malloc(strlen(pv)+1);
+ pvlen = strlen(pv)+1;
+ newaddr = (char*)PerlMemShared_malloc(pvlen);
if (!newaddr) {
PerlLIO_write(PerlIO_fileno(Perl_error_log),
PL_no_mem, strlen(PL_no_mem));
my_exit(1);
}
- return strcpy(newaddr,pv);
+ return memcpy(newaddr,pv,pvlen);
}
/*
Perl_savesvpv(pTHX_ SV *sv)
{
STRLEN len;
- const char *pv = SvPV(sv, len);
+ const char *pv = SvPV_const(sv, len);
register char *newaddr;
++len;
- New(903,newaddr,len,char);
+ Newx(newaddr,len,char);
return (char *) CopyD(pv,newaddr,len,char);
}
return PL_mess_sv;
/* Create as PVMG now, to avoid any upgrading later */
- New(905, sv, 1, SV);
- Newz(905, any, 1, XPVMG);
+ Newx(sv, 1, SV);
+ Newxz(any, 1, XPVMG);
SvFLAGS(sv) = SVt_PVMG;
SvANY(sv) = (void*)any;
SvPV_set(sv, 0);
char *
Perl_vform(pTHX_ const char *pat, va_list *args)
{
- SV *sv = mess_alloc();
+ SV * const sv = mess_alloc();
sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
return SvPVX(sv);
}
}
STATIC COP*
-S_closest_cop(pTHX_ COP *cop, OP *o)
+S_closest_cop(pTHX_ COP *cop, const OP *o)
{
/* Look for PL_op starting from o. cop is the last COP we've seen. */
/* Nothing found. */
- return 0;
+ return Null(COP *);
}
SV *
else {
#ifdef USE_SFIO
/* SFIO can really mess with your errno */
- int e = errno;
+ const int e = errno;
#endif
- PerlIO *serr = Perl_error_log;
+ PerlIO * const serr = Perl_error_log;
PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
(void)PerlIO_flush(serr);
/* Common code used by vcroak, vdie and vwarner */
-void S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8);
-
-STATIC char *
-S_vdie_croak_common(pTHX_ const char* pat, va_list* args, STRLEN* msglen,
- I32* utf8)
-{
- dVAR;
- char *message;
-
- if (pat) {
- SV *msv = vmess(pat, args);
- if (PL_errors && SvCUR(PL_errors)) {
- sv_catsv(PL_errors, msv);
- message = SvPV(PL_errors, *msglen);
- SvCUR_set(PL_errors, 0);
- }
- else
- message = SvPV(msv,*msglen);
- *utf8 = SvUTF8(msv);
- }
- else {
- message = Nullch;
- }
-
- DEBUG_S(PerlIO_printf(Perl_debug_log,
- "%p: die/croak: message = %s\ndiehook = %p\n",
- thr, message, PL_diehook));
- if (PL_diehook) {
- S_vdie_common(aTHX_ message, *msglen, *utf8);
- }
- return message;
-}
-
-void
+STATIC void
S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8)
{
HV *stash;
GV *gv;
CV *cv;
/* sv_2cv might call Perl_croak() */
- SV *olddiehook = PL_diehook;
+ SV * const olddiehook = PL_diehook;
assert(PL_diehook);
ENTER;
}
}
+STATIC const char *
+S_vdie_croak_common(pTHX_ const char* pat, va_list* args, STRLEN* msglen,
+ I32* utf8)
+{
+ dVAR;
+ const char *message;
+
+ if (pat) {
+ SV * const msv = vmess(pat, args);
+ if (PL_errors && SvCUR(PL_errors)) {
+ sv_catsv(PL_errors, msv);
+ message = SvPV_const(PL_errors, *msglen);
+ SvCUR_set(PL_errors, 0);
+ }
+ else
+ message = SvPV_const(msv,*msglen);
+ *utf8 = SvUTF8(msv);
+ }
+ else {
+ message = Nullch;
+ }
+
+ DEBUG_S(PerlIO_printf(Perl_debug_log,
+ "%p: die/croak: message = %s\ndiehook = %p\n",
+ thr, message, PL_diehook));
+ if (PL_diehook) {
+ S_vdie_common(aTHX_ message, *msglen, *utf8);
+ }
+ return message;
+}
+
OP *
Perl_vdie(pTHX_ const char* pat, va_list *args)
{
"%p: die: curstack = %p, mainstack = %p\n",
thr, PL_curstack, PL_mainstack));
- message = S_vdie_croak_common(aTHX_ pat, args, &msglen, &utf8);
+ message = vdie_croak_common(pat, args, &msglen, &utf8);
PL_restartop = die_where(message, msglen);
SvFLAGS(ERRSV) |= utf8;
JMPENV_JUMP(3);
}
else if (!message)
- message = SvPVx(ERRSV, msglen);
+ message = SvPVx_const(ERRSV, msglen);
write_to_stderr(message, msglen);
my_failure_exit();
Perl_vwarn(pTHX_ const char* pat, va_list *args)
{
dVAR;
- char *message;
- HV *stash;
- GV *gv;
- CV *cv;
- SV *msv;
STRLEN msglen;
- I32 utf8 = 0;
-
- msv = vmess(pat, args);
- utf8 = SvUTF8(msv);
- message = SvPV(msv, msglen);
+ SV * const msv = vmess(pat, args);
+ const I32 utf8 = SvUTF8(msv);
+ const char * const message = SvPV_const(msv, msglen);
if (PL_warnhook) {
/* sv_2cv might call Perl_warn() */
- SV *oldwarnhook = PL_warnhook;
+ SV * const oldwarnhook = PL_warnhook;
+ CV * cv;
+ HV * stash;
+ GV * gv;
+
ENTER;
SAVESPTR(PL_warnhook);
PL_warnhook = Nullsv;
SV *msg;
ENTER;
+ SAVESPTR(PL_warnhook);
+ PL_warnhook = Nullsv;
save_re_context();
msg = newSVpvn(message, msglen);
SvFLAGS(msg) |= utf8;
if (ckDEAD(err)) {
SV * const msv = vmess(pat, args);
STRLEN msglen;
- const char *message = SvPV(msv, msglen);
+ const char *message = SvPV_const(msv, msglen);
const I32 utf8 = SvUTF8(msv);
if (PL_diehook) {
}
}
+/* implements the ckWARN? macros */
+
+bool
+Perl_ckwarn(pTHX_ U32 w)
+{
+ return
+ (
+ isLEXWARN_on
+ && PL_curcop->cop_warnings != pWARN_NONE
+ && (
+ PL_curcop->cop_warnings == pWARN_ALL
+ || isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w))
+ || (unpackWARN2(w) &&
+ isWARN_on(PL_curcop->cop_warnings, unpackWARN2(w)))
+ || (unpackWARN3(w) &&
+ isWARN_on(PL_curcop->cop_warnings, unpackWARN3(w)))
+ || (unpackWARN4(w) &&
+ isWARN_on(PL_curcop->cop_warnings, unpackWARN4(w)))
+ )
+ )
+ ||
+ (
+ isLEXWARN_off && PL_dowarn & G_WARN_ON
+ )
+ ;
+}
+
+/* implements the ckWARN?_d macro */
+
+bool
+Perl_ckwarn_d(pTHX_ U32 w)
+{
+ return
+ isLEXWARN_off
+ || PL_curcop->cop_warnings == pWARN_ALL
+ || (
+ PL_curcop->cop_warnings != pWARN_NONE
+ && (
+ isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w))
+ || (unpackWARN2(w) &&
+ isWARN_on(PL_curcop->cop_warnings, unpackWARN2(w)))
+ || (unpackWARN3(w) &&
+ isWARN_on(PL_curcop->cop_warnings, unpackWARN3(w)))
+ || (unpackWARN4(w) &&
+ isWARN_on(PL_curcop->cop_warnings, unpackWARN4(w)))
+ )
+ )
+ ;
+}
+
+
+
/* since we've already done strlen() for both nam and val
* we can use that info to make things faster than
* sprintf(s, "%s=%s", nam, val)
I32 max;
char **tmpenv;
- /*SUPPRESS 530*/
for (max = i; environ[max]; max++) ;
tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*));
for (j=0; j<max; j++) { /* copy environment */
my_setenv_format(environ[i], nam, nlen, val, vlen);
} else {
# endif
-# if defined(__CYGWIN__) || defined(EPOC) || defined(SYMBIAN)
- setenv(nam, val, 1);
+# if defined(__CYGWIN__) || defined(EPOC) || defined(__SYMBIAN32__)
+# if defined(HAS_UNSETENV)
+ if (val == NULL) {
+ (void)unsetenv(nam);
+ } else {
+ (void)setenv(nam, val, 1);
+ }
+# else /* ! HAS_UNSETENV */
+ (void)setenv(nam, val, 1);
+# endif /* HAS_UNSETENV */
# else
- char *new_env;
- int nlen = strlen(nam), vlen;
- if (!val) {
- val = "";
- }
- vlen = strlen(val);
- new_env = (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
- /* all that work just for this */
- my_setenv_format(new_env, nam, nlen, val, vlen);
- (void)putenv(new_env);
+# if defined(HAS_UNSETENV)
+ if (val == NULL) {
+ (void)unsetenv(nam);
+ } else {
+ int nlen = strlen(nam);
+ int vlen = strlen(val);
+ char *new_env =
+ (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
+ my_setenv_format(new_env, nam, nlen, val, vlen);
+ (void)putenv(new_env);
+ }
+# else /* ! HAS_UNSETENV */
+ char *new_env;
+ int nlen = strlen(nam), vlen;
+ if (!val) {
+ val = "";
+ }
+ vlen = strlen(val);
+ new_env = (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
+ /* all that work just for this */
+ my_setenv_format(new_env, nam, nlen, val, vlen);
+ (void)putenv(new_env);
+# endif /* HAS_UNSETENV */
# endif /* __CYGWIN__ */
#ifndef PERL_USE_SAFE_PUTENV
}
val = "";
}
vlen = strlen(val);
- New(904, envstr, nlen+vlen+2, char);
+ Newx(envstr, nlen+vlen+2, char);
my_setenv_format(envstr, nam, nlen, val, vlen);
(void)PerlEnv_putenv(envstr);
Safefree(envstr);
I32
Perl_setenv_getix(pTHX_ const char *nam)
{
- register I32 i, len = strlen(nam);
+ register I32 i;
+ register const I32 len = strlen(nam);
for (i = 0; environ[i]; i++) {
if (
#ifdef UNLINK_ALL_VERSIONS
I32
-Perl_unlnk(pTHX_ char *f) /* unlink all versions of a file */
+Perl_unlnk(pTHX_ const char *f) /* unlink all versions of a file */
{
I32 i;
char *
Perl_my_bcopy(register const char *from,register char *to,register I32 len)
{
- char *retval = to;
+ char * const retval = to;
if (from - to >= 0) {
while (len--)
void *
Perl_my_memset(register char *loc, register I32 ch, register I32 len)
{
- char *retval = loc;
+ char * const retval = loc;
while (len--)
*loc++ = ch;
char *
Perl_my_bzero(register char *loc, register I32 len)
{
- char *retval = loc;
+ char * const retval = loc;
while (len--)
*loc++ = 0;
LOCK_FDPID_MUTEX;
sv = *av_fetch(PL_fdpid,p[This],TRUE);
UNLOCK_FDPID_MUTEX;
- (void)SvUPGRADE(sv,SVt_IV);
+ SvUPGRADE(sv,SVt_IV);
SvIV_set(sv, pid);
PL_forkprocess = pid;
/* If we managed to get status pipe check for exec fail */
/* 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)
PerlIO *
-Perl_my_popen(pTHX_ char *cmd, char *mode)
+Perl_my_popen(pTHX_ const char *cmd, const char *mode)
{
int p[2];
register I32 This, that;
register Pid_t pid;
SV *sv;
- I32 doexec = !(*cmd == '-' && cmd[1] == '\0');
+ const I32 doexec = !(*cmd == '-' && cmd[1] == '\0');
I32 did_pipes = 0;
int pp[2];
PerlProc__exit(1);
}
#endif /* defined OS2 */
- /*SUPPRESS 560*/
if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) {
SvREADONLY_off(GvSV(tmpgv));
sv_setiv(GvSV(tmpgv), PerlProc_getpid());
PL_ppid = (IV)getppid();
#endif
PL_forkprocess = 0;
+#ifdef PERL_USES_PL_PIDSTATUS
hv_clear(PL_pidstatus); /* we have no children */
+#endif
return Nullfp;
#undef THIS
#undef THAT
LOCK_FDPID_MUTEX;
sv = *av_fetch(PL_fdpid,p[This],TRUE);
UNLOCK_FDPID_MUTEX;
- (void)SvUPGRADE(sv,SVt_IV);
+ SvUPGRADE(sv,SVt_IV);
SvIV_set(sv, pid);
PL_forkprocess = pid;
if (did_pipes && pid > 0) {
#ifdef USE_ITHREADS
/* only "parent" interpreter can diddle signals */
if (PL_curinterp != aTHX)
- return SIG_ERR;
+ return (Sighandler_t) SIG_ERR;
#endif
- act.sa_handler = handler;
+ act.sa_handler = (void(*)(int))handler;
sigemptyset(&act.sa_mask);
act.sa_flags = 0;
#ifdef SA_RESTART
act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
#endif
#if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
- if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN)
+ if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
act.sa_flags |= SA_NOCLDWAIT;
#endif
if (sigaction(signo, &act, &oact) == -1)
- return SIG_ERR;
+ return (Sighandler_t) SIG_ERR;
else
- return oact.sa_handler;
+ return (Sighandler_t) oact.sa_handler;
}
Sighandler_t
struct sigaction oact;
if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
- return SIG_ERR;
+ return (Sighandler_t) SIG_ERR;
else
- return oact.sa_handler;
+ return (Sighandler_t) oact.sa_handler;
}
int
return -1;
#endif
- act.sa_handler = handler;
+ act.sa_handler = (void(*)(int))handler;
sigemptyset(&act.sa_mask);
act.sa_flags = 0;
#ifdef SA_RESTART
act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
#endif
#if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
- if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN)
+ if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
act.sa_flags |= SA_NOCLDWAIT;
#endif
return sigaction(signo, &act, save);
#if defined(USE_ITHREADS) && !defined(WIN32)
/* only "parent" interpreter can diddle signals */
if (PL_curinterp != aTHX)
- return SIG_ERR;
+ return (Sighandler_t) SIG_ERR;
#endif
return PerlProc_signal(signo, handler);
#if defined(USE_ITHREADS) && !defined(WIN32)
/* only "parent" interpreter can diddle signals */
if (PL_curinterp != aTHX)
- return SIG_ERR;
+ return (Sighandler_t) SIG_ERR;
#endif
PL_sig_trapped = 0;
return -1;
#endif
*save = PerlProc_signal(signo, handler);
- return (*save == SIG_ERR) ? -1 : 0;
+ return (*save == (Sighandler_t) SIG_ERR) ? -1 : 0;
}
int
if (PL_curinterp != aTHX)
return -1;
#endif
- return (PerlProc_signal(signo, *save) == SIG_ERR) ? -1 : 0;
+ return (PerlProc_signal(signo, *save) == (Sighandler_t) SIG_ERR) ? -1 : 0;
}
#endif /* !HAS_SIGACTION */
Pid_t pid2;
bool close_failed;
int saved_errno = 0;
-#ifdef VMS
- int saved_vaxc_errno;
-#endif
#ifdef WIN32
int saved_win32_errno;
#endif
#endif
if ((close_failed = (PerlIO_close(ptr) == EOF))) {
saved_errno = errno;
-#ifdef VMS
- saved_vaxc_errno = vaxc$errno;
-#endif
#ifdef WIN32
saved_win32_errno = GetLastError();
#endif
if(PerlProc_kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */
#endif
#ifndef PERL_MICRO
- rsignal_save(SIGHUP, SIG_IGN, &hstat);
- rsignal_save(SIGINT, SIG_IGN, &istat);
- rsignal_save(SIGQUIT, SIG_IGN, &qstat);
+ rsignal_save(SIGHUP, (Sighandler_t) SIG_IGN, &hstat);
+ rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &istat);
+ rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qstat);
#endif
do {
pid2 = wait4pid(pid, &status, 0);
rsignal_restore(SIGQUIT, &qstat);
#endif
if (close_failed) {
- SETERRNO(saved_errno, saved_vaxc_errno);
+ SETERRNO(saved_errno, 0);
return -1;
}
return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status));
I32 result = 0;
if (!pid)
return -1;
-#if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME)
+#ifdef PERL_USES_PL_PIDSTATUS
{
char spid[TYPE_CHARS(IV)];
if (pid > 0) {
SV** svp;
- sprintf(spid, "%"IVdf, (IV)pid);
- svp = hv_fetch(PL_pidstatus,spid,strlen(spid),FALSE);
+ const I32 len = my_sprintf(spid, "%"IVdf, (IV)pid);
+
+ svp = hv_fetch(PL_pidstatus,spid,len,FALSE);
if (svp && *svp != &PL_sv_undef) {
*statusp = SvIVX(*svp);
(void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD);
hv_iterinit(PL_pidstatus);
if ((entry = hv_iternext(PL_pidstatus))) {
SV *sv = hv_iterval(PL_pidstatus,entry);
+ I32 len;
pid = atoi(hv_iterkey(entry,(I32*)statusp));
*statusp = SvIVX(sv);
- sprintf(spid, "%"IVdf, (IV)pid);
- (void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD);
+ len = my_sprintf(spid, "%"IVdf, (IV)pid);
+ /* The hash iterator is currently on this entry, so simply
+ calling hv_delete would trigger the lazy delete, which on
+ aggregate does more work, beacuse next call to hv_iterinit()
+ would spot the flag, and have to call the delete routine,
+ while in the meantime any new entries can't re-use that
+ memory. */
+ hv_iterinit(PL_pidstatus);
+ (void)hv_delete(PL_pidstatus,spid,len,G_DISCARD);
return pid;
}
}
result = wait4((pid==-1)?0:pid,statusp,flags,Null(struct rusage *));
goto finish;
#endif
-#if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME)
+#ifdef PERL_USES_PL_PIDSTATUS
#if defined(HAS_WAITPID) && defined(HAS_WAITPID_RUNTIME)
hard_way:
#endif
}
#endif /* !DOSISH || OS2 || WIN32 || NETWARE */
+#ifdef PERL_USES_PL_PIDSTATUS
void
-/*SUPPRESS 590*/
Perl_pidgone(pTHX_ Pid_t pid, int status)
{
register SV *sv;
char spid[TYPE_CHARS(IV)];
+ const size_t len = my_sprintf(spid, "%"IVdf, (IV)pid);
- sprintf(spid, "%"IVdf, (IV)pid);
- sv = *hv_fetch(PL_pidstatus,spid,strlen(spid),TRUE);
- (void)SvUPGRADE(sv,SVt_IV);
+ sv = *hv_fetch(PL_pidstatus,spid,len,TRUE);
+ SvUPGRADE(sv,SVt_IV);
SvIV_set(sv, status);
return;
}
+#endif
#if defined(atarist) || defined(OS2) || defined(EPOC)
int pclose();
#endif /* !HAS_RENAME */
char*
-Perl_find_script(pTHX_ const char *scriptname, bool dosearch, const char **search_ext, I32 flags)
+Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
+ const char *const *const search_ext, I32 flags)
{
const char *xfound = Nullch;
char *xfailed = Nullch;
#endif
/* additional extensions to try in each dir if scriptname not found */
#ifdef SEARCH_EXTS
- const char *exts[] = { SEARCH_EXTS };
- const char **ext = search_ext ? search_ext : exts;
+ const char *const exts[] = { SEARCH_EXTS };
+ const char *const *const ext = search_ext ? search_ext : exts;
int extidx = 0, i = 0;
const char *curext = Nullch;
#else
- (void)search_ext;
+ PERL_UNUSED_ARG(search_ext);
# define MAX_EXT_LEN 0
#endif
len = strlen(scriptname);
if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
break;
+ /* FIXME? Convert to memcpy */
cur = strcpy(tmpbuf, scriptname);
}
} while (extidx >= 0 && ext[extidx] /* try an extension? */
tmpbuf[len++] = ':';
#else
if (len
-#if defined(atarist) || defined(__MINT__) || defined(DOSISH)
+# if defined(atarist) || defined(__MINT__) || defined(DOSISH)
&& tmpbuf[len - 1] != '/'
&& tmpbuf[len - 1] != '\\'
-#endif
+# endif
)
tmpbuf[len++] = '/';
if (len == 2 && tmpbuf[0] == '.')
seen_dot = 1;
#endif
+ /* FIXME? Convert to memcpy by storing previous strlen(scriptname)
+ */
(void)strcpy(tmpbuf + len, scriptname);
#endif /* !VMS */
}
scriptname = Nullch;
}
- if (xfailed)
- Safefree(xfailed);
+ Safefree(xfailed);
scriptname = xfound;
}
return (scriptname ? savepv(scriptname) : Nullch);
void
Perl_set_context(void *t)
{
- dVAR;
+ dVAR;
#if defined(USE_ITHREADS)
# ifdef I_MACH_CTHREADS
cthread_set_data(cthread_self(), t);
Perl_croak_nocontext("panic: pthread_setspecific");
# endif
#else
- (void)t;
+ PERL_UNUSED_ARG(t);
#endif
}
char *
Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
{
- char *env_trans = PerlEnv_getenv(env_elem);
+ char * const env_trans = PerlEnv_getenv(env_elem);
if (env_trans)
*len = strlen(env_trans);
return env_trans;
void
Perl_report_evil_fh(pTHX_ const GV *gv, const IO *io, I32 op)
{
- const char *func =
+ const char * const func =
op == OP_READLINE ? "readline" : /* "<HANDLE>" not nice */
op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */
PL_op_desc[op];
- const char *pars = OP_IS_FILETEST(op) ? "" : "()";
- const char *type = OP_IS_SOCKET(op)
+ const char * const pars = OP_IS_FILETEST(op) ? "" : "()";
+ const char * const type = OP_IS_SOCKET(op)
|| (gv && io && IoTYPE(io) == IoTYPE_SOCKET)
? "socket" : "filehandle";
- const char *name = NULL;
-
- if (gv && isGV(gv)) {
- name = GvENAME(gv);
- }
+ const char * const name = gv && isGV(gv) ? GvENAME(gv) : NULL;
if (op == OP_phoney_OUTPUT_ONLY || op == OP_phoney_INPUT_ONLY) {
if (ckWARN(WARN_IO)) {
- const char *direction = (op == OP_phoney_INPUT_ONLY) ? "in" : "out";
+ const char * const direction = (op == OP_phoney_INPUT_ONLY) ? "in" : "out";
if (name && *name)
Perl_warner(aTHX_ packWARN(WARN_IO),
"Filehandle %s opened only for %sput",
{
#ifdef HAS_TM_TM_ZONE
Time_t now;
- struct tm* my_tm;
+ const struct tm* my_tm;
(void)time(&now);
my_tm = localtime(&now);
if (my_tm)
Copy(my_tm, ptm, 1, struct tm);
+#else
+ PERL_UNUSED_ARG(ptm);
#endif
}
} STMT_END;
#endif
buflen = 64;
- New(0, buf, buflen, char);
+ Newx(buf, buflen, char);
len = strftime(buf, buflen, fmt, &mytm);
/*
** The following is needed to handle to the situation where
const int fmtlen = strlen(fmt);
const int bufsize = fmtlen + buflen;
- New(0, buf, bufsize, char);
+ Newx(buf, bufsize, char);
while (buf) {
buflen = strftime(buf, bufsize, fmt, &mytm);
if (buflen > 0 && buflen < bufsize)
int pathlen=0;
Direntry_t *dp;
- (void)SvUPGRADE(sv, SVt_PV);
+ SvUPGRADE(sv, SVt_PV);
if (PerlLIO_lstat(".", &statbuf) < 0) {
SV_CWD_RETURN_UNDEF;
=cut
*/
-char *
+const char *
Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
{
- const char *start = s;
- const char *pos = s;
- I32 saw_period = 0;
- bool saw_under = 0;
- SV* sv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
- (void)sv_upgrade(sv, SVt_PVAV); /* needs to be an AV type */
- AvREAL_on((AV*)sv);
-
- /* pre-scan the imput string to check for decimals */
+ const char *start;
+ const char *pos;
+ const char *last;
+ int saw_period = 0;
+ int alpha = 0;
+ int width = 3;
+ AV *av = newAV();
+ SV *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 (*s == 'v') {
+ s++; /* get past 'v' */
+ qv = 1; /* force quoted version processing */
+ }
+
+ start = last = pos = s;
+
+ /* pre-scan the input string to check for decimals/underbars */
while ( *pos == '.' || *pos == '_' || isDIGIT(*pos) )
{
if ( *pos == '.' )
{
- if ( saw_under )
+ if ( alpha )
Perl_croak(aTHX_ "Invalid version format (underscores before decimal)");
saw_period++ ;
+ last = pos;
}
else if ( *pos == '_' )
{
- if ( saw_under )
+ if ( alpha )
Perl_croak(aTHX_ "Invalid version format (multiple underscores)");
- saw_under = 1;
+ alpha = 1;
+ width = pos - last - 1; /* natural width of sub-version */
}
pos++;
}
- pos = s;
- if (*pos == 'v') {
- pos++; /* get past 'v' */
+ if ( saw_period > 1 )
qv = 1; /* force quoted version processing */
- }
+
+ pos = s;
+
+ if ( qv )
+ hv_store((HV *)hv, "qv", 2, newSViv(qv), 0);
+ if ( alpha )
+ hv_store((HV *)hv, "alpha", 5, newSViv(alpha), 0);
+ if ( !qv && width < 3 )
+ hv_store((HV *)hv, "width", 5, newSViv(width), 0);
+
while (isDIGIT(*pos))
pos++;
if (!isALPHA(*pos)) {
I32 rev;
- if (*s == 'v') s++; /* get past 'v' */
-
for (;;) {
rev = 0;
{
/* this is atoi() that delimits on underscores */
- const char *end = pos;
+ const char *end = pos;
I32 mult = 1;
I32 orev;
- if ( s < pos && s > start && *(s-1) == '_' ) {
- mult *= -1; /* alpha version */
- }
+
/* the following if() will only be true after the decimal
* point of a version originally created with a bare
* floating point number, i.e. not quoted in any way
*/
- if ( !qv && s > start+1 && saw_period == 1 ) {
+ if ( !qv && s > start && saw_period == 1 ) {
mult *= 100;
while ( s < end ) {
orev = rev;
if ( PERL_ABS(orev) > PERL_ABS(rev) )
Perl_croak(aTHX_ "Integer overflow in version");
s++;
+ if ( *s == '_' )
+ s++;
}
}
else {
}
}
}
-
+
/* Append revision */
- av_push((AV *)sv, newSViv(rev));
- if ( (*pos == '.' || *pos == '_') && isDIGIT(pos[1]))
+ av_push(av, newSViv(rev));
+ if ( *pos == '.' && isDIGIT(pos[1]) )
+ s = ++pos;
+ else if ( *pos == '_' && isDIGIT(pos[1]) )
s = ++pos;
else if ( isDIGIT(*pos) )
s = pos;
s = pos;
break;
}
- while ( isDIGIT(*pos) ) {
- if ( saw_period == 1 && pos-s == 3 )
- break;
- pos++;
+ if ( qv ) {
+ while ( isDIGIT(*pos) )
+ pos++;
+ }
+ else {
+ int digits = 0;
+ while ( ( isDIGIT(*pos) || *pos == '_' ) && digits < 3 ) {
+ if ( *pos != '_' )
+ digits++;
+ pos++;
+ }
}
}
}
- if ( qv ) { /* quoted versions always become full version objects */
- I32 len = av_len((AV *)sv);
+ if ( qv ) { /* quoted versions always get at least three terms*/
+ I32 len = av_len(av);
/* This for loop appears to trigger a compiler bug on OS X, as it
loops infinitely. Yes, len is negative. No, it makes no sense.
Compiler in question is:
*/
len = 2 - len;
while (len-- > 0)
- av_push((AV *)sv, newSViv(0));
+ av_push(av, newSViv(0));
}
- return (char *)s;
+
+ if ( av_len(av) == -1 ) /* oops, someone forgot to pass a value */
+ av_push(av, newSViv(0));
+
+ /* And finally, store the AV in the hash */
+ hv_store((HV *)hv, "version", 7, newRV_noinc((SV *)av), 0);
+ return s;
}
/*
SV *
Perl_new_version(pTHX_ SV *ver)
{
- SV *rv = newSV(0);
+ SV * const rv = newSV(0);
if ( sv_derived_from(ver,"version") ) /* can just copy directly */
{
I32 key;
- AV *av = (AV *)SvRV(ver);
- SV* sv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
- (void)sv_upgrade(sv, SVt_PVAV); /* needs to be an AV type */
- AvREAL_on((AV*)sv);
- for ( key = 0; key <= av_len(av); key++ )
+ AV * const av = newAV();
+ AV *sav;
+ /* 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);
+
+ if ( hv_exists((HV *)ver, "alpha", 5) )
+ hv_store((HV *)hv, "alpha", 5, &PL_sv_yes, 0);
+
+ if ( hv_exists((HV*)ver, "width", 5 ) )
{
- const I32 rev = SvIV(*av_fetch(av, key, FALSE));
- av_push((AV *)sv, newSViv(rev));
+ const I32 width = SvIV(*hv_fetch((HV*)ver, "width", 5, FALSE));
+ hv_store((HV *)hv, "width", 5, newSViv(width), 0);
}
+
+ sav = (AV *)SvRV(*hv_fetch((HV*)ver, "version", 7, FALSE));
+ /* This will get reblessed later if a derived class*/
+ for ( key = 0; key <= av_len(sav); key++ )
+ {
+ const I32 rev = SvIV(*av_fetch(sav, key, FALSE));
+ av_push(av, newSViv(rev));
+ }
+
+ hv_store((HV *)hv, "version", 7, newRV_noinc((SV *)av), 0);
return rv;
}
#ifdef SvVOK
if ( SvVOK(ver) ) { /* already a v-string */
- char *version;
- MAGIC* mg = mg_find(ver,PERL_MAGIC_vstring);
- version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
- sv_setpv(rv,version);
+ const MAGIC* const mg = mg_find(ver,PERL_MAGIC_vstring);
+ const STRLEN len = mg->mg_len;
+ char * const version = savepvn( (const char*)mg->mg_ptr, len);
+ sv_setpvn(rv,version,len);
Safefree(version);
}
else {
}
#ifdef SvVOK
else if ( SvVOK(ver) ) { /* already a v-string */
- MAGIC* mg = mg_find(ver,PERL_MAGIC_vstring);
+ const MAGIC* const mg = mg_find(ver,PERL_MAGIC_vstring);
version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
qv = 1;
}
#endif
else /* must be a string or something like a string */
{
- version = savesvpv(ver);
+ version = savepv(SvPV_nolen(ver));
}
(void)scan_version(version, ver, qv);
Safefree(version);
return ver;
}
+/*
+=for apidoc vverify
+
+Validates that the SV contains a valid version object.
+
+ bool vverify(SV *vobj);
+
+Note that it only confirms the bare minimum structure (so as not to get
+confused by derived classes which may contain additional hash entries):
+
+=over 4
+
+=item * The SV contains a [reference to a] hash
+
+=item * The hash contains a "version" key
+
+=item * The "version" key has [a reference to] an AV as its value
+
+=back
+
+=cut
+*/
+
+bool
+Perl_vverify(pTHX_ SV *vs)
+{
+ SV *sv;
+ if ( SvROK(vs) )
+ vs = SvRV(vs);
+
+ /* see if the appropriate elements exist */
+ if ( SvTYPE(vs) == SVt_PVHV
+ && hv_exists((HV*)vs, "version", 7)
+ && (sv = SvRV(*hv_fetch((HV*)vs, "version", 7, FALSE)))
+ && SvTYPE(sv) == SVt_PVAV )
+ return TRUE;
+ else
+ return FALSE;
+}
/*
=for apidoc vnumify
Perl_vnumify(pTHX_ SV *vs)
{
I32 i, len, digit;
- SV *sv = newSV(0);
+ int width;
+ bool alpha = FALSE;
+ SV * const sv = newSV(0);
+ AV *av;
if ( SvROK(vs) )
vs = SvRV(vs);
- len = av_len((AV *)vs);
+
+ if ( !vverify(vs) )
+ Perl_croak(aTHX_ "Invalid version object");
+
+ /* see if various flags exist */
+ if ( hv_exists((HV*)vs, "alpha", 5 ) )
+ alpha = TRUE;
+ if ( hv_exists((HV*)vs, "width", 5 ) )
+ width = SvIV(*hv_fetch((HV*)vs, "width", 5, FALSE));
+ else
+ width = 3;
+
+
+ /* attempt to retrieve the version array */
+ if ( !(av = (AV *)SvRV(*hv_fetch((HV*)vs, "version", 7, FALSE)) ) ) {
+ sv_catpvn(sv,"0",1);
+ return sv;
+ }
+
+ len = av_len(av);
if ( len == -1 )
{
- Perl_sv_catpv(aTHX_ sv,"0");
+ sv_catpvn(sv,"0",1);
return sv;
}
- digit = SvIVX(*av_fetch((AV *)vs, 0, 0));
- Perl_sv_setpvf(aTHX_ sv,"%d.", (int)PERL_ABS(digit));
+
+ digit = SvIV(*av_fetch(av, 0, 0));
+ Perl_sv_setpvf(aTHX_ sv, "%d.", (int)PERL_ABS(digit));
for ( i = 1 ; i < len ; i++ )
{
- digit = SvIVX(*av_fetch((AV *)vs, i, 0));
- Perl_sv_catpvf(aTHX_ sv,"%03d", (int)PERL_ABS(digit));
+ digit = SvIV(*av_fetch(av, i, 0));
+ if ( width < 3 ) {
+ const int denom = (int)pow(10,(3-width));
+ const div_t term = div((int)PERL_ABS(digit),denom);
+ Perl_sv_catpvf(aTHX_ sv, "%0*d_%d", width, term.quot, term.rem);
+ }
+ else {
+ Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
+ }
}
if ( len > 0 )
{
- digit = SvIVX(*av_fetch((AV *)vs, len, 0));
- if ( (int)PERL_ABS(digit) != 0 || len == 1 )
- {
- if ( digit < 0 ) /* alpha version */
- Perl_sv_catpv(aTHX_ sv,"_");
- /* Don't display additional trailing zeros */
- Perl_sv_catpvf(aTHX_ sv,"%03d", (int)PERL_ABS(digit));
- }
+ digit = SvIV(*av_fetch(av, len, 0));
+ if ( alpha && width == 3 ) /* alpha version */
+ sv_catpvn(sv,"_",1);
+ Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
}
else /* len == 0 */
{
- Perl_sv_catpv(aTHX_ sv,"000");
+ sv_catpvn(sv,"000",3);
}
return sv;
}
Perl_vnormal(pTHX_ SV *vs)
{
I32 i, len, digit;
- SV *sv = newSV(0);
+ bool alpha = FALSE;
+ SV * const sv = newSV(0);
+ AV *av;
if ( SvROK(vs) )
vs = SvRV(vs);
- len = av_len((AV *)vs);
+
+ if ( !vverify(vs) )
+ Perl_croak(aTHX_ "Invalid version object");
+
+ if ( hv_exists((HV*)vs, "alpha", 5 ) )
+ alpha = TRUE;
+ av = (AV *)SvRV(*hv_fetch((HV*)vs, "version", 7, FALSE));
+
+ len = av_len(av);
if ( len == -1 )
{
- Perl_sv_catpv(aTHX_ sv,"");
+ sv_catpvn(sv,"",0);
return sv;
}
- digit = SvIVX(*av_fetch((AV *)vs, 0, 0));
- Perl_sv_setpvf(aTHX_ sv,"%"IVdf,(IV)digit);
- for ( i = 1 ; i <= len ; i++ )
+ digit = SvIV(*av_fetch(av, 0, 0));
+ Perl_sv_setpvf(aTHX_ sv, "v%"IVdf, (IV)digit);
+ for ( i = 1 ; i < len ; i++ ) {
+ digit = SvIV(*av_fetch(av, i, 0));
+ Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
+ }
+
+ if ( len > 0 )
{
- digit = SvIVX(*av_fetch((AV *)vs, i, 0));
- if ( digit < 0 )
- Perl_sv_catpvf(aTHX_ sv,"_%"IVdf,(IV)-digit);
+ /* handle last digit specially */
+ digit = SvIV(*av_fetch(av, len, 0));
+ if ( alpha )
+ Perl_sv_catpvf(aTHX_ sv, "_%"IVdf, (IV)digit);
else
- Perl_sv_catpvf(aTHX_ sv,".%"IVdf,(IV)digit);
+ Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
}
-
+
if ( len <= 2 ) { /* short version, must be at least three */
for ( len = 2 - len; len != 0; len-- )
- Perl_sv_catpv(aTHX_ sv,".0");
+ sv_catpvn(sv,".0",2);
}
-
return sv;
-}
+}
/*
=for apidoc vstringify
SV *
Perl_vstringify(pTHX_ SV *vs)
{
- I32 len, digit;
if ( SvROK(vs) )
vs = SvRV(vs);
- len = av_len((AV *)vs);
- digit = SvIVX(*av_fetch((AV *)vs, len, 0));
- if ( len < 2 || ( len == 2 && digit < 0 ) )
- return vnumify(vs);
- else
+ if ( !vverify(vs) )
+ Perl_croak(aTHX_ "Invalid version object");
+
+ if ( hv_exists((HV *)vs, "qv", 2) )
return vnormal(vs);
+ else
+ return vnumify(vs);
}
/*
*/
int
-Perl_vcmp(pTHX_ SV *lsv, SV *rsv)
+Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
{
I32 i,l,m,r,retval;
- if ( SvROK(lsv) )
- lsv = SvRV(lsv);
- if ( SvROK(rsv) )
- rsv = SvRV(rsv);
- l = av_len((AV *)lsv);
- r = av_len((AV *)rsv);
+ bool lalpha = FALSE;
+ bool ralpha = FALSE;
+ I32 left = 0;
+ I32 right = 0;
+ AV *lav, *rav;
+ if ( SvROK(lhv) )
+ lhv = SvRV(lhv);
+ if ( SvROK(rhv) )
+ rhv = SvRV(rhv);
+
+ if ( !vverify(lhv) )
+ Perl_croak(aTHX_ "Invalid version object");
+
+ if ( !vverify(rhv) )
+ Perl_croak(aTHX_ "Invalid version object");
+
+ /* get the left hand term */
+ lav = (AV *)SvRV(*hv_fetch((HV*)lhv, "version", 7, FALSE));
+ if ( hv_exists((HV*)lhv, "alpha", 5 ) )
+ lalpha = TRUE;
+
+ /* and the right hand term */
+ rav = (AV *)SvRV(*hv_fetch((HV*)rhv, "version", 7, FALSE));
+ if ( hv_exists((HV*)rhv, "alpha", 5 ) )
+ ralpha = TRUE;
+
+ l = av_len(lav);
+ r = av_len(rav);
m = l < r ? l : r;
retval = 0;
i = 0;
while ( i <= m && retval == 0 )
{
- I32 left = SvIV(*av_fetch((AV *)lsv,i,0));
- I32 right = SvIV(*av_fetch((AV *)rsv,i,0));
- bool lalpha = left < 0 ? 1 : 0;
- bool ralpha = right < 0 ? 1 : 0;
- left = abs(left);
- right = abs(right);
- if ( left < right || (left == right && lalpha && !ralpha) )
+ left = SvIV(*av_fetch(lav,i,0));
+ right = SvIV(*av_fetch(rav,i,0));
+ if ( left < right )
retval = -1;
- if ( left > right || (left == right && ralpha && !lalpha) )
+ if ( left > right )
retval = +1;
i++;
}
+ /* tiebreaker for alpha with identical terms */
+ if ( retval == 0 && l == r && left == right && ( lalpha || ralpha ) )
+ {
+ if ( lalpha && !ralpha )
+ {
+ retval = -1;
+ }
+ else if ( ralpha && !lalpha)
+ {
+ retval = +1;
+ }
+ }
+
if ( l != r && retval == 0 ) /* possible match except for trailing 0's */
{
if ( l < r )
{
while ( i <= r && retval == 0 )
{
- if ( SvIV(*av_fetch((AV *)rsv,i,0)) != 0 )
+ if ( SvIV(*av_fetch(rav,i,0)) != 0 )
retval = -1; /* not a match after all */
i++;
}
{
while ( i <= l && retval == 0 )
{
- if ( SvIV(*av_fetch((AV *)lsv,i,0)) != 0 )
+ if ( SvIV(*av_fetch(lav,i,0)) != 0 )
retval = +1; /* not a match after all */
i++;
}
void
Perl_sv_nosharing(pTHX_ SV *sv)
{
- (void)sv;
+ PERL_UNUSED_ARG(sv);
}
/*
void
Perl_sv_nolocking(pTHX_ SV *sv)
{
- (void)sv;
+ PERL_UNUSED_ARG(sv);
}
void
Perl_sv_nounlocking(pTHX_ SV *sv)
{
- (void)sv;
+ PERL_UNUSED_ARG(sv);
}
U32
return myseed;
}
+#ifdef USE_ITHREADS
+bool
+Perl_stashpv_hvname_match(pTHX_ const COP *c, const HV *hv)
+{
+ const char * const stashpv = CopSTASHPV(c);
+ const char * const name = HvNAME_get(hv);
+
+ if (stashpv == name)
+ return TRUE;
+ if (stashpv && name)
+ if (strEQ(stashpv, name))
+ return TRUE;
+ return FALSE;
+}
+#endif
+
+
#ifdef PERL_GLOBAL_STRUCT
struct perl_vars *
#endif /* PERL_GLOBAL_STRUCT */
+#ifdef PERL_MEM_LOG
+
+#define PERL_MEM_LOG_SPRINTF_BUF_SIZE 128
+
+Malloc_t
+Perl_mem_log_alloc(const UV n, const UV typesize, const char *typename, Malloc_t newalloc, const char *filename, const int linenumber, const char *funcname)
+{
+#ifdef PERL_MEM_LOG_STDERR
+ /* We can't use PerlIO for obvious reasons. */
+ char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
+ sprintf(buf,
+ "alloc: %s:%d:%s: %"IVdf" %"UVuf" %s = %"IVdf": %"UVxf"\n",
+ filename, linenumber, funcname,
+ n, typesize, typename, n * typesize, PTR2UV(newalloc));
+ PerlLIO_write(2, buf, strlen(buf));
+#endif
+ return newalloc;
+}
+
+Malloc_t
+Perl_mem_log_realloc(const UV n, const UV typesize, const char *typename, Malloc_t oldalloc, Malloc_t newalloc, const char *filename, const int linenumber, const char *funcname)
+{
+#ifdef PERL_MEM_LOG_STDERR
+ /* We can't use PerlIO for obvious reasons. */
+ char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
+ sprintf(buf,
+ "realloc: %s:%d:%s: %"IVdf" %"UVuf" %s = %"IVdf": %"UVxf" -> %"UVxf"\n",
+ filename, linenumber, funcname,
+ n, typesize, typename, n * typesize, PTR2UV(oldalloc), PTR2UV(newalloc));
+ PerlLIO_write(2, buf, strlen(buf));
+#endif
+ return newalloc;
+}
+
+Malloc_t
+Perl_mem_log_free(Malloc_t oldalloc, const char *filename, const int linenumber, const char *funcname)
+{
+#ifdef PERL_MEM_LOG_STDERR
+ /* We can't use PerlIO for obvious reasons. */
+ char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
+ sprintf(buf, "free: %s:%d:%s: %"UVxf"\n",
+ filename, linenumber, funcname, PTR2UV(oldalloc));
+ PerlLIO_write(2, buf, strlen(buf));
+#endif
+ return oldalloc;
+}
+
+#endif /* PERL_MEM_LOG */
+
+/*
+=for apidoc my_sprintf
+
+The C library C<sprintf>, wrapped if necessary, to ensure that it will return
+the length of the string written to the buffer. Only rare pre-ANSI systems
+need the wrapper function - usually this is a direct call to C<sprintf>.
+
+=cut
+*/
+#ifndef SPRINTF_RETURNS_STRLEN
+int
+Perl_my_sprintf(char *buffer, const char* pat, ...)
+{
+ va_list args;
+ va_start(args, pat);
+ vsprintf(buffer, pat, args);
+ va_end(args);
+ return strlen(buffer);
+}
+#endif
+
/*
* Local variables:
* c-indentation-style: bsd
https://perl5.git.perl.org / perl5.git / blobdiff