X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=util.c;h=40abb483b03868345fc26f448bd3ba06ebbada56;hb=5460b889677b9f352c882dbcd4ad4470b8281664;hp=9dcade23fb3d575886718399170344a9ec6afd71;hpb=3aed30dc9bb800ec04a3f44e5176c45032741bdd;p=p5sagit%2Fp5-mst-13.2.git diff --git a/util.c b/util.c index 9dcade2..40abb48 100644 --- a/util.c +++ b/util.c @@ -1,6 +1,6 @@ /* util.c * - * Copyright (c) 1991-2002, Larry Wall + * Copyright (c) 1991-2003, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -38,15 +38,6 @@ #define FLUSH -#ifdef LEAKTEST - -long xcount[MAXXCOUNT]; -long lastxcount[MAXXCOUNT]; -long xycount[MAXXCOUNT][MAXYCOUNT]; -long lastxycount[MAXXCOUNT][MAXYCOUNT]; - -#endif - #if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC) # define FD_CLOEXEC 1 /* NeXT needs this */ #endif @@ -189,148 +180,6 @@ Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size) /*NOTREACHED*/ } -#ifdef LEAKTEST - -struct mem_test_strut { - union { - long type; - char c[2]; - } u; - long size; -}; - -# define ALIGN sizeof(struct mem_test_strut) - -# define sizeof_chunk(ch) (((struct mem_test_strut*) (ch))->size) -# define typeof_chunk(ch) \ - (((struct mem_test_strut*) (ch))->u.c[0] + ((struct mem_test_strut*) (ch))->u.c[1]*100) -# define set_typeof_chunk(ch,t) \ - (((struct mem_test_strut*) (ch))->u.c[0] = t % 100, ((struct mem_test_strut*) (ch))->u.c[1] = t / 100) -#define SIZE_TO_Y(size) ( (size) > MAXY_SIZE \ - ? MAXYCOUNT - 1 \ - : ( (size) > 40 \ - ? ((size) - 1)/8 + 5 \ - : ((size) - 1)/4)) - -Malloc_t -Perl_safexmalloc(I32 x, MEM_SIZE size) -{ - register char* where = (char*)safemalloc(size + ALIGN); - - xcount[x] += size; - xycount[x][SIZE_TO_Y(size)]++; - set_typeof_chunk(where, x); - sizeof_chunk(where) = size; - return (Malloc_t)(where + ALIGN); -} - -Malloc_t -Perl_safexrealloc(Malloc_t wh, MEM_SIZE size) -{ - char *where = (char*)wh; - - if (!wh) - return safexmalloc(0,size); - - { - MEM_SIZE old = sizeof_chunk(where - ALIGN); - int t = typeof_chunk(where - ALIGN); - register char* new = (char*)saferealloc(where - ALIGN, size + ALIGN); - - xycount[t][SIZE_TO_Y(old)]--; - xycount[t][SIZE_TO_Y(size)]++; - xcount[t] += size - old; - sizeof_chunk(new) = size; - return (Malloc_t)(new + ALIGN); - } -} - -void -Perl_safexfree(Malloc_t wh) -{ - I32 x; - char *where = (char*)wh; - MEM_SIZE size; - - if (!where) - return; - where -= ALIGN; - size = sizeof_chunk(where); - x = where[0] + 100 * where[1]; - xcount[x] -= size; - xycount[x][SIZE_TO_Y(size)]--; - safefree(where); -} - -Malloc_t -Perl_safexcalloc(I32 x,MEM_SIZE count, MEM_SIZE size) -{ - register char * where = (char*)safexmalloc(x, size * count + ALIGN); - xcount[x] += size; - xycount[x][SIZE_TO_Y(size)]++; - memset((void*)(where + ALIGN), 0, size * count); - set_typeof_chunk(where, x); - sizeof_chunk(where) = size; - return (Malloc_t)(where + ALIGN); -} - -STATIC void -S_xstat(pTHX_ int flag) -{ - register I32 i, j, total = 0; - I32 subtot[MAXYCOUNT]; - - for (j = 0; j < MAXYCOUNT; j++) { - subtot[j] = 0; - } - - PerlIO_printf(Perl_debug_log, " Id subtot 4 8 12 16 20 24 28 32 36 40 48 56 64 72 80 80+\n", total); - for (i = 0; i < MAXXCOUNT; i++) { - total += xcount[i]; - for (j = 0; j < MAXYCOUNT; j++) { - subtot[j] += xycount[i][j]; - } - if (flag == 0 - ? xcount[i] /* Have something */ - : (flag == 2 - ? xcount[i] != lastxcount[i] /* Changed */ - : xcount[i] > lastxcount[i])) { /* Growed */ - PerlIO_printf(Perl_debug_log,"%2d %02d %7ld ", i / 100, i % 100, - flag == 2 ? xcount[i] - lastxcount[i] : xcount[i]); - lastxcount[i] = xcount[i]; - for (j = 0; j < MAXYCOUNT; j++) { - if ( flag == 0 - ? xycount[i][j] /* Have something */ - : (flag == 2 - ? xycount[i][j] != lastxycount[i][j] /* Changed */ - : xycount[i][j] > lastxycount[i][j])) { /* Growed */ - PerlIO_printf(Perl_debug_log,"%3ld ", - flag == 2 - ? xycount[i][j] - lastxycount[i][j] - : xycount[i][j]); - lastxycount[i][j] = xycount[i][j]; - } else { - PerlIO_printf(Perl_debug_log, " . ", xycount[i][j]); - } - } - PerlIO_printf(Perl_debug_log, "\n"); - } - } - if (flag != 2) { - PerlIO_printf(Perl_debug_log, "Total %7ld ", total); - for (j = 0; j < MAXYCOUNT; j++) { - if (subtot[j]) { - PerlIO_printf(Perl_debug_log, "%3ld ", subtot[j]); - } else { - PerlIO_printf(Perl_debug_log, " . "); - } - } - PerlIO_printf(Perl_debug_log, "\n"); - } -} - -#endif /* LEAKTEST */ - /* These must be defined when not using Perl's malloc for binary * compatibility */ @@ -508,8 +357,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. */ @@ -1118,10 +971,6 @@ 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; @@ -1413,14 +1262,6 @@ Perl_vwarn(pTHX_ const char* pat, va_list *args) PerlIO *serr = Perl_error_log; PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen); -#ifdef LEAKTEST - DEBUG_L(*message == '!' - ? (xstat(message[1]=='!' - ? (message[2]=='!' ? 2 : 1) - : 0) - , 0) - : 0); -#endif (void)PerlIO_flush(serr); } } @@ -1491,9 +1332,6 @@ Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* 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 */ if (PL_diehook) { /* sv_2cv might call Perl_croak() */ SV *olddiehook = PL_diehook; @@ -1564,14 +1402,6 @@ Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args) { PerlIO *serr = Perl_error_log; PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen); -#ifdef LEAKTEST - DEBUG_L(*message == '!' - ? (xstat(message[1]=='!' - ? (message[2]=='!' ? 2 : 1) - : 0) - , 0) - : 0); -#endif (void)PerlIO_flush(serr); } } @@ -2249,7 +2079,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); @@ -2262,7 +2092,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); @@ -2276,7 +2106,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(); @@ -2346,6 +2176,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) { @@ -2361,9 +2196,8 @@ 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 (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN) @@ -2401,9 +2235,8 @@ 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 */ -#endif + if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) + act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */ #endif #ifdef SA_NOCLDWAIT if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN) @@ -2969,7 +2802,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)) @@ -2990,7 +2823,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 @@ -3002,280 +2835,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) @@ -3395,11 +2954,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; @@ -3426,6 +2980,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; } @@ -3433,7 +2990,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) @@ -3474,7 +3031,7 @@ Perl_my_fflush_all(pTHX) return 0; } # endif - SETERRNO(EBADF,RMS$_IFI); + SETERRNO(EBADF,RMS_IFI); return EOF; # endif #endif @@ -3499,14 +3056,14 @@ Perl_report_evil_fh(pTHX_ GV *gv, IO *io, I32 op) 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"; if (name && *name) Perl_warner(aTHX_ packWARN(WARN_IO), "Filehandle %s opened only for %sput", - name, (op == OP_phoney_INPUT_ONLY ? "in" : "out")); + name, direction); else Perl_warner(aTHX_ packWARN(WARN_IO), - "Filehandle opened only for %sput", - (op == OP_phoney_INPUT_ONLY ? "in" : "out")); + "Filehandle opened only for %sput", direction); } } else { @@ -3836,6 +3393,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); @@ -4128,13 +3699,12 @@ Perl_scan_vstring(pTHX_ char *s, SV *sv) pos++; } SvPOK_on(sv); - sv_magicext(sv,NULL,PERL_MAGIC_vstring,NULL,(const char*)start, pos-start); + sv_magic(sv,NULL,PERL_MAGIC_vstring,(const char*)start, pos-start); SvRMAGICAL_on(sv); } return s; } - /* =for apidoc scan_version @@ -4156,38 +3726,96 @@ is a beta version). */ char * -Perl_scan_version(pTHX_ char *version, SV *rv) +Perl_scan_version(pTHX_ char *s, SV *rv) { - char* d; - int beta = 0; + 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 */ - d = version; - if (*d == 'v') - d++; - if (isDIGIT(*d)) { - while (isDIGIT(*d) || *d == '.' || *d == '\0') - d++; - if (*d == '_') { - *d = '.'; - if (*(d+1) == '0' && *(d+2) != '0') { /* perl-style version */ - *(d+1) = *(d+2); - *(d+2) = '0'; - if (ckWARN(WARN_PORTABLE)) - Perl_warner(aTHX_ packWARN(WARN_PORTABLE), - "perl-style version not portable"); - } + (void)sv_upgrade(sv, SVt_PVAV); /* needs to be an AV type */ + + /* pre-scan the imput string to check for decimals */ + while ( *pos == '.' || *pos == '_' || isDIGIT(*pos) ) + { + if ( *pos == '.' ) + { + if ( saw_under ) + Perl_croak(aTHX_ "Invalid version format (underscores before decimal)"); + saw_period++ ; + } + else if ( *pos == '_' ) + { + if ( saw_under ) + Perl_croak(aTHX_ "Invalid version format (multiple underscores)"); + saw_under = 1; + } + pos++; + } + pos = s; + + if (*pos == 'v') pos++; /* get past 'v' */ + 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 */ + char *end = pos; + I32 mult = 1; + I32 orev; + if ( s < pos && s > start && *(s-1) == '_' ) { + mult *= -1; /* beta 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 ( s > start+1 && saw_period == 1 && !saw_under ) { + 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; + else if ( isDIGIT(*pos) ) + s = pos; else { - beta = -1; + s = pos; + break; + } + while ( isDIGIT(*pos) ) { + if ( !saw_under && saw_period == 1 && pos-s == 3 ) + break; + pos++; } } - while (isDIGIT(*d) || *d == '.' || *d == '\0') - d++; - if (*d == '_') - Perl_croak(aTHX_ "Invalid version format (multiple underscores)"); } - version = scan_vstring(version, sv); /* store the v-string in the object */ - SvIVX(sv) = beta; - return version; + return s; } /* @@ -4206,15 +3834,23 @@ want to upgrade the SV. SV * Perl_new_version(pTHX_ SV *ver) { - SV *rv = NEWSV(92,5); + SV *rv = newSV(0); char *version; - - if ( SvMAGICAL(ver) ) { /* already a v-string */ + if ( SvNOK(ver) ) /* may get too much accuracy */ + { + char tbuf[64]; + sprintf(tbuf,"%.9"NVgf, SvNVX(ver)); + version = savepv(tbuf); + } +#ifdef SvVOK + 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 ); } - else { - version = (char *)SvPV_nolen(ver); +#endif + else /* must be a string or something like a string */ + { + version = (char *)SvPV(ver,PL_na); } version = scan_version(version,rv); return rv; @@ -4233,91 +3869,148 @@ Returns a pointer to the upgraded SV. */ SV * -Perl_upg_version(pTHX_ SV *sv) +Perl_upg_version(pTHX_ SV *ver) { - char *version = (char *)SvPV_nolen(sv_mortalcopy(sv)); - bool utf8 = SvUTF8(sv); - if ( SvVOK(sv) ) { /* already a v-string */ - SV * ver = newSVrv(sv, "version"); - sv_setpv(ver,version); - if ( utf8 ) - SvUTF8_on(ver); - } - else { - version = scan_version(version,sv); + char *version = savepvn(SvPVX(ver),SvCUR(ver)); +#ifdef SvVOK + 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 ); } - return sv; +#endif + version = scan_version(version,ver); + return ver; } /* =for apidoc vnumify -Accepts a version (or vstring) object and returns the -normalized floating point representation. Call like: +Accepts a version object and returns the normalized floating +point representation. Call like: - sv = vnumify(sv,SvRV(rv)); + sv = vnumify(rv); -NOTE: no checking is done to see if the object is of the -correct type (for speed). +NOTE: you can pass either the object directly or the SV +contained within the RV. =cut */ SV * -Perl_vnumify(pTHX_ SV *sv, SV *vs) +Perl_vnumify(pTHX_ SV *vs) { - U8* pv = (U8*)SvPVX(vs); - STRLEN len = SvCUR(vs); - STRLEN retlen; - UV digit = utf8_to_uvchr(pv,&retlen); - Perl_sv_setpvf(aTHX_ sv,"%"UVf".",digit); - for (pv += retlen, len -= retlen; - len > 0; - pv += retlen, len -= retlen) + I32 i, len, digit; + SV *sv = NEWSV(92,0); + if ( SvROK(vs) ) + vs = SvRV(vs); + len = av_len((AV *)vs); + if ( len == -1 ) { - digit = utf8_to_uvchr(pv,&retlen); - Perl_sv_catpvf(aTHX_ sv,"%03"UVf,digit); + Perl_sv_catpv(aTHX_ sv,"0"); + return sv; } + digit = SvIVX(*av_fetch((AV *)vs, 0, 0)); + Perl_sv_setpvf(aTHX_ sv,"%d.", PERL_ABS(digit)); + for ( i = 1 ; i <= len ; i++ ) + { + digit = SvIVX(*av_fetch((AV *)vs, i, 0)); + Perl_sv_catpvf(aTHX_ sv,"%03d", PERL_ABS(digit)); + } + if ( len == 0 ) + Perl_sv_catpv(aTHX_ sv,"000"); + sv_setnv(sv, SvNV(sv)); return sv; } /* =for apidoc vstringify -Accepts a version (or vstring) object and returns the -normalized representation. Call like: +Accepts a version object and returns the normalized string +representation. Call like: - sv = vstringify(sv,SvRV(rv)); + sv = vstringify(rv); -NOTE: no checking is done to see if the object is of the -correct type (for speed). +NOTE: you can pass either the object directly or the SV +contained within the RV. =cut */ SV * -Perl_vstringify(pTHX_ SV *sv, SV *vs) +Perl_vstringify(pTHX_ SV *vs) { - U8* pv = (U8*)SvPVX(vs); - STRLEN len = SvCUR(vs); - STRLEN retlen; - UV digit = utf8_to_uvchr(pv,&retlen); - Perl_sv_setpvf(aTHX_ sv,"%"UVf,digit); - for (pv += retlen, len -= retlen; - len > 0; - pv += retlen, len -= retlen) + I32 i, len, digit; + SV *sv = NEWSV(92,0); + if ( SvROK(vs) ) + vs = SvRV(vs); + len = av_len((AV *)vs); + if ( len == -1 ) { - digit = utf8_to_uvchr(pv,&retlen); - Perl_sv_catpvf(aTHX_ sv,".%"UVf,digit); + Perl_sv_catpv(aTHX_ sv,""); + return sv; } - if (SvIVX(vs) < 0) { - char* pv = SvPVX(sv); - for (pv += SvCUR(sv); *pv != '.'; pv--) - ; - *pv = '_'; + digit = SvIVX(*av_fetch((AV *)vs, 0, 0)); + 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,"_%"IVdf,(IV)-digit); + else + Perl_sv_catpvf(aTHX_ sv,".%"IVdf,(IV)digit); } + if ( len == 0 ) + Perl_sv_catpv(aTHX_ sv,".0"); return sv; +} + +/* +=for apidoc vcmp + +Version object aware cmp. Both operands must already have been +converted into version objects. + +=cut +*/ + +int +Perl_vcmp(pTHX_ SV *lsv, SV *rsv) +{ + 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); + 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 lbeta = left < 0 ? 1 : 0; + bool rbeta = right < 0 ? 1 : 0; + left = PERL_ABS(left); + right = PERL_ABS(right); + if ( left < right || (left == right && lbeta && !rbeta) ) + retval = -1; + if ( left > right || (left == right && rbeta && !lbeta) ) + retval = +1; + i++; + } + + if ( l != r && retval == 0 ) /* possible match except for trailing 0 */ + { + if ( !( l < r && r-l == 1 && SvIV(*av_fetch((AV *)rsv,r,0)) == 0 ) && + !( l-r == 1 && SvIV(*av_fetch((AV *)lsv,l,0)) == 0 ) ) + { + retval = l < r ? -1 : +1; /* not a match after all */ + } + } + return retval; } #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT) @@ -4621,3 +4314,56 @@ 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) + 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: + 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; +} +