X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/5f89c282eacf9ef123bf0b311fb4124e837004d7..f337b084e4f053c4222a0b9a773a9e12c0232e6d:/util.c diff --git a/util.c b/util.c index 90a0e91..fc99463 100644 --- a/util.c +++ b/util.c @@ -1,6 +1,7 @@ /* util.c * - * Copyright (c) 1991-2002, Larry Wall + * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, + * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -12,15 +13,18 @@ * not content." --Gandalf */ +/* This file contains assorted utility routines. + * Which is a polite way of saying any stuff that people couldn't think of + * a better place for. Amongst other things, it includes the warning and + * dieing stuff, plus wrappers for malloc code. + */ + #include "EXTERN.h" #define PERL_IN_UTIL_C #include "perl.h" #ifndef PERL_MICRO -#if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX) #include -#endif - #ifndef SIG_ERR # define SIG_ERR ((Sighandler_t) -1) #endif @@ -74,7 +78,9 @@ Perl_safesysmalloc(MEM_SIZE size) else if (PL_nomemok) return Nullch; else { - PerlIO_puts(Perl_error_log,PL_no_mem) FLUSH; + /* Can't use PerlIO to write as it allocates memory */ + PerlLIO_write(PerlIO_fileno(Perl_error_log), + PL_no_mem, strlen(PL_no_mem)); my_exit(1); return Nullch; } @@ -121,7 +127,9 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size) else if (PL_nomemok) return Nullch; else { - PerlIO_puts(Perl_error_log,PL_no_mem) FLUSH; + /* Can't use PerlIO to write as it allocates memory */ + PerlLIO_write(PerlIO_fileno(Perl_error_log), + PL_no_mem, strlen(PL_no_mem)); my_exit(1); return Nullch; } @@ -173,7 +181,9 @@ Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size) else if (PL_nomemok) return Nullch; else { - PerlIO_puts(Perl_error_log,PL_no_mem) FLUSH; + /* Can't use PerlIO to write as it allocates memory */ + PerlLIO_write(PerlIO_fileno(Perl_error_log), + PL_no_mem, strlen(PL_no_mem)); my_exit(1); return Nullch; } @@ -357,8 +367,12 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags) I32 rarest = 0; U32 frequency = 256; - if (flags & FBMcf_TAIL) + if (flags & FBMcf_TAIL) { + MAGIC *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); if (len == 0) /* TAIL might be on a zero-length string. */ @@ -743,12 +757,20 @@ be freed with the C function. char * Perl_savepv(pTHX_ const char *pv) { - register char *newaddr = Nullch; - if (pv) { - New(902,newaddr,strlen(pv)+1,char); - (void)strcpy(newaddr,pv); - } - return newaddr; + register char *newaddr; +#ifdef PERL_MALLOC_WRAP + STRLEN pvlen; +#endif + if (!pv) + return Nullch; + +#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 */ @@ -772,13 +794,13 @@ Perl_savepvn(pTHX_ const char *pv, register I32 len) New(903,newaddr,len+1,char); /* Give a meaning to NULL pointer mainly for the use in sv_magic() */ if (pv) { - Copy(pv,newaddr,len,char); /* might not be null terminated */ - newaddr[len] = '\0'; /* is now */ + /* might not be null terminated */ + newaddr[len] = '\0'; + return CopyD(pv,newaddr,len,char); } else { - Zero(newaddr,len+1,char); + return ZeroD(newaddr,len+1,char); } - return newaddr; } /* @@ -792,14 +814,39 @@ which is shared between threads. char * Perl_savesharedpv(pTHX_ const char *pv) { - register char *newaddr = Nullch; - if (pv) { - newaddr = (char*)PerlMemShared_malloc(strlen(pv)+1); - (void)strcpy(newaddr,pv); + register char *newaddr; + if (!pv) + return Nullch; + + newaddr = (char*)PerlMemShared_malloc(strlen(pv)+1); + if (!newaddr) { + PerlLIO_write(PerlIO_fileno(Perl_error_log), + PL_no_mem, strlen(PL_no_mem)); + my_exit(1); } - return newaddr; + return strcpy(newaddr,pv); } +/* +=for apidoc savesvpv + +A version of C/C which gets the string to duplicate from +the passed in SV using C + +=cut +*/ + +char * +Perl_savesvpv(pTHX_ SV *sv) +{ + STRLEN len; + const char *pv = SvPV(sv, len); + register char *newaddr; + + ++len; + New(903,newaddr,len,char); + return CopyD(pv,newaddr,len,char); +} /* the SV for Perl_form() and mess() is not kept in an arena */ @@ -967,82 +1014,148 @@ Perl_vmess(pTHX_ const char *pat, va_list *args) line_mode ? "line" : "chunk", (IV)IoLINES(GvIOp(PL_last_in_gv))); } -#ifdef USE_5005THREADS - if (thr->tid) - Perl_sv_catpvf(aTHX_ sv, " thread %ld", thr->tid); -#endif sv_catpv(sv, PL_dirty ? dgd : ".\n"); } return sv; } -OP * -Perl_vdie(pTHX_ const char* pat, va_list *args) +void +Perl_write_to_stderr(pTHX_ const char* message, int msglen) { - char *message; - int was_in_eval = PL_in_eval; - HV *stash; - GV *gv; - CV *cv; - SV *msv; - STRLEN msglen; + IO *io; + MAGIC *mg; - DEBUG_S(PerlIO_printf(Perl_debug_log, - "%p: die: curstack = %p, mainstack = %p\n", - thr, PL_curstack, PL_mainstack)); + if (PL_stderrgv && SvREFCNT(PL_stderrgv) + && (io = GvIO(PL_stderrgv)) + && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) + { + dSP; + ENTER; + SAVETMPS; + + save_re_context(); + SAVESPTR(PL_stderrgv); + PL_stderrgv = Nullgv; + + PUSHSTACKi(PERLSI_MAGIC); + + PUSHMARK(SP); + EXTEND(SP,2); + PUSHs(SvTIED_obj((SV*)io, mg)); + PUSHs(sv_2mortal(newSVpvn(message, msglen))); + PUTBACK; + call_method("PRINT", G_SCALAR); + + POPSTACK; + FREETMPS; + LEAVE; + } + else { +#ifdef USE_SFIO + /* SFIO can really mess with your errno */ + int e = errno; +#endif + PerlIO *serr = Perl_error_log; + + PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen); + (void)PerlIO_flush(serr); +#ifdef USE_SFIO + errno = e; +#endif + } +} + +/* Common code used by vcroak, vdie and vwarner */ + +void S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8); + +char * +S_vdie_croak_common(pTHX_ const char* pat, va_list* args, STRLEN* msglen, + I32* utf8) +{ + char *message; if (pat) { - msv = vmess(pat, args); + SV *msv = vmess(pat, args); if (PL_errors && SvCUR(PL_errors)) { sv_catsv(PL_errors, msv); - message = SvPV(PL_errors, msglen); + message = SvPV(PL_errors, *msglen); SvCUR_set(PL_errors, 0); } else - message = SvPV(msv,msglen); + message = SvPV(msv,*msglen); + *utf8 = SvUTF8(msv); } else { message = Nullch; - msglen = 0; } DEBUG_S(PerlIO_printf(Perl_debug_log, - "%p: die: message = %s\ndiehook = %p\n", + "%p: die/croak: message = %s\ndiehook = %p\n", thr, message, PL_diehook)); if (PL_diehook) { - /* sv_2cv might call Perl_croak() */ - SV *olddiehook = PL_diehook; - ENTER; - SAVESPTR(PL_diehook); - PL_diehook = Nullsv; - cv = sv_2cv(olddiehook, &stash, &gv, 0); - LEAVE; - if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) { - dSP; - SV *msg; + S_vdie_common(aTHX_ message, *msglen, *utf8); + } + return message; +} - ENTER; - save_re_context(); - if (message) { - msg = newSVpvn(message, msglen); - SvREADONLY_on(msg); - SAVEFREESV(msg); - } - else { - msg = ERRSV; - } +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; + + assert(PL_diehook); + ENTER; + SAVESPTR(PL_diehook); + PL_diehook = Nullsv; + cv = sv_2cv(olddiehook, &stash, &gv, 0); + LEAVE; + if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) { + dSP; + SV *msg; - PUSHSTACKi(PERLSI_DIEHOOK); - PUSHMARK(SP); - XPUSHs(msg); - PUTBACK; - call_sv((SV*)cv, G_DISCARD); - POPSTACK; - LEAVE; + ENTER; + save_re_context(); + if (message) { + msg = newSVpvn(message, msglen); + SvFLAGS(msg) |= utf8; + SvREADONLY_on(msg); + SAVEFREESV(msg); } + else { + msg = ERRSV; + } + + PUSHSTACKi(PERLSI_DIEHOOK); + PUSHMARK(SP); + XPUSHs(msg); + PUTBACK; + call_sv((SV*)cv, G_DISCARD); + POPSTACK; + LEAVE; } +} + +OP * +Perl_vdie(pTHX_ const char* pat, va_list *args) +{ + char *message; + int was_in_eval = PL_in_eval; + STRLEN msglen; + I32 utf8 = 0; + + DEBUG_S(PerlIO_printf(Perl_debug_log, + "%p: die: curstack = %p, mainstack = %p\n", + thr, PL_curstack, PL_mainstack)); + + message = S_vdie_croak_common(aTHX_ pat, args, &msglen, &utf8); PL_restartop = die_where(message, msglen); + SvFLAGS(ERRSV) |= utf8; DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: die: restartop = %p, was_in_eval = %d, top_env = %p\n", thr, PL_restartop, was_in_eval, PL_top_env)); @@ -1080,82 +1193,20 @@ void Perl_vcroak(pTHX_ const char* pat, va_list *args) { char *message; - HV *stash; - GV *gv; - CV *cv; - SV *msv; STRLEN msglen; + I32 utf8 = 0; - if (pat) { - 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); - } - else { - message = Nullch; - msglen = 0; - } - - DEBUG_S(PerlIO_printf(Perl_debug_log, "croak: 0x%"UVxf" %s", - PTR2UV(thr), message)); - - if (PL_diehook) { - /* sv_2cv might call Perl_croak() */ - SV *olddiehook = PL_diehook; - ENTER; - SAVESPTR(PL_diehook); - PL_diehook = Nullsv; - cv = sv_2cv(olddiehook, &stash, &gv, 0); - LEAVE; - if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) { - dSP; - SV *msg; - - ENTER; - save_re_context(); - if (message) { - msg = newSVpvn(message, msglen); - SvREADONLY_on(msg); - SAVEFREESV(msg); - } - else { - msg = ERRSV; - } + message = S_vdie_croak_common(aTHX_ pat, args, &msglen, &utf8); - PUSHSTACKi(PERLSI_DIEHOOK); - PUSHMARK(SP); - XPUSHs(msg); - PUTBACK; - call_sv((SV*)cv, G_DISCARD); - POPSTACK; - LEAVE; - } - } if (PL_in_eval) { PL_restartop = die_where(message, msglen); + SvFLAGS(ERRSV) |= utf8; JMPENV_JUMP(3); } else if (!message) message = SvPVx(ERRSV, msglen); - { -#ifdef USE_SFIO - /* SFIO can really mess with your errno */ - int e = errno; -#endif - PerlIO *serr = Perl_error_log; - - PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen); - (void)PerlIO_flush(serr); -#ifdef USE_SFIO - errno = e; -#endif - } + write_to_stderr(message, msglen); my_failure_exit(); } @@ -1178,8 +1229,9 @@ Perl_croak_nocontext(const char *pat, ...) =for apidoc croak This is the XSUB-writer's interface to Perl's C function. -Normally use this function the same way you use the C C -function. See C. +Normally call this function the same way you call the C C +function. Calling C returns control directly to Perl, +sidestepping the normal C order of execution. See C. If you want to throw an exception object, assign the object to C<$@> and then pass C to croak(): @@ -1210,10 +1262,10 @@ Perl_vwarn(pTHX_ const char* pat, va_list *args) CV *cv; SV *msv; STRLEN msglen; - IO *io; - MAGIC *mg; + I32 utf8 = 0; msv = vmess(pat, args); + utf8 = SvUTF8(msv); message = SvPV(msv, msglen); if (PL_warnhook) { @@ -1231,6 +1283,7 @@ Perl_vwarn(pTHX_ const char* pat, va_list *args) ENTER; save_re_context(); msg = newSVpvn(message, msglen); + SvFLAGS(msg) |= utf8; SvREADONLY_on(msg); SAVEFREESV(msg); @@ -1245,25 +1298,7 @@ Perl_vwarn(pTHX_ const char* pat, va_list *args) } } - /* if STDERR is tied, use it instead */ - if (PL_stderrgv && (io = GvIOp(PL_stderrgv)) - && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) { - dSP; ENTER; - PUSHMARK(SP); - XPUSHs(SvTIED_obj((SV*)io, mg)); - XPUSHs(sv_2mortal(newSVpvn(message, msglen))); - PUTBACK; - call_method("PRINT", G_SCALAR); - LEAVE; - return; - } - - { - PerlIO *serr = Perl_error_log; - - PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen); - (void)PerlIO_flush(serr); - } + write_to_stderr(message, msglen); } #if defined(PERL_IMPLICIT_CONTEXT) @@ -1281,9 +1316,8 @@ Perl_warn_nocontext(const char *pat, ...) /* =for apidoc warn -This is the XSUB-writer's interface to Perl's C function. Use this -function the same way you use the C C function. See -C. +This is the XSUB-writer's interface to Perl's C function. Call this +function the same way you call the C C function. See C. =cut */ @@ -1321,92 +1355,26 @@ Perl_warner(pTHX_ U32 err, const char* pat,...) void Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args) { - char *message; - HV *stash; - GV *gv; - CV *cv; - SV *msv; - STRLEN msglen; - - msv = vmess(pat, args); - message = SvPV(msv, msglen); - if (ckDEAD(err)) { -#ifdef USE_5005THREADS - DEBUG_S(PerlIO_printf(Perl_debug_log, "croak: 0x%"UVxf" %s", PTR2UV(thr), message)); -#endif /* USE_5005THREADS */ + SV *msv = vmess(pat, args); + STRLEN msglen; + char *message = SvPV(msv, msglen); + I32 utf8 = SvUTF8(msv); + if (PL_diehook) { - /* sv_2cv might call Perl_croak() */ - SV *olddiehook = PL_diehook; - ENTER; - SAVESPTR(PL_diehook); - PL_diehook = Nullsv; - cv = sv_2cv(olddiehook, &stash, &gv, 0); - LEAVE; - if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) { - dSP; - SV *msg; - - ENTER; - save_re_context(); - msg = newSVpvn(message, msglen); - SvREADONLY_on(msg); - SAVEFREESV(msg); - - PUSHSTACKi(PERLSI_DIEHOOK); - PUSHMARK(sp); - XPUSHs(msg); - PUTBACK; - call_sv((SV*)cv, G_DISCARD); - POPSTACK; - LEAVE; - } + assert(message); + S_vdie_common(aTHX_ message, msglen, utf8); } if (PL_in_eval) { PL_restartop = die_where(message, msglen); + SvFLAGS(ERRSV) |= utf8; JMPENV_JUMP(3); } - { - PerlIO *serr = Perl_error_log; - PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen); - (void)PerlIO_flush(serr); - } + write_to_stderr(message, msglen); my_failure_exit(); } else { - if (PL_warnhook) { - /* sv_2cv might call Perl_warn() */ - SV *oldwarnhook = PL_warnhook; - ENTER; - SAVESPTR(PL_warnhook); - PL_warnhook = Nullsv; - cv = sv_2cv(oldwarnhook, &stash, &gv, 0); - LEAVE; - if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) { - dSP; - SV *msg; - - ENTER; - save_re_context(); - msg = newSVpvn(message, msglen); - SvREADONLY_on(msg); - SAVEFREESV(msg); - - PUSHSTACKi(PERLSI_WARNHOOK); - PUSHMARK(sp); - XPUSHs(msg); - PUTBACK; - call_sv((SV*)cv, G_DISCARD); - POPSTACK; - LEAVE; - return; - } - } - { - PerlIO *serr = Perl_error_log; - PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen); - (void)PerlIO_flush(serr); - } + Perl_vwarn(aTHX_ pat, args); } } @@ -1432,6 +1400,7 @@ Perl_my_setenv(pTHX_ char *nam, char *val) #endif { #ifndef PERL_USE_SAFE_PUTENV + if (!PL_use_safe_putenv) { /* most putenv()s leak, so we manipulate environ directly */ register I32 i=setenv_getix(nam); /* where does it go? */ int nlen, vlen; @@ -1472,8 +1441,8 @@ Perl_my_setenv(pTHX_ char *nam, char *val) environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char)); /* all that work just for this */ my_setenv_format(environ[i], nam, nlen, val, vlen); - -#else /* PERL_USE_SAFE_PUTENV */ + } else { +# endif # if defined(__CYGWIN__) || defined( EPOC) setenv(nam, val, 1); # else @@ -1488,7 +1457,9 @@ Perl_my_setenv(pTHX_ char *nam, char *val) my_setenv_format(new_env, nam, nlen, val, vlen); (void)putenv(new_env); # endif /* __CYGWIN__ */ -#endif /* PERL_USE_SAFE_PUTENV */ +#ifndef PERL_USE_SAFE_PUTENV + } +#endif } } @@ -1512,6 +1483,7 @@ Perl_my_setenv(pTHX_ char *nam,char *val) #endif /* WIN32 || NETWARE */ +#ifndef PERL_MICRO I32 Perl_setenv_getix(pTHX_ char *nam) { @@ -1529,6 +1501,7 @@ Perl_setenv_getix(pTHX_ char *nam) } /* potential SEGV's */ return i; } +#endif /* !PERL_MICRO */ #endif /* !VMS && !EPOC*/ @@ -1721,53 +1694,244 @@ Perl_my_ntohl(pTHX_ long l) * -DWS */ -#define HTOV(name,type) \ - type \ - name (register type n) \ - { \ - union { \ - type value; \ - char c[sizeof(type)]; \ - } u; \ - register I32 i; \ - register I32 s; \ - for (i = 0, s = 0; i < sizeof(u.c); i++, s += 8) { \ - u.c[i] = (n >> s) & 0xFF; \ - } \ - return u.value; \ - } +#define HTOLE(name,type) \ + type \ + name (register type n) \ + { \ + union { \ + type value; \ + char c[sizeof(type)]; \ + } u; \ + register I32 i; \ + register I32 s = 0; \ + for (i = 0; i < sizeof(u.c); i++, s += 8) { \ + u.c[i] = (n >> s) & 0xFF; \ + } \ + return u.value; \ + } + +#define LETOH(name,type) \ + type \ + name (register type n) \ + { \ + union { \ + type value; \ + char c[sizeof(type)]; \ + } u; \ + register I32 i; \ + register I32 s = 0; \ + u.value = n; \ + n = 0; \ + for (i = 0; i < sizeof(u.c); i++, s += 8) { \ + n |= ((type)(u.c[i] & 0xFF)) << s; \ + } \ + return n; \ + } + +/* + * Big-endian byte order functions. + */ + +#define HTOBE(name,type) \ + type \ + name (register type n) \ + { \ + union { \ + type value; \ + char c[sizeof(type)]; \ + } u; \ + register I32 i; \ + register I32 s = 8*(sizeof(u.c)-1); \ + for (i = 0; i < sizeof(u.c); i++, s -= 8) { \ + u.c[i] = (n >> s) & 0xFF; \ + } \ + return u.value; \ + } + +#define BETOH(name,type) \ + type \ + name (register type n) \ + { \ + union { \ + type value; \ + char c[sizeof(type)]; \ + } u; \ + register I32 i; \ + register I32 s = 8*(sizeof(u.c)-1); \ + u.value = n; \ + n = 0; \ + for (i = 0; i < sizeof(u.c); i++, s -= 8) { \ + n |= ((type)(u.c[i] & 0xFF)) << s; \ + } \ + return n; \ + } + +/* + * If we just can't do it... + */ + +#define NOT_AVAIL(name,type) \ + type \ + name (register type n) \ + { \ + Perl_croak_nocontext(#name "() not available"); \ + return n; /* not reached */ \ + } + + +#if defined(HAS_HTOVS) && !defined(htovs) +HTOLE(htovs,short) +#endif +#if defined(HAS_HTOVL) && !defined(htovl) +HTOLE(htovl,long) +#endif +#if defined(HAS_VTOHS) && !defined(vtohs) +LETOH(vtohs,short) +#endif +#if defined(HAS_VTOHL) && !defined(vtohl) +LETOH(vtohl,long) +#endif + +#ifdef PERL_NEED_MY_HTOLE16 +# if U16SIZE == 2 +HTOLE(Perl_my_htole16,U16) +# else +NOT_AVAIL(Perl_my_htole16,U16) +# endif +#endif +#ifdef PERL_NEED_MY_LETOH16 +# if U16SIZE == 2 +LETOH(Perl_my_letoh16,U16) +# else +NOT_AVAIL(Perl_my_letoh16,U16) +# endif +#endif +#ifdef PERL_NEED_MY_HTOBE16 +# if U16SIZE == 2 +HTOBE(Perl_my_htobe16,U16) +# else +NOT_AVAIL(Perl_my_htobe16,U16) +# endif +#endif +#ifdef PERL_NEED_MY_BETOH16 +# if U16SIZE == 2 +BETOH(Perl_my_betoh16,U16) +# else +NOT_AVAIL(Perl_my_betoh16,U16) +# endif +#endif + +#ifdef PERL_NEED_MY_HTOLE32 +# if U32SIZE == 4 +HTOLE(Perl_my_htole32,U32) +# else +NOT_AVAIL(Perl_my_htole32,U32) +# endif +#endif +#ifdef PERL_NEED_MY_LETOH32 +# if U32SIZE == 4 +LETOH(Perl_my_letoh32,U32) +# else +NOT_AVAIL(Perl_my_letoh32,U32) +# endif +#endif +#ifdef PERL_NEED_MY_HTOBE32 +# if U32SIZE == 4 +HTOBE(Perl_my_htobe32,U32) +# else +NOT_AVAIL(Perl_my_htobe32,U32) +# endif +#endif +#ifdef PERL_NEED_MY_BETOH32 +# if U32SIZE == 4 +BETOH(Perl_my_betoh32,U32) +# else +NOT_AVAIL(Perl_my_betoh32,U32) +# endif +#endif + +#ifdef PERL_NEED_MY_HTOLE64 +# if U64SIZE == 8 +HTOLE(Perl_my_htole64,U64) +# else +NOT_AVAIL(Perl_my_htole64,U64) +# endif +#endif +#ifdef PERL_NEED_MY_LETOH64 +# if U64SIZE == 8 +LETOH(Perl_my_letoh64,U64) +# else +NOT_AVAIL(Perl_my_letoh64,U64) +# endif +#endif +#ifdef PERL_NEED_MY_HTOBE64 +# if U64SIZE == 8 +HTOBE(Perl_my_htobe64,U64) +# else +NOT_AVAIL(Perl_my_htobe64,U64) +# endif +#endif +#ifdef PERL_NEED_MY_BETOH64 +# if U64SIZE == 8 +BETOH(Perl_my_betoh64,U64) +# else +NOT_AVAIL(Perl_my_betoh64,U64) +# endif +#endif + +#ifdef PERL_NEED_MY_HTOLES +HTOLE(Perl_my_htoles,short) +#endif +#ifdef PERL_NEED_MY_LETOHS +LETOH(Perl_my_letohs,short) +#endif +#ifdef PERL_NEED_MY_HTOBES +HTOBE(Perl_my_htobes,short) +#endif +#ifdef PERL_NEED_MY_BETOHS +BETOH(Perl_my_betohs,short) +#endif -#define VTOH(name,type) \ - type \ - name (register type n) \ - { \ - union { \ - type value; \ - char c[sizeof(type)]; \ - } u; \ - register I32 i; \ - register I32 s; \ - u.value = n; \ - n = 0; \ - for (i = 0, s = 0; i < sizeof(u.c); i++, s += 8) { \ - n += (u.c[i] & 0xFF) << s; \ - } \ - return n; \ - } +#ifdef PERL_NEED_MY_HTOLEI +HTOLE(Perl_my_htolei,int) +#endif +#ifdef PERL_NEED_MY_LETOHI +LETOH(Perl_my_letohi,int) +#endif +#ifdef PERL_NEED_MY_HTOBEI +HTOBE(Perl_my_htobei,int) +#endif +#ifdef PERL_NEED_MY_BETOHI +BETOH(Perl_my_betohi,int) +#endif -#if defined(HAS_HTOVS) && !defined(htovs) -HTOV(htovs,short) +#ifdef PERL_NEED_MY_HTOLEL +HTOLE(Perl_my_htolel,long) #endif -#if defined(HAS_HTOVL) && !defined(htovl) -HTOV(htovl,long) +#ifdef PERL_NEED_MY_LETOHL +LETOH(Perl_my_letohl,long) #endif -#if defined(HAS_VTOHS) && !defined(vtohs) -VTOH(vtohs,short) +#ifdef PERL_NEED_MY_HTOBEL +HTOBE(Perl_my_htobel,long) #endif -#if defined(HAS_VTOHL) && !defined(vtohl) -VTOH(vtohl,long) +#ifdef PERL_NEED_MY_BETOHL +BETOH(Perl_my_betohl,long) #endif +void +Perl_my_swabn(void *ptr, int n) +{ + register char *s = (char *)ptr; + register char *e = s + (n-1); + register char tc; + + for (n /= 2; n > 0; s++, e--, n--) { + tc = *s; + *s = *e; + *e = tc; + } +} + PerlIO * Perl_my_popen_list(pTHX_ char *mode, int n, SV **args) { @@ -1909,7 +2073,7 @@ Perl_my_popen(pTHX_ char *cmd, char *mode) register I32 This, that; register Pid_t pid; SV *sv; - I32 doexec = strNE(cmd,"-"); + I32 doexec = !(*cmd == '-' && cmd[1] == '\0'); I32 did_pipes = 0; int pp[2]; @@ -2082,7 +2246,7 @@ Perl_my_popen(pTHX_ char *cmd, char *mode) void Perl_atfork_lock(void) { -#if defined(USE_5005THREADS) || defined(USE_ITHREADS) +#if defined(USE_ITHREADS) /* locks must be held in locking order (if any) */ # ifdef MYMALLOC MUTEX_LOCK(&PL_malloc_mutex); @@ -2095,7 +2259,7 @@ Perl_atfork_lock(void) void Perl_atfork_unlock(void) { -#if defined(USE_5005THREADS) || defined(USE_ITHREADS) +#if defined(USE_ITHREADS) /* locks must be released in same order as in atfork_lock() */ # ifdef MYMALLOC MUTEX_UNLOCK(&PL_malloc_mutex); @@ -2109,7 +2273,7 @@ Perl_my_fork(void) { #if defined(HAS_FORK) Pid_t pid; -#if (defined(USE_5005THREADS) || defined(USE_ITHREADS)) && !defined(HAS_PTHREAD_ATFORK) +#if defined(USE_ITHREADS) && !defined(HAS_PTHREAD_ATFORK) atfork_lock(); pid = fork(); atfork_unlock(); @@ -2179,6 +2343,11 @@ dup2(int oldfd, int newfd) #ifndef PERL_MICRO #ifdef HAS_SIGACTION +#ifdef MACOS_TRADITIONAL +/* We don't want restart behavior on MacOS */ +#undef SA_RESTART +#endif + Sighandler_t Perl_rsignal(pTHX_ int signo, Sighandler_t handler) { @@ -2194,11 +2363,10 @@ Perl_rsignal(pTHX_ int signo, Sighandler_t handler) sigemptyset(&act.sa_mask); act.sa_flags = 0; #ifdef SA_RESTART -#if defined(PERL_OLD_SIGNALS) - act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */ -#endif + if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) + act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */ #endif -#ifdef SA_NOCLDWAIT +#if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */ if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN) act.sa_flags |= SA_NOCLDWAIT; #endif @@ -2234,11 +2402,10 @@ Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save) sigemptyset(&act.sa_mask); act.sa_flags = 0; #ifdef SA_RESTART -#if defined(PERL_OLD_SIGNALS) - act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */ + if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) + act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */ #endif -#endif -#ifdef SA_NOCLDWAIT +#if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */ if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN) act.sa_flags |= SA_NOCLDWAIT; #endif @@ -2400,7 +2567,7 @@ Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags) { SV *sv; SV** svp; - char spid[TYPE_CHARS(int)]; + char spid[TYPE_CHARS(IV)]; if (pid > 0) { sprintf(spid, "%"IVdf, (IV)pid); @@ -2416,9 +2583,6 @@ Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags) hv_iterinit(PL_pidstatus); if ((entry = hv_iternext(PL_pidstatus))) { - SV *sv; - char spid[TYPE_CHARS(int)]; - pid = atoi(hv_iterkey(entry,(I32*)statusp)); sv = hv_iterval(PL_pidstatus,entry); *statusp = SvIVX(sv); @@ -2467,7 +2631,7 @@ void Perl_pidgone(pTHX_ Pid_t pid, int status) { register SV *sv; - char spid[TYPE_CHARS(int)]; + char spid[TYPE_CHARS(IV)]; sprintf(spid, "%"IVdf, (IV)pid); sv = *hv_fetch(PL_pidstatus,spid,strlen(spid),TRUE); @@ -2802,7 +2966,7 @@ Perl_find_script(pTHX_ char *scriptname, bool dosearch, char **search_ext, I32 f void * Perl_get_context(void) { -#if defined(USE_5005THREADS) || defined(USE_ITHREADS) +#if defined(USE_ITHREADS) # ifdef OLD_PTHREADS_API pthread_addr_t t; if (pthread_getspecific(PL_thr_key, &t)) @@ -2823,7 +2987,7 @@ Perl_get_context(void) void Perl_set_context(void *t) { -#if defined(USE_5005THREADS) || defined(USE_ITHREADS) +#if defined(USE_ITHREADS) # ifdef I_MACH_CTHREADS cthread_set_data(cthread_self(), t); # else @@ -2835,280 +2999,6 @@ Perl_set_context(void *t) #endif /* !PERL_GET_CONTEXT_DEFINED */ -#ifdef USE_5005THREADS - -#ifdef FAKE_THREADS -/* Very simplistic scheduler for now */ -void -schedule(void) -{ - thr = thr->i.next_run; -} - -void -Perl_cond_init(pTHX_ perl_cond *cp) -{ - *cp = 0; -} - -void -Perl_cond_signal(pTHX_ perl_cond *cp) -{ - perl_os_thread t; - perl_cond cond = *cp; - - if (!cond) - return; - t = cond->thread; - /* Insert t in the runnable queue just ahead of us */ - t->i.next_run = thr->i.next_run; - thr->i.next_run->i.prev_run = t; - t->i.prev_run = thr; - thr->i.next_run = t; - thr->i.wait_queue = 0; - /* Remove from the wait queue */ - *cp = cond->next; - Safefree(cond); -} - -void -Perl_cond_broadcast(pTHX_ perl_cond *cp) -{ - perl_os_thread t; - perl_cond cond, cond_next; - - for (cond = *cp; cond; cond = cond_next) { - t = cond->thread; - /* Insert t in the runnable queue just ahead of us */ - t->i.next_run = thr->i.next_run; - thr->i.next_run->i.prev_run = t; - t->i.prev_run = thr; - thr->i.next_run = t; - thr->i.wait_queue = 0; - /* Remove from the wait queue */ - cond_next = cond->next; - Safefree(cond); - } - *cp = 0; -} - -void -Perl_cond_wait(pTHX_ perl_cond *cp) -{ - perl_cond cond; - - if (thr->i.next_run == thr) - Perl_croak(aTHX_ "panic: perl_cond_wait called by last runnable thread"); - - New(666, cond, 1, struct perl_wait_queue); - cond->thread = thr; - cond->next = *cp; - *cp = cond; - thr->i.wait_queue = cond; - /* Remove ourselves from runnable queue */ - thr->i.next_run->i.prev_run = thr->i.prev_run; - thr->i.prev_run->i.next_run = thr->i.next_run; -} -#endif /* FAKE_THREADS */ - -MAGIC * -Perl_condpair_magic(pTHX_ SV *sv) -{ - MAGIC *mg; - - (void)SvUPGRADE(sv, SVt_PVMG); - mg = mg_find(sv, PERL_MAGIC_mutex); - if (!mg) { - condpair_t *cp; - - New(53, cp, 1, condpair_t); - MUTEX_INIT(&cp->mutex); - COND_INIT(&cp->owner_cond); - COND_INIT(&cp->cond); - cp->owner = 0; - LOCK_CRED_MUTEX; /* XXX need separate mutex? */ - mg = mg_find(sv, PERL_MAGIC_mutex); - if (mg) { - /* someone else beat us to initialising it */ - UNLOCK_CRED_MUTEX; /* XXX need separate mutex? */ - MUTEX_DESTROY(&cp->mutex); - COND_DESTROY(&cp->owner_cond); - COND_DESTROY(&cp->cond); - Safefree(cp); - } - else { - sv_magic(sv, Nullsv, PERL_MAGIC_mutex, 0, 0); - mg = SvMAGIC(sv); - mg->mg_ptr = (char *)cp; - mg->mg_len = sizeof(cp); - UNLOCK_CRED_MUTEX; /* XXX need separate mutex? */ - DEBUG_S(WITH_THR(PerlIO_printf(Perl_debug_log, - "%p: condpair_magic %p\n", thr, sv))); - } - } - return mg; -} - -SV * -Perl_sv_lock(pTHX_ SV *osv) -{ - MAGIC *mg; - SV *sv = osv; - - LOCK_SV_LOCK_MUTEX; - if (SvROK(sv)) { - sv = SvRV(sv); - } - - mg = condpair_magic(sv); - MUTEX_LOCK(MgMUTEXP(mg)); - if (MgOWNER(mg) == thr) - MUTEX_UNLOCK(MgMUTEXP(mg)); - else { - while (MgOWNER(mg)) - COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg)); - MgOWNER(mg) = thr; - DEBUG_S(PerlIO_printf(Perl_debug_log, - "0x%"UVxf": Perl_lock lock 0x%"UVxf"\n", - PTR2UV(thr), PTR2UV(sv))); - MUTEX_UNLOCK(MgMUTEXP(mg)); - SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv); - } - UNLOCK_SV_LOCK_MUTEX; - return sv; -} - -/* - * Make a new perl thread structure using t as a prototype. Some of the - * fields for the new thread are copied from the prototype thread, t, - * so t should not be running in perl at the time this function is - * called. The use by ext/Thread/Thread.xs in core perl (where t is the - * thread calling new_struct_thread) clearly satisfies this constraint. - */ -struct perl_thread * -Perl_new_struct_thread(pTHX_ struct perl_thread *t) -{ -#if !defined(PERL_IMPLICIT_CONTEXT) - struct perl_thread *thr; -#endif - SV *sv; - SV **svp; - I32 i; - - sv = newSVpvn("", 0); - SvGROW(sv, sizeof(struct perl_thread) + 1); - SvCUR_set(sv, sizeof(struct perl_thread)); - thr = (Thread) SvPVX(sv); -#ifdef DEBUGGING - Poison(thr, 1, struct perl_thread); - PL_markstack = 0; - PL_scopestack = 0; - PL_savestack = 0; - PL_retstack = 0; - PL_dirty = 0; - PL_localizing = 0; - Zero(&PL_hv_fetch_ent_mh, 1, HE); - PL_efloatbuf = (char*)NULL; - PL_efloatsize = 0; -#else - Zero(thr, 1, struct perl_thread); -#endif - - thr->oursv = sv; - init_stacks(); - - PL_curcop = &PL_compiling; - thr->interp = t->interp; - thr->cvcache = newHV(); - thr->threadsv = newAV(); - thr->specific = newAV(); - thr->errsv = newSVpvn("", 0); - thr->flags = THRf_R_JOINABLE; - thr->thr_done = 0; - MUTEX_INIT(&thr->mutex); - - JMPENV_BOOTSTRAP; - - PL_in_eval = EVAL_NULL; /* ~(EVAL_INEVAL|EVAL_WARNONLY|EVAL_KEEPERR|EVAL_INREQUIRE) */ - PL_restartop = 0; - - PL_statname = NEWSV(66,0); - PL_errors = newSVpvn("", 0); - PL_maxscream = -1; - PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp); - PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags); - PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start); - PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string); - PL_regfree = MEMBER_TO_FPTR(Perl_pregfree); - PL_regindent = 0; - PL_reginterp_cnt = 0; - PL_lastscream = Nullsv; - PL_screamfirst = 0; - PL_screamnext = 0; - PL_reg_start_tmp = 0; - PL_reg_start_tmpl = 0; - PL_reg_poscache = Nullch; - - PL_peepp = MEMBER_TO_FPTR(Perl_peep); - - /* parent thread's data needs to be locked while we make copy */ - MUTEX_LOCK(&t->mutex); - -#ifdef PERL_FLEXIBLE_EXCEPTIONS - PL_protect = t->Tprotect; -#endif - - PL_curcop = t->Tcurcop; /* XXX As good a guess as any? */ - PL_defstash = t->Tdefstash; /* XXX maybe these should */ - PL_curstash = t->Tcurstash; /* always be set to main? */ - - PL_tainted = t->Ttainted; - PL_curpm = t->Tcurpm; /* XXX No PMOP ref count */ - PL_rs = newSVsv(t->Trs); - PL_last_in_gv = Nullgv; - PL_ofs_sv = t->Tofs_sv ? SvREFCNT_inc(PL_ofs_sv) : Nullsv; - PL_defoutgv = (GV*)SvREFCNT_inc(t->Tdefoutgv); - PL_chopset = t->Tchopset; - PL_bodytarget = newSVsv(t->Tbodytarget); - PL_toptarget = newSVsv(t->Ttoptarget); - if (t->Tformtarget == t->Ttoptarget) - PL_formtarget = PL_toptarget; - else - PL_formtarget = PL_bodytarget; - - /* Initialise all per-thread SVs that the template thread used */ - svp = AvARRAY(t->threadsv); - for (i = 0; i <= AvFILLp(t->threadsv); i++, svp++) { - if (*svp && *svp != &PL_sv_undef) { - SV *sv = newSVsv(*svp); - av_store(thr->threadsv, i, sv); - sv_magic(sv, 0, PERL_MAGIC_sv, &PL_threadsv_names[i], 1); - DEBUG_S(PerlIO_printf(Perl_debug_log, - "new_struct_thread: copied threadsv %"IVdf" %p->%p\n", - (IV)i, t, thr)); - } - } - thr->threadsvp = AvARRAY(thr->threadsv); - - MUTEX_LOCK(&PL_threads_mutex); - PL_nthreads++; - thr->tid = ++PL_threadnum; - thr->next = t->next; - thr->prev = t; - t->next = thr; - thr->next->prev = thr; - MUTEX_UNLOCK(&PL_threads_mutex); - - /* done copying parent's state */ - MUTEX_UNLOCK(&t->mutex); - -#ifdef HAVE_THREAD_INTERN - Perl_init_thread_intern(thr); -#endif /* HAVE_THREAD_INTERN */ - return thr; -} -#endif /* USE_5005THREADS */ - #ifdef PERL_GLOBAL_STRUCT struct perl_vars * Perl_GetVars(pTHX) @@ -3228,11 +3118,6 @@ Perl_get_vtbl(pTHX_ int vtbl_id) case want_vtbl_uvar: result = &PL_vtbl_uvar; break; -#ifdef USE_5005THREADS - case want_vtbl_mutex: - result = &PL_vtbl_mutex; - break; -#endif case want_vtbl_defelem: result = &PL_vtbl_defelem; break; @@ -3259,6 +3144,9 @@ Perl_get_vtbl(pTHX_ int vtbl_id) case want_vtbl_backref: result = &PL_vtbl_backref; break; + case want_vtbl_utf8: + result = &PL_vtbl_utf8; + break; } return result; } @@ -3266,7 +3154,7 @@ Perl_get_vtbl(pTHX_ int vtbl_id) I32 Perl_my_fflush_all(pTHX) { -#if defined(FFLUSH_NULL) +#if defined(USE_PERLIO) || defined(FFLUSH_NULL) || defined(USE_SFIO) return PerlIO_flush(NULL); #else # if defined(HAS__FWALK) @@ -3669,6 +3557,20 @@ Perl_my_strftime(pTHX_ char *fmt, int sec, int min, int hour, int mday, int mon, mytm.tm_yday = yday; mytm.tm_isdst = isdst; mini_mktime(&mytm); + /* use libc to get the values for tm_gmtoff and tm_zone [perl #18238] */ +#if defined(HAS_MKTIME) && (defined(HAS_TM_TM_GMTOFF) || defined(HAS_TM_TM_ZONE)) + STMT_START { + struct tm mytm2; + mytm2 = mytm; + mktime(&mytm2); +#ifdef HAS_TM_TM_GMTOFF + mytm.tm_gmtoff = mytm2.tm_gmtoff; +#endif +#ifdef HAS_TM_TM_ZONE + mytm.tm_zone = mytm2.tm_zone; +#endif + } STMT_END; +#endif buflen = 64; New(0, buf, buflen, char); len = strftime(buf, buflen, fmt, &mytm); @@ -3889,85 +3791,6 @@ Perl_getcwd_sv(pTHX_ register SV *sv) } /* -=head1 SV Manipulation Functions - -=for apidoc scan_vstring - -Returns a pointer to the next character after the parsed -vstring, as well as updating the passed in sv. - -Function must be called like - - sv = NEWSV(92,5); - s = scan_vstring(s,sv); - -The sv should already be large enough to store the vstring -passed in, for performance reasons. - -=cut -*/ - -char * -Perl_scan_vstring(pTHX_ char *s, SV *sv) -{ - char *pos = s; - char *start = s; - if (*pos == 'v') pos++; /* get past 'v' */ - while (isDIGIT(*pos) || *pos == '_') - pos++; - if (!isALPHA(*pos)) { - UV rev; - U8 tmpbuf[UTF8_MAXLEN+1]; - U8 *tmpend; - - if (*s == 'v') s++; /* get past 'v' */ - - sv_setpvn(sv, "", 0); - - for (;;) { - rev = 0; - { - /* this is atoi() that tolerates underscores */ - char *end = pos; - UV mult = 1; - while (--end >= s) { - UV orev; - if (*end == '_') - continue; - orev = rev; - rev += (*end - '0') * mult; - mult *= 10; - if (orev > rev && ckWARN_d(WARN_OVERFLOW)) - Perl_warner(aTHX_ packWARN(WARN_OVERFLOW), - "Integer overflow in decimal number"); - } - } -#ifdef EBCDIC - if (rev > 0x7FFFFFFF) - Perl_croak(aTHX "In EBCDIC the v-string components cannot exceed 2147483647"); -#endif - /* Append native character for the rev point */ - tmpend = uvchr_to_utf8(tmpbuf, rev); - sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf); - if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(rev))) - SvUTF8_on(sv); - if (*pos == '.' && isDIGIT(pos[1])) - s = ++pos; - else { - s = pos; - break; - } - while (isDIGIT(*pos) || *pos == '_') - pos++; - } - SvPOK_on(sv); - sv_magic(sv,NULL,PERL_MAGIC_vstring,(const char*)start, pos-start); - SvRMAGICAL_on(sv); - } - return s; -} - -/* =for apidoc scan_version Returns a pointer to the next character after the parsed @@ -3976,25 +3799,29 @@ an RV. Function must be called with an already existing SV like - sv = NEWSV(92,0); - s = scan_version(s,sv); + sv = newSV(0); + 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 beta version). +is a alpha version). The boolean qv denotes that the version +should be interpreted as if it had multiple decimals, even if +it doesn't. =cut */ char * -Perl_scan_version(pTHX_ char *s, SV *rv) +Perl_scan_version(pTHX_ char *s, SV *rv, bool qv) { + const char *start = s; 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 */ while ( *pos == '.' || *pos == '_' || isDIGIT(*pos) ) @@ -4004,7 +3831,7 @@ Perl_scan_version(pTHX_ char *s, SV *rv) if ( saw_under ) Perl_croak(aTHX_ "Invalid version format (underscores before decimal)"); saw_period++ ; - } + } else if ( *pos == '_' ) { if ( saw_under ) @@ -4015,9 +3842,12 @@ Perl_scan_version(pTHX_ char *s, SV *rv) } pos = s; - if (*pos == 'v') pos++; /* get past 'v' */ + if (*pos == 'v') { + pos++; /* get past 'v' */ + qv = 1; /* force quoted version processing */ + } while (isDIGIT(*pos)) - pos++; + pos++; if (!isALPHA(*pos)) { I32 rev; @@ -4026,27 +3856,40 @@ Perl_scan_version(pTHX_ char *s, SV *rv) for (;;) { rev = 0; { - /* this is atoi() that delimits on underscores */ - char *end = pos; - I32 mult = 1; - if ( s < pos && *(s-1) == '_' ) { - if ( *s == '0' && *(s+1) != '0') - mult = 10; /* perl-style */ - else - mult = -1; /* beta version */ - } - while (--end >= s) { - - I32 orev; - orev = rev; - rev += (*end - '0') * mult; - mult *= 10; - if ( abs(orev) > abs(rev) ) - Perl_croak(aTHX_ "Integer overflow in version"); - } - } - - /* Append revision */ + /* this is atoi() that delimits on underscores */ + 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 ) { + mult *= 100; + while ( s < end ) { + orev = rev; + rev += (*s - '0') * mult; + mult /= 10; + if ( PERL_ABS(orev) > PERL_ABS(rev) ) + Perl_croak(aTHX_ "Integer overflow in version"); + s++; + } + } + else { + while (--end >= s) { + orev = rev; + rev += (*end - '0') * mult; + mult *= 10; + if ( PERL_ABS(orev) > PERL_ABS(rev) ) + Perl_croak(aTHX_ "Integer overflow in version"); + } + } + } + + /* Append revision */ av_push((AV *)sv, newSViv(rev)); if ( (*pos == '.' || *pos == '_') && isDIGIT(pos[1])) s = ++pos; @@ -4063,6 +3906,19 @@ Perl_scan_version(pTHX_ char *s, SV *rv) } } } + if ( qv ) { /* quoted versions always become full version objects */ + I32 len = av_len((AV *)sv); + /* 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: + gcc version 3.3 20030304 (Apple Computer, Inc. build 1640) + for ( len = 2 - len; len > 0; len-- ) + av_push((AV *)sv, newSViv(0)); + */ + len = 2 - len; + while (len-- > 0) + av_push((AV *)sv, newSViv(0)); + } return s; } @@ -4082,16 +3938,36 @@ want to upgrade the SV. SV * Perl_new_version(pTHX_ SV *ver) { - SV *rv = NEWSV(92,5); - char *version = (char *)SvPV(ver,PL_na); - + SV *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++ ) + { + I32 rev = SvIV(*av_fetch(av, key, FALSE)); + av_push((AV *)sv, newSViv(rev)); + } + 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); + Safefree(version); + } + else { +#endif + sv_setsv(rv,ver); /* make a duplicate */ +#ifdef SvVOK } #endif - version = scan_version(version,rv); + upg_version(rv); return rv; } @@ -4110,14 +3986,28 @@ Returns a pointer to the upgraded SV. SV * Perl_upg_version(pTHX_ SV *ver) { - char *version = savepvn(SvPVX(ver),SvCUR(ver)); + char *version; + bool qv = 0; + + if ( SvNOK(ver) ) /* may get too much accuracy */ + { + char tbuf[64]; + sprintf(tbuf,"%.9"NVgf, SvNVX(ver)); + version = savepv(tbuf); + } #ifdef SvVOK - if ( SvVOK(ver) ) { /* already a v-string */ + else if ( SvVOK(ver) ) { /* already a v-string */ MAGIC* mg = mg_find(ver,PERL_MAGIC_vstring); version = savepvn( (const char*)mg->mg_ptr,mg->mg_len ); + qv = 1; } #endif - version = scan_version(version,ver); + else /* must be a string or something like a string */ + { + version = savesvpv(ver); + } + (void)scan_version(version, ver, qv); + Safefree(version); return ver; } @@ -4140,29 +4030,48 @@ SV * Perl_vnumify(pTHX_ SV *vs) { I32 i, len, digit; - SV *sv = NEWSV(92,0); + SV *sv = newSV(0); if ( SvROK(vs) ) vs = SvRV(vs); len = av_len((AV *)vs); + if ( len == -1 ) + { + Perl_sv_catpv(aTHX_ sv,"0"); + return sv; + } digit = SvIVX(*av_fetch((AV *)vs, 0, 0)); - Perl_sv_setpvf(aTHX_ sv,"%d.",abs(digit)); - for ( i = 1 ; i <= len ; i++ ) + 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",abs(digit)); + Perl_sv_catpvf(aTHX_ sv,"%03d", (int)PERL_ABS(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)); + } } - if ( len == 0 ) + else /* len == 0 */ + { Perl_sv_catpv(aTHX_ sv,"000"); + } return sv; } /* -=for apidoc vstringify +=for apidoc vnormal Accepts a version object and returns the normalized string representation. Call like: - sv = vstringify(rv); + sv = vnormal(rv); NOTE: you can pass either the object directly or the SV contained within the RV. @@ -4171,26 +4080,61 @@ contained within the RV. */ SV * -Perl_vstringify(pTHX_ SV *vs) +Perl_vnormal(pTHX_ SV *vs) { I32 i, len, digit; - SV *sv = NEWSV(92,0); + SV *sv = newSV(0); if ( SvROK(vs) ) vs = SvRV(vs); len = av_len((AV *)vs); + if ( len == -1 ) + { + Perl_sv_catpv(aTHX_ sv,""); + return sv; + } digit = SvIVX(*av_fetch((AV *)vs, 0, 0)); - Perl_sv_setpvf(aTHX_ sv,"%d",digit); + Perl_sv_setpvf(aTHX_ sv,"%"IVdf,(IV)digit); for ( i = 1 ; i <= len ; i++ ) -{ + { digit = SvIVX(*av_fetch((AV *)vs, i, 0)); if ( digit < 0 ) - Perl_sv_catpvf(aTHX_ sv,"_%d",-digit); + Perl_sv_catpvf(aTHX_ sv,"_%"IVdf,(IV)-digit); else - Perl_sv_catpvf(aTHX_ sv,".%d",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"); } - if ( len == 0 ) - Perl_sv_catpv(aTHX_ sv,".0"); + return sv; +} + +/* +=for apidoc vstringify + +In order to maintain maximum compatibility with earlier versions +of Perl, this function will return either the floating point +notation or the multiple dotted notation, depending on whether +the original version contained 1 or more dots, respectively + +=cut +*/ + +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 + return vnormal(vs); } /* @@ -4219,19 +4163,38 @@ Perl_vcmp(pTHX_ SV *lsv, SV *rsv) { I32 left = SvIV(*av_fetch((AV *)lsv,i,0)); I32 right = SvIV(*av_fetch((AV *)rsv,i,0)); - bool lbeta = left < 0 ? 1 : 0; - bool rbeta = right < 0 ? 1 : 0; + bool lalpha = left < 0 ? 1 : 0; + bool ralpha = right < 0 ? 1 : 0; left = abs(left); right = abs(right); - if ( left < right || (left == right && lbeta && !rbeta) ) + if ( left < right || (left == right && lalpha && !ralpha) ) retval = -1; - if ( left > right || (left == right && rbeta && !lbeta) ) + if ( left > right || (left == right && ralpha && !lalpha) ) retval = +1; i++; } - if ( l != r && retval == 0 ) - retval = l < r ? -1 : +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 ) + retval = -1; /* not a match after all */ + i++; + } + } + else + { + while ( i <= l && retval == 0 ) + { + if ( SvIV(*av_fetch((AV *)lsv,i,0)) != 0 ) + retval = +1; /* not a match after all */ + i++; + } + } + } return retval; } @@ -4536,3 +4499,174 @@ Perl_sv_nounlocking(pTHX_ SV *sv) { } +U32 +Perl_parse_unicode_opts(pTHX_ char **popt) +{ + char *p = *popt; + U32 opt = 0; + + if (*p) { + if (isDIGIT(*p)) { + opt = (U32) atoi(p); + while (isDIGIT(*p)) p++; + if (*p && *p != '\n' && *p != '\r') + Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p); + } + else { + for (; *p; p++) { + switch (*p) { + case PERL_UNICODE_STDIN: + opt |= PERL_UNICODE_STDIN_FLAG; break; + case PERL_UNICODE_STDOUT: + opt |= PERL_UNICODE_STDOUT_FLAG; break; + case PERL_UNICODE_STDERR: + opt |= PERL_UNICODE_STDERR_FLAG; break; + case PERL_UNICODE_STD: + opt |= PERL_UNICODE_STD_FLAG; break; + case PERL_UNICODE_IN: + opt |= PERL_UNICODE_IN_FLAG; break; + case PERL_UNICODE_OUT: + opt |= PERL_UNICODE_OUT_FLAG; break; + case PERL_UNICODE_INOUT: + opt |= PERL_UNICODE_INOUT_FLAG; break; + case PERL_UNICODE_LOCALE: + opt |= PERL_UNICODE_LOCALE_FLAG; break; + case PERL_UNICODE_ARGV: + opt |= PERL_UNICODE_ARGV_FLAG; break; + default: + if (*p != '\n' && *p != '\r') + Perl_croak(aTHX_ + "Unknown Unicode option letter '%c'", *p); + } + } + } + } + else + opt = PERL_UNICODE_DEFAULT_FLAGS; + + if (opt & ~PERL_UNICODE_ALL_FLAGS) + Perl_croak(aTHX_ "Unknown Unicode option value %"UVuf, + (UV) (opt & ~PERL_UNICODE_ALL_FLAGS)); + + *popt = p; + + return opt; +} + +U32 +Perl_seed(pTHX) +{ + /* + * This is really just a quick hack which grabs various garbage + * values. It really should be a real hash algorithm which + * spreads the effect of every input bit onto every output bit, + * if someone who knows about such things would bother to write it. + * Might be a good idea to add that function to CORE as well. + * No numbers below come from careful analysis or anything here, + * except they are primes and SEED_C1 > 1E6 to get a full-width + * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should + * probably be bigger too. + */ +#if RANDBITS > 16 +# define SEED_C1 1000003 +#define SEED_C4 73819 +#else +# define SEED_C1 25747 +#define SEED_C4 20639 +#endif +#define SEED_C2 3 +#define SEED_C3 269 +#define SEED_C5 26107 + +#ifndef PERL_NO_DEV_RANDOM + int fd; +#endif + U32 u; +#ifdef VMS +# include + /* when[] = (low 32 bits, high 32 bits) of time since epoch + * in 100-ns units, typically incremented ever 10 ms. */ + unsigned int when[2]; +#else +# ifdef HAS_GETTIMEOFDAY + struct timeval when; +# else + Time_t when; +# endif +#endif + +/* This test is an escape hatch, this symbol isn't set by Configure. */ +#ifndef PERL_NO_DEV_RANDOM +#ifndef PERL_RANDOM_DEVICE + /* /dev/random isn't used by default because reads from it will block + * if there isn't enough entropy available. You can compile with + * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there + * is enough real entropy to fill the seed. */ +# define PERL_RANDOM_DEVICE "/dev/urandom" +#endif + fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0); + if (fd != -1) { + if (PerlLIO_read(fd, &u, sizeof u) != sizeof u) + u = 0; + PerlLIO_close(fd); + if (u) + return u; + } +#endif + +#ifdef VMS + _ckvmssts(sys$gettim(when)); + u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1]; +#else +# ifdef HAS_GETTIMEOFDAY + PerlProc_gettimeofday(&when,NULL); + u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec; +# else + (void)time(&when); + u = (U32)SEED_C1 * when; +# endif +#endif + u += SEED_C3 * (U32)PerlProc_getpid(); + u += SEED_C4 * (U32)PTR2UV(PL_stack_sp); +#ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */ + u += SEED_C5 * (U32)PTR2UV(&when); +#endif + return u; +} + +UV +Perl_get_hash_seed(pTHX) +{ + char *s = PerlEnv_getenv("PERL_HASH_SEED"); + UV myseed = 0; + + if (s) + while (isSPACE(*s)) s++; + if (s && isDIGIT(*s)) + myseed = (UV)Atoul(s); + else +#ifdef USE_HASH_SEED_EXPLICIT + if (s) +#endif + { + /* Compute a random seed */ + (void)seedDrand01((Rand_seed_t)seed()); + myseed = (UV)(Drand01() * (NV)UV_MAX); +#if RANDBITS < (UVSIZE * 8) + /* Since there are not enough randbits to to reach all + * the bits of a UV, the low bits might need extra + * help. Sum in another random number that will + * fill in the low bits. */ + myseed += + (UV)(Drand01() * (NV)((1 << ((UVSIZE * 8 - RANDBITS))) - 1)); +#endif /* RANDBITS < (UVSIZE * 8) */ + if (myseed == 0) { /* Superparanoia. */ + myseed = (UV)(Drand01() * (NV)UV_MAX); /* One more chance. */ + if (myseed == 0) + Perl_croak(aTHX_ "Your random numbers are not that random"); + } + } + PL_rehash_seed_set = TRUE; + + return myseed; +}