X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=util.c;h=2fa77408a988ec5973bd68cf0ec2a4d14a7b9ac0;hb=6224f72bf639f0ca7f774fe2738f2408b3e430ac;hp=3572c4279c6e79d29ff9a0808f71595518a9b9cf;hpb=a559c25918b1466cdb50c9f978a86f01be0bac10;p=p5sagit%2Fp5-mst-13.2.git diff --git a/util.c b/util.c index 3572c42..2fa7740 100644 --- a/util.c +++ b/util.c @@ -1,271 +1,2862 @@ -/* $Header: util.c,v 1.0.1.1 88/01/28 11:06:35 root Exp $ +/* util.c + * + * Copyright (c) 1991-1997, 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. * - * $Log: util.c,v $ - * Revision 1.0.1.1 88/01/28 11:06:35 root - * patch8: changed fatal() to support eval operator with exiting. - * - * Revision 1.0 87/12/18 13:06:30 root - * Initial revision - * */ -#include +/* + * "Very useful, no doubt, that was to Saruman; yet it seems that he was + * not content." --Gandalf + */ -#include "handy.h" #include "EXTERN.h" -#include "search.h" #include "perl.h" -#include "INTERN.h" -#include "util.h" +#include "perlmem.h" + +#if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX) +#include +#endif + +#ifndef SIG_ERR +# define SIG_ERR ((Sighandler_t) -1) +#endif + +/* XXX If this causes problems, set i_unistd=undef in the hint file. */ +#ifdef I_UNISTD +# include +#endif + +#ifdef I_VFORK +# include +#endif + +/* Put this after #includes because fork and vfork prototypes may + conflict. +*/ +#ifndef HAS_VFORK +# define vfork fork +#endif + +#ifdef I_FCNTL +# include +#endif +#ifdef I_SYS_FILE +# include +#endif + +#ifdef I_SYS_WAIT +# include +#endif #define FLUSH -#define MEM_SIZE unsigned int -static char nomem[] = "Out of memory!\n"; +#ifdef LEAKTEST + +static void xstat _((int)); +long xcount[MAXXCOUNT]; +long lastxcount[MAXXCOUNT]; +long xycount[MAXXCOUNT][MAXYCOUNT]; +long lastxycount[MAXXCOUNT][MAXYCOUNT]; + +#endif + +#ifndef MYMALLOC /* paranoid version of malloc */ -static int an = 0; +/* NOTE: Do not call the next three routines directly. Use the macros + * in handy.h, so that we can easily redefine everything to do tracking of + * allocated hunks back to the original New to track down any memory leaks. + * XXX This advice seems to be widely ignored :-( --AD August 1996. + */ -char * -safemalloc(size) -MEM_SIZE size; +Malloc_t +safemalloc(MEM_SIZE size) { - char *ptr; - char *malloc(); - - ptr = malloc(size?size:1); /* malloc(0) is NASTY on our system */ + Malloc_t ptr; +#ifdef HAS_64K_LIMIT + if (size > 0xffff) { + PerlIO_printf(PerlIO_stderr(), "Allocation too large: %lx\n", size) FLUSH; + my_exit(1); + } +#endif /* HAS_64K_LIMIT */ #ifdef DEBUGGING - if (debug & 128) - fprintf(stderr,"0x%x: (%05d) malloc %d bytes\n",ptr,an++,size); + if ((long)size < 0) + croak("panic: malloc"); +#endif + ptr = PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */ +#if !(defined(I286) || defined(atarist)) + DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%x: (%05d) malloc %ld bytes\n",ptr,an++,(long)size)); +#else + DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) malloc %ld bytes\n",ptr,an++,(long)size)); #endif if (ptr != Nullch) return ptr; + else if (nomemok) + return Nullch; else { - fputs(nomem,stdout) FLUSH; - exit(1); + PerlIO_puts(PerlIO_stderr(),no_mem) FLUSH; + my_exit(1); + return Nullch; } /*NOTREACHED*/ } /* paranoid version of realloc */ -char * -saferealloc(where,size) -char *where; -MEM_SIZE size; +Malloc_t +saferealloc(Malloc_t where,MEM_SIZE size) { - char *ptr; - char *realloc(); + Malloc_t ptr; +#if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) + Malloc_t PerlMem_realloc(); +#endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */ - ptr = realloc(where,size?size:1); /* realloc(0) is NASTY on our system */ -#ifdef DEBUGGING - if (debug & 128) { - fprintf(stderr,"0x%x: (%05d) rfree\n",where,an++); - fprintf(stderr,"0x%x: (%05d) realloc %d bytes\n",ptr,an++,size); +#ifdef HAS_64K_LIMIT + if (size > 0xffff) { + PerlIO_printf(PerlIO_stderr(), + "Reallocation too large: %lx\n", size) FLUSH; + my_exit(1); } +#endif /* HAS_64K_LIMIT */ + if (!size) { + safefree(where); + return NULL; + } + + if (!where) + return safemalloc(size); +#ifdef DEBUGGING + if ((long)size < 0) + croak("panic: realloc"); +#endif + ptr = PerlMem_realloc(where,size); + +#if !(defined(I286) || defined(atarist)) + DEBUG_m( { + PerlIO_printf(Perl_debug_log, "0x%x: (%05d) rfree\n",where,an++); + PerlIO_printf(Perl_debug_log, "0x%x: (%05d) realloc %ld bytes\n",ptr,an++,(long)size); + } ) +#else + DEBUG_m( { + PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) rfree\n",where,an++); + PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) realloc %ld bytes\n",ptr,an++,(long)size); + } ) #endif + if (ptr != Nullch) return ptr; + else if (nomemok) + return Nullch; else { - fputs(nomem,stdout) FLUSH; - exit(1); + PerlIO_puts(PerlIO_stderr(),no_mem) FLUSH; + my_exit(1); + return Nullch; } /*NOTREACHED*/ } /* safe version of free */ -safefree(where) -char *where; +Free_t +safefree(Malloc_t where) +{ +#if !(defined(I286) || defined(atarist)) + DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%x: (%05d) free\n",(char *) where,an++)); +#else + DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) free\n",(char *) where,an++)); +#endif + if (where) { + /*SUPPRESS 701*/ + PerlMem_free(where); + } +} + +/* safe version of calloc */ + +Malloc_t +safecalloc(MEM_SIZE count, MEM_SIZE size) { + Malloc_t ptr; + +#ifdef HAS_64K_LIMIT + if (size * count > 0xffff) { + PerlIO_printf(PerlIO_stderr(), + "Allocation too large: %lx\n", size * count) FLUSH; + my_exit(1); + } +#endif /* HAS_64K_LIMIT */ #ifdef DEBUGGING - if (debug & 128) - fprintf(stderr,"0x%x: (%05d) free\n",where,an++); + if ((long)size < 0 || (long)count < 0) + croak("panic: calloc"); +#endif + size *= count; + ptr = PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */ +#if !(defined(I286) || defined(atarist)) + DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%x: (%05d) calloc %ld x %ld bytes\n",ptr,an++,(long)count,(long)size)); +#else + DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) calloc %ld x %ld bytes\n",ptr,an++,(long)count,(long)size)); #endif - free(where); + if (ptr != Nullch) { + memset((void*)ptr, 0, size); + return ptr; + } + else if (nomemok) + return Nullch; + else { + PerlIO_puts(PerlIO_stderr(),no_mem) FLUSH; + my_exit(1); + return Nullch; + } + /*NOTREACHED*/ } -/* safe version of string copy */ +#endif /* !MYMALLOC */ -char * -safecpy(to,from,len) -char *to; -register char *from; -register int len; +#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 +safexmalloc(I32 x, MEM_SIZE size) { - register char *dest = to; + register char* where = (char*)safemalloc(size + ALIGN); - if (from != Nullch) - for (len--; len && (*dest++ = *from++); len--) ; - *dest = '\0'; - return to; + xcount[x] += size; + xycount[x][SIZE_TO_Y(size)]++; + set_typeof_chunk(where, x); + sizeof_chunk(where) = size; + return (Malloc_t)(where + ALIGN); } -#ifdef undef -/* safe version of string concatenate, with \n deletion and space padding */ +Malloc_t +safexrealloc(Malloc_t wh, MEM_SIZE size) +{ + char *where = (char*)wh; -char * -safecat(to,from,len) -char *to; -register char *from; -register int len; + 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 +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 +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 +xstat(int flag) { - register char *dest = to; + register I32 i, j, total = 0; + I32 subtot[MAXYCOUNT]; - len--; /* leave room for null */ - if (*dest) { - while (len && *dest++) len--; - if (len) { - len--; - *(dest-1) = ' '; + for (j = 0; j < MAXYCOUNT; j++) { + subtot[j] = 0; + } + + PerlIO_printf(PerlIO_stderr(), " 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(PerlIO_stderr(),"%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(PerlIO_stderr(),"%3ld ", + flag == 2 + ? xycount[i][j] - lastxycount[i][j] + : xycount[i][j]); + lastxycount[i][j] = xycount[i][j]; + } else { + PerlIO_printf(PerlIO_stderr(), " . ", xycount[i][j]); + } + } + PerlIO_printf(PerlIO_stderr(), "\n"); } } - if (from != Nullch) - while (len && (*dest++ = *from++)) len--; - if (len) - dest--; - if (*(dest-1) == '\n') - dest--; - *dest = '\0'; - return to; + if (flag != 2) { + PerlIO_printf(PerlIO_stderr(), "Total %7ld ", total); + for (j = 0; j < MAXYCOUNT; j++) { + if (subtot[j]) { + PerlIO_printf(PerlIO_stderr(), "%3ld ", subtot[j]); + } else { + PerlIO_printf(PerlIO_stderr(), " . "); + } + } + PerlIO_printf(PerlIO_stderr(), "\n"); + } } -#endif + +#endif /* LEAKTEST */ /* copy a string up to some (non-backslashed) delimiter, if any */ char * -cpytill(to,from,delim) -register char *to, *from; -register int delim; +delimcpy(register char *to, register char *toend, register char *from, register char *fromend, register int delim, I32 *retlen) { - for (; *from; from++,to++) { - if (*from == '\\' && from[1] == delim) - from++; + register I32 tolen; + for (tolen = 0; from < fromend; from++, tolen++) { + if (*from == '\\') { + if (from[1] == delim) + from++; + else { + if (to < toend) + *to++ = *from; + tolen++; + from++; + } + } else if (*from == delim) break; - *to = *from; + if (to < toend) + *to++ = *from; } - *to = '\0'; + if (to < toend) + *to = '\0'; + *retlen = tolen; return from; } /* return ptr to little string in big string, NULL if not found */ +/* This routine was donated by Corey Satten. */ char * -instr(big, little) -char *big, *little; - +instr(register char *big, register char *little) { - register char *t, *s, *x; + register char *s, *x; + register I32 first; - for (t = big; *t; t++) { - for (x=t,s=little; *s; x++,s++) { + if (!little) + return big; + first = *little++; + if (!first) + return big; + while (*big) { + if (*big++ != first) + continue; + for (x=big,s=little; *s; /**/ ) { if (!*x) return Nullch; - if (*s != *x) + if (*s++ != *x++) { + s--; break; + } } if (!*s) - return t; + return big-1; } return Nullch; } -/* copy a string to a safe spot */ +/* same as instr but allow embedded nulls */ char * -savestr(str) -char *str; +ninstr(register char *big, register char *bigend, char *little, char *lend) { - register char *newaddr = safemalloc((MEM_SIZE)(strlen(str)+1)); + register char *s, *x; + register I32 first = *little; + register char *littleend = lend; - (void)strcpy(newaddr,str); - return newaddr; + if (!first && little >= littleend) + return big; + if (bigend - big < littleend - little) + return Nullch; + bigend -= littleend - little++; + while (big <= bigend) { + if (*big++ != first) + continue; + for (x=big,s=little; s < littleend; /**/ ) { + if (*s++ != *x++) { + s--; + break; + } + } + if (s >= littleend) + return big-1; + } + return Nullch; } -/* grow a static string to at least a certain length */ +/* reverse of the above--find last substring */ + +char * +rninstr(register char *big, char *bigend, char *little, char *lend) +{ + register char *bigbeg; + register char *s, *x; + register I32 first = *little; + register char *littleend = lend; + + if (!first && little >= littleend) + return bigend; + bigbeg = big; + big = bigend - (littleend - little++); + while (big >= bigbeg) { + if (*big-- != first) + continue; + for (x=big+2,s=little; s < littleend; /**/ ) { + if (*s++ != *x++) { + s--; + break; + } + } + if (s >= littleend) + return big+1; + } + return Nullch; +} +/* + * Set up for a new ctype locale. + */ void -growstr(strptr,curlen,newlen) -char **strptr; -int *curlen; -int newlen; -{ - if (newlen > *curlen) { /* need more room? */ - if (*curlen) - *strptr = saferealloc(*strptr,(MEM_SIZE)newlen); +perl_new_ctype(char *newctype) +{ +#ifdef USE_LOCALE_CTYPE + + int i; + + for (i = 0; i < 256; i++) { + if (isUPPER_LC(i)) + fold_locale[i] = toLOWER_LC(i); + else if (isLOWER_LC(i)) + fold_locale[i] = toUPPER_LC(i); else - *strptr = safemalloc((MEM_SIZE)newlen); - *curlen = newlen; + fold_locale[i] = i; } + +#endif /* USE_LOCALE_CTYPE */ } -/*VARARGS1*/ -fatal(pat,a1,a2,a3,a4) -char *pat; +/* + * Set up for a new collation locale. + */ +void +perl_new_collate(char *newcoll) { - extern FILE *e_fp; - extern char *e_tmpname; +#ifdef USE_LOCALE_COLLATE - if (in_eval) { - sprintf(tokenbuf,pat,a1,a2,a3,a4); - str_set(stabent("@",TRUE)->stab_val,tokenbuf); - longjmp(eval_env,1); + if (! newcoll) { + if (collation_name) { + ++collation_ix; + Safefree(collation_name); + collation_name = NULL; + collation_standard = TRUE; + collxfrm_base = 0; + collxfrm_mult = 2; + } + return; } - fprintf(stderr,pat,a1,a2,a3,a4); - if (e_fp) - UNLINK(e_tmpname); - exit(1); -} -static bool firstsetenv = TRUE; -extern char **environ; + if (! collation_name || strNE(collation_name, newcoll)) { + ++collation_ix; + Safefree(collation_name); + collation_name = savepv(newcoll); + collation_standard = (strEQ(newcoll, "C") || strEQ(newcoll, "POSIX")); + + { + /* 2: at most so many chars ('a', 'b'). */ + /* 50: surely no system expands a char more. */ +#define XFRMBUFSIZE (2 * 50) + char xbuf[XFRMBUFSIZE]; + Size_t fa = strxfrm(xbuf, "a", XFRMBUFSIZE); + Size_t fb = strxfrm(xbuf, "ab", XFRMBUFSIZE); + SSize_t mult = fb - fa; + if (mult < 1) + croak("strxfrm() gets absurd"); + collxfrm_base = (fa > mult) ? (fa - mult) : 0; + collxfrm_mult = mult; + } + } + +#endif /* USE_LOCALE_COLLATE */ +} +/* + * Set up for a new numeric locale. + */ void -setenv(nam,val) -char *nam, *val; +perl_new_numeric(char *newnum) { - register int i=envix(nam); /* where does it go? */ +#ifdef USE_LOCALE_NUMERIC - if (!environ[i]) { /* does not exist yet */ - if (firstsetenv) { /* need we copy environment? */ - int j; -#ifndef lint - char **tmpenv = (char**) /* point our wand at memory */ - safemalloc((i+2) * sizeof(char*)); -#else - char **tmpenv = Null(char **); -#endif /* lint */ - - firstsetenv = FALSE; - for (j=0; j 1 || + printwarn && + (!(p = PerlEnv_getenv("PERL_BADLANG")) || atoi(p))); + + if (locwarn) { +#ifdef LC_ALL + + PerlIO_printf(PerlIO_stderr(), + "perl: warning: Setting locale failed.\n"); + +#else /* !LC_ALL */ + + PerlIO_printf(PerlIO_stderr(), + "perl: warning: Setting locale failed for the categories:\n\t"); +#ifdef USE_LOCALE_CTYPE + if (! curctype) + PerlIO_printf(PerlIO_stderr(), "LC_CTYPE "); +#endif /* USE_LOCALE_CTYPE */ +#ifdef USE_LOCALE_COLLATE + if (! curcoll) + PerlIO_printf(PerlIO_stderr(), "LC_COLLATE "); +#endif /* USE_LOCALE_COLLATE */ +#ifdef USE_LOCALE_NUMERIC + if (! curnum) + PerlIO_printf(PerlIO_stderr(), "LC_NUMERIC "); +#endif /* USE_LOCALE_NUMERIC */ + PerlIO_printf(PerlIO_stderr(), "\n"); + +#endif /* LC_ALL */ + + PerlIO_printf(PerlIO_stderr(), + "perl: warning: Please check that your locale settings:\n"); + + PerlIO_printf(PerlIO_stderr(), + "\tLC_ALL = %c%s%c,\n", + lc_all ? '"' : '(', + lc_all ? lc_all : "unset", + lc_all ? '"' : ')'); + + { + char **e; + for (e = environ; *e; e++) { + if (strnEQ(*e, "LC_", 3) + && strnNE(*e, "LC_ALL=", 7) + && (p = strchr(*e, '='))) + PerlIO_printf(PerlIO_stderr(), "\t%.*s = \"%s\",\n", + (int)(p - *e), *e, p + 1); + } + } + + PerlIO_printf(PerlIO_stderr(), + "\tLANG = %c%s%c\n", + lang ? '"' : '(', + lang ? lang : "unset", + lang ? '"' : ')'); + + PerlIO_printf(PerlIO_stderr(), + " are supported and installed on your system.\n"); + } + +#ifdef LC_ALL + + if (setlocale(LC_ALL, "C")) { + if (locwarn) + PerlIO_printf(PerlIO_stderr(), + "perl: warning: Falling back to the standard locale (\"C\").\n"); + ok = 0; + } + else { + if (locwarn) + PerlIO_printf(PerlIO_stderr(), + "perl: warning: Failed to fall back to the standard locale (\"C\").\n"); + ok = -1; + } + +#else /* ! LC_ALL */ + + if (0 +#ifdef USE_LOCALE_CTYPE + || !(curctype || setlocale(LC_CTYPE, "C")) +#endif /* USE_LOCALE_CTYPE */ +#ifdef USE_LOCALE_COLLATE + || !(curcoll || setlocale(LC_COLLATE, "C")) +#endif /* USE_LOCALE_COLLATE */ +#ifdef USE_LOCALE_NUMERIC + || !(curnum || setlocale(LC_NUMERIC, "C")) +#endif /* USE_LOCALE_NUMERIC */ + ) + { + if (locwarn) + PerlIO_printf(PerlIO_stderr(), + "perl: warning: Cannot fall back to the standard locale (\"C\").\n"); + ok = -1; + } + +#endif /* ! LC_ALL */ + +#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 */ } - environ[i] = safemalloc(strlen(nam) + strlen(val) + 2); - /* this may or may not be in */ - /* the old environ structure */ - sprintf(environ[i],"%s=%s",nam,val);/* all that work just for this */ + +#ifdef USE_LOCALE_CTYPE + perl_new_ctype(curctype); +#endif /* USE_LOCALE_CTYPE */ + +#ifdef USE_LOCALE_COLLATE + perl_new_collate(curcoll); +#endif /* USE_LOCALE_COLLATE */ + +#ifdef USE_LOCALE_NUMERIC + perl_new_numeric(curnum); +#endif /* USE_LOCALE_NUMERIC */ + +#endif /* USE_LOCALE */ + + return ok; } +/* Backwards compatibility. */ int -envix(nam) -char *nam; +perl_init_i18nl14n(int printwarn) { - register int i, len = strlen(nam); + return perl_init_i18nl10n(printwarn); +} - for (i = 0; environ[i]; i++) { - if (strnEQ(environ[i],nam,len) && environ[i][len] == '=') - break; /* strnEQ must come first to avoid */ - } /* potential SEGV's */ - return i; +#ifdef USE_LOCALE_COLLATE + +/* + * mem_collxfrm() is a bit like strxfrm() but with two important + * differences. First, it handles embedded NULs. Second, it allocates + * a bit more memory than needed for the transformed data itself. + * The real transformed data begins at offset sizeof(collationix). + * Please see sv_collxfrm() to see how this is used. + */ +char * +mem_collxfrm(const char *s, STRLEN len, STRLEN *xlen) +{ + char *xbuf; + STRLEN xAlloc, xin, xout; /* xalloc is a reserved word in VC */ + + /* the first sizeof(collationix) bytes are used by sv_collxfrm(). */ + /* the +1 is for the terminating NUL. */ + + xAlloc = sizeof(collation_ix) + collxfrm_base + (collxfrm_mult * len) + 1; + New(171, xbuf, xAlloc, char); + if (! xbuf) + goto bad; + + *(U32*)xbuf = collation_ix; + xout = sizeof(collation_ix); + for (xin = 0; xin < len; ) { + SSize_t xused; + + for (;;) { + xused = strxfrm(xbuf + xout, s + xin, xAlloc - xout); + if (xused == -1) + goto bad; + if (xused < xAlloc - xout) + break; + xAlloc = (2 * xAlloc) + 1; + Renew(xbuf, xAlloc, char); + if (! xbuf) + goto bad; + } + + xin += strlen(s + xin) + 1; + xout += xused; + + /* Embedded NULs are understood but silently skipped + * because they make no sense in locale collation. */ + } + + xbuf[xout] = '\0'; + *xlen = xout - sizeof(collation_ix); + return xbuf; + + bad: + Safefree(xbuf); + *xlen = 0; + return NULL; +} + +#endif /* USE_LOCALE_COLLATE */ + +void +fbm_compile(SV *sv, U32 flags /* not used yet */) +{ + register unsigned char *s; + register unsigned char *table; + register U32 i; + register U32 len = SvCUR(sv); + I32 rarest = 0; + U32 frequency = 256; + + sv_upgrade(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) { + Sv_Grow(sv,len + 258); + table = (unsigned char*)(SvPVX(sv) + len + 1); + s = table - 2; + for (i = 0; i < 256; i++) { + table[i] = len; + } + i = 0; + while (s >= (unsigned char*)(SvPVX(sv))) + { + if (table[*s] == len) + table[*s] = i; + s--,i++; + } + } + sv_magic(sv, Nullsv, 'B', Nullch, 0); /* deep magic */ + SvVALID_on(sv); + + s = (unsigned char*)(SvPVX(sv)); /* deeper magic */ + for (i = 0; i < len; i++) { + if (freq[s[i]] < frequency) { + rarest = i; + frequency = freq[s[i]]; + } + } + BmRARE(sv) = s[rarest]; + BmPREVIOUS(sv) = rarest; + DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %d\n",BmRARE(sv),BmPREVIOUS(sv))); +} + +char * +fbm_instr(unsigned char *big, register unsigned char *bigend, SV *littlestr) +{ + register unsigned char *s; + register I32 tmp; + register I32 littlelen; + register unsigned char *little; + register unsigned char *table; + register unsigned char *olds; + register unsigned char *oldlittle; + + if (SvTYPE(littlestr) != SVt_PVBM || !SvVALID(littlestr)) { + STRLEN len; + char *l = SvPV(littlestr,len); + if (!len) { + if (SvTAIL(littlestr)) { /* Can be only 0-len constant + substr => we can ignore SvVALID */ + if (multiline) { + char *t = "\n"; + if ((s = (unsigned char*)ninstr((char*)big, (char*)bigend, + t, t + len))) { + return (char*)s; + } + } + if (bigend > big && bigend[-1] == '\n') + return (char *)(bigend - 1); + else + return (char *) bigend; + } + return (char*)big; + } + return ninstr((char*)big,(char*)bigend, l, l + len); + } + + littlelen = SvCUR(littlestr); + if (SvTAIL(littlestr) && !multiline) { /* tail anchored? */ + if (littlelen > bigend - big) + return Nullch; + little = (unsigned char*)SvPVX(littlestr); + s = bigend - littlelen; + if (s > big + && bigend[-1] == '\n' + && s[-1] == *little && memEQ((char*)s - 1,(char*)little,littlelen)) + return (char*)s - 1; /* how sweet it is */ + else if (*s == *little && memEQ((char*)s,(char*)little,littlelen)) + return (char*)s; /* how sweet it is */ + return Nullch; + } + if (littlelen <= 2) { + unsigned char c1 = (unsigned char)SvPVX(littlestr)[0]; + unsigned char c2 = (unsigned char)SvPVX(littlestr)[1]; + /* This may do extra comparisons if littlelen == 2, but this + should be hidden in the noise since we do less indirection. */ + + s = big; + bigend -= littlelen; + while (s <= bigend) { + if (s[0] == c1 + && (littlelen == 1 || s[1] == c2) + && (!SvTAIL(littlestr) + || s == bigend + || s[littlelen] == '\n')) /* Automatically multiline */ + { + return (char*)s; + } + s++; + } + return Nullch; + } + table = (unsigned char*)(SvPVX(littlestr) + littlelen + 1); + if (--littlelen >= bigend - big) + return Nullch; + s = big + littlelen; + oldlittle = little = table - 2; + if (s < bigend) { + top2: + /*SUPPRESS 560*/ + if (tmp = table[*s]) { +#ifdef POINTERRIGOR + if (bigend - s > tmp) { + s += tmp; + goto top2; + } +#else + if ((s += tmp) < bigend) + goto top2; +#endif + return Nullch; + } + else { + tmp = littlelen; /* less expensive than calling strncmp() */ + olds = s; + while (tmp--) { + if (*--s == *--little) + continue; + differ: + s = olds + 1; /* here we pay the price for failure */ + little = oldlittle; + if (s < bigend) /* fake up continue to outer loop */ + goto top2; + return Nullch; + } + if (SvTAIL(littlestr) /* automatically multiline */ + && olds + 1 != bigend + && olds[1] != '\n') + goto differ; + return (char *)s; + } + } + return Nullch; +} + +/* start_shift, end_shift are positive quantities which give offsets + of ends of some substring of bigstr. + If `last' we want the last occurence. + 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. + Note that we do not take into account SvTAIL, so it may give wrong + positives if _ALL flag is set. + */ + +char * +screaminstr(SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last) +{ + register unsigned char *s, *x; + register unsigned char *big; + register I32 pos; + register I32 previous; + register I32 first; + register unsigned char *little; + register I32 stop_pos; + register unsigned char *littleend; + I32 found = 0; + + if (*old_posp == -1 + ? (pos = screamfirst[BmRARE(littlestr)]) < 0 + : (((pos = *old_posp), pos += screamnext[pos]) == 0)) + return Nullch; + little = (unsigned char *)(SvPVX(littlestr)); + littleend = little + SvCUR(littlestr); + first = *little++; + /* The value of pos we can start at: */ + previous = BmPREVIOUS(littlestr); + big = (unsigned char *)(SvPVX(bigstr)); + /* The value of pos we can stop at: */ + stop_pos = SvCUR(bigstr) - end_shift - (SvCUR(littlestr) - 1 - previous); + if (previous + start_shift > stop_pos) return Nullch; + while (pos < previous + start_shift) { + if (!(pos += screamnext[pos])) + return Nullch; + } +#ifdef POINTERRIGOR + do { + if (pos >= stop_pos) return Nullch; + if (big[pos-previous] != first) + continue; + for (x=big+pos+1-previous,s=little; s < littleend; /**/ ) { + if (*s++ != *x++) { + s--; + break; + } + } + if (s == littleend) { + *old_posp = pos; + if (!last) return (char *)(big+pos-previous); + found = 1; + } + } while ( pos += screamnext[pos] ); + return (last && found) ? (char *)(big+(*old_posp)-previous) : Nullch; +#else /* !POINTERRIGOR */ + big -= previous; + do { + if (pos >= stop_pos) return Nullch; + if (big[pos] != first) + continue; + for (x=big+pos+1,s=little; s < littleend; /**/ ) { + if (*s++ != *x++) { + s--; + break; + } + } + if (s == littleend) { + *old_posp = pos; + if (!last) return (char *)(big+pos); + found = 1; + } + } while ( pos += screamnext[pos] ); + return (last && found) ? (char *)(big+(*old_posp)) : Nullch; +#endif /* POINTERRIGOR */ +} + +I32 +ibcmp(char *s1, char *s2, register I32 len) +{ + register U8 *a = (U8 *)s1; + register U8 *b = (U8 *)s2; + while (len--) { + if (*a != *b && *a != fold[*b]) + return 1; + a++,b++; + } + return 0; +} + +I32 +ibcmp_locale(char *s1, char *s2, register I32 len) +{ + register U8 *a = (U8 *)s1; + register U8 *b = (U8 *)s2; + while (len--) { + if (*a != *b && *a != fold_locale[*b]) + return 1; + a++,b++; + } + return 0; +} + +/* copy a string to a safe spot */ + +char * +savepv(char *sv) +{ + register char *newaddr; + + New(902,newaddr,strlen(sv)+1,char); + (void)strcpy(newaddr,sv); + return newaddr; +} + +/* same thing but with a known length */ + +char * +savepvn(char *sv, 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 */ + return newaddr; +} + +/* the SV for form() and mess() is not kept in an arena */ + +STATIC SV * +mess_alloc(void) +{ + SV *sv; + XPVMG *any; + + /* Create as PVMG now, to avoid any upgrading later */ + New(905, sv, 1, SV); + Newz(905, any, 1, XPVMG); + SvFLAGS(sv) = SVt_PVMG; + SvANY(sv) = (void*)any; + SvREFCNT(sv) = 1 << 30; /* practically infinite */ + return sv; +} + +char * +form(const char* pat, ...) +{ + va_list args; + va_start(args, pat); + if (!mess_sv) + mess_sv = mess_alloc(); + sv_vsetpvfn(mess_sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + va_end(args); + return SvPVX(mess_sv); +} + +char * +mess(const char *pat, va_list *args) +{ + SV *sv; + static char dgd[] = " during global destruction.\n"; + + if (!mess_sv) + mess_sv = mess_alloc(); + sv = mess_sv; + sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); + if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') { + dTHR; + if (dirty) + sv_catpv(sv, dgd); + else { + if (curcop->cop_line) + sv_catpvf(sv, " at %_ line %ld", + GvSV(curcop->cop_filegv), (long)curcop->cop_line); + if (GvIO(last_in_gv) && IoLINES(GvIOp(last_in_gv))) { + bool line_mode = (RsSIMPLE(rs) && + SvLEN(rs) == 1 && *SvPVX(rs) == '\n'); + sv_catpvf(sv, ", <%s> %s %ld", + last_in_gv == argvgv ? "" : GvNAME(last_in_gv), + line_mode ? "line" : "chunk", + (long)IoLINES(GvIOp(last_in_gv))); + } + sv_catpv(sv, ".\n"); + } + } + return SvPVX(sv); +} + +OP * +die(const char* pat, ...) +{ + dTHR; + va_list args; + char *message; + int was_in_eval = in_eval; + HV *stash; + GV *gv; + CV *cv; + +#ifdef USE_THREADS + DEBUG_L(PerlIO_printf(PerlIO_stderr(), + "%p: die: curstack = %p, mainstack = %p\n", + thr, curstack, mainstack)); +#endif /* USE_THREADS */ + + va_start(args, pat); + message = pat ? mess(pat, &args) : Nullch; + va_end(args); + +#ifdef USE_THREADS + DEBUG_L(PerlIO_printf(PerlIO_stderr(), + "%p: die: message = %s\ndiehook = %p\n", + thr, message, diehook)); +#endif /* USE_THREADS */ + if (diehook) { + /* sv_2cv might call croak() */ + SV *olddiehook = diehook; + ENTER; + SAVESPTR(diehook); + diehook = Nullsv; + cv = sv_2cv(olddiehook, &stash, &gv, 0); + LEAVE; + if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) { + dSP; + SV *msg; + + ENTER; + if(message) { + msg = newSVpv(message, 0); + SvREADONLY_on(msg); + SAVEFREESV(msg); + } + else { + msg = ERRSV; + } + + PUSHSTACK(SI_DIEHOOK); + PUSHMARK(SP); + XPUSHs(msg); + PUTBACK; + perl_call_sv((SV*)cv, G_DISCARD); + POPSTACK(); + LEAVE; + } + } + + restartop = die_where(message); +#ifdef USE_THREADS + DEBUG_L(PerlIO_printf(PerlIO_stderr(), + "%p: die: restartop = %p, was_in_eval = %d, top_env = %p\n", + thr, restartop, was_in_eval, top_env)); +#endif /* USE_THREADS */ + if ((!restartop && was_in_eval) || top_env->je_prev) + JMPENV_JUMP(3); + return restartop; +} + +void +croak(const char* pat, ...) +{ + dTHR; + va_list args; + char *message; + HV *stash; + GV *gv; + CV *cv; + + va_start(args, pat); + message = mess(pat, &args); + va_end(args); +#ifdef USE_THREADS + DEBUG_L(PerlIO_printf(PerlIO_stderr(), "croak: 0x%lx %s", (unsigned long) thr, message)); +#endif /* USE_THREADS */ + if (diehook) { + /* sv_2cv might call croak() */ + SV *olddiehook = diehook; + ENTER; + SAVESPTR(diehook); + diehook = Nullsv; + cv = sv_2cv(olddiehook, &stash, &gv, 0); + LEAVE; + if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) { + dSP; + SV *msg; + + ENTER; + msg = newSVpv(message, 0); + SvREADONLY_on(msg); + SAVEFREESV(msg); + + PUSHSTACK(SI_DIEHOOK); + PUSHMARK(SP); + XPUSHs(msg); + PUTBACK; + perl_call_sv((SV*)cv, G_DISCARD); + POPSTACK(); + LEAVE; + } + } + if (in_eval) { + restartop = die_where(message); + JMPENV_JUMP(3); + } + PerlIO_puts(PerlIO_stderr(),message); + (void)PerlIO_flush(PerlIO_stderr()); + my_failure_exit(); +} + +void +warn(const char* pat,...) +{ + va_list args; + char *message; + HV *stash; + GV *gv; + CV *cv; + + va_start(args, pat); + message = mess(pat, &args); + va_end(args); + + if (warnhook) { + /* sv_2cv might call warn() */ + dTHR; + SV *oldwarnhook = warnhook; + ENTER; + SAVESPTR(warnhook); + warnhook = Nullsv; + cv = sv_2cv(oldwarnhook, &stash, &gv, 0); + LEAVE; + if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) { + dSP; + SV *msg; + + ENTER; + msg = newSVpv(message, 0); + SvREADONLY_on(msg); + SAVEFREESV(msg); + + PUSHSTACK(SI_WARNHOOK); + PUSHMARK(SP); + XPUSHs(msg); + PUTBACK; + perl_call_sv((SV*)cv, G_DISCARD); + POPSTACK(); + LEAVE; + return; + } + } + PerlIO_puts(PerlIO_stderr(),message); +#ifdef LEAKTEST + DEBUG_L(*message == '!' + ? (xstat(message[1]=='!' + ? (message[2]=='!' ? 2 : 1) + : 0) + , 0) + : 0); +#endif + (void)PerlIO_flush(PerlIO_stderr()); +} + +#ifndef VMS /* VMS' my_setenv() is in VMS.c */ +#ifndef WIN32 +void +my_setenv(char *nam, char *val) +{ + register I32 i=setenv_getix(nam); /* where does it go? */ + + if (environ == origenviron) { /* need we copy environment? */ + I32 j; + I32 max; + char **tmpenv; + + /*SUPPRESS 530*/ + for (max = i; environ[max]; max++) ; + New(901,tmpenv, max+2, char*); + for (j=0; j= 0; i++) ; + return i ? 0 : -1; +} +#endif + +#if !defined(HAS_BCOPY) || !defined(HAS_SAFE_BCOPY) +char * +my_bcopy(register char *from,register char *to,register I32 len) +{ + char *retval = to; + + if (from - to >= 0) { + while (len--) + *to++ = *from++; + } + else { + to += len; + from += len; + while (len--) + *(--to) = *(--from); + } + return retval; +} +#endif + +#ifndef HAS_MEMSET +void * +my_memset(loc,ch,len) +register char *loc; +register I32 ch; +register I32 len; +{ + char *retval = loc; + + while (len--) + *loc++ = ch; + return retval; +} +#endif + +#if !defined(HAS_BZERO) && !defined(HAS_MEMSET) +char * +my_bzero(loc,len) +register char *loc; +register I32 len; +{ + char *retval = loc; + + while (len--) + *loc++ = 0; + return retval; +} +#endif + +#if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP) +I32 +my_memcmp(s1,s2,len) +char *s1; +char *s2; +register I32 len; +{ + register U8 *a = (U8 *)s1; + register U8 *b = (U8 *)s2; + register I32 tmp; + + while (len--) { + if (tmp = *a++ - *b++) + return tmp; + } + return 0; +} +#endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */ + +#ifndef HAS_VPRINTF + +#ifdef USE_CHAR_VSPRINTF +char * +#else +int +#endif +vsprintf(dest, pat, args) +char *dest; +const char *pat; +char *args; +{ + FILE fakebuf; + + fakebuf._ptr = dest; + fakebuf._cnt = 32767; +#ifndef _IOSTRG +#define _IOSTRG 0 +#endif + fakebuf._flag = _IOWRT|_IOSTRG; + _doprnt(pat, args, &fakebuf); /* what a kludge */ + (void)putc('\0', &fakebuf); +#ifdef USE_CHAR_VSPRINTF + return(dest); +#else + return 0; /* perl doesn't use return value */ +#endif +} + +#endif /* HAS_VPRINTF */ + +#ifdef MYSWAP +#if BYTEORDER != 0x4321 +short +my_swap(short s) +{ +#if (BYTEORDER & 1) == 0 + short result; + + result = ((s & 255) << 8) + ((s >> 8) & 255); + return result; +#else + return s; +#endif +} + +long +my_htonl(long l) +{ + union { + long result; + char c[sizeof(long)]; + } u; + +#if BYTEORDER == 0x1234 + u.c[0] = (l >> 24) & 255; + u.c[1] = (l >> 16) & 255; + u.c[2] = (l >> 8) & 255; + u.c[3] = l & 255; + return u.result; +#else +#if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf) + croak("Unknown BYTEORDER\n"); +#else + register I32 o; + register I32 s; + + for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) { + u.c[o & 0xf] = (l >> s) & 255; + } + return u.result; +#endif +#endif +} + +long +my_ntohl(long l) +{ + union { + long l; + char c[sizeof(long)]; + } u; + +#if BYTEORDER == 0x1234 + u.c[0] = (l >> 24) & 255; + u.c[1] = (l >> 16) & 255; + u.c[2] = (l >> 8) & 255; + u.c[3] = l & 255; + return u.l; +#else +#if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf) + croak("Unknown BYTEORDER\n"); +#else + register I32 o; + register I32 s; + + u.l = l; + l = 0; + for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) { + l |= (u.c[o & 0xf] & 255) << s; + } + return l; +#endif +#endif +} + +#endif /* BYTEORDER != 0x4321 */ +#endif /* MYSWAP */ + +/* + * Little-endian byte order functions - 'v' for 'VAX', or 'reVerse'. + * If these functions are defined, + * the BYTEORDER is neither 0x1234 nor 0x4321. + * However, this is not assumed. + * -DWS + */ + +#define HTOV(name,type) \ + type \ + name (n) \ + register type n; \ + { \ + union { \ + type value; \ + char c[sizeof(type)]; \ + } u; \ + register I32 i; \ + register I32 s; \ + for (i = 0, s = 0; i < sizeof(u.c); i++, s += 8) { \ + u.c[i] = (n >> s) & 0xFF; \ + } \ + return u.value; \ + } + +#define VTOH(name,type) \ + type \ + name (n) \ + register type n; \ + { \ + union { \ + type value; \ + char c[sizeof(type)]; \ + } u; \ + register I32 i; \ + register I32 s; \ + u.value = n; \ + n = 0; \ + for (i = 0, s = 0; i < sizeof(u.c); i++, s += 8) { \ + n += (u.c[i] & 0xFF) << s; \ + } \ + return n; \ + } + +#if defined(HAS_HTOVS) && !defined(htovs) +HTOV(htovs,short) +#endif +#if defined(HAS_HTOVL) && !defined(htovl) +HTOV(htovl,long) +#endif +#if defined(HAS_VTOHS) && !defined(vtohs) +VTOH(vtohs,short) +#endif +#if defined(HAS_VTOHL) && !defined(vtohl) +VTOH(vtohl,long) +#endif + + /* VMS' my_popen() is in VMS.c, same with OS/2. */ +#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) +PerlIO * +my_popen(char *cmd, char *mode) +{ + int p[2]; + register I32 This, that; + register I32 pid; + SV *sv; + I32 doexec = strNE(cmd,"-"); + +#ifdef OS2 + if (doexec) { + return my_syspopen(cmd,mode); + } +#endif + This = (*mode == 'w'); + that = !This; + if (doexec && tainting) { + taint_env(); + taint_proper("Insecure %s%s", "EXEC"); + } + if (PerlProc_pipe(p) < 0) + return Nullfp; + while ((pid = (doexec?vfork():fork())) < 0) { + if (errno != EAGAIN) { + PerlLIO_close(p[This]); + if (!doexec) + croak("Can't fork"); + return Nullfp; + } + sleep(5); + } + if (pid == 0) { + GV* tmpgv; + +#undef THIS +#undef THAT +#define THIS that +#define THAT This + PerlLIO_close(p[THAT]); + if (p[THIS] != (*mode == 'r')) { + PerlLIO_dup2(p[THIS], *mode == 'r'); + PerlLIO_close(p[THIS]); + } + if (doexec) { +#if !defined(HAS_FCNTL) || !defined(F_SETFD) + int fd; + +#ifndef NOFILE +#define NOFILE 20 +#endif + for (fd = maxsysfd + 1; fd < NOFILE; fd++) + PerlLIO_close(fd); +#endif + do_exec(cmd); /* may or may not use the shell */ + PerlProc__exit(1); + } + /*SUPPRESS 560*/ + if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV)) + sv_setiv(GvSV(tmpgv), (IV)getpid()); + forkprocess = 0; + hv_clear(pidstatus); /* we have no children */ + return Nullfp; +#undef THIS +#undef THAT + } + do_execfree(); /* free any memory malloced by child on vfork */ + PerlLIO_close(p[that]); + if (p[that] < p[This]) { + PerlLIO_dup2(p[This], p[that]); + PerlLIO_close(p[This]); + p[This] = p[that]; + } + sv = *av_fetch(fdpid,p[This],TRUE); + (void)SvUPGRADE(sv,SVt_IV); + SvIVX(sv) = pid; + forkprocess = pid; + return PerlIO_fdopen(p[This], mode); +} +#else +#if defined(atarist) || defined(DJGPP) +FILE *popen(); +PerlIO * +my_popen(cmd,mode) +char *cmd; +char *mode; +{ + /* Needs work for PerlIO ! */ + /* used 0 for 2nd parameter to PerlIO-exportFILE; apparently not used */ + return popen(PerlIO_exportFILE(cmd, 0), mode); +} +#endif + +#endif /* !DOSISH */ + +#ifdef DUMP_FDS +void +dump_fds(char *s) +{ + int fd; + struct stat tmpstatbuf; + + PerlIO_printf(PerlIO_stderr(),"%s", s); + for (fd = 0; fd < 32; fd++) { + if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0) + PerlIO_printf(PerlIO_stderr()," %d",fd); + } + PerlIO_printf(PerlIO_stderr(),"\n"); +} +#endif /* DUMP_FDS */ + +#ifndef HAS_DUP2 +int +dup2(oldfd,newfd) +int oldfd; +int newfd; +{ +#if defined(HAS_FCNTL) && defined(F_DUPFD) + if (oldfd == newfd) + return oldfd; + PerlLIO_close(newfd); + return fcntl(oldfd, F_DUPFD, newfd); +#else +#define DUP2_MAX_FDS 256 + int fdtmp[DUP2_MAX_FDS]; + I32 fdx = 0; + int fd; + + if (oldfd == newfd) + return oldfd; + PerlLIO_close(newfd); + /* good enough for low fd's... */ + while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) { + if (fdx >= DUP2_MAX_FDS) { + PerlLIO_close(fd); + fd = -1; + break; + } + fdtmp[fdx++] = fd; + } + while (fdx > 0) + PerlLIO_close(fdtmp[--fdx]); + return fd; +#endif +} +#endif + + +#ifdef HAS_SIGACTION + +Sighandler_t +rsignal(int signo, Sighandler_t handler) +{ + struct sigaction act, oact; + + act.sa_handler = handler; + sigemptyset(&act.sa_mask); + act.sa_flags = 0; +#ifdef SA_RESTART + act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */ +#endif + if (sigaction(signo, &act, &oact) == -1) + return SIG_ERR; + else + return oact.sa_handler; +} + +Sighandler_t +rsignal_state(int signo) +{ + struct sigaction oact; + + if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1) + return SIG_ERR; + else + return oact.sa_handler; +} + +int +rsignal_save(int signo, Sighandler_t handler, Sigsave_t *save) +{ + struct sigaction act; + + act.sa_handler = handler; + sigemptyset(&act.sa_mask); + act.sa_flags = 0; +#ifdef SA_RESTART + act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */ +#endif + return sigaction(signo, &act, save); +} + +int +rsignal_restore(int signo, Sigsave_t *save) +{ + return sigaction(signo, save, (struct sigaction *)NULL); +} + +#else /* !HAS_SIGACTION */ + +Sighandler_t +rsignal(int signo, Sighandler_t handler) +{ + return PerlProc_signal(signo, handler); +} + +static int sig_trapped; + +static +Signal_t +sig_trap(int signo) +{ + sig_trapped++; +} + +Sighandler_t +rsignal_state(int signo) +{ + Sighandler_t oldsig; + + sig_trapped = 0; + oldsig = PerlProc_signal(signo, sig_trap); + PerlProc_signal(signo, oldsig); + if (sig_trapped) + PerlProc_kill(getpid(), signo); + return oldsig; +} + +int +rsignal_save(int signo, Sighandler_t handler, Sigsave_t *save) +{ + *save = PerlProc_signal(signo, handler); + return (*save == SIG_ERR) ? -1 : 0; +} + +int +rsignal_restore(int signo, Sigsave_t *save) +{ + return (PerlProc_signal(signo, *save) == SIG_ERR) ? -1 : 0; +} + +#endif /* !HAS_SIGACTION */ + + /* VMS' my_pclose() is in VMS.c; same with OS/2 */ +#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) +I32 +my_pclose(PerlIO *ptr) +{ + Sigsave_t hstat, istat, qstat; + int status; + SV **svp; + int pid; + int pid2; + bool close_failed; + int saved_errno; +#ifdef VMS + int saved_vaxc_errno; +#endif +#ifdef WIN32 + int saved_win32_errno; +#endif + + svp = av_fetch(fdpid,PerlIO_fileno(ptr),TRUE); + pid = (int)SvIVX(*svp); + SvREFCNT_dec(*svp); + *svp = &sv_undef; +#ifdef OS2 + if (pid == -1) { /* Opened by popen. */ + return my_syspclose(ptr); + } +#endif + if ((close_failed = (PerlIO_close(ptr) == EOF))) { + saved_errno = errno; +#ifdef VMS + saved_vaxc_errno = vaxc$errno; +#endif +#ifdef WIN32 + saved_win32_errno = GetLastError(); +#endif + } +#ifdef UTS + if(PerlProc_kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */ +#endif + rsignal_save(SIGHUP, SIG_IGN, &hstat); + rsignal_save(SIGINT, SIG_IGN, &istat); + rsignal_save(SIGQUIT, SIG_IGN, &qstat); + do { + pid2 = wait4pid(pid, &status, 0); + } while (pid2 == -1 && errno == EINTR); + rsignal_restore(SIGHUP, &hstat); + rsignal_restore(SIGINT, &istat); + rsignal_restore(SIGQUIT, &qstat); + if (close_failed) { + SETERRNO(saved_errno, saved_vaxc_errno); + return -1; + } + return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status)); +} +#endif /* !DOSISH */ + +#if !defined(DOSISH) || defined(OS2) || defined(WIN32) +I32 +wait4pid(int pid, int *statusp, int flags) +{ + SV *sv; + SV** svp; + char spid[TYPE_CHARS(int)]; + + if (!pid) + return -1; + if (pid > 0) { + sprintf(spid, "%d", pid); + svp = hv_fetch(pidstatus,spid,strlen(spid),FALSE); + if (svp && *svp != &sv_undef) { + *statusp = SvIVX(*svp); + (void)hv_delete(pidstatus,spid,strlen(spid),G_DISCARD); + return pid; + } + } + else { + HE *entry; + + hv_iterinit(pidstatus); + if (entry = hv_iternext(pidstatus)) { + pid = atoi(hv_iterkey(entry,(I32*)statusp)); + sv = hv_iterval(pidstatus,entry); + *statusp = SvIVX(sv); + sprintf(spid, "%d", pid); + (void)hv_delete(pidstatus,spid,strlen(spid),G_DISCARD); + return pid; + } + } +#ifdef HAS_WAITPID +# ifdef HAS_WAITPID_RUNTIME + if (!HAS_WAITPID_RUNTIME) + goto hard_way; +# endif + return PerlProc_waitpid(pid,statusp,flags); +#endif +#if !defined(HAS_WAITPID) && defined(HAS_WAIT4) + return wait4((pid==-1)?0:pid,statusp,flags,Null(struct rusage *)); +#endif +#if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME) + hard_way: + { + I32 result; + if (flags) + croak("Can't do waitpid with flags"); + else { + while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0) + pidgone(result,*statusp); + if (result < 0) + *statusp = -1; + } + return result; + } +#endif +} +#endif /* !DOSISH || OS2 || WIN32 */ + +void +/*SUPPRESS 590*/ +pidgone(int pid, int status) +{ + register SV *sv; + char spid[TYPE_CHARS(int)]; + + sprintf(spid, "%d", pid); + sv = *hv_fetch(pidstatus,spid,strlen(spid),TRUE); + (void)SvUPGRADE(sv,SVt_IV); + SvIVX(sv) = status; + return; +} + +#if defined(atarist) || defined(OS2) || defined(DJGPP) +int pclose(); +#ifdef HAS_FORK +int /* Cannot prototype with I32 + in os2ish.h. */ +my_syspclose(ptr) +#else +I32 +my_pclose(ptr) +#endif +PerlIO *ptr; +{ + /* Needs work for PerlIO ! */ + FILE *f = PerlIO_findFILE(ptr); + I32 result = pclose(f); + PerlIO_releaseFILE(ptr,f); + return result; +} +#endif + +void +repeatcpy(register char *to, register char *from, I32 len, register I32 count) +{ + register I32 todo; + register char *frombase = from; + + if (len == 1) { + todo = *from; + while (count-- > 0) + *to++ = todo; + return; + } + while (count-- > 0) { + for (todo = len; todo > 0; todo--) { + *to++ = *from++; + } + from = frombase; + } +} + +#ifndef CASTNEGFLOAT +U32 +cast_ulong(f) +double f; +{ + long along; + +#if CASTFLAGS & 2 +# define BIGDOUBLE 2147483648.0 + if (f >= BIGDOUBLE) + return (unsigned long)(f-(long)(f/BIGDOUBLE)*BIGDOUBLE)|0x80000000; +#endif + if (f >= 0.0) + return (unsigned long)f; + along = (long)f; + return (unsigned long)along; +} +# undef BIGDOUBLE +#endif + +#ifndef CASTI32 + +/* Unfortunately, on some systems the cast_uv() function doesn't + work with the system-supplied definition of ULONG_MAX. The + comparison (f >= ULONG_MAX) always comes out true. It must be a + problem with the compiler constant folding. + + In any case, this workaround should be fine on any two's complement + system. If it's not, supply a '-DMY_ULONG_MAX=whatever' in your + ccflags. + --Andy Dougherty +*/ + +/* Code modified to prefer proper named type ranges, I32, IV, or UV, instead + of LONG_(MIN/MAX). + -- Kenneth Albanowski +*/ + +#ifndef MY_UV_MAX +# define MY_UV_MAX ((UV)IV_MAX * (UV)2 + (UV)1) +#endif + +I32 +cast_i32(f) +double f; +{ + if (f >= I32_MAX) + return (I32) I32_MAX; + if (f <= I32_MIN) + return (I32) I32_MIN; + return (I32) f; +} + +IV +cast_iv(f) +double f; +{ + if (f >= IV_MAX) + return (IV) IV_MAX; + if (f <= IV_MIN) + return (IV) IV_MIN; + return (IV) f; +} + +UV +cast_uv(f) +double f; +{ + if (f >= MY_UV_MAX) + return (UV) MY_UV_MAX; + return (UV) f; +} + +#endif + +#ifndef HAS_RENAME +I32 +same_dirent(a,b) +char *a; +char *b; +{ + char *fa = strrchr(a,'/'); + char *fb = strrchr(b,'/'); + struct stat tmpstatbuf1; + struct stat tmpstatbuf2; + SV *tmpsv = sv_newmortal(); + + if (fa) + fa++; + else + fa = a; + if (fb) + fb++; + else + fb = b; + if (strNE(a,b)) + return FALSE; + if (fa == a) + sv_setpv(tmpsv, "."); + else + sv_setpvn(tmpsv, a, fa - a); + if (PerlLIO_stat(SvPVX(tmpsv), &tmpstatbuf1) < 0) + return FALSE; + if (fb == b) + sv_setpv(tmpsv, "."); + else + sv_setpvn(tmpsv, b, fb - b); + if (PerlLIO_stat(SvPVX(tmpsv), &tmpstatbuf2) < 0) + return FALSE; + return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev && + tmpstatbuf1.st_ino == tmpstatbuf2.st_ino; +} +#endif /* !HAS_RENAME */ + +UV +scan_oct(char *start, I32 len, I32 *retlen) +{ + register char *s = start; + register UV retval = 0; + bool overflowed = FALSE; + + while (len && *s >= '0' && *s <= '7') { + register UV n = retval << 3; + if (!overflowed && (n >> 3) != retval) { + warn("Integer overflow in octal number"); + overflowed = TRUE; + } + retval = n | (*s++ - '0'); + len--; + } + if (dowarn && len && (*s == '8' || *s == '9')) + warn("Illegal octal digit ignored"); + *retlen = s - start; + return retval; +} + +UV +scan_hex(char *start, I32 len, I32 *retlen) +{ + register char *s = start; + register UV retval = 0; + bool overflowed = FALSE; + char *tmp = s; + + while (len-- && *s && (tmp = strchr((char *) hexdigit, *s))) { + register UV n = retval << 4; + if (!overflowed && (n >> 4) != retval) { + warn("Integer overflow in hex number"); + overflowed = TRUE; + } + retval = n | ((tmp - hexdigit) & 15); + s++; + } + if (dowarn && !tmp) { + warn("Illegal hex digit ignored"); + } + *retlen = s - start; + return retval; +} + +char* +find_script(char *scriptname, bool dosearch, char **search_ext, I32 flags) +{ + dTHR; + char *xfound = Nullch; + char *xfailed = Nullch; + register char *s; + I32 len; + int retval; +#if defined(DOSISH) && !defined(OS2) && !defined(atarist) +# define SEARCH_EXTS ".bat", ".cmd", NULL +# define MAX_EXT_LEN 4 +#endif +#ifdef OS2 +# define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL +# define MAX_EXT_LEN 4 +#endif +#ifdef VMS +# define SEARCH_EXTS ".pl", ".com", NULL +# define MAX_EXT_LEN 4 +#endif + /* additional extensions to try in each dir if scriptname not found */ +#ifdef SEARCH_EXTS + char *exts[] = { SEARCH_EXTS }; + char **ext = search_ext ? search_ext : exts; + int extidx = 0, i = 0; + char *curext = Nullch; +#else +# define MAX_EXT_LEN 0 +#endif + + /* + * If dosearch is true and if scriptname does not contain path + * delimiters, search the PATH for scriptname. + * + * If SEARCH_EXTS is also defined, will look for each + * scriptname{SEARCH_EXTS} whenever scriptname is not found + * while searching the PATH. + * + * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search + * proceeds as follows: + * If DOSISH or VMSISH: + * + look for ./scriptname{,.foo,.bar} + * + search the PATH for scriptname{,.foo,.bar} + * + * If !DOSISH: + * + look *only* in the PATH for scriptname{,.foo,.bar} (note + * this will not look in '.' if it's not in the PATH) + */ + +#ifdef VMS +# ifdef ALWAYS_DEFTYPES + len = strlen(scriptname); + if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') { + int hasdir, idx = 0, deftypes = 1; + bool seen_dot = 1; + + hasdir = !dosearch || (strpbrk(scriptname,":[= sizeof tokenbuf) + continue; /* don't search dir with too-long name */ + strcat(tokenbuf, scriptname); +#else /* !VMS */ + +#ifdef DOSISH + if (strEQ(scriptname, "-")) + dosearch = 0; + if (dosearch) { /* Look in '.' first. */ + char *cur = scriptname; +#ifdef SEARCH_EXTS + if ((curext = strrchr(scriptname,'.'))) /* possible current ext */ + while (ext[i]) + if (strEQ(ext[i++],curext)) { + extidx = -1; /* already has an ext */ + break; + } + do { +#endif + DEBUG_p(PerlIO_printf(Perl_debug_log, + "Looking for %s\n",cur)); + if (PerlLIO_stat(cur,&statbuf) >= 0) { + dosearch = 0; + scriptname = cur; +#ifdef SEARCH_EXTS + break; +#endif + } +#ifdef SEARCH_EXTS + if (cur == scriptname) { + len = strlen(scriptname); + if (len+MAX_EXT_LEN+1 >= sizeof(tokenbuf)) + break; + cur = strcpy(tokenbuf, scriptname); + } + } while (extidx >= 0 && ext[extidx] /* try an extension? */ + && strcpy(tokenbuf+len, ext[extidx++])); +#endif + } +#endif + + if (dosearch && !strchr(scriptname, '/') +#ifdef DOSISH + && !strchr(scriptname, '\\') +#endif + && (s = PerlEnv_getenv("PATH"))) { + bool seen_dot = 0; + + bufend = s + strlen(s); + while (s < bufend) { +#if defined(atarist) || defined(DOSISH) + for (len = 0; *s +# ifdef atarist + && *s != ',' +# endif + && *s != ';'; len++, s++) { + if (len < sizeof tokenbuf) + tokenbuf[len] = *s; + } + if (len < sizeof tokenbuf) + tokenbuf[len] = '\0'; +#else /* ! (atarist || DOSISH) */ + s = delimcpy(tokenbuf, tokenbuf + sizeof tokenbuf, s, bufend, + ':', + &len); +#endif /* ! (atarist || DOSISH) */ + if (s < bufend) + s++; + if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tokenbuf) + continue; /* don't search dir with too-long name */ + if (len +#if defined(atarist) || defined(DOSISH) + && tokenbuf[len - 1] != '/' + && tokenbuf[len - 1] != '\\' +#endif + ) + tokenbuf[len++] = '/'; + if (len == 2 && tokenbuf[0] == '.') + seen_dot = 1; + (void)strcpy(tokenbuf + len, scriptname); +#endif /* !VMS */ + +#ifdef SEARCH_EXTS + len = strlen(tokenbuf); + if (extidx > 0) /* reset after previous loop */ + extidx = 0; + do { +#endif + DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tokenbuf)); + retval = PerlLIO_stat(tokenbuf,&statbuf); +#ifdef SEARCH_EXTS + } while ( retval < 0 /* not there */ + && extidx>=0 && ext[extidx] /* try an extension? */ + && strcpy(tokenbuf+len, ext[extidx++]) + ); +#endif + if (retval < 0) + continue; + if (S_ISREG(statbuf.st_mode) + && cando(S_IRUSR,TRUE,&statbuf) +#ifndef DOSISH + && cando(S_IXUSR,TRUE,&statbuf) +#endif + ) + { + xfound = tokenbuf; /* bingo! */ + break; + } + if (!xfailed) + xfailed = savepv(tokenbuf); + } +#ifndef DOSISH + if (!xfound && !seen_dot && !xfailed && (PerlLIO_stat(scriptname,&statbuf) < 0)) +#endif + seen_dot = 1; /* Disable message. */ + if (!xfound) + scriptname = NULL; +/* croak("Can't %s %s%s%s", + (xfailed ? "execute" : "find"), + (xfailed ? xfailed : scriptname), + (xfailed ? "" : " on PATH"), + (xfailed || seen_dot) ? "" : ", '.' not in PATH"); */ + if (xfailed) + Safefree(xfailed); + scriptname = xfound; + } + return scriptname; +} + + +#ifdef USE_THREADS +#ifdef FAKE_THREADS +/* Very simplistic scheduler for now */ +void +schedule(void) +{ + thr = thr->i.next_run; +} + +void +perl_cond_init(cp) +perl_cond *cp; +{ + *cp = 0; +} + +void +perl_cond_signal(cp) +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(cp) +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(cp) +perl_cond *cp; +{ + perl_cond cond; + + if (thr->i.next_run == thr) + croak("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 */ + +#ifdef OLD_PTHREADS_API +struct perl_thread * +getTHR _((void)) +{ + pthread_addr_t t; + + if (pthread_getspecific(thr_key, &t)) + croak("panic: pthread_getspecific"); + return (struct perl_thread *) t; +} +#endif /* OLD_PTHREADS_API */ + +MAGIC * +condpair_magic(SV *sv) +{ + MAGIC *mg; + + SvUPGRADE(sv, SVt_PVMG); + mg = mg_find(sv, 'm'); + 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_SV_MUTEX; + mg = mg_find(sv, 'm'); + if (mg) { + /* someone else beat us to initialising it */ + UNLOCK_SV_MUTEX; + MUTEX_DESTROY(&cp->mutex); + COND_DESTROY(&cp->owner_cond); + COND_DESTROY(&cp->cond); + Safefree(cp); + } + else { + sv_magic(sv, Nullsv, 'm', 0, 0); + mg = SvMAGIC(sv); + mg->mg_ptr = (char *)cp; + mg->mg_len = sizeof(cp); + UNLOCK_SV_MUTEX; + DEBUG_L(WITH_THR(PerlIO_printf(PerlIO_stderr(), + "%p: condpair_magic %p\n", thr, sv));) + } + } + return mg; +} + +/* + * 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 * +new_struct_thread(struct perl_thread *t) +{ + struct perl_thread *thr; + SV *sv; + SV **svp; + I32 i; + + sv = newSVpv("", 0); + SvGROW(sv, sizeof(struct perl_thread) + 1); + SvCUR_set(sv, sizeof(struct perl_thread)); + thr = (Thread) SvPVX(sv); + /* debug */ + memset(thr, 0xab, sizeof(struct perl_thread)); + markstack = 0; + scopestack = 0; + savestack = 0; + retstack = 0; + dirty = 0; + localizing = 0; + /* end debug */ + + thr->oursv = sv; + init_stacks(ARGS); + + curcop = &compiling; + thr->cvcache = newHV(); + thr->threadsv = newAV(); + thr->specific = newAV(); + thr->errsv = newSVpv("", 0); + thr->errhv = newHV(); + thr->flags = THRf_R_JOINABLE; + MUTEX_INIT(&thr->mutex); + + curcop = t->Tcurcop; /* XXX As good a guess as any? */ + defstash = t->Tdefstash; /* XXX maybe these should */ + 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 + info there at least is thread specific this has to + be per-thread. Otherwise a 'die' in a thread gives + that thread the C stack of last thread to do an eval {}! + See comments in scope.h + Initialize top entry (as in perl.c for main thread) + */ + start_env.je_prev = NULL; + start_env.je_ret = -1; + start_env.je_mustcatch = TRUE; + top_env = &start_env; + + in_eval = FALSE; + restartop = 0; + + tainted = t->Ttainted; + curpm = t->Tcurpm; /* XXX No PMOP ref count */ + nrs = newSVsv(t->Tnrs); + rs = newSVsv(t->Trs); + last_in_gv = (GV*)SvREFCNT_inc(t->Tlast_in_gv); + ofslen = t->Tofslen; + ofs = savepvn(t->Tofs, ofslen); + defoutgv = (GV*)SvREFCNT_inc(t->Tdefoutgv); + chopset = t->Tchopset; + formtarget = newSVsv(t->Tformtarget); + bodytarget = newSVsv(t->Tbodytarget); + toptarget = newSVsv(t->Ttoptarget); + + /* 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 != &sv_undef) { + SV *sv = newSVsv(*svp); + av_store(thr->threadsv, i, sv); + sv_magic(sv, 0, 0, &threadsv_names[i], 1); + DEBUG_L(PerlIO_printf(PerlIO_stderr(), + "new_struct_thread: copied threadsv %d %p->%p\n",i, t, thr)); + } + } + thr->threadsvp = AvARRAY(thr->threadsv); + + MUTEX_LOCK(&threads_mutex); + nthreads++; + thr->tid = ++threadnum; + thr->next = t->next; + thr->prev = t; + t->next = thr; + thr->next->prev = thr; + MUTEX_UNLOCK(&threads_mutex); + +#ifdef HAVE_THREAD_INTERN + init_thread_intern(thr); +#endif /* HAVE_THREAD_INTERN */ + return thr; +} +#endif /* USE_THREADS */ + +#ifdef HUGE_VAL +/* + * This hack is to force load of "huge" support from libm.a + * So it is in perl for (say) POSIX to use. + * Needed for SunOS with Sun's 'acc' for example. + */ +double +Perl_huge(void) +{ + return HUGE_VAL; +} +#endif + +#ifdef PERL_GLOBAL_STRUCT +struct perl_vars * +Perl_GetVars(void) +{ + return &Perl_Vars; +} +#endif + +char ** +get_op_names(void) +{ + return op_name; +} + +char ** +get_op_descs(void) +{ + return op_desc; +} + +char * +get_no_modify(void) +{ + return (char*)no_modify; +} + +U32 * +get_opargs(void) +{ + return opargs; +} + + +SV ** +get_specialsv_list(void) +{ + return specialsv_list; }