diff options
Diffstat (limited to 'contrib/perl5/util.c')
| -rw-r--r-- | contrib/perl5/util.c | 279 |
1 files changed, 197 insertions, 82 deletions
diff --git a/contrib/perl5/util.c b/contrib/perl5/util.c index 431c5fa..39f5f7a 100644 --- a/contrib/perl5/util.c +++ b/contrib/perl5/util.c @@ -1,6 +1,6 @@ /* util.c * - * Copyright (c) 1991-1997, Larry Wall + * Copyright (c) 1991-1999, 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. @@ -621,6 +621,9 @@ perl_init_i18nl10n(int printwarn) #ifdef USE_LOCALE_NUMERIC char *curnum = NULL; #endif /* USE_LOCALE_NUMERIC */ +#ifdef __GLIBC__ + char *language = PerlEnv_getenv("LANGUAGE"); +#endif char *lc_all = PerlEnv_getenv("LC_ALL"); char *lang = PerlEnv_getenv("LANG"); bool setlocale_failure = FALSE; @@ -641,65 +644,53 @@ perl_init_i18nl10n(int printwarn) else setlocale_failure = TRUE; } - if (!setlocale_failure) -#endif /* LC_ALL */ - { + if (!setlocale_failure) { #ifdef USE_LOCALE_CTYPE - if (! (curctype = setlocale(LC_CTYPE, - (!done && (lang || PerlEnv_getenv("LC_CTYPE"))) + if (! (curctype = + setlocale(LC_CTYPE, + (!done && (lang || PerlEnv_getenv("LC_CTYPE"))) ? "" : Nullch))) setlocale_failure = TRUE; #endif /* USE_LOCALE_CTYPE */ #ifdef USE_LOCALE_COLLATE - if (! (curcoll = setlocale(LC_COLLATE, - (!done && (lang || PerlEnv_getenv("LC_COLLATE"))) + if (! (curcoll = + setlocale(LC_COLLATE, + (!done && (lang || PerlEnv_getenv("LC_COLLATE"))) ? "" : Nullch))) setlocale_failure = TRUE; #endif /* USE_LOCALE_COLLATE */ #ifdef USE_LOCALE_NUMERIC - if (! (curnum = setlocale(LC_NUMERIC, - (!done && (lang || PerlEnv_getenv("LC_NUMERIC"))) + if (! (curnum = + setlocale(LC_NUMERIC, + (!done && (lang || PerlEnv_getenv("LC_NUMERIC"))) ? "" : Nullch))) setlocale_failure = TRUE; #endif /* USE_LOCALE_NUMERIC */ } -#else /* !LOCALE_ENVIRON_REQUIRED */ +#endif /* LC_ALL */ -#ifdef LC_ALL +#endif /* !LOCALE_ENVIRON_REQUIRED */ +#ifdef LC_ALL if (! setlocale(LC_ALL, "")) setlocale_failure = TRUE; - else { -#ifdef USE_LOCALE_CTYPE - curctype = setlocale(LC_CTYPE, Nullch); -#endif /* USE_LOCALE_CTYPE */ -#ifdef USE_LOCALE_COLLATE - curcoll = setlocale(LC_COLLATE, Nullch); -#endif /* USE_LOCALE_COLLATE */ -#ifdef USE_LOCALE_NUMERIC - curnum = setlocale(LC_NUMERIC, Nullch); -#endif /* USE_LOCALE_NUMERIC */ - } - -#else /* !LC_ALL */ +#endif /* LC_ALL */ + if (!setlocale_failure) { #ifdef USE_LOCALE_CTYPE - if (! (curctype = setlocale(LC_CTYPE, ""))) - setlocale_failure = TRUE; + if (! (curctype = setlocale(LC_CTYPE, ""))) + setlocale_failure = TRUE; #endif /* USE_LOCALE_CTYPE */ #ifdef USE_LOCALE_COLLATE - if (! (curcoll = setlocale(LC_COLLATE, ""))) - setlocale_failure = TRUE; + if (! (curcoll = setlocale(LC_COLLATE, ""))) + setlocale_failure = TRUE; #endif /* USE_LOCALE_COLLATE */ #ifdef USE_LOCALE_NUMERIC - if (! (curnum = setlocale(LC_NUMERIC, ""))) - setlocale_failure = TRUE; + if (! (curnum = setlocale(LC_NUMERIC, ""))) + setlocale_failure = TRUE; #endif /* USE_LOCALE_NUMERIC */ - -#endif /* LC_ALL */ - -#endif /* !LOCALE_ENVIRON_REQUIRED */ + } if (setlocale_failure) { char *p; @@ -736,6 +727,14 @@ perl_init_i18nl10n(int printwarn) PerlIO_printf(PerlIO_stderr(), "perl: warning: Please check that your locale settings:\n"); +#ifdef __GLIBC__ + PerlIO_printf(PerlIO_stderr(), + "\tLANGUAGE = %c%s%c,\n", + language ? '"' : '(', + language ? language : "unset", + language ? '"' : ')'); +#endif + PerlIO_printf(PerlIO_stderr(), "\tLC_ALL = %c%s%c,\n", lc_all ? '"' : '(', @@ -897,14 +896,15 @@ mem_collxfrm(const char *s, STRLEN len, STRLEN *xlen) void fbm_compile(SV *sv, U32 flags /* not used yet */) { - register unsigned char *s; - register unsigned char *table; + register U8 *s; + register U8 *table; register U32 i; - register U32 len = SvCUR(sv); + STRLEN len; I32 rarest = 0; U32 frequency = 256; - sv_upgrade(sv, SVt_PVBM); + s = (U8*)SvPV_force(sv, len); + (void)SvUPGRADE(sv, SVt_PVBM); if (len > 255 || len == 0) /* TAIL might be on on a zero-length string. */ return; /* can't have offsets that big */ if (len > 2) { @@ -1501,21 +1501,16 @@ my_setenv(char *nam,char *val) #else /* !USE_WIN32_RTL_ENV */ - /* The sane way to deal with the environment. - * Has these advantages over putenv() & co.: - * * enables us to store a truly empty value in the - * environment (like in UNIX). - * * we don't have to deal with RTL globals, bugs and leaks. - * * Much faster. - * Why you may want to enable USE_WIN32_RTL_ENV: - * * environ[] and RTL functions will not reflect changes, - * which might be an issue if extensions want to access - * the env. via RTL. This cuts both ways, since RTL will - * not see changes made by extensions that call the Win32 - * functions directly, either. - * GSAR 97-06-07 - */ - SetEnvironmentVariable(nam,val); + register char *envstr; + STRLEN len = strlen(nam) + 3; + if (!val) { + val = ""; + } + len += strlen(val); + New(904, envstr, len, char); + (void)sprintf(envstr,"%s=%s",nam,val); + (void)PerlEnv_putenv(envstr); + Safefree(envstr); #endif } @@ -2198,9 +2193,9 @@ repeatcpy(register char *to, register char *from, I32 len, register I32 count) register char *frombase = from; if (len == 1) { - todo = *from; + register char c = *from; while (count-- > 0) - *to++ = todo; + *to++ = c; return; } while (count-- > 0) { @@ -2354,18 +2349,26 @@ scan_hex(char *start, I32 len, I32 *retlen) register UV retval = 0; bool overflowed = FALSE; char *tmp = s; + register UV n; - while (len-- && *s && (tmp = strchr((char *) PL_hexdigit, *s))) { - register UV n = retval << 4; + while (len-- && *s) { + tmp = strchr((char *) PL_hexdigit, *s++); + if (!tmp) { + if (*(s-1) == '_' || (*(s-1) == 'x' && retval == 0)) + continue; + else { + --s; + if (PL_dowarn) + warn("Illegal hex digit ignored"); + break; + } + } + n = retval << 4; if (!overflowed && (n >> 4) != retval) { warn("Integer overflow in hex number"); overflowed = TRUE; } retval = n | ((tmp - PL_hexdigit) & 15); - s++; - } - if (PL_dowarn && !tmp) { - warn("Illegal hex digit ignored"); } *retlen = s - start; return retval; @@ -2469,7 +2472,8 @@ find_script(char *scriptname, bool dosearch, char **search_ext, I32 flags) #endif DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",cur)); - if (PerlLIO_stat(cur,&PL_statbuf) >= 0) { + if (PerlLIO_stat(cur,&PL_statbuf) >= 0 + && !S_ISDIR(PL_statbuf.st_mode)) { dosearch = 0; scriptname = cur; #ifdef SEARCH_EXTS @@ -2538,6 +2542,9 @@ find_script(char *scriptname, bool dosearch, char **search_ext, I32 flags) #endif DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf)); retval = PerlLIO_stat(tmpbuf,&PL_statbuf); + if (S_ISDIR(PL_statbuf.st_mode)) { + retval = -1; + } #ifdef SEARCH_EXTS } while ( retval < 0 /* not there */ && extidx>=0 && ext[extidx] /* try an extension? */ @@ -2560,7 +2567,9 @@ find_script(char *scriptname, bool dosearch, char **search_ext, I32 flags) xfailed = savepv(tmpbuf); } #ifndef DOSISH - if (!xfound && !seen_dot && !xfailed && (PerlLIO_stat(scriptname,&PL_statbuf) < 0)) + if (!xfound && !seen_dot && !xfailed && + (PerlLIO_stat(scriptname,&PL_statbuf) < 0 + || S_ISDIR(PL_statbuf.st_mode))) #endif seen_dot = 1; /* Disable message. */ if (!xfound) { @@ -2729,7 +2738,7 @@ new_struct_thread(struct perl_thread *t) SvGROW(sv, sizeof(struct perl_thread) + 1); SvCUR_set(sv, sizeof(struct perl_thread)); thr = (Thread) SvPVX(sv); - /* debug */ +#ifdef DEBUGGING memset(thr, 0xab, sizeof(struct perl_thread)); PL_markstack = 0; PL_scopestack = 0; @@ -2737,7 +2746,10 @@ new_struct_thread(struct perl_thread *t) PL_retstack = 0; PL_dirty = 0; PL_localizing = 0; - /* end debug */ + Zero(&PL_hv_fetch_ent_mh, 1, HE); +#else + Zero(thr, 1, struct perl_thread); +#endif thr->oursv = sv; init_stacks(ARGS); @@ -2751,10 +2763,6 @@ new_struct_thread(struct perl_thread *t) thr->flags = THRf_R_JOINABLE; MUTEX_INIT(&thr->mutex); - 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? */ - /* top_env needs to be non-zero. It points to an area in which longjmp() stuff is stored, as C callstack @@ -2772,6 +2780,25 @@ new_struct_thread(struct perl_thread *t) PL_in_eval = FALSE; PL_restartop = 0; + PL_statname = NEWSV(66,0); + PL_maxscream = -1; + PL_regcompp = FUNC_NAME_TO_PTR(pregcomp); + PL_regexecp = FUNC_NAME_TO_PTR(regexec_flags); + 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; + + /* parent thread's data needs to be locked while we make copy */ + MUTEX_LOCK(&t->mutex); + + 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_nrs = newSVsv(t->Tnrs); @@ -2785,18 +2812,6 @@ new_struct_thread(struct perl_thread *t) PL_bodytarget = newSVsv(t->Tbodytarget); PL_toptarget = newSVsv(t->Ttoptarget); - PL_statname = NEWSV(66,0); - PL_maxscream = -1; - PL_regcompp = FUNC_NAME_TO_PTR(pregcomp); - PL_regexecp = FUNC_NAME_TO_PTR(regexec_flags); - 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; - /* Initialise all per-thread SVs that the template thread used */ svp = AvARRAY(t->threadsv); for (i = 0; i <= AvFILLp(t->threadsv); i++, svp++) { @@ -2819,6 +2834,9 @@ new_struct_thread(struct perl_thread *t) thr->next->prev = thr; MUTEX_UNLOCK(&PL_threads_mutex); + /* done copying parent's state */ + MUTEX_UNLOCK(&t->mutex); + #ifdef HAVE_THREAD_INTERN init_thread_intern(thr); #endif /* HAVE_THREAD_INTERN */ @@ -2877,3 +2895,100 @@ get_specialsv_list(void) { return PL_specialsv_list; } + + +MGVTBL* +get_vtbl(int vtbl_id) +{ + MGVTBL* result = Null(MGVTBL*); + + switch(vtbl_id) { + case want_vtbl_sv: + result = &vtbl_sv; + break; + case want_vtbl_env: + result = &vtbl_env; + break; + case want_vtbl_envelem: + result = &vtbl_envelem; + break; + case want_vtbl_sig: + result = &vtbl_sig; + break; + case want_vtbl_sigelem: + result = &vtbl_sigelem; + break; + case want_vtbl_pack: + result = &vtbl_pack; + break; + case want_vtbl_packelem: + result = &vtbl_packelem; + break; + case want_vtbl_dbline: + result = &vtbl_dbline; + break; + case want_vtbl_isa: + result = &vtbl_isa; + break; + case want_vtbl_isaelem: + result = &vtbl_isaelem; + break; + case want_vtbl_arylen: + result = &vtbl_arylen; + break; + case want_vtbl_glob: + result = &vtbl_glob; + break; + case want_vtbl_mglob: + result = &vtbl_mglob; + break; + case want_vtbl_nkeys: + result = &vtbl_nkeys; + break; + case want_vtbl_taint: + result = &vtbl_taint; + break; + case want_vtbl_substr: + result = &vtbl_substr; + break; + case want_vtbl_vec: + result = &vtbl_vec; + break; + case want_vtbl_pos: + result = &vtbl_pos; + break; + case want_vtbl_bm: + result = &vtbl_bm; + break; + case want_vtbl_fm: + result = &vtbl_fm; + break; + case want_vtbl_uvar: + result = &vtbl_uvar; + break; +#ifdef USE_THREADS + case want_vtbl_mutex: + result = &vtbl_mutex; + break; +#endif + case want_vtbl_defelem: + result = &vtbl_defelem; + break; + case want_vtbl_regexp: + result = &vtbl_regexp; + break; +#ifdef USE_LOCALE_COLLATE + case want_vtbl_collxfrm: + result = &vtbl_collxfrm; + break; +#endif + case want_vtbl_amagic: + result = &vtbl_amagic; + break; + case want_vtbl_amagicelem: + result = &vtbl_amagicelem; + break; + } + return result; +} + |
