X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=util.c;h=623c44cf8169f11d75415b8407f8a1d9ef20a382;hb=739c8b3a364622b7992851a224b3e6424e7e3b03;hp=7a7d5f16d446aba9c54eb86a52611e7dd160ac4b;hpb=3e209e7147bec9694b511c058bf24a0b91ec8ac6;p=p5sagit%2Fp5-mst-13.2.git diff --git a/util.c b/util.c index 7a7d5f1..623c44c 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. @@ -26,21 +26,16 @@ #endif #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_SYS_WAIT # include #endif +#ifdef HAS_SELECT +# ifdef I_SYS_SELECT +# include +# endif +#endif + #define FLUSH #ifdef LEAKTEST @@ -56,14 +51,14 @@ long lastxycount[MAXXCOUNT][MAXYCOUNT]; # define FD_CLOEXEC 1 /* NeXT needs this */ #endif -/* paranoid version of system's malloc() */ - /* 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. */ +/* paranoid version of system's malloc() */ + Malloc_t Perl_safesysmalloc(MEM_SIZE size) { @@ -336,6 +331,37 @@ S_xstat(pTHX_ int flag) #endif /* LEAKTEST */ +/* These must be defined when not using Perl's malloc for binary + * compatibility */ + +#ifndef MYMALLOC + +Malloc_t Perl_malloc (MEM_SIZE nbytes) +{ + dTHXs; + return (Malloc_t)PerlMem_malloc(nbytes); +} + +Malloc_t Perl_calloc (MEM_SIZE elements, MEM_SIZE size) +{ + dTHXs; + return (Malloc_t)PerlMem_calloc(elements, size); +} + +Malloc_t Perl_realloc (Malloc_t where, MEM_SIZE nbytes) +{ + dTHXs; + return (Malloc_t)PerlMem_realloc(where, nbytes); +} + +Free_t Perl_mfree (Malloc_t where) +{ + dTHXs; + PerlMem_free(where); +} + +#endif + /* copy a string up to some (non-backslashed) delimiter, if any */ char * @@ -462,6 +488,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() @@ -484,7 +512,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; @@ -518,7 +546,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); @@ -550,9 +578,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)))) @@ -679,7 +707,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 */ @@ -692,16 +720,8 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit top2: /*SUPPRESS 560*/ if ((tmp = table[*s])) { -#ifdef POINTERRIGOR - if (bigend - s > tmp) { - s += tmp; - goto top2; - } - s += tmp; -#else if ((s += tmp) < bigend) goto top2; -#endif goto check_end; } else { /* less expensive than calling strncmp() */ @@ -732,7 +752,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. @@ -742,7 +762,7 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit */ /* If SvTAIL is actually due to \Z or \z, this gives false positives - if PL_multiline. In fact if !PL_multiline the autoritative answer + if PL_multiline. In fact if !PL_multiline the authoritative answer is not supported yet. */ char * @@ -781,33 +801,20 @@ Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift /* The value of pos we can stop at: */ stop_pos = SvCUR(bigstr) - end_shift - (SvCUR(littlestr) - 1 - previous); if (previous + start_shift > stop_pos) { +/* + stop_pos does not include SvTAIL in the count, so this check is incorrect + (I think) - see [ID 20010618.006] and t/op/study.t. HVDS 2001/06/19 +*/ +#if 0 if (previous + start_shift == stop_pos + 1) /* A fake '\n'? */ goto check_tail; +#endif return Nullch; } while (pos < previous + start_shift) { if (!(pos += PL_screamnext[pos])) goto cant_find; } -#ifdef POINTERRIGOR - do { - if (pos >= stop_pos) break; - 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 += PL_screamnext[pos] ); - return (last && found) ? (char *)(big+(*old_posp)-previous) : Nullch; -#else /* !POINTERRIGOR */ big -= previous; do { if (pos >= stop_pos) break; @@ -827,7 +834,6 @@ Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift } while ( pos += PL_screamnext[pos] ); if (last && found) return (char *)(big+(*old_posp)); -#endif /* POINTERRIGOR */ check_tail: if (!SvTAIL(littlestr) || (end_shift > 0)) return Nullch; @@ -873,20 +879,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; } @@ -895,23 +907,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 * @@ -950,6 +991,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, ...) { @@ -994,26 +1055,70 @@ Perl_mess(pTHX_ const char *pat, ...) return retval; } +STATIC COP* +S_closest_cop(pTHX_ COP *cop, OP *o) +{ + /* Look for PL_op starting from o. cop is the last COP we've seen. */ + + if (!o || o == PL_op) return cop; + + if (o->op_flags & OPf_KIDS) { + OP *kid; + for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) + { + COP *new_cop; + + /* If the OP_NEXTSTATE has been optimised away we can still use it + * the get the file and line number. */ + + if (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE) + cop = (COP *)kid; + + /* Keep searching, and return when we've found something. */ + + new_cop = closest_cop(cop, kid); + if (new_cop) return new_cop; + } + } + + /* Nothing found. */ + + return 0; +} + SV * Perl_vmess(pTHX_ const char *pat, va_list *args) { SV *sv = mess_alloc(); static char dgd[] = " during global destruction.\n"; + COP *cop; sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') { - if (CopLINE(PL_curcop)) + + /* + * Try and find the file and line for PL_op. This will usually be + * PL_curcop, but it might be a cop that has been optimised away. We + * can try to find such a cop by searching through the optree starting + * from the sibling of PL_curcop. + */ + + cop = closest_cop(PL_curcop, PL_curcop->op_sibling); + if (!cop) cop = PL_curcop; + + if (CopLINE(cop)) Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf, - CopFILE(PL_curcop), (IV)CopLINE(PL_curcop)); + 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_THREADS +#ifdef USE_5005THREADS if (thr->tid) Perl_sv_catpvf(aTHX_ sv, " thread %ld", thr->tid); #endif @@ -1186,6 +1291,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 */ @@ -1193,7 +1301,7 @@ Perl_vcroak(pTHX_ const char* pat, va_list *args) #endif PerlIO *serr = Perl_error_log; - PerlIO_write(serr, message, msglen); + PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen); (void)PerlIO_flush(serr); #ifdef USE_SFIO errno = e; @@ -1216,6 +1324,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. @@ -1251,6 +1361,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); @@ -1283,10 +1395,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; - PerlIO_write(serr, message, msglen); + PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen); #ifdef LEAKTEST DEBUG_L(*message == '!' ? (xstat(message[1]=='!' @@ -1365,9 +1491,9 @@ Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args) message = SvPV(msv, msglen); if (ckDEAD(err)) { -#ifdef USE_THREADS +#ifdef USE_5005THREADS DEBUG_S(PerlIO_printf(Perl_debug_log, "croak: 0x%"UVxf" %s", PTR2UV(thr), message)); -#endif /* USE_THREADS */ +#endif /* USE_5005THREADS */ if (PL_diehook) { /* sv_2cv might call Perl_croak() */ SV *olddiehook = PL_diehook; @@ -1401,7 +1527,7 @@ Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args) } { PerlIO *serr = Perl_error_log; - PerlIO_write(serr, message, msglen); + PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen); (void)PerlIO_flush(serr); } my_failure_exit(); @@ -1438,7 +1564,7 @@ Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args) } { PerlIO *serr = Perl_error_log; - PerlIO_write(serr, message, msglen); + PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen); #ifdef LEAKTEST DEBUG_L(*message == '!' ? (xstat(message[1]=='!' @@ -1452,15 +1578,31 @@ Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args) } } +/* 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; @@ -1471,8 +1613,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) did_pipes = 1; - while ((pid = vfork()) < 0) { + while ((pid = PerlProc_fork()) < 0) { if (errno != EAGAIN) { PerlLIO_close(p[This]); if (did_pipes) { @@ -1858,7 +2011,7 @@ Perl_my_popen_list(pTHX_ char *mode, int n, SV **args) #undef THAT } /* Parent */ - do_execfree(); /* free any memory malloced by child on vfork */ + do_execfree(); /* free any memory malloced by child on fork */ /* Close child's end of pipe */ PerlLIO_close(p[that]); if (did_pipes) @@ -1892,6 +2045,7 @@ Perl_my_popen_list(pTHX_ char *mode, int n, SV **args) did_pipes = 0; if (n) { /* Error */ int pid2, status; + PerlLIO_close(p[This]); if (n != sizeof(int)) Perl_croak(aTHX_ "panic: kid popen errno read"); do { @@ -1939,9 +2093,10 @@ Perl_my_popen(pTHX_ char *cmd, char *mode) return Nullfp; if (doexec && PerlProc_pipe(pp) >= 0) did_pipes = 1; - while ((pid = (doexec?vfork():fork())) < 0) { + while ((pid = PerlProc_fork()) < 0) { if (errno != EAGAIN) { PerlLIO_close(p[This]); + PerlLIO_close(p[that]); if (did_pipes) { PerlLIO_close(pp[0]); PerlLIO_close(pp[1]); @@ -1959,7 +2114,6 @@ Perl_my_popen(pTHX_ char *cmd, char *mode) #undef THAT #define THIS that #define THAT This - PerlLIO_close(p[THAT]); if (did_pipes) { PerlLIO_close(pp[0]); #if defined(HAS_FCNTL) && defined(F_SETFD) @@ -1969,7 +2123,11 @@ Perl_my_popen(pTHX_ char *cmd, char *mode) if (p[THIS] != (*mode == 'r')) { PerlLIO_dup2(p[THIS], *mode == 'r'); PerlLIO_close(p[THIS]); + if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */ + PerlLIO_close(p[THAT]); } + else + PerlLIO_close(p[THAT]); #ifndef OS2 if (doexec) { #if !defined(HAS_FCNTL) || !defined(F_SETFD) @@ -1992,8 +2150,11 @@ Perl_my_popen(pTHX_ char *cmd, char *mode) } #endif /* defined OS2 */ /*SUPPRESS 560*/ - if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) + if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) { + SvREADONLY_off(GvSV(tmpgv)); sv_setiv(GvSV(tmpgv), PerlProc_getpid()); + SvREADONLY_on(GvSV(tmpgv)); + } PL_forkprocess = 0; hv_clear(PL_pidstatus); /* we have no children */ return Nullfp; @@ -2001,7 +2162,6 @@ Perl_my_popen(pTHX_ char *cmd, char *mode) #undef THAT } do_execfree(); /* free any memory malloced by child on vfork */ - PerlLIO_close(p[that]); if (did_pipes) PerlLIO_close(pp[1]); if (p[that] < p[This]) { @@ -2009,6 +2169,9 @@ Perl_my_popen(pTHX_ char *cmd, char *mode) PerlLIO_close(p[This]); p[This] = p[that]; } + else + PerlLIO_close(p[that]); + LOCK_FDPID_MUTEX; sv = *av_fetch(PL_fdpid,p[This],TRUE); UNLOCK_FDPID_MUTEX; @@ -2031,6 +2194,7 @@ Perl_my_popen(pTHX_ char *cmd, char *mode) did_pipes = 0; if (n) { /* Error */ int pid2, status; + PerlLIO_close(p[This]); if (n != sizeof(int)) Perl_croak(aTHX_ "panic: kid popen errno read"); do { @@ -2045,7 +2209,7 @@ Perl_my_popen(pTHX_ char *cmd, char *mode) return PerlIO_fdopen(p[This], mode); } #else -#if defined(atarist) || defined(DJGPP) +#if defined(atarist) || defined(EPOC) FILE *popen(); PerlIO * Perl_my_popen(pTHX_ char *cmd, char *mode) @@ -2057,16 +2221,78 @@ Perl_my_popen(pTHX_ char *cmd, char *mode) */ return PerlIO_importFILE(popen(cmd, mode), 0); } +#else +#if defined(DJGPP) +FILE *djgpp_popen(); +PerlIO * +Perl_my_popen(pTHX_ char *cmd, char *mode) +{ + PERL_FLUSHALL_FOR_CHILD; + /* Call system's popen() to get a FILE *, then import it. + used 0 for 2nd parameter to PerlIO_importFILE; + apparently not used + */ + return PerlIO_importFILE(djgpp_popen(cmd, mode), 0); +} +#endif #endif #endif /* !DOSISH */ +/* this is called in parent before the fork() */ +void +Perl_atfork_lock(void) +{ +#if defined(USE_5005THREADS) || defined(USE_ITHREADS) + /* locks must be held in locking order (if any) */ +# ifdef MYMALLOC + MUTEX_LOCK(&PL_malloc_mutex); +# endif + OP_REFCNT_LOCK; +#endif +} + +/* this is called in both parent and child after the fork() */ +void +Perl_atfork_unlock(void) +{ +#if defined(USE_5005THREADS) || defined(USE_ITHREADS) + /* locks must be released in same order as in atfork_lock() */ +# ifdef MYMALLOC + MUTEX_UNLOCK(&PL_malloc_mutex); +# endif + OP_REFCNT_UNLOCK; +#endif +} + +Pid_t +Perl_my_fork(void) +{ +#if defined(HAS_FORK) + Pid_t pid; +#if (defined(USE_5005THREADS) || defined(USE_ITHREADS)) && !defined(HAS_PTHREAD_ATFORK) + atfork_lock(); + pid = fork(); + atfork_unlock(); +#else + /* atfork_lock() and atfork_unlock() are installed as pthread_atfork() + * handlers elsewhere in the code */ + pid = fork(); +#endif + return pid; +#else + /* this "canna happen" since nothing should be calling here if !HAS_FORK */ + Perl_croak_nocontext("fork() not available"); + return 0; +#endif /* HAS_FORK */ +} + #ifdef DUMP_FDS void Perl_dump_fds(pTHX_ char *s) { int fd; - struct stat tmpstatbuf; + Stat_t tmpstatbuf; PerlIO_printf(Perl_debug_log,"%s", s); for (fd = 0; fd < 32; fd++) { @@ -2123,7 +2349,7 @@ Perl_rsignal(pTHX_ int signo, Sighandler_t handler) sigemptyset(&act.sa_mask); act.sa_flags = 0; #ifdef SA_RESTART -#if !defined(USE_PERLIO) || defined(PERL_OLD_SIGNALS) +#if defined(PERL_OLD_SIGNALS) act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */ #endif #endif @@ -2157,7 +2383,7 @@ 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(USE_PERLIO) || defined(PERL_OLD_SIGNALS) +#if defined(PERL_OLD_SIGNALS) act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */ #endif #endif @@ -2182,7 +2408,8 @@ Perl_rsignal(pTHX_ int signo, Sighandler_t handler) return PerlProc_signal(signo, handler); } -static int sig_trapped; +static int sig_trapped; /* XXX signals are process-wide anyway, so we + ignore the implications of this for threading */ static Signal_t @@ -2287,6 +2514,7 @@ Perl_my_pclose(pTHX_ PerlIO *ptr) I32 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags) { + I32 result; if (!pid) return -1; #if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME) @@ -2309,6 +2537,9 @@ Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags) 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); @@ -2324,15 +2555,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 { @@ -2341,9 +2573,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 */ @@ -2361,7 +2597,7 @@ Perl_pidgone(pTHX_ Pid_t pid, int status) return; } -#if defined(atarist) || defined(OS2) || defined(DJGPP) +#if defined(atarist) || defined(OS2) || defined(EPOC) int pclose(); #ifdef HAS_FORK int /* Cannot prototype with I32 @@ -2375,9 +2611,20 @@ Perl_my_pclose(pTHX_ PerlIO *ptr) /* Needs work for PerlIO ! */ FILE *f = PerlIO_findFILE(ptr); I32 result = pclose(f); + PerlIO_releaseFILE(ptr,f); + return result; +} +#endif + #if defined(DJGPP) +int djgpp_pclose(); +I32 +Perl_my_pclose(pTHX_ PerlIO *ptr) +{ + /* Needs work for PerlIO ! */ + FILE *f = PerlIO_findFILE(ptr); + I32 result = djgpp_pclose(f); result = (result << 8) & 0xff00; -#endif PerlIO_releaseFILE(ptr,f); return result; } @@ -2409,8 +2656,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) @@ -2447,7 +2694,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 @@ -2676,7 +2923,7 @@ Perl_find_script(pTHX_ char *scriptname, bool dosearch, char **search_ext, I32 f void * Perl_get_context(void) { -#if defined(USE_THREADS) || defined(USE_ITHREADS) +#if defined(USE_5005THREADS) || defined(USE_ITHREADS) # ifdef OLD_PTHREADS_API pthread_addr_t t; if (pthread_getspecific(PL_thr_key, &t)) @@ -2697,7 +2944,7 @@ Perl_get_context(void) void Perl_set_context(void *t) { -#if defined(USE_THREADS) || defined(USE_ITHREADS) +#if defined(USE_5005THREADS) || defined(USE_ITHREADS) # ifdef I_MACH_CTHREADS cthread_set_data(cthread_self(), t); # else @@ -2709,7 +2956,7 @@ Perl_set_context(void *t) #endif /* !PERL_GET_CONTEXT_DEFINED */ -#ifdef USE_THREADS +#ifdef USE_5005THREADS #ifdef FAKE_THREADS /* Very simplistic scheduler for now */ @@ -2817,7 +3064,7 @@ Perl_condpair_magic(pTHX_ SV *sv) 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));) + "%p: condpair_magic %p\n", thr, sv))); } } return mg; @@ -2844,7 +3091,7 @@ Perl_sv_lock(pTHX_ SV *osv) MgOWNER(mg) = thr; DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": Perl_lock lock 0x%"UVxf"\n", - PTR2UV(thr), PTR2UV(sv));) + PTR2UV(thr), PTR2UV(sv))); MUTEX_UNLOCK(MgMUTEXP(mg)); SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv); } @@ -2874,7 +3121,7 @@ Perl_new_struct_thread(pTHX_ struct perl_thread *t) SvCUR_set(sv, sizeof(struct perl_thread)); thr = (Thread) SvPVX(sv); #ifdef DEBUGGING - memset(thr, 0xab, sizeof(struct perl_thread)); + Poison(thr, 1, struct perl_thread); PL_markstack = 0; PL_scopestack = 0; PL_savestack = 0; @@ -2923,6 +3170,8 @@ Perl_new_struct_thread(pTHX_ struct perl_thread *t) 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); @@ -2936,8 +3185,7 @@ Perl_new_struct_thread(pTHX_ struct perl_thread *t) PL_tainted = t->Ttainted; PL_curpm = t->Tcurpm; /* XXX No PMOP ref count */ - PL_nrs = newSVsv(t->Tnrs); - PL_rs = t->Tnrs ? SvREFCNT_inc(PL_nrs) : Nullsv; + 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); @@ -2980,7 +3228,7 @@ Perl_new_struct_thread(pTHX_ struct perl_thread *t) #endif /* HAVE_THREAD_INTERN */ return thr; } -#endif /* USE_THREADS */ +#endif /* USE_5005THREADS */ #ifdef PERL_GLOBAL_STRUCT struct perl_vars * @@ -3101,7 +3349,7 @@ Perl_get_vtbl(pTHX_ int vtbl_id) case want_vtbl_uvar: result = &PL_vtbl_uvar; break; -#ifdef USE_THREADS +#ifdef USE_5005THREADS case want_vtbl_mutex: result = &PL_vtbl_mutex; break; @@ -3143,6 +3391,7 @@ Perl_my_fflush_all(pTHX) 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); @@ -3210,32 +3459,30 @@ Perl_report_evil_fh(pTHX_ GV *gv, IO *io, I32 op) } 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", + Perl_warner(aTHX_ packWARN(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", + Perl_warner(aTHX_ packWARN(WARN_IO), "Filehandle opened only for %sput", (op == OP_phoney_INPUT_ONLY ? "in" : "out")); } else if (name && *name) { - Perl_warner(aTHX_ warn_type, + 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_ warn_type, + 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_ warn_type, + 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_ warn_type, + Perl_warner(aTHX_ packWARN(warn_type), "\t(Are you trying to call %s%s on dirhandle?)\n", func, pars); } @@ -3281,30 +3528,32 @@ Perl_ebcdic_control(pTHX_ int ch) } #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 +/* 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); @@ -3583,7 +3832,9 @@ return FALSE (dp->d_name[1] == '.' && dp->d_name[2] == '\0'))) /* -=for apidoc sv_getcwd +=head1 Miscellaneous Functions + +=for apidoc getcwd_sv Fill the sv with current working directory @@ -3598,33 +3849,43 @@ Fill the sv with current working directory * because you might chdir out of a directory that you can't chdir * back into. */ -/* XXX: this needs more porting #ifndef HAS_GETCWD */ int -Perl_sv_getcwd(pTHX_ register SV *sv) +Perl_getcwd_sv(pTHX_ register SV *sv) { #ifndef PERL_MICRO -#ifndef HAS_GETCWD - struct stat statbuf; - int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino; - int namelen, pathlen=0; - DIR *dir; - Direntry_t *dp; +#ifndef INCOMPLETE_TAINTS + SvTAINTED_on(sv); #endif - (void)SvUPGRADE(sv, SVt_PV); - #ifdef HAS_GETCWD - - SvGROW(sv, 128); - while ((getcwd(SvPVX(sv), SvLEN(sv)-1) == NULL) && errno == ERANGE) { - SvGROW(sv, SvLEN(sv) + 128); + { + char buf[MAXPATHLEN]; + + /* 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; + } } - SvCUR_set(sv, strlen(SvPVX(sv))); - SvPOK_only(sv); #else + Stat_t statbuf; + int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino; + int namelen, pathlen=0; + DIR *dir; + Direntry_t *dp; + + (void)SvUPGRADE(sv, SVt_PV); + if (PerlLIO_lstat(".", &statbuf) < 0) { SV_CWD_RETURN_UNDEF; } @@ -3681,6 +3942,10 @@ Perl_sv_getcwd(pTHX_ register SV *sv) SV_CWD_RETURN_UNDEF; } + if (pathlen + namelen + 1 >= MAXPATHLEN) { + SV_CWD_RETURN_UNDEF; + } + SvGROW(sv, pathlen + namelen + 1); if (pathlen) { @@ -3702,12 +3967,14 @@ Perl_sv_getcwd(pTHX_ register SV *sv) #endif } - SvCUR_set(sv, pathlen); - *SvEND(sv) = '\0'; - SvPOK_only(sv); + if (pathlen) { + SvCUR_set(sv, pathlen); + *SvEND(sv) = '\0'; + SvPOK_only(sv); - if (PerlDir_chdir(SvPVX(sv)) < 0) { - SV_CWD_RETURN_UNDEF; + if (PerlDir_chdir(SvPVX(sv)) < 0) { + SV_CWD_RETURN_UNDEF; + } } if (PerlLIO_stat(".", &statbuf) < 0) { SV_CWD_RETURN_UNDEF; @@ -3720,174 +3987,389 @@ Perl_sv_getcwd(pTHX_ register SV *sv) Perl_croak(aTHX_ "Unstable directory path, " "current directory changed unexpectedly"); } -#endif return TRUE; +#endif + #else return FALSE; #endif } /* -=for apidoc sv_realpath +=head1 SV Manipulation Functions + +=for apidoc new_vstring -Wrap or emulate realpath(3). +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 = new_vstring(s,sv); + +The sv must already be large enough to store the vstring +passed in. =cut - */ -int -Perl_sv_realpath(pTHX_ SV *sv, char *path, STRLEN len) -{ -#ifndef PERL_MICRO - char name[MAXPATHLEN] = { 0 }, *s; - STRLEN pathlen, namelen; +*/ - /* Don't use strlen() to avoid running off the end. */ - s = memchr(path, '\0', MAXPATHLEN); - pathlen = s ? s - path : MAXPATHLEN; +char * +Perl_new_vstring(pTHX_ char *s, SV *sv) +{ + char *pos = 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; -#ifdef HAS_REALPATH + if (*s == 'v') s++; /* get past 'v' */ - /* Be paranoid about the use of realpath(), - * it is an infamous source of buffer overruns. */ + sv_setpvn(sv, "", 0); - /* Is the source buffer too long? */ - if (pathlen == MAXPATHLEN) { - Perl_warn(aTHX_ "sv_realpath: realpath(\"%s\"): %c= (MAXPATHLEN = %d)", - path, s ? '=' : '>', MAXPATHLEN); - SV_CWD_RETURN_UNDEF; + for (;;) { + rev = 0; + { + /* this is atoi() that tolerates underscores */ + char *end = pos; + UV mult = 1; + if ( s > pos && *(s-1) == '_') { + mult = 10; + } + while (--end >= s) { + UV orev; + 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 == '.' || *pos == '_') && isDIGIT(pos[1])) + s = ++pos; + else { + s = pos; + break; + } + while (isDIGIT(*pos) ) + pos++; + } + SvPOK_on(sv); + SvREADONLY_on(sv); } + return s; +} - /* Here goes nothing. */ - if (realpath(path, name) == NULL) { - Perl_warn(aTHX_ "sv_realpath: realpath(\"%s\"): %s", - path, Strerror(errno)); - SV_CWD_RETURN_UNDEF; - } +#if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT) +# define EMULATE_SOCKETPAIR_UDP +#endif - /* Is the destination buffer too long? - * Don't use strlen() to avoid running off the end. */ - s = memchr(name, '\0', MAXPATHLEN); - namelen = s ? s - name : MAXPATHLEN; - if (namelen == MAXPATHLEN) { - Perl_warn(aTHX_ "sv_realpath: realpath(\"%s\"): %c= (MAXPATHLEN = %d)", - path, s ? '=' : '>', MAXPATHLEN); - SV_CWD_RETURN_UNDEF; - } +#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. + */ - /* The coast is clear? */ - sv_setpvn(sv, name, namelen); - SvPOK_only(sv); + { + 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; + } + } - return TRUE; + /* 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: { - DIR *parent; - Direntry_t *dp; - char dotdots[MAXPATHLEN] = { 0 }; - struct stat cst, pst, tst; + 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 (PerlLIO_stat(path, &cst) < 0) { - Perl_warn(aTHX_ "sv_realpath: stat(\"%s\"): %s", - path, Strerror(errno)); - SV_CWD_RETURN_UNDEF; +#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; } - (void)SvUPGRADE(sv, SVt_PV); +#ifdef EMULATE_SOCKETPAIR_UDP + if (type == SOCK_DGRAM) + return S_socketpair_udp (fd); +#endif - if (!len) { - len = strlen(path); + 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; } - Copy(path, dotdots, len, char); + fd[0] = connector; + fd[1] = acceptor; + return 0; - for (;;) { - strcat(dotdots, "/.."); - StructCopy(&cst, &pst, struct stat); + 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 - if (PerlLIO_stat(dotdots, &cst) < 0) { - Perl_warn(aTHX_ "sv_realpath: stat(\"%s\"): %s", - dotdots, Strerror(errno)); - SV_CWD_RETURN_UNDEF; - } +/* - if (pst.st_dev == cst.st_dev && pst.st_ino == cst.st_ino) { - /* We've reached the root: previous is same as current */ - break; - } else { - STRLEN dotdotslen = strlen(dotdots); +=for apidoc sv_nosharing - /* Scan through the dir looking for name of previous */ - if (!(parent = PerlDir_open(dotdots))) { - Perl_warn(aTHX_ "sv_realpath: opendir(\"%s\"): %s", - dotdots, Strerror(errno)); - SV_CWD_RETURN_UNDEF; - } +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. - SETERRNO(0,SS$_NORMAL); /* for readdir() */ - while ((dp = PerlDir_read(parent)) != NULL) { - if (SV_CWD_ISDOT(dp)) { - continue; - } +=cut +*/ - Copy(dotdots, name, dotdotslen, char); - name[dotdotslen] = '/'; -#ifdef DIRNAMLEN - namelen = dp->d_namlen; -#else - namelen = strlen(dp->d_name); -#endif - Copy(dp->d_name, name + dotdotslen + 1, namelen, char); - name[dotdotslen + 1 + namelen] = 0; +void +Perl_sv_nosharing(pTHX_ SV *sv) +{ +} - if (PerlLIO_lstat(name, &tst) < 0) { - PerlDir_close(parent); - Perl_warn(aTHX_ "sv_realpath: lstat(\"%s\"): %s", - name, Strerror(errno)); - SV_CWD_RETURN_UNDEF; - } +/* +=for apidoc sv_nolocking - if (tst.st_dev == pst.st_dev && tst.st_ino == pst.st_ino) - break; +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. - SETERRNO(0,SS$_NORMAL); /* for readdir() */ - } +=cut +*/ - if (!dp && errno) { - Perl_warn(aTHX_ "sv_realpath: readdir(\"%s\"): %s", - dotdots, Strerror(errno)); - SV_CWD_RETURN_UNDEF; - } +void +Perl_sv_nolocking(pTHX_ SV *sv) +{ +} - SvGROW(sv, pathlen + namelen + 1); - if (pathlen) { - /* shift down */ - Move(SvPVX(sv), SvPVX(sv) + namelen + 1, pathlen, char); - } - *SvPVX(sv) = '/'; - Move(dp->d_name, SvPVX(sv)+1, namelen, char); - pathlen += (namelen + 1); +/* +=for apidoc sv_nounlocking -#ifdef VOID_CLOSEDIR - PerlDir_close(parent); -#else - if (PerlDir_close(parent) < 0) { - Perl_warn(aTHX_ "sv_realpath: closedir(\"%s\"): %s", - dotdots, Strerror(errno)); - SV_CWD_RETURN_UNDEF; - } -#endif - } - } +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. - SvCUR_set(sv, pathlen); - SvPOK_only(sv); +=cut +*/ - return TRUE; - } -#endif -#else - return FALSE; -#endif +void +Perl_sv_nounlocking(pTHX_ SV *sv) +{ }