X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=util.c;h=ab1d6dc2131b3ec454c1c05d2ca920772d248cc1;hb=a40a317b715a38747586893811eae258898ef4d7;hp=ed7ca66902501a60293e9c42fcfea8d08b8c0dd7;hpb=26ec6fc3972632211ff6621d98aed1b1df0d166d;p=p5sagit%2Fp5-mst-13.2.git diff --git a/util.c b/util.c index ed7ca66..ab1d6dc 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, 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. @@ -357,8 +358,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. */ @@ -967,10 +972,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; @@ -1246,7 +1247,7 @@ Perl_vwarn(pTHX_ const char* pat, va_list *args) } /* if STDERR is tied, use it instead */ - if (PL_stderrgv && (io = GvIOp(PL_stderrgv)) + if (PL_stderrgv && SvREFCNT(PL_stderrgv) && (io = GvIO(PL_stderrgv)) && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) { dSP; ENTER; PUSHMARK(SP); @@ -1332,9 +1333,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; @@ -2082,7 +2080,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 +2093,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 +2107,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 +2177,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,9 +2197,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) @@ -2234,9 +2236,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) @@ -2802,7 +2803,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 +2824,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 +2836,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 +2955,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 +2981,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 +2991,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 +3394,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); @@ -3944,7 +3683,7 @@ Perl_scan_vstring(pTHX_ char *s, SV *sv) } #ifdef EBCDIC if (rev > 0x7FFFFFFF) - Perl_croak(aTHX "In EBCDIC the v-string components cannot exceed 2147483647"); + 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); @@ -3990,6 +3729,7 @@ is a beta version). char * Perl_scan_version(pTHX_ char *s, SV *rv) { + const char *start = s; char *pos = s; I32 saw_period = 0; bool saw_under = 0; @@ -4026,26 +3766,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; /* 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; @@ -4081,7 +3835,7 @@ want to upgrade the SV. SV * Perl_new_version(pTHX_ SV *ver) { - SV *rv = NEWSV(92,5); + SV *rv = newSV(0); char *version; if ( SvNOK(ver) ) /* may get too much accuracy */ { @@ -4095,7 +3849,7 @@ Perl_new_version(pTHX_ SV *ver) version = savepvn( (const char*)mg->mg_ptr,mg->mg_len ); } #endif - else + else /* must be a string or something like a string */ { version = (char *)SvPV(ver,PL_na); } @@ -4158,14 +3912,15 @@ Perl_vnumify(pTHX_ SV *vs) return sv; } digit = SvIVX(*av_fetch((AV *)vs, 0, 0)); - Perl_sv_setpvf(aTHX_ sv,"%d.",abs(digit)); + 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",abs(digit)); + 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; } @@ -4197,19 +3952,19 @@ Perl_vstringify(pTHX_ SV *vs) 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 == 0 ) Perl_sv_catpv(aTHX_ sv,".0"); return sv; -} +} /* =for apidoc vcmp @@ -4239,8 +3994,8 @@ Perl_vcmp(pTHX_ SV *lsv, SV *rsv) 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); + left = PERL_ABS(left); + right = PERL_ABS(right); if ( left < right || (left == right && lbeta && !rbeta) ) retval = -1; if ( left > right || (left == right && rbeta && !lbeta) ) @@ -4248,8 +4003,14 @@ Perl_vcmp(pTHX_ SV *lsv, SV *rsv) i++; } - if ( l != r && retval == 0 ) - retval = l < r ? -1 : +1; + 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; } @@ -4554,3 +4315,57 @@ 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; +} +