X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=util.c;h=303a19fde39e92d689888dd3c89b77d53924e117;hb=7df0d0422c26edcc954b82bd79e461b99b3c4092;hp=75f48ef978058795c537c1a6345fb762f08dbabf;hpb=df3728a2a53a64c63edf08a4429a7a57b76ca4aa;p=p5sagit%2Fp5-mst-13.2.git diff --git a/util.c b/util.c index 75f48ef..303a19f 100644 --- a/util.c +++ b/util.c @@ -1,6 +1,6 @@ /* util.c * - * Copyright (c) 1991-2001, Larry Wall + * Copyright (c) 1991-2002, 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. @@ -30,17 +30,14 @@ # include #endif -#define FLUSH - -#ifdef LEAKTEST - -long xcount[MAXXCOUNT]; -long lastxcount[MAXXCOUNT]; -long xycount[MAXXCOUNT][MAXYCOUNT]; -long lastxycount[MAXXCOUNT][MAXYCOUNT]; - +#ifdef HAS_SELECT +# ifdef I_SYS_SELECT +# include +# endif #endif +#define FLUSH + #if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC) # define FD_CLOEXEC 1 /* NeXT needs this */ #endif @@ -79,7 +76,7 @@ Perl_safesysmalloc(MEM_SIZE size) else { PerlIO_puts(Perl_error_log,PL_no_mem) FLUSH; my_exit(1); - return Nullch; + return Nullch; } /*NOTREACHED*/ } @@ -183,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 */ @@ -333,19 +188,19 @@ S_xstat(pTHX_ int flag) Malloc_t Perl_malloc (MEM_SIZE nbytes) { dTHXs; - return PerlMem_malloc(nbytes); + return (Malloc_t)PerlMem_malloc(nbytes); } Malloc_t Perl_calloc (MEM_SIZE elements, MEM_SIZE size) { dTHXs; - return PerlMem_calloc(elements, size); + return (Malloc_t)PerlMem_calloc(elements, size); } Malloc_t Perl_realloc (Malloc_t where, MEM_SIZE nbytes) { dTHXs; - return PerlMem_realloc(where, nbytes); + return (Malloc_t)PerlMem_realloc(where, nbytes); } Free_t Perl_mfree (Malloc_t where) @@ -482,6 +337,8 @@ Perl_rninstr(pTHX_ register const char *big, const char *bigend, const char *lit If FBMcf_TAIL, the table is created as if the string has a trailing \n. */ /* +=head1 Miscellaneous Functions + =for apidoc fbm_compile Analyses the string in order to make fast searches on it using fbm_instr() @@ -504,7 +361,7 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags) sv_catpvn(sv, "\n", 1); /* Taken into account in fbm_instr() */ s = (U8*)SvPV_force(sv, len); (void)SvUPGRADE(sv, SVt_PVBM); - if (len == 0) /* TAIL might be on on a zero-length string. */ + if (len == 0) /* TAIL might be on a zero-length string. */ return; if (len > 2) { U8 mlen; @@ -538,7 +395,7 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags) } } BmRARE(sv) = s[rarest]; - BmPREVIOUS(sv) = rarest; + BmPREVIOUS(sv) = (U16)rarest; BmUSEFUL(sv) = 100; /* Initial value */ if (flags & FBMcf_TAIL) SvTAIL_on(sv); @@ -570,9 +427,9 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit register STRLEN littlelen = l; register I32 multiline = flags & FBMrf_MULTILINE; - if (bigend - big < littlelen) { + if ((STRLEN)(bigend - big) < littlelen) { if ( SvTAIL(littlestr) - && (bigend - big == littlelen - 1) + && ((STRLEN)(bigend - big) == littlelen - 1) && (littlelen == 1 || (*big == *little && memEQ((char *)big, (char *)little, littlelen - 1)))) @@ -699,7 +556,7 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit register unsigned char *table = little + littlelen + FBM_TABLE_OFFSET; register unsigned char *oldlittle; - if (littlelen > bigend - big) + if (littlelen > (STRLEN)(bigend - big)) return Nullch; --littlelen; /* Last char found by table lookup */ @@ -744,7 +601,7 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit /* start_shift, end_shift are positive quantities which give offsets of ends of some substring of bigstr. - If `last' we want the last occurence. + If `last' we want the last occurrence. old_posp is the way of communication between consequent calls if the next call needs to find the . The initial *old_posp should be -1. @@ -871,20 +728,26 @@ Perl_ibcmp_locale(pTHX_ const char *s1, const char *s2, register I32 len) /* copy a string to a safe spot */ /* +=head1 Memory Management + =for apidoc savepv -Copy a string to a safe spot. This does not use an SV. +Perl's version of C. Returns a pointer to a newly allocated +string which is a duplicate of C. The size of the string is +determined by C. The memory allocated for the new string can +be freed with the C function. =cut */ char * -Perl_savepv(pTHX_ const char *sv) +Perl_savepv(pTHX_ const char *pv) { - register char *newaddr; - - New(902,newaddr,strlen(sv)+1,char); - (void)strcpy(newaddr,sv); + register char *newaddr = Nullch; + if (pv) { + New(902,newaddr,strlen(pv)+1,char); + (void)strcpy(newaddr,pv); + } return newaddr; } @@ -893,23 +756,52 @@ Perl_savepv(pTHX_ const char *sv) /* =for apidoc savepvn -Copy a string to a safe spot. The C indicates number of bytes to -copy. This does not use an SV. +Perl's version of what C would be if it existed. Returns a +pointer to a newly allocated string which is a duplicate of the first +C bytes from C. The memory allocated for the new string can be +freed with the C function. =cut */ char * -Perl_savepvn(pTHX_ const char *sv, register I32 len) +Perl_savepvn(pTHX_ const char *pv, register I32 len) { register char *newaddr; New(903,newaddr,len+1,char); - Copy(sv,newaddr,len,char); /* might not be null terminated */ - newaddr[len] = '\0'; /* is now */ + /* 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 */ + } + else { + Zero(newaddr,len+1,char); + } + return newaddr; +} + +/* +=for apidoc savesharedpv + +A version of C which allocates the duplicate string in memory +which is shared between threads. + +=cut +*/ +char * +Perl_savesharedpv(pTHX_ const char *pv) +{ + register char *newaddr = Nullch; + if (pv) { + newaddr = (char*)PerlMemShared_malloc(strlen(pv)+1); + (void)strcpy(newaddr,pv); + } return newaddr; } + + /* the SV for Perl_form() and mess() is not kept in an arena */ STATIC SV * @@ -948,6 +840,26 @@ Perl_form_nocontext(const char* pat, ...) } #endif /* PERL_IMPLICIT_CONTEXT */ +/* +=head1 Miscellaneous Functions +=for apidoc form + +Takes a sprintf-style format pattern and conventional +(non-SV) arguments and returns the formatted string. + + (char *) Perl_form(pTHX_ const char* pat, ...) + +can be used any place a string (char *) is required: + + char * s = Perl_form("%d.%d",major,minor); + +Uses a single private buffer so if you want to format several strings you +must explicitly copy the earlier strings away (and free the copies when you +are done). + +=cut +*/ + char * Perl_form(pTHX_ const char* pat, ...) { @@ -1045,19 +957,16 @@ Perl_vmess(pTHX_ const char *pat, va_list *args) if (CopLINE(cop)) Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf, - CopFILE(cop), (IV)CopLINE(cop)); + OutCopFILE(cop), (IV)CopLINE(cop)); if (GvIO(PL_last_in_gv) && IoLINES(GvIOp(PL_last_in_gv))) { bool line_mode = (RsSIMPLE(PL_rs) && SvCUR(PL_rs) == 1 && *SvPVX(PL_rs) == '\n'); Perl_sv_catpvf(aTHX_ sv, ", <%s> %s %"IVdf, - PL_last_in_gv == PL_argvgv ? "" : GvNAME(PL_last_in_gv), - line_mode ? "line" : "chunk", - (IV)IoLINES(GvIOp(PL_last_in_gv))); + PL_last_in_gv == PL_argvgv ? + "" : GvNAME(PL_last_in_gv), + 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; @@ -1227,6 +1136,9 @@ Perl_vcroak(pTHX_ const char* pat, va_list *args) PL_restartop = die_where(message, msglen); JMPENV_JUMP(3); } + else if (!message) + message = SvPVx(ERRSV, msglen); + { #ifdef USE_SFIO /* SFIO can really mess with your errno */ @@ -1257,6 +1169,8 @@ Perl_croak_nocontext(const char *pat, ...) #endif /* PERL_IMPLICIT_CONTEXT */ /* +=head1 Warning and Dieing + =for apidoc croak This is the XSUB-writer's interface to Perl's C function. @@ -1292,6 +1206,8 @@ Perl_vwarn(pTHX_ const char* pat, va_list *args) CV *cv; SV *msv; STRLEN msglen; + IO *io; + MAGIC *mg; msv = vmess(pat, args); message = SvPV(msv, msglen); @@ -1324,18 +1240,24 @@ Perl_vwarn(pTHX_ const char* pat, va_list *args) return; } } + + /* 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); -#ifdef LEAKTEST - DEBUG_L(*message == '!' - ? (xstat(message[1]=='!' - ? (message[2]=='!' ? 2 : 1) - : 0) - , 0) - : 0); -#endif (void)PerlIO_flush(serr); } } @@ -1406,102 +1328,106 @@ 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; - 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; + 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); + msg = newSVpvn(message, msglen); + SvREADONLY_on(msg); + SAVEFREESV(msg); PUSHSTACKi(PERLSI_DIEHOOK); - PUSHMARK(sp); - XPUSHs(msg); - PUTBACK; - call_sv((SV*)cv, G_DISCARD); + PUSHMARK(sp); + XPUSHs(msg); + PUTBACK; + call_sv((SV*)cv, G_DISCARD); POPSTACK; - LEAVE; - } - } - if (PL_in_eval) { - PL_restartop = die_where(message, msglen); - JMPENV_JUMP(3); - } + LEAVE; + } + } + if (PL_in_eval) { + PL_restartop = die_where(message, msglen); + JMPENV_JUMP(3); + } { PerlIO *serr = Perl_error_log; PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen); (void)PerlIO_flush(serr); } - my_failure_exit(); - + 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); + 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; + if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) { + dSP; + SV *msg; - ENTER; + ENTER; save_re_context(); - msg = newSVpvn(message, msglen); - SvREADONLY_on(msg); - SAVEFREESV(msg); + msg = newSVpvn(message, msglen); + SvREADONLY_on(msg); + SAVEFREESV(msg); PUSHSTACKi(PERLSI_WARNHOOK); - PUSHMARK(sp); - XPUSHs(msg); - PUTBACK; - call_sv((SV*)cv, G_DISCARD); + PUSHMARK(sp); + XPUSHs(msg); + PUTBACK; + call_sv((SV*)cv, G_DISCARD); POPSTACK; - LEAVE; - return; - } - } + LEAVE; + return; + } + } { 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); } } } +/* 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) + */ +#define my_setenv_format(s, nam, nlen, val, vlen) \ + Copy(nam, s, nlen, char); \ + *(s+nlen) = '='; \ + Copy(val, s+(nlen+1), vlen, char); \ + *(s+(nlen+1+vlen)) = '\0' + #ifdef USE_ENVIRON_ARRAY - /* VMS' and EPOC's my_setenv() is in vms.c and epoc.c */ + /* VMS' my_setenv() is in vms.c */ #if !defined(WIN32) && !defined(NETWARE) void Perl_my_setenv(pTHX_ char *nam, char *val) { +#ifdef USE_ITHREADS + /* only parent thread can modify process environment */ + if (PL_curinterp == aTHX) +#endif + { #ifndef PERL_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; if (environ == PL_origenviron) { /* need we copy environment? */ I32 j; @@ -1512,8 +1438,9 @@ Perl_my_setenv(pTHX_ char *nam, char *val) for (max = i; environ[max]; max++) ; tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*)); for (j=0; j 0) { - sprintf(spid, "%"IVdf, (IV)pid); - svp = hv_fetch(PL_pidstatus,spid,strlen(spid),FALSE); - if (svp && *svp != &PL_sv_undef) { - *statusp = SvIVX(*svp); - (void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD); - return pid; - } - } - else { - HE *entry; + SV *sv; + SV** svp; + char spid[TYPE_CHARS(int)]; - hv_iterinit(PL_pidstatus); - if ((entry = hv_iternext(PL_pidstatus))) { - pid = atoi(hv_iterkey(entry,(I32*)statusp)); - sv = hv_iterval(PL_pidstatus,entry); - *statusp = SvIVX(sv); + if (pid > 0) { sprintf(spid, "%"IVdf, (IV)pid); - (void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD); - return pid; + svp = hv_fetch(PL_pidstatus,spid,strlen(spid),FALSE); + if (svp && *svp != &PL_sv_undef) { + *statusp = SvIVX(*svp); + (void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD); + return pid; + } + } + else { + HE *entry; + + 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); + sprintf(spid, "%"IVdf, (IV)pid); + (void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD); + return pid; + } } - } } #endif #ifdef HAS_WAITPID @@ -2428,15 +2432,16 @@ Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags) if (!HAS_WAITPID_RUNTIME) goto hard_way; # endif - return PerlProc_waitpid(pid,statusp,flags); + result = PerlProc_waitpid(pid,statusp,flags); + goto finish; #endif #if !defined(HAS_WAITPID) && defined(HAS_WAIT4) - return wait4((pid==-1)?0:pid,statusp,flags,Null(struct rusage *)); + 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) hard_way: { - I32 result; if (flags) Perl_croak(aTHX_ "Can't do waitpid with flags"); else { @@ -2445,9 +2450,13 @@ Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags) if (result < 0) *statusp = -1; } - return result; } #endif + finish: + if (result < 0 && errno == EINTR) { + PERL_ASYNC_CHECK(); + } + return result; } #endif /* !DOSISH || OS2 || WIN32 || NETWARE */ @@ -2465,7 +2474,7 @@ Perl_pidgone(pTHX_ Pid_t pid, int status) return; } -#if defined(atarist) || defined(OS2) +#if defined(atarist) || defined(OS2) || defined(EPOC) int pclose(); #ifdef HAS_FORK int /* Cannot prototype with I32 @@ -2524,8 +2533,8 @@ Perl_same_dirent(pTHX_ char *a, char *b) { char *fa = strrchr(a,'/'); char *fb = strrchr(b,'/'); - struct stat tmpstatbuf1; - struct stat tmpstatbuf2; + Stat_t tmpstatbuf1; + Stat_t tmpstatbuf2; SV *tmpsv = sv_newmortal(); if (fa) @@ -2562,7 +2571,7 @@ Perl_find_script(pTHX_ char *scriptname, bool dosearch, char **search_ext, I32 f char *xfailed = Nullch; char tmpbuf[MAXPATHLEN]; register char *s; - I32 len; + I32 len = 0; int retval; #if defined(DOSISH) && !defined(OS2) && !defined(atarist) # define SEARCH_EXTS ".bat", ".cmd", NULL @@ -2685,7 +2694,7 @@ Perl_find_script(pTHX_ char *scriptname, bool dosearch, char **search_ext, I32 f #endif { bool seen_dot = 0; - + PL_bufend = s + strlen(s); while (s < PL_bufend) { #ifdef MACOS_TRADITIONAL @@ -2757,7 +2766,7 @@ Perl_find_script(pTHX_ char *scriptname, bool dosearch, char **search_ext, I32 f #endif ) { - xfound = tmpbuf; /* bingo! */ + xfound = tmpbuf; /* bingo! */ break; } if (!xfailed) @@ -2771,7 +2780,7 @@ Perl_find_script(pTHX_ char *scriptname, bool dosearch, char **search_ext, I32 f seen_dot = 1; /* Disable message. */ if (!xfound) { if (flags & 1) { /* do or die? */ - Perl_croak(aTHX_ "Can't %s %s%s%s", + Perl_croak(aTHX_ "Can't %s %s%s%s", (xfailed ? "execute" : "find"), (xfailed ? xfailed : scriptname), (xfailed ? "" : " on PATH"), @@ -2791,7 +2800,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)) @@ -2812,7 +2821,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 @@ -2824,280 +2833,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 - memset(thr, 0xab, sizeof(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) @@ -3217,11 +2952,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; @@ -3248,6 +2978,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; } @@ -3255,10 +2988,11 @@ 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) + extern int fflush(FILE *); /* undocumented, unprototyped, but very useful BSDism */ extern void _fwalk(int (*)(FILE *)); _fwalk(&fflush); @@ -3295,7 +3029,7 @@ Perl_my_fflush_all(pTHX) return 0; } # endif - SETERRNO(EBADF,RMS$_IFI); + SETERRNO(EBADF,RMS_IFI); return EOF; # endif #endif @@ -3304,56 +3038,67 @@ Perl_my_fflush_all(pTHX) void Perl_report_evil_fh(pTHX_ GV *gv, IO *io, I32 op) { - char *vile; - I32 warn_type; char *func = op == OP_READLINE ? "readline" : /* "" not nice */ op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */ PL_op_desc[op]; char *pars = OP_IS_FILETEST(op) ? "" : "()"; - char *type = OP_IS_SOCKET(op) || - (gv && io && IoTYPE(io) == IoTYPE_SOCKET) ? - "socket" : "filehandle"; + char *type = OP_IS_SOCKET(op) + || (gv && io && IoTYPE(io) == IoTYPE_SOCKET) + ? "socket" : "filehandle"; char *name = NULL; - if (gv && io && IoTYPE(io) == IoTYPE_CLOSED) { - vile = "closed"; - warn_type = WARN_CLOSED; - } - else { - vile = "unopened"; - warn_type = WARN_UNOPENED; - } - if (gv && isGV(gv)) { - SV *sv = sv_newmortal(); - gv_efullname4(sv, gv, Nullch, FALSE); - name = SvPVX(sv); + name = GvENAME(gv); } if (op == OP_phoney_OUTPUT_ONLY || op == OP_phoney_INPUT_ONLY) { - if (name && *name) - Perl_warner(aTHX_ WARN_IO, "Filehandle %s opened only for %sput", - name, - (op == OP_phoney_INPUT_ONLY ? "in" : "out")); - else - Perl_warner(aTHX_ WARN_IO, "Filehandle opened only for %sput", - (op == OP_phoney_INPUT_ONLY ? "in" : "out")); - } else if (name && *name) { - Perl_warner(aTHX_ warn_type, - "%s%s on %s %s %s", func, pars, vile, type, name); - if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP)) - Perl_warner(aTHX_ warn_type, - "\t(Are you trying to call %s%s on dirhandle %s?)\n", - func, pars, name); + 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, direction); + else + Perl_warner(aTHX_ packWARN(WARN_IO), + "Filehandle opened only for %sput", direction); + } } else { - Perl_warner(aTHX_ warn_type, - "%s%s on %s %s", func, pars, vile, type); - if (gv && io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP)) - Perl_warner(aTHX_ warn_type, + char *vile; + I32 warn_type; + + if (gv && io && IoTYPE(io) == IoTYPE_CLOSED) { + vile = "closed"; + warn_type = WARN_CLOSED; + } + else { + vile = "unopened"; + warn_type = WARN_UNOPENED; + } + + if (ckWARN(warn_type)) { + if (name && *name) { + Perl_warner(aTHX_ packWARN(warn_type), + "%s%s on %s %s %s", func, pars, vile, type, name); + if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP)) + Perl_warner( + aTHX_ packWARN(warn_type), + "\t(Are you trying to call %s%s on dirhandle %s?)\n", + func, pars, name + ); + } + else { + Perl_warner(aTHX_ packWARN(warn_type), + "%s%s on %s %s", func, pars, vile, type); + if (gv && io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP)) + Perl_warner( + aTHX_ packWARN(warn_type), "\t(Are you trying to call %s%s on dirhandle?)\n", - func, pars); + func, pars + ); + } + } } } @@ -3364,63 +3109,65 @@ static const char controllablechars[] = "?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_"; int Perl_ebcdic_control(pTHX_ int ch) { - if (ch > 'a') { - char *ctlp; - - if (islower(ch)) - ch = toupper(ch); - - if ((ctlp = strchr(controllablechars, ch)) == 0) { - Perl_die(aTHX_ "unrecognised control character '%c'\n", ch); - } - - if (ctlp == controllablechars) - return('\177'); /* DEL */ - else - return((unsigned char)(ctlp - controllablechars - 1)); - } else { /* Want uncontrol */ - if (ch == '\177' || ch == -1) - return('?'); - else if (ch == '\157') - return('\177'); - else if (ch == '\174') - return('\000'); - else if (ch == '^') /* '\137' in 1047, '\260' in 819 */ - return('\036'); - else if (ch == '\155') - return('\037'); - else if (0 < ch && ch < (sizeof(controllablechars) - 1)) - return(controllablechars[ch+1]); - else - Perl_die(aTHX_ "invalid control request: '\\%03o'\n", ch & 0xFF); - } -} -#endif - -/* XXX struct tm on some systems (SunOS4/BSD) contains extra (non POSIX) - * fields for which we don't have Configure support yet: - * char *tm_zone; -- abbreviation of timezone name - * long tm_gmtoff; -- offset from GMT in seconds - * To workaround core dumps from the uninitialised tm_zone we get the + if (ch > 'a') { + char *ctlp; + + if (islower(ch)) + ch = toupper(ch); + + if ((ctlp = strchr(controllablechars, ch)) == 0) { + Perl_die(aTHX_ "unrecognised control character '%c'\n", ch); + } + + if (ctlp == controllablechars) + return('\177'); /* DEL */ + else + return((unsigned char)(ctlp - controllablechars - 1)); + } else { /* Want uncontrol */ + if (ch == '\177' || ch == -1) + return('?'); + else if (ch == '\157') + return('\177'); + else if (ch == '\174') + return('\000'); + else if (ch == '^') /* '\137' in 1047, '\260' in 819 */ + return('\036'); + else if (ch == '\155') + return('\037'); + else if (0 < ch && ch < (sizeof(controllablechars) - 1)) + return(controllablechars[ch+1]); + else + Perl_die(aTHX_ "invalid control request: '\\%03o'\n", ch & 0xFF); + } +} +#endif + +/* To workaround core dumps from the uninitialised tm_zone we get the * system to give us a reasonable struct to copy. This fix means that * strftime uses the tm_zone and tm_gmtoff values returned by * localtime(time()). That should give the desired result most of the * time. But probably not always! * - * This is a temporary workaround to be removed once Configure - * support is added and NETaa14816 is considered in full. - * It does not address tzname aspects of NETaa14816. + * This does not address tzname aspects of NETaa14816. + * */ + #ifdef HAS_GNULIBC # ifndef STRUCT_TM_HASZONE # define STRUCT_TM_HASZONE # endif #endif +#ifdef STRUCT_TM_HASZONE /* Backward compat */ +# ifndef HAS_TM_TM_ZONE +# define HAS_TM_TM_ZONE +# endif +#endif + void Perl_init_tm(pTHX_ struct tm *ptm) /* see mktime, strftime and asctime */ { -#ifdef STRUCT_TM_HASZONE +#ifdef HAS_TM_TM_ZONE Time_t now; (void)time(&now); Copy(localtime(&now), ptm, 1, struct tm); @@ -3644,8 +3391,22 @@ 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); - buflen = 64; - New(0, buf, buflen, char); + /* 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); /* ** The following is needed to handle to the situation where @@ -3696,9 +3457,11 @@ return FALSE #define SV_CWD_ISDOT(dp) \ (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \ - (dp->d_name[1] == '.' && dp->d_name[2] == '\0'))) + (dp->d_name[1] == '.' && dp->d_name[2] == '\0'))) /* +=head1 Miscellaneous Functions + =for apidoc getcwd_sv Fill the sv with current working directory @@ -3727,23 +3490,23 @@ Perl_getcwd_sv(pTHX_ register SV *sv) { char buf[MAXPATHLEN]; - /* Some getcwd()s automatically allocate a buffer of the given + /* Some getcwd()s automatically allocate a buffer of the given * size from the heap if they are given a NULL buffer pointer. * The problem is that this behaviour is not portable. */ - if (getcwd(buf, sizeof(buf) - 1)) { - STRLEN len = strlen(buf); - sv_setpvn(sv, buf, len); - return TRUE; - } - else { - sv_setsv(sv, &PL_sv_undef); - return FALSE; - } + if (getcwd(buf, sizeof(buf) - 1)) { + STRLEN len = strlen(buf); + sv_setpvn(sv, buf, len); + return TRUE; + } + else { + sv_setsv(sv, &PL_sv_undef); + return FALSE; + } } #else - struct stat statbuf; + Stat_t statbuf; int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino; int namelen, pathlen=0; DIR *dir; @@ -3752,7 +3515,7 @@ Perl_getcwd_sv(pTHX_ register SV *sv) (void)SvUPGRADE(sv, SVt_PV); if (PerlLIO_lstat(".", &statbuf) < 0) { - SV_CWD_RETURN_UNDEF; + SV_CWD_RETURN_UNDEF; } orig_cdev = statbuf.st_dev; @@ -3761,102 +3524,844 @@ Perl_getcwd_sv(pTHX_ register SV *sv) cino = orig_cino; for (;;) { - odev = cdev; - oino = cino; - - if (PerlDir_chdir("..") < 0) { - SV_CWD_RETURN_UNDEF; - } - if (PerlLIO_stat(".", &statbuf) < 0) { - SV_CWD_RETURN_UNDEF; - } - - cdev = statbuf.st_dev; - cino = statbuf.st_ino; - - if (odev == cdev && oino == cino) { - break; - } - if (!(dir = PerlDir_open("."))) { - SV_CWD_RETURN_UNDEF; - } - - while ((dp = PerlDir_read(dir)) != NULL) { + odev = cdev; + oino = cino; + + if (PerlDir_chdir("..") < 0) { + SV_CWD_RETURN_UNDEF; + } + if (PerlLIO_stat(".", &statbuf) < 0) { + SV_CWD_RETURN_UNDEF; + } + + cdev = statbuf.st_dev; + cino = statbuf.st_ino; + + if (odev == cdev && oino == cino) { + break; + } + if (!(dir = PerlDir_open("."))) { + SV_CWD_RETURN_UNDEF; + } + + while ((dp = PerlDir_read(dir)) != NULL) { #ifdef DIRNAMLEN - namelen = dp->d_namlen; + namelen = dp->d_namlen; #else - namelen = strlen(dp->d_name); + namelen = strlen(dp->d_name); #endif - /* skip . and .. */ - if (SV_CWD_ISDOT(dp)) { - continue; - } + /* skip . and .. */ + if (SV_CWD_ISDOT(dp)) { + continue; + } - if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) { - SV_CWD_RETURN_UNDEF; - } + if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) { + SV_CWD_RETURN_UNDEF; + } - tdev = statbuf.st_dev; - tino = statbuf.st_ino; - if (tino == oino && tdev == odev) { - break; - } - } + tdev = statbuf.st_dev; + tino = statbuf.st_ino; + if (tino == oino && tdev == odev) { + break; + } + } - if (!dp) { - SV_CWD_RETURN_UNDEF; - } + if (!dp) { + SV_CWD_RETURN_UNDEF; + } - if (pathlen + namelen + 1 >= MAXPATHLEN) { - SV_CWD_RETURN_UNDEF; + if (pathlen + namelen + 1 >= MAXPATHLEN) { + SV_CWD_RETURN_UNDEF; } - SvGROW(sv, pathlen + namelen + 1); + SvGROW(sv, pathlen + namelen + 1); - if (pathlen) { - /* shift down */ - Move(SvPVX(sv), SvPVX(sv) + namelen + 1, pathlen, char); - } + if (pathlen) { + /* shift down */ + Move(SvPVX(sv), SvPVX(sv) + namelen + 1, pathlen, char); + } - /* prepend current directory to the front */ - *SvPVX(sv) = '/'; - Move(dp->d_name, SvPVX(sv)+1, namelen, char); - pathlen += (namelen + 1); + /* prepend current directory to the front */ + *SvPVX(sv) = '/'; + Move(dp->d_name, SvPVX(sv)+1, namelen, char); + pathlen += (namelen + 1); #ifdef VOID_CLOSEDIR - PerlDir_close(dir); + PerlDir_close(dir); #else - if (PerlDir_close(dir) < 0) { - SV_CWD_RETURN_UNDEF; - } + if (PerlDir_close(dir) < 0) { + SV_CWD_RETURN_UNDEF; + } #endif } if (pathlen) { - SvCUR_set(sv, pathlen); - *SvEND(sv) = '\0'; - SvPOK_only(sv); + SvCUR_set(sv, pathlen); + *SvEND(sv) = '\0'; + SvPOK_only(sv); if (PerlDir_chdir(SvPVX(sv)) < 0) { - SV_CWD_RETURN_UNDEF; - } + SV_CWD_RETURN_UNDEF; + } } if (PerlLIO_stat(".", &statbuf) < 0) { - SV_CWD_RETURN_UNDEF; + SV_CWD_RETURN_UNDEF; } cdev = statbuf.st_dev; cino = statbuf.st_ino; if (cdev != orig_cdev || cino != orig_cino) { - Perl_croak(aTHX_ "Unstable directory path, " - "current directory changed unexpectedly"); + Perl_croak(aTHX_ "Unstable directory path, " + "current directory changed unexpectedly"); } -#endif return TRUE; +#endif + #else return FALSE; #endif } +/* +=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 +version string, as well as upgrading the passed in SV to +an RV. + +Function must be called with an already existing SV like + + sv = NEWSV(92,0); + s = scan_version(s,sv); + +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). + +=cut +*/ + +char * +Perl_scan_version(pTHX_ char *s, SV *rv) +{ + 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 */ + + /* 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 ( abs(orev) > abs(rev) ) + Perl_croak(aTHX_ "Integer overflow in version"); + s++; + } + } + else { + while (--end >= s) { + orev = rev; + rev += (*end - '0') * mult; + mult *= 10; + if ( abs(orev) > 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 { + s = pos; + break; + } + while ( isDIGIT(*pos) ) { + if ( !saw_under && saw_period == 1 && pos-s == 3 ) + break; + pos++; + } + } + } + return s; +} + +/* +=for apidoc new_version + +Returns a new version object based on the passed in SV: + + SV *sv = new_version(SV *ver); + +Does not alter the passed in ver SV. See "upg_version" if you +want to upgrade the SV. + +=cut +*/ + +SV * +Perl_new_version(pTHX_ SV *ver) +{ + SV *rv = newSV(0); + char *version; + 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 ); + } +#endif + else /* must be a string or something like a string */ + { + version = (char *)SvPV(ver,PL_na); + } + version = scan_version(version,rv); + return rv; +} + +/* +=for apidoc upg_version + +In-place upgrade of the supplied SV to a version object. + + SV *sv = upg_version(SV *sv); + +Returns a pointer to the upgraded SV. + +=cut +*/ + +SV * +Perl_upg_version(pTHX_ SV *ver) +{ + 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 ); + } +#endif + version = scan_version(version,ver); + return ver; +} + + +/* +=for apidoc vnumify + +Accepts a version object and returns the normalized floating +point representation. Call like: + + sv = vnumify(rv); + +NOTE: you can pass either the object directly or the SV +contained within the RV. + +=cut +*/ + +SV * +Perl_vnumify(pTHX_ SV *vs) +{ + I32 i, len, digit; + SV *sv = NEWSV(92,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++ ) + { + digit = SvIVX(*av_fetch((AV *)vs, i, 0)); + Perl_sv_catpvf(aTHX_ sv,"%03d",abs(digit)); + } + if ( len == 0 ) + Perl_sv_catpv(aTHX_ sv,"000"); + sv_setnv(sv, SvNV(sv)); + return sv; +} + +/* +=for apidoc vstringify + +Accepts a version object and returns the normalized string +representation. Call like: + + sv = vstringify(rv); + +NOTE: you can pass either the object directly or the SV +contained within the RV. + +=cut +*/ + +SV * +Perl_vstringify(pTHX_ SV *vs) +{ + I32 i, len, digit; + SV *sv = NEWSV(92,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,"%"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 = abs(left); + right = 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) +# define EMULATE_SOCKETPAIR_UDP +#endif + +#ifdef EMULATE_SOCKETPAIR_UDP +static int +S_socketpair_udp (int fd[2]) { + dTHX; + /* Fake a datagram socketpair using UDP to localhost. */ + int sockets[2] = {-1, -1}; + struct sockaddr_in addresses[2]; + int i; + Sock_size_t size = sizeof(struct sockaddr_in); + unsigned short port; + int got; + + memset(&addresses, 0, sizeof(addresses)); + i = 1; + do { + sockets[i] = PerlSock_socket(AF_INET, SOCK_DGRAM, PF_INET); + if (sockets[i] == -1) + goto tidy_up_and_fail; + + addresses[i].sin_family = AF_INET; + addresses[i].sin_addr.s_addr = htonl(INADDR_LOOPBACK); + addresses[i].sin_port = 0; /* kernel choses port. */ + if (PerlSock_bind(sockets[i], (struct sockaddr *) &addresses[i], + sizeof(struct sockaddr_in)) == -1) + goto tidy_up_and_fail; + } while (i--); + + /* Now have 2 UDP sockets. Find out which port each is connected to, and + for each connect the other socket to it. */ + i = 1; + do { + if (PerlSock_getsockname(sockets[i], (struct sockaddr *) &addresses[i], + &size) == -1) + goto tidy_up_and_fail; + if (size != sizeof(struct sockaddr_in)) + goto abort_tidy_up_and_fail; + /* !1 is 0, !0 is 1 */ + if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i], + sizeof(struct sockaddr_in)) == -1) + goto tidy_up_and_fail; + } while (i--); + + /* Now we have 2 sockets connected to each other. I don't trust some other + process not to have already sent a packet to us (by random) so send + a packet from each to the other. */ + i = 1; + do { + /* I'm going to send my own port number. As a short. + (Who knows if someone somewhere has sin_port as a bitfield and needs + this routine. (I'm assuming crays have socketpair)) */ + port = addresses[i].sin_port; + got = PerlLIO_write(sockets[i], &port, sizeof(port)); + if (got != sizeof(port)) { + if (got == -1) + goto tidy_up_and_fail; + goto abort_tidy_up_and_fail; + } + } while (i--); + + /* Packets sent. I don't trust them to have arrived though. + (As I understand it Solaris TCP stack is multithreaded. Non-blocking + connect to localhost will use a second kernel thread. In 2.6 the + first thread running the connect() returns before the second completes, + so EINPROGRESS> In 2.7 the improved stack is faster and connect() + returns 0. Poor programs have tripped up. One poor program's authors' + had a 50-1 reverse stock split. Not sure how connected these were.) + So I don't trust someone not to have an unpredictable UDP stack. + */ + + { + struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */ + int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0]; + fd_set rset; + + FD_ZERO(&rset); + FD_SET(sockets[0], &rset); + FD_SET(sockets[1], &rset); + + got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor); + if (got != 2 || !FD_ISSET(sockets[0], &rset) + || !FD_ISSET(sockets[1], &rset)) { + /* I hope this is portable and appropriate. */ + if (got == -1) + goto tidy_up_and_fail; + goto abort_tidy_up_and_fail; + } + } + + /* And the paranoia department even now doesn't trust it to have arrive + (hence MSG_DONTWAIT). Or that what arrives was sent by us. */ + { + struct sockaddr_in readfrom; + unsigned short buffer[2]; + + i = 1; + do { +#ifdef MSG_DONTWAIT + got = PerlSock_recvfrom(sockets[i], (char *) &buffer, + sizeof(buffer), MSG_DONTWAIT, + (struct sockaddr *) &readfrom, &size); +#else + got = PerlSock_recvfrom(sockets[i], (char *) &buffer, + sizeof(buffer), 0, + (struct sockaddr *) &readfrom, &size); +#endif + + if (got == -1) + goto tidy_up_and_fail; + if (got != sizeof(port) + || size != sizeof(struct sockaddr_in) + /* Check other socket sent us its port. */ + || buffer[0] != (unsigned short) addresses[!i].sin_port + /* Check kernel says we got the datagram from that socket */ + || readfrom.sin_family != addresses[!i].sin_family + || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr + || readfrom.sin_port != addresses[!i].sin_port) + goto abort_tidy_up_and_fail; + } while (i--); + } + /* My caller (my_socketpair) has validated that this is non-NULL */ + fd[0] = sockets[0]; + fd[1] = sockets[1]; + /* I hereby declare this connection open. May God bless all who cross + her. */ + return 0; + + abort_tidy_up_and_fail: + errno = ECONNABORTED; + tidy_up_and_fail: + { + int save_errno = errno; + if (sockets[0] != -1) + PerlLIO_close(sockets[0]); + if (sockets[1] != -1) + PerlLIO_close(sockets[1]); + errno = save_errno; + return -1; + } +} +#endif /* EMULATE_SOCKETPAIR_UDP */ + +#if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) +int +Perl_my_socketpair (int family, int type, int protocol, int fd[2]) { + /* Stevens says that family must be AF_LOCAL, protocol 0. + I'm going to enforce that, then ignore it, and use TCP (or UDP). */ + dTHX; + int listener = -1; + int connector = -1; + int acceptor = -1; + struct sockaddr_in listen_addr; + struct sockaddr_in connect_addr; + Sock_size_t size; + + if (protocol +#ifdef AF_UNIX + || family != AF_UNIX +#endif + ) { + errno = EAFNOSUPPORT; + return -1; + } + if (!fd) { + errno = EINVAL; + return -1; + } + +#ifdef EMULATE_SOCKETPAIR_UDP + if (type == SOCK_DGRAM) + return S_socketpair_udp(fd); +#endif + + listener = PerlSock_socket(AF_INET, type, 0); + if (listener == -1) + return -1; + memset(&listen_addr, 0, sizeof(listen_addr)); + listen_addr.sin_family = AF_INET; + listen_addr.sin_addr.s_addr = htonl(INADDR_LOOPBACK); + listen_addr.sin_port = 0; /* kernel choses port. */ + if (PerlSock_bind(listener, (struct sockaddr *) &listen_addr, + sizeof(listen_addr)) == -1) + goto tidy_up_and_fail; + if (PerlSock_listen(listener, 1) == -1) + goto tidy_up_and_fail; + + connector = PerlSock_socket(AF_INET, type, 0); + if (connector == -1) + goto tidy_up_and_fail; + /* We want to find out the port number to connect to. */ + size = sizeof(connect_addr); + if (PerlSock_getsockname(listener, (struct sockaddr *) &connect_addr, + &size) == -1) + goto tidy_up_and_fail; + if (size != sizeof(connect_addr)) + goto abort_tidy_up_and_fail; + if (PerlSock_connect(connector, (struct sockaddr *) &connect_addr, + sizeof(connect_addr)) == -1) + goto tidy_up_and_fail; + + size = sizeof(listen_addr); + acceptor = PerlSock_accept(listener, (struct sockaddr *) &listen_addr, + &size); + if (acceptor == -1) + goto tidy_up_and_fail; + if (size != sizeof(listen_addr)) + goto abort_tidy_up_and_fail; + PerlLIO_close(listener); + /* Now check we are talking to ourself by matching port and host on the + two sockets. */ + if (PerlSock_getsockname(connector, (struct sockaddr *) &connect_addr, + &size) == -1) + goto tidy_up_and_fail; + if (size != sizeof(connect_addr) + || listen_addr.sin_family != connect_addr.sin_family + || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr + || listen_addr.sin_port != connect_addr.sin_port) { + goto abort_tidy_up_and_fail; + } + fd[0] = connector; + fd[1] = acceptor; + return 0; + + abort_tidy_up_and_fail: + errno = ECONNABORTED; /* I hope this is portable and appropriate. */ + tidy_up_and_fail: + { + int save_errno = errno; + if (listener != -1) + PerlLIO_close(listener); + if (connector != -1) + PerlLIO_close(connector); + if (acceptor != -1) + PerlLIO_close(acceptor); + errno = save_errno; + return -1; + } +} +#else +/* In any case have a stub so that there's code corresponding + * to the my_socketpair in global.sym. */ +int +Perl_my_socketpair (int family, int type, int protocol, int fd[2]) { +#ifdef HAS_SOCKETPAIR + return socketpair(family, type, protocol, fd); +#else + return -1; +#endif +} +#endif + +/* + +=for apidoc sv_nosharing + +Dummy routine which "shares" an SV when there is no sharing module present. +Exists to avoid test for a NULL function pointer and because it could potentially warn under +some level of strict-ness. + +=cut +*/ + +void +Perl_sv_nosharing(pTHX_ SV *sv) +{ +} + +/* +=for apidoc sv_nolocking + +Dummy routine which "locks" an SV when there is no locking module present. +Exists to avoid test for a NULL function pointer and because it could potentially warn under +some level of strict-ness. + +=cut +*/ + +void +Perl_sv_nolocking(pTHX_ SV *sv) +{ +} + + +/* +=for apidoc sv_nounlocking + +Dummy routine which "unlocks" an SV when there is no locking module present. +Exists to avoid test for a NULL function pointer and because it could potentially warn under +some level of strict-ness. + +=cut +*/ + +void +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 0x%"UVuf, + (UV) (opt & ~PERL_UNICODE_ALL_FLAGS)); + + *popt = p; + + return opt; +} +