1N/A/* util.c
1N/A *
1N/A * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
1N/A * 2000, 2001, 2002, 2003, 2004, by Larry Wall and others
1N/A *
1N/A * You may distribute under the terms of either the GNU General Public
1N/A * License or the Artistic License, as specified in the README file.
1N/A *
1N/A */
1N/A
1N/A/*
1N/A * "Very useful, no doubt, that was to Saruman; yet it seems that he was
1N/A * not content." --Gandalf
1N/A */
1N/A
1N/A#include "EXTERN.h"
1N/A#define PERL_IN_UTIL_C
1N/A#include "perl.h"
1N/A
1N/A#ifndef PERL_MICRO
1N/A#include <signal.h>
1N/A#ifndef SIG_ERR
1N/A# define SIG_ERR ((Sighandler_t) -1)
1N/A#endif
1N/A#endif
1N/A
1N/A#ifdef I_SYS_WAIT
1N/A# include <sys/wait.h>
1N/A#endif
1N/A
1N/A#ifdef HAS_SELECT
1N/A# ifdef I_SYS_SELECT
1N/A# include <sys/select.h>
1N/A# endif
1N/A#endif
1N/A
1N/A#define FLUSH
1N/A
1N/A#if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC)
1N/A# define FD_CLOEXEC 1 /* NeXT needs this */
1N/A#endif
1N/A
1N/A/* NOTE: Do not call the next three routines directly. Use the macros
1N/A * in handy.h, so that we can easily redefine everything to do tracking of
1N/A * allocated hunks back to the original New to track down any memory leaks.
1N/A * XXX This advice seems to be widely ignored :-( --AD August 1996.
1N/A */
1N/A
1N/A/* paranoid version of system's malloc() */
1N/A
1N/AMalloc_t
1N/APerl_safesysmalloc(MEM_SIZE size)
1N/A{
1N/A dTHX;
1N/A Malloc_t ptr;
1N/A#ifdef HAS_64K_LIMIT
1N/A if (size > 0xffff) {
1N/A PerlIO_printf(Perl_error_log,
1N/A "Allocation too large: %lx\n", size) FLUSH;
1N/A my_exit(1);
1N/A }
1N/A#endif /* HAS_64K_LIMIT */
1N/A#ifdef DEBUGGING
1N/A if ((long)size < 0)
1N/A Perl_croak_nocontext("panic: malloc");
1N/A#endif
1N/A ptr = (Malloc_t)PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */
1N/A PERL_ALLOC_CHECK(ptr);
1N/A DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
1N/A if (ptr != Nullch)
1N/A return ptr;
1N/A else if (PL_nomemok)
1N/A return Nullch;
1N/A else {
1N/A /* Can't use PerlIO to write as it allocates memory */
1N/A PerlLIO_write(PerlIO_fileno(Perl_error_log),
1N/A PL_no_mem, strlen(PL_no_mem));
1N/A my_exit(1);
1N/A return Nullch;
1N/A }
1N/A /*NOTREACHED*/
1N/A}
1N/A
1N/A/* paranoid version of system's realloc() */
1N/A
1N/AMalloc_t
1N/APerl_safesysrealloc(Malloc_t where,MEM_SIZE size)
1N/A{
1N/A dTHX;
1N/A Malloc_t ptr;
1N/A#if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) && !defined(PERL_MICRO)
1N/A Malloc_t PerlMem_realloc();
1N/A#endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */
1N/A
1N/A#ifdef HAS_64K_LIMIT
1N/A if (size > 0xffff) {
1N/A PerlIO_printf(Perl_error_log,
1N/A "Reallocation too large: %lx\n", size) FLUSH;
1N/A my_exit(1);
1N/A }
1N/A#endif /* HAS_64K_LIMIT */
1N/A if (!size) {
1N/A safesysfree(where);
1N/A return NULL;
1N/A }
1N/A
1N/A if (!where)
1N/A return safesysmalloc(size);
1N/A#ifdef DEBUGGING
1N/A if ((long)size < 0)
1N/A Perl_croak_nocontext("panic: realloc");
1N/A#endif
1N/A ptr = (Malloc_t)PerlMem_realloc(where,size);
1N/A PERL_ALLOC_CHECK(ptr);
1N/A
1N/A DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++));
1N/A DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
1N/A
1N/A if (ptr != Nullch)
1N/A return ptr;
1N/A else if (PL_nomemok)
1N/A return Nullch;
1N/A else {
1N/A /* Can't use PerlIO to write as it allocates memory */
1N/A PerlLIO_write(PerlIO_fileno(Perl_error_log),
1N/A PL_no_mem, strlen(PL_no_mem));
1N/A my_exit(1);
1N/A return Nullch;
1N/A }
1N/A /*NOTREACHED*/
1N/A}
1N/A
1N/A/* safe version of system's free() */
1N/A
1N/AFree_t
1N/APerl_safesysfree(Malloc_t where)
1N/A{
1N/A#ifdef PERL_IMPLICIT_SYS
1N/A dTHX;
1N/A#endif
1N/A DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) free\n",PTR2UV(where),(long)PL_an++));
1N/A if (where) {
1N/A /*SUPPRESS 701*/
1N/A PerlMem_free(where);
1N/A }
1N/A}
1N/A
1N/A/* safe version of system's calloc() */
1N/A
1N/AMalloc_t
1N/APerl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
1N/A{
1N/A dTHX;
1N/A Malloc_t ptr;
1N/A
1N/A#ifdef HAS_64K_LIMIT
1N/A if (size * count > 0xffff) {
1N/A PerlIO_printf(Perl_error_log,
1N/A "Allocation too large: %lx\n", size * count) FLUSH;
1N/A my_exit(1);
1N/A }
1N/A#endif /* HAS_64K_LIMIT */
1N/A#ifdef DEBUGGING
1N/A if ((long)size < 0 || (long)count < 0)
1N/A Perl_croak_nocontext("panic: calloc");
1N/A#endif
1N/A size *= count;
1N/A ptr = (Malloc_t)PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */
1N/A PERL_ALLOC_CHECK(ptr);
1N/A DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) calloc %ld x %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)count,(long)size));
1N/A if (ptr != Nullch) {
1N/A memset((void*)ptr, 0, size);
1N/A return ptr;
1N/A }
1N/A else if (PL_nomemok)
1N/A return Nullch;
1N/A else {
1N/A /* Can't use PerlIO to write as it allocates memory */
1N/A PerlLIO_write(PerlIO_fileno(Perl_error_log),
1N/A PL_no_mem, strlen(PL_no_mem));
1N/A my_exit(1);
1N/A return Nullch;
1N/A }
1N/A /*NOTREACHED*/
1N/A}
1N/A
1N/A/* These must be defined when not using Perl's malloc for binary
1N/A * compatibility */
1N/A
1N/A#ifndef MYMALLOC
1N/A
1N/AMalloc_t Perl_malloc (MEM_SIZE nbytes)
1N/A{
1N/A dTHXs;
1N/A return (Malloc_t)PerlMem_malloc(nbytes);
1N/A}
1N/A
1N/AMalloc_t Perl_calloc (MEM_SIZE elements, MEM_SIZE size)
1N/A{
1N/A dTHXs;
1N/A return (Malloc_t)PerlMem_calloc(elements, size);
1N/A}
1N/A
1N/AMalloc_t Perl_realloc (Malloc_t where, MEM_SIZE nbytes)
1N/A{
1N/A dTHXs;
1N/A return (Malloc_t)PerlMem_realloc(where, nbytes);
1N/A}
1N/A
1N/AFree_t Perl_mfree (Malloc_t where)
1N/A{
1N/A dTHXs;
1N/A PerlMem_free(where);
1N/A}
1N/A
1N/A#endif
1N/A
1N/A/* copy a string up to some (non-backslashed) delimiter, if any */
1N/A
1N/Achar *
1N/APerl_delimcpy(pTHX_ register char *to, register char *toend, register char *from, register char *fromend, register int delim, I32 *retlen)
1N/A{
1N/A register I32 tolen;
1N/A for (tolen = 0; from < fromend; from++, tolen++) {
1N/A if (*from == '\\') {
1N/A if (from[1] == delim)
1N/A from++;
1N/A else {
1N/A if (to < toend)
1N/A *to++ = *from;
1N/A tolen++;
1N/A from++;
1N/A }
1N/A }
1N/A else if (*from == delim)
1N/A break;
1N/A if (to < toend)
1N/A *to++ = *from;
1N/A }
1N/A if (to < toend)
1N/A *to = '\0';
1N/A *retlen = tolen;
1N/A return from;
1N/A}
1N/A
1N/A/* return ptr to little string in big string, NULL if not found */
1N/A/* This routine was donated by Corey Satten. */
1N/A
1N/Achar *
1N/APerl_instr(pTHX_ register const char *big, register const char *little)
1N/A{
1N/A register const char *s, *x;
1N/A register I32 first;
1N/A
1N/A if (!little)
1N/A return (char*)big;
1N/A first = *little++;
1N/A if (!first)
1N/A return (char*)big;
1N/A while (*big) {
1N/A if (*big++ != first)
1N/A continue;
1N/A for (x=big,s=little; *s; /**/ ) {
1N/A if (!*x)
1N/A return Nullch;
1N/A if (*s++ != *x++) {
1N/A s--;
1N/A break;
1N/A }
1N/A }
1N/A if (!*s)
1N/A return (char*)(big-1);
1N/A }
1N/A return Nullch;
1N/A}
1N/A
1N/A/* same as instr but allow embedded nulls */
1N/A
1N/Achar *
1N/APerl_ninstr(pTHX_ register const char *big, register const char *bigend, const char *little, const char *lend)
1N/A{
1N/A register const char *s, *x;
1N/A register I32 first = *little;
1N/A register const char *littleend = lend;
1N/A
1N/A if (!first && little >= littleend)
1N/A return (char*)big;
1N/A if (bigend - big < littleend - little)
1N/A return Nullch;
1N/A bigend -= littleend - little++;
1N/A while (big <= bigend) {
1N/A if (*big++ != first)
1N/A continue;
1N/A for (x=big,s=little; s < littleend; /**/ ) {
1N/A if (*s++ != *x++) {
1N/A s--;
1N/A break;
1N/A }
1N/A }
1N/A if (s >= littleend)
1N/A return (char*)(big-1);
1N/A }
1N/A return Nullch;
1N/A}
1N/A
1N/A/* reverse of the above--find last substring */
1N/A
1N/Achar *
1N/APerl_rninstr(pTHX_ register const char *big, const char *bigend, const char *little, const char *lend)
1N/A{
1N/A register const char *bigbeg;
1N/A register const char *s, *x;
1N/A register I32 first = *little;
1N/A register const char *littleend = lend;
1N/A
1N/A if (!first && little >= littleend)
1N/A return (char*)bigend;
1N/A bigbeg = big;
1N/A big = bigend - (littleend - little++);
1N/A while (big >= bigbeg) {
1N/A if (*big-- != first)
1N/A continue;
1N/A for (x=big+2,s=little; s < littleend; /**/ ) {
1N/A if (*s++ != *x++) {
1N/A s--;
1N/A break;
1N/A }
1N/A }
1N/A if (s >= littleend)
1N/A return (char*)(big+1);
1N/A }
1N/A return Nullch;
1N/A}
1N/A
1N/A#define FBM_TABLE_OFFSET 2 /* Number of bytes between EOS and table*/
1N/A
1N/A/* As a space optimization, we do not compile tables for strings of length
1N/A 0 and 1, and for strings of length 2 unless FBMcf_TAIL. These are
1N/A special-cased in fbm_instr().
1N/A
1N/A If FBMcf_TAIL, the table is created as if the string has a trailing \n. */
1N/A
1N/A/*
1N/A=head1 Miscellaneous Functions
1N/A
1N/A=for apidoc fbm_compile
1N/A
1N/AAnalyses the string in order to make fast searches on it using fbm_instr()
1N/A-- the Boyer-Moore algorithm.
1N/A
1N/A=cut
1N/A*/
1N/A
1N/Avoid
1N/APerl_fbm_compile(pTHX_ SV *sv, U32 flags)
1N/A{
1N/A register U8 *s;
1N/A register U8 *table;
1N/A register U32 i;
1N/A STRLEN len;
1N/A I32 rarest = 0;
1N/A U32 frequency = 256;
1N/A
1N/A if (flags & FBMcf_TAIL) {
1N/A MAGIC *mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
1N/A sv_catpvn(sv, "\n", 1); /* Taken into account in fbm_instr() */
1N/A if (mg && mg->mg_len >= 0)
1N/A mg->mg_len++;
1N/A }
1N/A s = (U8*)SvPV_force(sv, len);
1N/A (void)SvUPGRADE(sv, SVt_PVBM);
1N/A if (len == 0) /* TAIL might be on a zero-length string. */
1N/A return;
1N/A if (len > 2) {
1N/A U8 mlen;
1N/A unsigned char *sb;
1N/A
1N/A if (len > 255)
1N/A mlen = 255;
1N/A else
1N/A mlen = (U8)len;
1N/A Sv_Grow(sv, len + 256 + FBM_TABLE_OFFSET);
1N/A table = (unsigned char*)(SvPVX(sv) + len + FBM_TABLE_OFFSET);
1N/A s = table - 1 - FBM_TABLE_OFFSET; /* last char */
1N/A memset((void*)table, mlen, 256);
1N/A table[-1] = (U8)flags;
1N/A i = 0;
1N/A sb = s - mlen + 1; /* first char (maybe) */
1N/A while (s >= sb) {
1N/A if (table[*s] == mlen)
1N/A table[*s] = (U8)i;
1N/A s--, i++;
1N/A }
1N/A }
1N/A sv_magic(sv, Nullsv, PERL_MAGIC_bm, Nullch, 0); /* deep magic */
1N/A SvVALID_on(sv);
1N/A
1N/A s = (unsigned char*)(SvPVX(sv)); /* deeper magic */
1N/A for (i = 0; i < len; i++) {
1N/A if (PL_freq[s[i]] < frequency) {
1N/A rarest = i;
1N/A frequency = PL_freq[s[i]];
1N/A }
1N/A }
1N/A BmRARE(sv) = s[rarest];
1N/A BmPREVIOUS(sv) = (U16)rarest;
1N/A BmUSEFUL(sv) = 100; /* Initial value */
1N/A if (flags & FBMcf_TAIL)
1N/A SvTAIL_on(sv);
1N/A DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %d\n",
1N/A BmRARE(sv),BmPREVIOUS(sv)));
1N/A}
1N/A
1N/A/* If SvTAIL(littlestr), it has a fake '\n' at end. */
1N/A/* If SvTAIL is actually due to \Z or \z, this gives false positives
1N/A if multiline */
1N/A
1N/A/*
1N/A=for apidoc fbm_instr
1N/A
1N/AReturns the location of the SV in the string delimited by C<str> and
1N/AC<strend>. It returns C<Nullch> if the string can't be found. The C<sv>
1N/Adoes not have to be fbm_compiled, but the search will not be as fast
1N/Athen.
1N/A
1N/A=cut
1N/A*/
1N/A
1N/Achar *
1N/APerl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *littlestr, U32 flags)
1N/A{
1N/A register unsigned char *s;
1N/A STRLEN l;
1N/A register unsigned char *little = (unsigned char *)SvPV(littlestr,l);
1N/A register STRLEN littlelen = l;
1N/A register I32 multiline = flags & FBMrf_MULTILINE;
1N/A
1N/A if ((STRLEN)(bigend - big) < littlelen) {
1N/A if ( SvTAIL(littlestr)
1N/A && ((STRLEN)(bigend - big) == littlelen - 1)
1N/A && (littlelen == 1
1N/A || (*big == *little &&
1N/A memEQ((char *)big, (char *)little, littlelen - 1))))
1N/A return (char*)big;
1N/A return Nullch;
1N/A }
1N/A
1N/A if (littlelen <= 2) { /* Special-cased */
1N/A
1N/A if (littlelen == 1) {
1N/A if (SvTAIL(littlestr) && !multiline) { /* Anchor only! */
1N/A /* Know that bigend != big. */
1N/A if (bigend[-1] == '\n')
1N/A return (char *)(bigend - 1);
1N/A return (char *) bigend;
1N/A }
1N/A s = big;
1N/A while (s < bigend) {
1N/A if (*s == *little)
1N/A return (char *)s;
1N/A s++;
1N/A }
1N/A if (SvTAIL(littlestr))
1N/A return (char *) bigend;
1N/A return Nullch;
1N/A }
1N/A if (!littlelen)
1N/A return (char*)big; /* Cannot be SvTAIL! */
1N/A
1N/A /* littlelen is 2 */
1N/A if (SvTAIL(littlestr) && !multiline) {
1N/A if (bigend[-1] == '\n' && bigend[-2] == *little)
1N/A return (char*)bigend - 2;
1N/A if (bigend[-1] == *little)
1N/A return (char*)bigend - 1;
1N/A return Nullch;
1N/A }
1N/A {
1N/A /* This should be better than FBM if c1 == c2, and almost
1N/A as good otherwise: maybe better since we do less indirection.
1N/A And we save a lot of memory by caching no table. */
1N/A register unsigned char c1 = little[0];
1N/A register unsigned char c2 = little[1];
1N/A
1N/A s = big + 1;
1N/A bigend--;
1N/A if (c1 != c2) {
1N/A while (s <= bigend) {
1N/A if (s[0] == c2) {
1N/A if (s[-1] == c1)
1N/A return (char*)s - 1;
1N/A s += 2;
1N/A continue;
1N/A }
1N/A next_chars:
1N/A if (s[0] == c1) {
1N/A if (s == bigend)
1N/A goto check_1char_anchor;
1N/A if (s[1] == c2)
1N/A return (char*)s;
1N/A else {
1N/A s++;
1N/A goto next_chars;
1N/A }
1N/A }
1N/A else
1N/A s += 2;
1N/A }
1N/A goto check_1char_anchor;
1N/A }
1N/A /* Now c1 == c2 */
1N/A while (s <= bigend) {
1N/A if (s[0] == c1) {
1N/A if (s[-1] == c1)
1N/A return (char*)s - 1;
1N/A if (s == bigend)
1N/A goto check_1char_anchor;
1N/A if (s[1] == c1)
1N/A return (char*)s;
1N/A s += 3;
1N/A }
1N/A else
1N/A s += 2;
1N/A }
1N/A }
1N/A check_1char_anchor: /* One char and anchor! */
1N/A if (SvTAIL(littlestr) && (*bigend == *little))
1N/A return (char *)bigend; /* bigend is already decremented. */
1N/A return Nullch;
1N/A }
1N/A if (SvTAIL(littlestr) && !multiline) { /* tail anchored? */
1N/A s = bigend - littlelen;
1N/A if (s >= big && bigend[-1] == '\n' && *s == *little
1N/A /* Automatically of length > 2 */
1N/A && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
1N/A {
1N/A return (char*)s; /* how sweet it is */
1N/A }
1N/A if (s[1] == *little
1N/A && memEQ((char*)s + 2, (char*)little + 1, littlelen - 2))
1N/A {
1N/A return (char*)s + 1; /* how sweet it is */
1N/A }
1N/A return Nullch;
1N/A }
1N/A if (SvTYPE(littlestr) != SVt_PVBM || !SvVALID(littlestr)) {
1N/A char *b = ninstr((char*)big,(char*)bigend,
1N/A (char*)little, (char*)little + littlelen);
1N/A
1N/A if (!b && SvTAIL(littlestr)) { /* Automatically multiline! */
1N/A /* Chop \n from littlestr: */
1N/A s = bigend - littlelen + 1;
1N/A if (*s == *little
1N/A && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
1N/A {
1N/A return (char*)s;
1N/A }
1N/A return Nullch;
1N/A }
1N/A return b;
1N/A }
1N/A
1N/A { /* Do actual FBM. */
1N/A register unsigned char *table = little + littlelen + FBM_TABLE_OFFSET;
1N/A register unsigned char *oldlittle;
1N/A
1N/A if (littlelen > (STRLEN)(bigend - big))
1N/A return Nullch;
1N/A --littlelen; /* Last char found by table lookup */
1N/A
1N/A s = big + littlelen;
1N/A little += littlelen; /* last char */
1N/A oldlittle = little;
1N/A if (s < bigend) {
1N/A register I32 tmp;
1N/A
1N/A top2:
1N/A /*SUPPRESS 560*/
1N/A if ((tmp = table[*s])) {
1N/A if ((s += tmp) < bigend)
1N/A goto top2;
1N/A goto check_end;
1N/A }
1N/A else { /* less expensive than calling strncmp() */
1N/A register unsigned char *olds = s;
1N/A
1N/A tmp = littlelen;
1N/A
1N/A while (tmp--) {
1N/A if (*--s == *--little)
1N/A continue;
1N/A s = olds + 1; /* here we pay the price for failure */
1N/A little = oldlittle;
1N/A if (s < bigend) /* fake up continue to outer loop */
1N/A goto top2;
1N/A goto check_end;
1N/A }
1N/A return (char *)s;
1N/A }
1N/A }
1N/A check_end:
1N/A if ( s == bigend && (table[-1] & FBMcf_TAIL)
1N/A && memEQ((char *)(bigend - littlelen),
1N/A (char *)(oldlittle - littlelen), littlelen) )
1N/A return (char*)bigend - littlelen;
1N/A return Nullch;
1N/A }
1N/A}
1N/A
1N/A/* start_shift, end_shift are positive quantities which give offsets
1N/A of ends of some substring of bigstr.
1N/A If `last' we want the last occurrence.
1N/A old_posp is the way of communication between consequent calls if
1N/A the next call needs to find the .
1N/A The initial *old_posp should be -1.
1N/A
1N/A Note that we take into account SvTAIL, so one can get extra
1N/A optimizations if _ALL flag is set.
1N/A */
1N/A
1N/A/* If SvTAIL is actually due to \Z or \z, this gives false positives
1N/A if PL_multiline. In fact if !PL_multiline the authoritative answer
1N/A is not supported yet. */
1N/A
1N/Achar *
1N/APerl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last)
1N/A{
1N/A register unsigned char *s, *x;
1N/A register unsigned char *big;
1N/A register I32 pos;
1N/A register I32 previous;
1N/A register I32 first;
1N/A register unsigned char *little;
1N/A register I32 stop_pos;
1N/A register unsigned char *littleend;
1N/A I32 found = 0;
1N/A
1N/A if (*old_posp == -1
1N/A ? (pos = PL_screamfirst[BmRARE(littlestr)]) < 0
1N/A : (((pos = *old_posp), pos += PL_screamnext[pos]) == 0)) {
1N/A cant_find:
1N/A if ( BmRARE(littlestr) == '\n'
1N/A && BmPREVIOUS(littlestr) == SvCUR(littlestr) - 1) {
1N/A little = (unsigned char *)(SvPVX(littlestr));
1N/A littleend = little + SvCUR(littlestr);
1N/A first = *little++;
1N/A goto check_tail;
1N/A }
1N/A return Nullch;
1N/A }
1N/A
1N/A little = (unsigned char *)(SvPVX(littlestr));
1N/A littleend = little + SvCUR(littlestr);
1N/A first = *little++;
1N/A /* The value of pos we can start at: */
1N/A previous = BmPREVIOUS(littlestr);
1N/A big = (unsigned char *)(SvPVX(bigstr));
1N/A /* The value of pos we can stop at: */
1N/A stop_pos = SvCUR(bigstr) - end_shift - (SvCUR(littlestr) - 1 - previous);
1N/A if (previous + start_shift > stop_pos) {
1N/A/*
1N/A stop_pos does not include SvTAIL in the count, so this check is incorrect
1N/A (I think) - see [ID 20010618.006] and t/op/study.t. HVDS 2001/06/19
1N/A*/
1N/A#if 0
1N/A if (previous + start_shift == stop_pos + 1) /* A fake '\n'? */
1N/A goto check_tail;
1N/A#endif
1N/A return Nullch;
1N/A }
1N/A while (pos < previous + start_shift) {
1N/A if (!(pos += PL_screamnext[pos]))
1N/A goto cant_find;
1N/A }
1N/A big -= previous;
1N/A do {
1N/A if (pos >= stop_pos) break;
1N/A if (big[pos] != first)
1N/A continue;
1N/A for (x=big+pos+1,s=little; s < littleend; /**/ ) {
1N/A if (*s++ != *x++) {
1N/A s--;
1N/A break;
1N/A }
1N/A }
1N/A if (s == littleend) {
1N/A *old_posp = pos;
1N/A if (!last) return (char *)(big+pos);
1N/A found = 1;
1N/A }
1N/A } while ( pos += PL_screamnext[pos] );
1N/A if (last && found)
1N/A return (char *)(big+(*old_posp));
1N/A check_tail:
1N/A if (!SvTAIL(littlestr) || (end_shift > 0))
1N/A return Nullch;
1N/A /* Ignore the trailing "\n". This code is not microoptimized */
1N/A big = (unsigned char *)(SvPVX(bigstr) + SvCUR(bigstr));
1N/A stop_pos = littleend - little; /* Actual littlestr len */
1N/A if (stop_pos == 0)
1N/A return (char*)big;
1N/A big -= stop_pos;
1N/A if (*big == first
1N/A && ((stop_pos == 1) ||
1N/A memEQ((char *)(big + 1), (char *)little, stop_pos - 1)))
1N/A return (char*)big;
1N/A return Nullch;
1N/A}
1N/A
1N/AI32
1N/APerl_ibcmp(pTHX_ const char *s1, const char *s2, register I32 len)
1N/A{
1N/A register U8 *a = (U8 *)s1;
1N/A register U8 *b = (U8 *)s2;
1N/A while (len--) {
1N/A if (*a != *b && *a != PL_fold[*b])
1N/A return 1;
1N/A a++,b++;
1N/A }
1N/A return 0;
1N/A}
1N/A
1N/AI32
1N/APerl_ibcmp_locale(pTHX_ const char *s1, const char *s2, register I32 len)
1N/A{
1N/A register U8 *a = (U8 *)s1;
1N/A register U8 *b = (U8 *)s2;
1N/A while (len--) {
1N/A if (*a != *b && *a != PL_fold_locale[*b])
1N/A return 1;
1N/A a++,b++;
1N/A }
1N/A return 0;
1N/A}
1N/A
1N/A/* copy a string to a safe spot */
1N/A
1N/A/*
1N/A=head1 Memory Management
1N/A
1N/A=for apidoc savepv
1N/A
1N/APerl's version of C<strdup()>. Returns a pointer to a newly allocated
1N/Astring which is a duplicate of C<pv>. The size of the string is
1N/Adetermined by C<strlen()>. The memory allocated for the new string can
1N/Abe freed with the C<Safefree()> function.
1N/A
1N/A=cut
1N/A*/
1N/A
1N/Achar *
1N/APerl_savepv(pTHX_ const char *pv)
1N/A{
1N/A register char *newaddr = Nullch;
1N/A if (pv) {
1N/A New(902,newaddr,strlen(pv)+1,char);
1N/A (void)strcpy(newaddr,pv);
1N/A }
1N/A return newaddr;
1N/A}
1N/A
1N/A/* same thing but with a known length */
1N/A
1N/A/*
1N/A=for apidoc savepvn
1N/A
1N/APerl's version of what C<strndup()> would be if it existed. Returns a
1N/Apointer to a newly allocated string which is a duplicate of the first
1N/AC<len> bytes from C<pv>. The memory allocated for the new string can be
1N/Afreed with the C<Safefree()> function.
1N/A
1N/A=cut
1N/A*/
1N/A
1N/Achar *
1N/APerl_savepvn(pTHX_ const char *pv, register I32 len)
1N/A{
1N/A register char *newaddr;
1N/A
1N/A New(903,newaddr,len+1,char);
1N/A /* Give a meaning to NULL pointer mainly for the use in sv_magic() */
1N/A if (pv) {
1N/A Copy(pv,newaddr,len,char); /* might not be null terminated */
1N/A newaddr[len] = '\0'; /* is now */
1N/A }
1N/A else {
1N/A Zero(newaddr,len+1,char);
1N/A }
1N/A return newaddr;
1N/A}
1N/A
1N/A/*
1N/A=for apidoc savesharedpv
1N/A
1N/AA version of C<savepv()> which allocates the duplicate string in memory
1N/Awhich is shared between threads.
1N/A
1N/A=cut
1N/A*/
1N/Achar *
1N/APerl_savesharedpv(pTHX_ const char *pv)
1N/A{
1N/A register char *newaddr = Nullch;
1N/A if (pv) {
1N/A newaddr = (char*)PerlMemShared_malloc(strlen(pv)+1);
1N/A (void)strcpy(newaddr,pv);
1N/A }
1N/A return newaddr;
1N/A}
1N/A
1N/A
1N/A
1N/A/* the SV for Perl_form() and mess() is not kept in an arena */
1N/A
1N/ASTATIC SV *
1N/AS_mess_alloc(pTHX)
1N/A{
1N/A SV *sv;
1N/A XPVMG *any;
1N/A
1N/A if (!PL_dirty)
1N/A return sv_2mortal(newSVpvn("",0));
1N/A
1N/A if (PL_mess_sv)
1N/A return PL_mess_sv;
1N/A
1N/A /* Create as PVMG now, to avoid any upgrading later */
1N/A New(905, sv, 1, SV);
1N/A Newz(905, any, 1, XPVMG);
1N/A SvFLAGS(sv) = SVt_PVMG;
1N/A SvANY(sv) = (void*)any;
1N/A SvREFCNT(sv) = 1 << 30; /* practically infinite */
1N/A PL_mess_sv = sv;
1N/A return sv;
1N/A}
1N/A
1N/A#if defined(PERL_IMPLICIT_CONTEXT)
1N/Achar *
1N/APerl_form_nocontext(const char* pat, ...)
1N/A{
1N/A dTHX;
1N/A char *retval;
1N/A va_list args;
1N/A va_start(args, pat);
1N/A retval = vform(pat, &args);
1N/A va_end(args);
1N/A return retval;
1N/A}
1N/A#endif /* PERL_IMPLICIT_CONTEXT */
1N/A
1N/A/*
1N/A=head1 Miscellaneous Functions
1N/A=for apidoc form
1N/A
1N/ATakes a sprintf-style format pattern and conventional
1N/A(non-SV) arguments and returns the formatted string.
1N/A
1N/A (char *) Perl_form(pTHX_ const char* pat, ...)
1N/A
1N/Acan be used any place a string (char *) is required:
1N/A
1N/A char * s = Perl_form("%d.%d",major,minor);
1N/A
1N/AUses a single private buffer so if you want to format several strings you
1N/Amust explicitly copy the earlier strings away (and free the copies when you
1N/Aare done).
1N/A
1N/A=cut
1N/A*/
1N/A
1N/Achar *
1N/APerl_form(pTHX_ const char* pat, ...)
1N/A{
1N/A char *retval;
1N/A va_list args;
1N/A va_start(args, pat);
1N/A retval = vform(pat, &args);
1N/A va_end(args);
1N/A return retval;
1N/A}
1N/A
1N/Achar *
1N/APerl_vform(pTHX_ const char *pat, va_list *args)
1N/A{
1N/A SV *sv = mess_alloc();
1N/A sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
1N/A return SvPVX(sv);
1N/A}
1N/A
1N/A#if defined(PERL_IMPLICIT_CONTEXT)
1N/ASV *
1N/APerl_mess_nocontext(const char *pat, ...)
1N/A{
1N/A dTHX;
1N/A SV *retval;
1N/A va_list args;
1N/A va_start(args, pat);
1N/A retval = vmess(pat, &args);
1N/A va_end(args);
1N/A return retval;
1N/A}
1N/A#endif /* PERL_IMPLICIT_CONTEXT */
1N/A
1N/ASV *
1N/APerl_mess(pTHX_ const char *pat, ...)
1N/A{
1N/A SV *retval;
1N/A va_list args;
1N/A va_start(args, pat);
1N/A retval = vmess(pat, &args);
1N/A va_end(args);
1N/A return retval;
1N/A}
1N/A
1N/ASTATIC COP*
1N/AS_closest_cop(pTHX_ COP *cop, OP *o)
1N/A{
1N/A /* Look for PL_op starting from o. cop is the last COP we've seen. */
1N/A
1N/A if (!o || o == PL_op) return cop;
1N/A
1N/A if (o->op_flags & OPf_KIDS) {
1N/A OP *kid;
1N/A for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1N/A {
1N/A COP *new_cop;
1N/A
1N/A /* If the OP_NEXTSTATE has been optimised away we can still use it
1N/A * the get the file and line number. */
1N/A
1N/A if (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE)
1N/A cop = (COP *)kid;
1N/A
1N/A /* Keep searching, and return when we've found something. */
1N/A
1N/A new_cop = closest_cop(cop, kid);
1N/A if (new_cop) return new_cop;
1N/A }
1N/A }
1N/A
1N/A /* Nothing found. */
1N/A
1N/A return 0;
1N/A}
1N/A
1N/ASV *
1N/APerl_vmess(pTHX_ const char *pat, va_list *args)
1N/A{
1N/A SV *sv = mess_alloc();
1N/A static char dgd[] = " during global destruction.\n";
1N/A COP *cop;
1N/A
1N/A sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
1N/A if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
1N/A
1N/A /*
1N/A * Try and find the file and line for PL_op. This will usually be
1N/A * PL_curcop, but it might be a cop that has been optimised away. We
1N/A * can try to find such a cop by searching through the optree starting
1N/A * from the sibling of PL_curcop.
1N/A */
1N/A
1N/A cop = closest_cop(PL_curcop, PL_curcop->op_sibling);
1N/A if (!cop) cop = PL_curcop;
1N/A
1N/A if (CopLINE(cop))
1N/A Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf,
1N/A OutCopFILE(cop), (IV)CopLINE(cop));
1N/A if (GvIO(PL_last_in_gv) && IoLINES(GvIOp(PL_last_in_gv))) {
1N/A bool line_mode = (RsSIMPLE(PL_rs) &&
1N/A SvCUR(PL_rs) == 1 && *SvPVX(PL_rs) == '\n');
1N/A Perl_sv_catpvf(aTHX_ sv, ", <%s> %s %"IVdf,
1N/A PL_last_in_gv == PL_argvgv ?
1N/A "" : GvNAME(PL_last_in_gv),
1N/A line_mode ? "line" : "chunk",
1N/A (IV)IoLINES(GvIOp(PL_last_in_gv)));
1N/A }
1N/A#ifdef USE_5005THREADS
1N/A if (thr->tid)
1N/A Perl_sv_catpvf(aTHX_ sv, " thread %ld", thr->tid);
1N/A#endif
1N/A sv_catpv(sv, PL_dirty ? dgd : ".\n");
1N/A }
1N/A return sv;
1N/A}
1N/A
1N/Avoid
1N/APerl_write_to_stderr(pTHX_ const char* message, int msglen)
1N/A{
1N/A IO *io;
1N/A MAGIC *mg;
1N/A
1N/A if (PL_stderrgv && SvREFCNT(PL_stderrgv)
1N/A && (io = GvIO(PL_stderrgv))
1N/A && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
1N/A {
1N/A dSP;
1N/A ENTER;
1N/A SAVETMPS;
1N/A
1N/A save_re_context();
1N/A SAVESPTR(PL_stderrgv);
1N/A PL_stderrgv = Nullgv;
1N/A
1N/A PUSHSTACKi(PERLSI_MAGIC);
1N/A
1N/A PUSHMARK(SP);
1N/A EXTEND(SP,2);
1N/A PUSHs(SvTIED_obj((SV*)io, mg));
1N/A PUSHs(sv_2mortal(newSVpvn(message, msglen)));
1N/A PUTBACK;
1N/A call_method("PRINT", G_SCALAR);
1N/A
1N/A POPSTACK;
1N/A FREETMPS;
1N/A LEAVE;
1N/A }
1N/A else {
1N/A#ifdef USE_SFIO
1N/A /* SFIO can really mess with your errno */
1N/A int e = errno;
1N/A#endif
1N/A PerlIO *serr = Perl_error_log;
1N/A
1N/A PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
1N/A (void)PerlIO_flush(serr);
1N/A#ifdef USE_SFIO
1N/A errno = e;
1N/A#endif
1N/A }
1N/A}
1N/A
1N/AOP *
1N/APerl_vdie(pTHX_ const char* pat, va_list *args)
1N/A{
1N/A char *message;
1N/A int was_in_eval = PL_in_eval;
1N/A HV *stash;
1N/A GV *gv;
1N/A CV *cv;
1N/A SV *msv;
1N/A STRLEN msglen;
1N/A I32 utf8 = 0;
1N/A
1N/A DEBUG_S(PerlIO_printf(Perl_debug_log,
1N/A "%p: die: curstack = %p, mainstack = %p\n",
1N/A thr, PL_curstack, PL_mainstack));
1N/A
1N/A if (pat) {
1N/A msv = vmess(pat, args);
1N/A if (PL_errors && SvCUR(PL_errors)) {
1N/A sv_catsv(PL_errors, msv);
1N/A message = SvPV(PL_errors, msglen);
1N/A SvCUR_set(PL_errors, 0);
1N/A }
1N/A else
1N/A message = SvPV(msv,msglen);
1N/A utf8 = SvUTF8(msv);
1N/A }
1N/A else {
1N/A message = Nullch;
1N/A msglen = 0;
1N/A }
1N/A
1N/A DEBUG_S(PerlIO_printf(Perl_debug_log,
1N/A "%p: die: message = %s\ndiehook = %p\n",
1N/A thr, message, PL_diehook));
1N/A if (PL_diehook) {
1N/A /* sv_2cv might call Perl_croak() */
1N/A SV *olddiehook = PL_diehook;
1N/A ENTER;
1N/A SAVESPTR(PL_diehook);
1N/A PL_diehook = Nullsv;
1N/A cv = sv_2cv(olddiehook, &stash, &gv, 0);
1N/A LEAVE;
1N/A if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1N/A dSP;
1N/A SV *msg;
1N/A
1N/A ENTER;
1N/A save_re_context();
1N/A if (message) {
1N/A msg = newSVpvn(message, msglen);
1N/A SvFLAGS(msg) |= utf8;
1N/A SvREADONLY_on(msg);
1N/A SAVEFREESV(msg);
1N/A }
1N/A else {
1N/A msg = ERRSV;
1N/A }
1N/A
1N/A PUSHSTACKi(PERLSI_DIEHOOK);
1N/A PUSHMARK(SP);
1N/A XPUSHs(msg);
1N/A PUTBACK;
1N/A call_sv((SV*)cv, G_DISCARD);
1N/A POPSTACK;
1N/A LEAVE;
1N/A }
1N/A }
1N/A
1N/A PL_restartop = die_where(message, msglen);
1N/A SvFLAGS(ERRSV) |= utf8;
1N/A DEBUG_S(PerlIO_printf(Perl_debug_log,
1N/A "%p: die: restartop = %p, was_in_eval = %d, top_env = %p\n",
1N/A thr, PL_restartop, was_in_eval, PL_top_env));
1N/A if ((!PL_restartop && was_in_eval) || PL_top_env->je_prev)
1N/A JMPENV_JUMP(3);
1N/A return PL_restartop;
1N/A}
1N/A
1N/A#if defined(PERL_IMPLICIT_CONTEXT)
1N/AOP *
1N/APerl_die_nocontext(const char* pat, ...)
1N/A{
1N/A dTHX;
1N/A OP *o;
1N/A va_list args;
1N/A va_start(args, pat);
1N/A o = vdie(pat, &args);
1N/A va_end(args);
1N/A return o;
1N/A}
1N/A#endif /* PERL_IMPLICIT_CONTEXT */
1N/A
1N/AOP *
1N/APerl_die(pTHX_ const char* pat, ...)
1N/A{
1N/A OP *o;
1N/A va_list args;
1N/A va_start(args, pat);
1N/A o = vdie(pat, &args);
1N/A va_end(args);
1N/A return o;
1N/A}
1N/A
1N/Avoid
1N/APerl_vcroak(pTHX_ const char* pat, va_list *args)
1N/A{
1N/A char *message;
1N/A HV *stash;
1N/A GV *gv;
1N/A CV *cv;
1N/A SV *msv;
1N/A STRLEN msglen;
1N/A I32 utf8 = 0;
1N/A
1N/A if (pat) {
1N/A msv = vmess(pat, args);
1N/A if (PL_errors && SvCUR(PL_errors)) {
1N/A sv_catsv(PL_errors, msv);
1N/A message = SvPV(PL_errors, msglen);
1N/A SvCUR_set(PL_errors, 0);
1N/A }
1N/A else
1N/A message = SvPV(msv,msglen);
1N/A utf8 = SvUTF8(msv);
1N/A }
1N/A else {
1N/A message = Nullch;
1N/A msglen = 0;
1N/A }
1N/A
1N/A DEBUG_S(PerlIO_printf(Perl_debug_log, "croak: 0x%"UVxf" %s",
1N/A PTR2UV(thr), message));
1N/A
1N/A if (PL_diehook) {
1N/A /* sv_2cv might call Perl_croak() */
1N/A SV *olddiehook = PL_diehook;
1N/A ENTER;
1N/A SAVESPTR(PL_diehook);
1N/A PL_diehook = Nullsv;
1N/A cv = sv_2cv(olddiehook, &stash, &gv, 0);
1N/A LEAVE;
1N/A if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1N/A dSP;
1N/A SV *msg;
1N/A
1N/A ENTER;
1N/A save_re_context();
1N/A if (message) {
1N/A msg = newSVpvn(message, msglen);
1N/A SvFLAGS(msg) |= utf8;
1N/A SvREADONLY_on(msg);
1N/A SAVEFREESV(msg);
1N/A }
1N/A else {
1N/A msg = ERRSV;
1N/A }
1N/A
1N/A PUSHSTACKi(PERLSI_DIEHOOK);
1N/A PUSHMARK(SP);
1N/A XPUSHs(msg);
1N/A PUTBACK;
1N/A call_sv((SV*)cv, G_DISCARD);
1N/A POPSTACK;
1N/A LEAVE;
1N/A }
1N/A }
1N/A if (PL_in_eval) {
1N/A PL_restartop = die_where(message, msglen);
1N/A SvFLAGS(ERRSV) |= utf8;
1N/A JMPENV_JUMP(3);
1N/A }
1N/A else if (!message)
1N/A message = SvPVx(ERRSV, msglen);
1N/A
1N/A write_to_stderr(message, msglen);
1N/A my_failure_exit();
1N/A}
1N/A
1N/A#if defined(PERL_IMPLICIT_CONTEXT)
1N/Avoid
1N/APerl_croak_nocontext(const char *pat, ...)
1N/A{
1N/A dTHX;
1N/A va_list args;
1N/A va_start(args, pat);
1N/A vcroak(pat, &args);
1N/A /* NOTREACHED */
1N/A va_end(args);
1N/A}
1N/A#endif /* PERL_IMPLICIT_CONTEXT */
1N/A
1N/A/*
1N/A=head1 Warning and Dieing
1N/A
1N/A=for apidoc croak
1N/A
1N/AThis is the XSUB-writer's interface to Perl's C<die> function.
1N/ANormally call this function the same way you call the C C<printf>
1N/Afunction. Calling C<croak> returns control directly to Perl,
1N/Asidestepping the normal C order of execution. See C<warn>.
1N/A
1N/AIf you want to throw an exception object, assign the object to
1N/AC<$@> and then pass C<Nullch> to croak():
1N/A
1N/A errsv = get_sv("@", TRUE);
1N/A sv_setsv(errsv, exception_object);
1N/A croak(Nullch);
1N/A
1N/A=cut
1N/A*/
1N/A
1N/Avoid
1N/APerl_croak(pTHX_ const char *pat, ...)
1N/A{
1N/A va_list args;
1N/A va_start(args, pat);
1N/A vcroak(pat, &args);
1N/A /* NOTREACHED */
1N/A va_end(args);
1N/A}
1N/A
1N/Avoid
1N/APerl_vwarn(pTHX_ const char* pat, va_list *args)
1N/A{
1N/A char *message;
1N/A HV *stash;
1N/A GV *gv;
1N/A CV *cv;
1N/A SV *msv;
1N/A STRLEN msglen;
1N/A I32 utf8 = 0;
1N/A
1N/A msv = vmess(pat, args);
1N/A utf8 = SvUTF8(msv);
1N/A message = SvPV(msv, msglen);
1N/A
1N/A if (PL_warnhook) {
1N/A /* sv_2cv might call Perl_warn() */
1N/A SV *oldwarnhook = PL_warnhook;
1N/A ENTER;
1N/A SAVESPTR(PL_warnhook);
1N/A PL_warnhook = Nullsv;
1N/A cv = sv_2cv(oldwarnhook, &stash, &gv, 0);
1N/A LEAVE;
1N/A if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1N/A dSP;
1N/A SV *msg;
1N/A
1N/A ENTER;
1N/A save_re_context();
1N/A msg = newSVpvn(message, msglen);
1N/A SvFLAGS(msg) |= utf8;
1N/A SvREADONLY_on(msg);
1N/A SAVEFREESV(msg);
1N/A
1N/A PUSHSTACKi(PERLSI_WARNHOOK);
1N/A PUSHMARK(SP);
1N/A XPUSHs(msg);
1N/A PUTBACK;
1N/A call_sv((SV*)cv, G_DISCARD);
1N/A POPSTACK;
1N/A LEAVE;
1N/A return;
1N/A }
1N/A }
1N/A
1N/A write_to_stderr(message, msglen);
1N/A}
1N/A
1N/A#if defined(PERL_IMPLICIT_CONTEXT)
1N/Avoid
1N/APerl_warn_nocontext(const char *pat, ...)
1N/A{
1N/A dTHX;
1N/A va_list args;
1N/A va_start(args, pat);
1N/A vwarn(pat, &args);
1N/A va_end(args);
1N/A}
1N/A#endif /* PERL_IMPLICIT_CONTEXT */
1N/A
1N/A/*
1N/A=for apidoc warn
1N/A
1N/AThis is the XSUB-writer's interface to Perl's C<warn> function. Call this
1N/Afunction the same way you call the C C<printf> function. See C<croak>.
1N/A
1N/A=cut
1N/A*/
1N/A
1N/Avoid
1N/APerl_warn(pTHX_ const char *pat, ...)
1N/A{
1N/A va_list args;
1N/A va_start(args, pat);
1N/A vwarn(pat, &args);
1N/A va_end(args);
1N/A}
1N/A
1N/A#if defined(PERL_IMPLICIT_CONTEXT)
1N/Avoid
1N/APerl_warner_nocontext(U32 err, const char *pat, ...)
1N/A{
1N/A dTHX;
1N/A va_list args;
1N/A va_start(args, pat);
1N/A vwarner(err, pat, &args);
1N/A va_end(args);
1N/A}
1N/A#endif /* PERL_IMPLICIT_CONTEXT */
1N/A
1N/Avoid
1N/APerl_warner(pTHX_ U32 err, const char* pat,...)
1N/A{
1N/A va_list args;
1N/A va_start(args, pat);
1N/A vwarner(err, pat, &args);
1N/A va_end(args);
1N/A}
1N/A
1N/Avoid
1N/APerl_vwarner(pTHX_ U32 err, const char* pat, va_list* args)
1N/A{
1N/A char *message;
1N/A HV *stash;
1N/A GV *gv;
1N/A CV *cv;
1N/A SV *msv;
1N/A STRLEN msglen;
1N/A I32 utf8 = 0;
1N/A
1N/A msv = vmess(pat, args);
1N/A message = SvPV(msv, msglen);
1N/A utf8 = SvUTF8(msv);
1N/A
1N/A if (ckDEAD(err)) {
1N/A#ifdef USE_5005THREADS
1N/A DEBUG_S(PerlIO_printf(Perl_debug_log, "croak: 0x%"UVxf" %s", PTR2UV(thr), message));
1N/A#endif /* USE_5005THREADS */
1N/A if (PL_diehook) {
1N/A /* sv_2cv might call Perl_croak() */
1N/A SV *olddiehook = PL_diehook;
1N/A ENTER;
1N/A SAVESPTR(PL_diehook);
1N/A PL_diehook = Nullsv;
1N/A cv = sv_2cv(olddiehook, &stash, &gv, 0);
1N/A LEAVE;
1N/A if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1N/A dSP;
1N/A SV *msg;
1N/A
1N/A ENTER;
1N/A save_re_context();
1N/A msg = newSVpvn(message, msglen);
1N/A SvFLAGS(msg) |= utf8;
1N/A SvREADONLY_on(msg);
1N/A SAVEFREESV(msg);
1N/A
1N/A PUSHSTACKi(PERLSI_DIEHOOK);
1N/A PUSHMARK(sp);
1N/A XPUSHs(msg);
1N/A PUTBACK;
1N/A call_sv((SV*)cv, G_DISCARD);
1N/A POPSTACK;
1N/A LEAVE;
1N/A }
1N/A }
1N/A if (PL_in_eval) {
1N/A PL_restartop = die_where(message, msglen);
1N/A SvFLAGS(ERRSV) |= utf8;
1N/A JMPENV_JUMP(3);
1N/A }
1N/A write_to_stderr(message, msglen);
1N/A my_failure_exit();
1N/A }
1N/A else {
1N/A if (PL_warnhook) {
1N/A /* sv_2cv might call Perl_warn() */
1N/A SV *oldwarnhook = PL_warnhook;
1N/A ENTER;
1N/A SAVESPTR(PL_warnhook);
1N/A PL_warnhook = Nullsv;
1N/A cv = sv_2cv(oldwarnhook, &stash, &gv, 0);
1N/A LEAVE;
1N/A if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1N/A dSP;
1N/A SV *msg;
1N/A
1N/A ENTER;
1N/A save_re_context();
1N/A msg = newSVpvn(message, msglen);
1N/A SvFLAGS(msg) |= utf8;
1N/A SvREADONLY_on(msg);
1N/A SAVEFREESV(msg);
1N/A
1N/A PUSHSTACKi(PERLSI_WARNHOOK);
1N/A PUSHMARK(sp);
1N/A XPUSHs(msg);
1N/A PUTBACK;
1N/A call_sv((SV*)cv, G_DISCARD);
1N/A POPSTACK;
1N/A LEAVE;
1N/A return;
1N/A }
1N/A }
1N/A write_to_stderr(message, msglen);
1N/A }
1N/A}
1N/A
1N/A/* since we've already done strlen() for both nam and val
1N/A * we can use that info to make things faster than
1N/A * sprintf(s, "%s=%s", nam, val)
1N/A */
1N/A#define my_setenv_format(s, nam, nlen, val, vlen) \
1N/A Copy(nam, s, nlen, char); \
1N/A *(s+nlen) = '='; \
1N/A Copy(val, s+(nlen+1), vlen, char); \
1N/A *(s+(nlen+1+vlen)) = '\0'
1N/A
1N/A#ifdef USE_ENVIRON_ARRAY
1N/A /* VMS' my_setenv() is in vms.c */
1N/A#if !defined(WIN32) && !defined(NETWARE)
1N/Avoid
1N/APerl_my_setenv(pTHX_ char *nam, char *val)
1N/A{
1N/A#ifdef USE_ITHREADS
1N/A /* only parent thread can modify process environment */
1N/A if (PL_curinterp == aTHX)
1N/A#endif
1N/A {
1N/A#ifndef PERL_USE_SAFE_PUTENV
1N/A /* most putenv()s leak, so we manipulate environ directly */
1N/A register I32 i=setenv_getix(nam); /* where does it go? */
1N/A int nlen, vlen;
1N/A
1N/A if (environ == PL_origenviron) { /* need we copy environment? */
1N/A I32 j;
1N/A I32 max;
1N/A char **tmpenv;
1N/A
1N/A /*SUPPRESS 530*/
1N/A for (max = i; environ[max]; max++) ;
1N/A tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*));
1N/A for (j=0; j<max; j++) { /* copy environment */
1N/A int len = strlen(environ[j]);
1N/A tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char));
1N/A Copy(environ[j], tmpenv[j], len+1, char);
1N/A }
1N/A tmpenv[max] = Nullch;
1N/A environ = tmpenv; /* tell exec where it is now */
1N/A }
1N/A if (!val) {
1N/A safesysfree(environ[i]);
1N/A while (environ[i]) {
1N/A environ[i] = environ[i+1];
1N/A i++;
1N/A }
1N/A return;
1N/A }
1N/A if (!environ[i]) { /* does not exist yet */
1N/A environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
1N/A environ[i+1] = Nullch; /* make sure it's null terminated */
1N/A }
1N/A else
1N/A safesysfree(environ[i]);
1N/A nlen = strlen(nam);
1N/A vlen = strlen(val);
1N/A
1N/A environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char));
1N/A /* all that work just for this */
1N/A my_setenv_format(environ[i], nam, nlen, val, vlen);
1N/A
1N/A#else /* PERL_USE_SAFE_PUTENV */
1N/A# if defined(__CYGWIN__) || defined( EPOC)
1N/A setenv(nam, val, 1);
1N/A# else
1N/A char *new_env;
1N/A int nlen = strlen(nam), vlen;
1N/A if (!val) {
1N/A val = "";
1N/A }
1N/A vlen = strlen(val);
1N/A new_env = (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
1N/A /* all that work just for this */
1N/A my_setenv_format(new_env, nam, nlen, val, vlen);
1N/A (void)putenv(new_env);
1N/A# endif /* __CYGWIN__ */
1N/A#endif /* PERL_USE_SAFE_PUTENV */
1N/A }
1N/A}
1N/A
1N/A#else /* WIN32 || NETWARE */
1N/A
1N/Avoid
1N/APerl_my_setenv(pTHX_ char *nam,char *val)
1N/A{
1N/A register char *envstr;
1N/A int nlen = strlen(nam), vlen;
1N/A
1N/A if (!val) {
1N/A val = "";
1N/A }
1N/A vlen = strlen(val);
1N/A New(904, envstr, nlen+vlen+2, char);
1N/A my_setenv_format(envstr, nam, nlen, val, vlen);
1N/A (void)PerlEnv_putenv(envstr);
1N/A Safefree(envstr);
1N/A}
1N/A
1N/A#endif /* WIN32 || NETWARE */
1N/A
1N/A#ifndef PERL_MICRO
1N/AI32
1N/APerl_setenv_getix(pTHX_ char *nam)
1N/A{
1N/A register I32 i, len = strlen(nam);
1N/A
1N/A for (i = 0; environ[i]; i++) {
1N/A if (
1N/A#ifdef WIN32
1N/A strnicmp(environ[i],nam,len) == 0
1N/A#else
1N/A strnEQ(environ[i],nam,len)
1N/A#endif
1N/A && environ[i][len] == '=')
1N/A break; /* strnEQ must come first to avoid */
1N/A } /* potential SEGV's */
1N/A return i;
1N/A}
1N/A#endif /* !PERL_MICRO */
1N/A
1N/A#endif /* !VMS && !EPOC*/
1N/A
1N/A#ifdef UNLINK_ALL_VERSIONS
1N/AI32
1N/APerl_unlnk(pTHX_ char *f) /* unlink all versions of a file */
1N/A{
1N/A I32 i;
1N/A
1N/A for (i = 0; PerlLIO_unlink(f) >= 0; i++) ;
1N/A return i ? 0 : -1;
1N/A}
1N/A#endif
1N/A
1N/A/* this is a drop-in replacement for bcopy() */
1N/A#if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY))
1N/Achar *
1N/APerl_my_bcopy(register const char *from,register char *to,register I32 len)
1N/A{
1N/A char *retval = to;
1N/A
1N/A if (from - to >= 0) {
1N/A while (len--)
1N/A *to++ = *from++;
1N/A }
1N/A else {
1N/A to += len;
1N/A from += len;
1N/A while (len--)
1N/A *(--to) = *(--from);
1N/A }
1N/A return retval;
1N/A}
1N/A#endif
1N/A
1N/A/* this is a drop-in replacement for memset() */
1N/A#ifndef HAS_MEMSET
1N/Avoid *
1N/APerl_my_memset(register char *loc, register I32 ch, register I32 len)
1N/A{
1N/A char *retval = loc;
1N/A
1N/A while (len--)
1N/A *loc++ = ch;
1N/A return retval;
1N/A}
1N/A#endif
1N/A
1N/A/* this is a drop-in replacement for bzero() */
1N/A#if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
1N/Achar *
1N/APerl_my_bzero(register char *loc, register I32 len)
1N/A{
1N/A char *retval = loc;
1N/A
1N/A while (len--)
1N/A *loc++ = 0;
1N/A return retval;
1N/A}
1N/A#endif
1N/A
1N/A/* this is a drop-in replacement for memcmp() */
1N/A#if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
1N/AI32
1N/APerl_my_memcmp(const char *s1, const char *s2, register I32 len)
1N/A{
1N/A register U8 *a = (U8 *)s1;
1N/A register U8 *b = (U8 *)s2;
1N/A register I32 tmp;
1N/A
1N/A while (len--) {
1N/A if (tmp = *a++ - *b++)
1N/A return tmp;
1N/A }
1N/A return 0;
1N/A}
1N/A#endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */
1N/A
1N/A#ifndef HAS_VPRINTF
1N/A
1N/A#ifdef USE_CHAR_VSPRINTF
1N/Achar *
1N/A#else
1N/Aint
1N/A#endif
1N/Avsprintf(char *dest, const char *pat, char *args)
1N/A{
1N/A FILE fakebuf;
1N/A
1N/A fakebuf._ptr = dest;
1N/A fakebuf._cnt = 32767;
1N/A#ifndef _IOSTRG
1N/A#define _IOSTRG 0
1N/A#endif
1N/A fakebuf._flag = _IOWRT|_IOSTRG;
1N/A _doprnt(pat, args, &fakebuf); /* what a kludge */
1N/A (void)putc('\0', &fakebuf);
1N/A#ifdef USE_CHAR_VSPRINTF
1N/A return(dest);
1N/A#else
1N/A return 0; /* perl doesn't use return value */
1N/A#endif
1N/A}
1N/A
1N/A#endif /* HAS_VPRINTF */
1N/A
1N/A#ifdef MYSWAP
1N/A#if BYTEORDER != 0x4321
1N/Ashort
1N/APerl_my_swap(pTHX_ short s)
1N/A{
1N/A#if (BYTEORDER & 1) == 0
1N/A short result;
1N/A
1N/A result = ((s & 255) << 8) + ((s >> 8) & 255);
1N/A return result;
1N/A#else
1N/A return s;
1N/A#endif
1N/A}
1N/A
1N/Along
1N/APerl_my_htonl(pTHX_ long l)
1N/A{
1N/A union {
1N/A long result;
1N/A char c[sizeof(long)];
1N/A } u;
1N/A
1N/A#if BYTEORDER == 0x1234
1N/A u.c[0] = (l >> 24) & 255;
1N/A u.c[1] = (l >> 16) & 255;
1N/A u.c[2] = (l >> 8) & 255;
1N/A u.c[3] = l & 255;
1N/A return u.result;
1N/A#else
1N/A#if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
1N/A Perl_croak(aTHX_ "Unknown BYTEORDER\n");
1N/A#else
1N/A register I32 o;
1N/A register I32 s;
1N/A
1N/A for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
1N/A u.c[o & 0xf] = (l >> s) & 255;
1N/A }
1N/A return u.result;
1N/A#endif
1N/A#endif
1N/A}
1N/A
1N/Along
1N/APerl_my_ntohl(pTHX_ long l)
1N/A{
1N/A union {
1N/A long l;
1N/A char c[sizeof(long)];
1N/A } u;
1N/A
1N/A#if BYTEORDER == 0x1234
1N/A u.c[0] = (l >> 24) & 255;
1N/A u.c[1] = (l >> 16) & 255;
1N/A u.c[2] = (l >> 8) & 255;
1N/A u.c[3] = l & 255;
1N/A return u.l;
1N/A#else
1N/A#if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
1N/A Perl_croak(aTHX_ "Unknown BYTEORDER\n");
1N/A#else
1N/A register I32 o;
1N/A register I32 s;
1N/A
1N/A u.l = l;
1N/A l = 0;
1N/A for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
1N/A l |= (u.c[o & 0xf] & 255) << s;
1N/A }
1N/A return l;
1N/A#endif
1N/A#endif
1N/A}
1N/A
1N/A#endif /* BYTEORDER != 0x4321 */
1N/A#endif /* MYSWAP */
1N/A
1N/A/*
1N/A * Little-endian byte order functions - 'v' for 'VAX', or 'reVerse'.
1N/A * If these functions are defined,
1N/A * the BYTEORDER is neither 0x1234 nor 0x4321.
1N/A * However, this is not assumed.
1N/A * -DWS
1N/A */
1N/A
1N/A#define HTOV(name,type) \
1N/A type \
1N/A name (register type n) \
1N/A { \
1N/A union { \
1N/A type value; \
1N/A char c[sizeof(type)]; \
1N/A } u; \
1N/A register I32 i; \
1N/A register I32 s; \
1N/A for (i = 0, s = 0; i < sizeof(u.c); i++, s += 8) { \
1N/A u.c[i] = (n >> s) & 0xFF; \
1N/A } \
1N/A return u.value; \
1N/A }
1N/A
1N/A#define VTOH(name,type) \
1N/A type \
1N/A name (register type n) \
1N/A { \
1N/A union { \
1N/A type value; \
1N/A char c[sizeof(type)]; \
1N/A } u; \
1N/A register I32 i; \
1N/A register I32 s; \
1N/A u.value = n; \
1N/A n = 0; \
1N/A for (i = 0, s = 0; i < sizeof(u.c); i++, s += 8) { \
1N/A n += (u.c[i] & 0xFF) << s; \
1N/A } \
1N/A return n; \
1N/A }
1N/A
1N/A#if defined(HAS_HTOVS) && !defined(htovs)
1N/AHTOV(htovs,short)
1N/A#endif
1N/A#if defined(HAS_HTOVL) && !defined(htovl)
1N/AHTOV(htovl,long)
1N/A#endif
1N/A#if defined(HAS_VTOHS) && !defined(vtohs)
1N/AVTOH(vtohs,short)
1N/A#endif
1N/A#if defined(HAS_VTOHL) && !defined(vtohl)
1N/AVTOH(vtohl,long)
1N/A#endif
1N/A
1N/APerlIO *
1N/APerl_my_popen_list(pTHX_ char *mode, int n, SV **args)
1N/A{
1N/A#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) && !defined(NETWARE)
1N/A int p[2];
1N/A register I32 This, that;
1N/A register Pid_t pid;
1N/A SV *sv;
1N/A I32 did_pipes = 0;
1N/A int pp[2];
1N/A
1N/A PERL_FLUSHALL_FOR_CHILD;
1N/A This = (*mode == 'w');
1N/A that = !This;
1N/A if (PL_tainting) {
1N/A taint_env();
1N/A taint_proper("Insecure %s%s", "EXEC");
1N/A }
1N/A if (PerlProc_pipe(p) < 0)
1N/A return Nullfp;
1N/A /* Try for another pipe pair for error return */
1N/A if (PerlProc_pipe(pp) >= 0)
1N/A did_pipes = 1;
1N/A while ((pid = PerlProc_fork()) < 0) {
1N/A if (errno != EAGAIN) {
1N/A PerlLIO_close(p[This]);
1N/A PerlLIO_close(p[that]);
1N/A if (did_pipes) {
1N/A PerlLIO_close(pp[0]);
1N/A PerlLIO_close(pp[1]);
1N/A }
1N/A return Nullfp;
1N/A }
1N/A sleep(5);
1N/A }
1N/A if (pid == 0) {
1N/A /* Child */
1N/A#undef THIS
1N/A#undef THAT
1N/A#define THIS that
1N/A#define THAT This
1N/A /* Close parent's end of error status pipe (if any) */
1N/A if (did_pipes) {
1N/A PerlLIO_close(pp[0]);
1N/A#if defined(HAS_FCNTL) && defined(F_SETFD)
1N/A /* Close error pipe automatically if exec works */
1N/A fcntl(pp[1], F_SETFD, FD_CLOEXEC);
1N/A#endif
1N/A }
1N/A /* Now dup our end of _the_ pipe to right position */
1N/A if (p[THIS] != (*mode == 'r')) {
1N/A PerlLIO_dup2(p[THIS], *mode == 'r');
1N/A PerlLIO_close(p[THIS]);
1N/A if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
1N/A PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
1N/A }
1N/A else
1N/A PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
1N/A#if !defined(HAS_FCNTL) || !defined(F_SETFD)
1N/A /* No automatic close - do it by hand */
1N/A# ifndef NOFILE
1N/A# define NOFILE 20
1N/A# endif
1N/A {
1N/A int fd;
1N/A
1N/A for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) {
1N/A if (fd != pp[1])
1N/A PerlLIO_close(fd);
1N/A }
1N/A }
1N/A#endif
1N/A do_aexec5(Nullsv, args-1, args-1+n, pp[1], did_pipes);
1N/A PerlProc__exit(1);
1N/A#undef THIS
1N/A#undef THAT
1N/A }
1N/A /* Parent */
1N/A do_execfree(); /* free any memory malloced by child on fork */
1N/A if (did_pipes)
1N/A PerlLIO_close(pp[1]);
1N/A /* Keep the lower of the two fd numbers */
1N/A if (p[that] < p[This]) {
1N/A PerlLIO_dup2(p[This], p[that]);
1N/A PerlLIO_close(p[This]);
1N/A p[This] = p[that];
1N/A }
1N/A else
1N/A PerlLIO_close(p[that]); /* close child's end of pipe */
1N/A
1N/A LOCK_FDPID_MUTEX;
1N/A sv = *av_fetch(PL_fdpid,p[This],TRUE);
1N/A UNLOCK_FDPID_MUTEX;
1N/A (void)SvUPGRADE(sv,SVt_IV);
1N/A SvIVX(sv) = pid;
1N/A PL_forkprocess = pid;
1N/A /* If we managed to get status pipe check for exec fail */
1N/A if (did_pipes && pid > 0) {
1N/A int errkid;
1N/A int n = 0, n1;
1N/A
1N/A while (n < sizeof(int)) {
1N/A n1 = PerlLIO_read(pp[0],
1N/A (void*)(((char*)&errkid)+n),
1N/A (sizeof(int)) - n);
1N/A if (n1 <= 0)
1N/A break;
1N/A n += n1;
1N/A }
1N/A PerlLIO_close(pp[0]);
1N/A did_pipes = 0;
1N/A if (n) { /* Error */
1N/A int pid2, status;
1N/A PerlLIO_close(p[This]);
1N/A if (n != sizeof(int))
1N/A Perl_croak(aTHX_ "panic: kid popen errno read");
1N/A do {
1N/A pid2 = wait4pid(pid, &status, 0);
1N/A } while (pid2 == -1 && errno == EINTR);
1N/A errno = errkid; /* Propagate errno from kid */
1N/A return Nullfp;
1N/A }
1N/A }
1N/A if (did_pipes)
1N/A PerlLIO_close(pp[0]);
1N/A return PerlIO_fdopen(p[This], mode);
1N/A#else
1N/A Perl_croak(aTHX_ "List form of piped open not implemented");
1N/A return (PerlIO *) NULL;
1N/A#endif
1N/A}
1N/A
1N/A /* VMS' my_popen() is in VMS.c, same with OS/2. */
1N/A#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
1N/APerlIO *
1N/APerl_my_popen(pTHX_ char *cmd, char *mode)
1N/A{
1N/A int p[2];
1N/A register I32 This, that;
1N/A register Pid_t pid;
1N/A SV *sv;
1N/A I32 doexec = strNE(cmd,"-");
1N/A I32 did_pipes = 0;
1N/A int pp[2];
1N/A
1N/A PERL_FLUSHALL_FOR_CHILD;
1N/A#ifdef OS2
1N/A if (doexec) {
1N/A return my_syspopen(aTHX_ cmd,mode);
1N/A }
1N/A#endif
1N/A This = (*mode == 'w');
1N/A that = !This;
1N/A if (doexec && PL_tainting) {
1N/A taint_env();
1N/A taint_proper("Insecure %s%s", "EXEC");
1N/A }
1N/A if (PerlProc_pipe(p) < 0)
1N/A return Nullfp;
1N/A if (doexec && PerlProc_pipe(pp) >= 0)
1N/A did_pipes = 1;
1N/A while ((pid = PerlProc_fork()) < 0) {
1N/A if (errno != EAGAIN) {
1N/A PerlLIO_close(p[This]);
1N/A PerlLIO_close(p[that]);
1N/A if (did_pipes) {
1N/A PerlLIO_close(pp[0]);
1N/A PerlLIO_close(pp[1]);
1N/A }
1N/A if (!doexec)
1N/A Perl_croak(aTHX_ "Can't fork");
1N/A return Nullfp;
1N/A }
1N/A sleep(5);
1N/A }
1N/A if (pid == 0) {
1N/A GV* tmpgv;
1N/A
1N/A#undef THIS
1N/A#undef THAT
1N/A#define THIS that
1N/A#define THAT This
1N/A if (did_pipes) {
1N/A PerlLIO_close(pp[0]);
1N/A#if defined(HAS_FCNTL) && defined(F_SETFD)
1N/A fcntl(pp[1], F_SETFD, FD_CLOEXEC);
1N/A#endif
1N/A }
1N/A if (p[THIS] != (*mode == 'r')) {
1N/A PerlLIO_dup2(p[THIS], *mode == 'r');
1N/A PerlLIO_close(p[THIS]);
1N/A if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
1N/A PerlLIO_close(p[THAT]);
1N/A }
1N/A else
1N/A PerlLIO_close(p[THAT]);
1N/A#ifndef OS2
1N/A if (doexec) {
1N/A#if !defined(HAS_FCNTL) || !defined(F_SETFD)
1N/A int fd;
1N/A
1N/A#ifndef NOFILE
1N/A#define NOFILE 20
1N/A#endif
1N/A {
1N/A int fd;
1N/A
1N/A for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
1N/A if (fd != pp[1])
1N/A PerlLIO_close(fd);
1N/A }
1N/A#endif
1N/A /* may or may not use the shell */
1N/A do_exec3(cmd, pp[1], did_pipes);
1N/A PerlProc__exit(1);
1N/A }
1N/A#endif /* defined OS2 */
1N/A /*SUPPRESS 560*/
1N/A if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) {
1N/A SvREADONLY_off(GvSV(tmpgv));
1N/A sv_setiv(GvSV(tmpgv), PerlProc_getpid());
1N/A SvREADONLY_on(GvSV(tmpgv));
1N/A }
1N/A#ifdef THREADS_HAVE_PIDS
1N/A PL_ppid = (IV)getppid();
1N/A#endif
1N/A PL_forkprocess = 0;
1N/A hv_clear(PL_pidstatus); /* we have no children */
1N/A return Nullfp;
1N/A#undef THIS
1N/A#undef THAT
1N/A }
1N/A do_execfree(); /* free any memory malloced by child on vfork */
1N/A if (did_pipes)
1N/A PerlLIO_close(pp[1]);
1N/A if (p[that] < p[This]) {
1N/A PerlLIO_dup2(p[This], p[that]);
1N/A PerlLIO_close(p[This]);
1N/A p[This] = p[that];
1N/A }
1N/A else
1N/A PerlLIO_close(p[that]);
1N/A
1N/A LOCK_FDPID_MUTEX;
1N/A sv = *av_fetch(PL_fdpid,p[This],TRUE);
1N/A UNLOCK_FDPID_MUTEX;
1N/A (void)SvUPGRADE(sv,SVt_IV);
1N/A SvIVX(sv) = pid;
1N/A PL_forkprocess = pid;
1N/A if (did_pipes && pid > 0) {
1N/A int errkid;
1N/A int n = 0, n1;
1N/A
1N/A while (n < sizeof(int)) {
1N/A n1 = PerlLIO_read(pp[0],
1N/A (void*)(((char*)&errkid)+n),
1N/A (sizeof(int)) - n);
1N/A if (n1 <= 0)
1N/A break;
1N/A n += n1;
1N/A }
1N/A PerlLIO_close(pp[0]);
1N/A did_pipes = 0;
1N/A if (n) { /* Error */
1N/A int pid2, status;
1N/A PerlLIO_close(p[This]);
1N/A if (n != sizeof(int))
1N/A Perl_croak(aTHX_ "panic: kid popen errno read");
1N/A do {
1N/A pid2 = wait4pid(pid, &status, 0);
1N/A } while (pid2 == -1 && errno == EINTR);
1N/A errno = errkid; /* Propagate errno from kid */
1N/A return Nullfp;
1N/A }
1N/A }
1N/A if (did_pipes)
1N/A PerlLIO_close(pp[0]);
1N/A return PerlIO_fdopen(p[This], mode);
1N/A}
1N/A#else
1N/A#if defined(atarist) || defined(EPOC)
1N/AFILE *popen();
1N/APerlIO *
1N/APerl_my_popen(pTHX_ char *cmd, char *mode)
1N/A{
1N/A PERL_FLUSHALL_FOR_CHILD;
1N/A /* Call system's popen() to get a FILE *, then import it.
1N/A used 0 for 2nd parameter to PerlIO_importFILE;
1N/A apparently not used
1N/A */
1N/A return PerlIO_importFILE(popen(cmd, mode), 0);
1N/A}
1N/A#else
1N/A#if defined(DJGPP)
1N/AFILE *djgpp_popen();
1N/APerlIO *
1N/APerl_my_popen(pTHX_ char *cmd, char *mode)
1N/A{
1N/A PERL_FLUSHALL_FOR_CHILD;
1N/A /* Call system's popen() to get a FILE *, then import it.
1N/A used 0 for 2nd parameter to PerlIO_importFILE;
1N/A apparently not used
1N/A */
1N/A return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
1N/A}
1N/A#endif
1N/A#endif
1N/A
1N/A#endif /* !DOSISH */
1N/A
1N/A/* this is called in parent before the fork() */
1N/Avoid
1N/APerl_atfork_lock(void)
1N/A{
1N/A#if defined(USE_5005THREADS) || defined(USE_ITHREADS)
1N/A /* locks must be held in locking order (if any) */
1N/A# ifdef MYMALLOC
1N/A MUTEX_LOCK(&PL_malloc_mutex);
1N/A# endif
1N/A OP_REFCNT_LOCK;
1N/A#endif
1N/A}
1N/A
1N/A/* this is called in both parent and child after the fork() */
1N/Avoid
1N/APerl_atfork_unlock(void)
1N/A{
1N/A#if defined(USE_5005THREADS) || defined(USE_ITHREADS)
1N/A /* locks must be released in same order as in atfork_lock() */
1N/A# ifdef MYMALLOC
1N/A MUTEX_UNLOCK(&PL_malloc_mutex);
1N/A# endif
1N/A OP_REFCNT_UNLOCK;
1N/A#endif
1N/A}
1N/A
1N/APid_t
1N/APerl_my_fork(void)
1N/A{
1N/A#if defined(HAS_FORK)
1N/A Pid_t pid;
1N/A#if (defined(USE_5005THREADS) || defined(USE_ITHREADS)) && !defined(HAS_PTHREAD_ATFORK)
1N/A atfork_lock();
1N/A pid = fork();
1N/A atfork_unlock();
1N/A#else
1N/A /* atfork_lock() and atfork_unlock() are installed as pthread_atfork()
1N/A * handlers elsewhere in the code */
1N/A pid = fork();
1N/A#endif
1N/A return pid;
1N/A#else
1N/A /* this "canna happen" since nothing should be calling here if !HAS_FORK */
1N/A Perl_croak_nocontext("fork() not available");
1N/A return 0;
1N/A#endif /* HAS_FORK */
1N/A}
1N/A
1N/A#ifdef DUMP_FDS
1N/Avoid
1N/APerl_dump_fds(pTHX_ char *s)
1N/A{
1N/A int fd;
1N/A Stat_t tmpstatbuf;
1N/A
1N/A PerlIO_printf(Perl_debug_log,"%s", s);
1N/A for (fd = 0; fd < 32; fd++) {
1N/A if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0)
1N/A PerlIO_printf(Perl_debug_log," %d",fd);
1N/A }
1N/A PerlIO_printf(Perl_debug_log,"\n");
1N/A}
1N/A#endif /* DUMP_FDS */
1N/A
1N/A#ifndef HAS_DUP2
1N/Aint
1N/Adup2(int oldfd, int newfd)
1N/A{
1N/A#if defined(HAS_FCNTL) && defined(F_DUPFD)
1N/A if (oldfd == newfd)
1N/A return oldfd;
1N/A PerlLIO_close(newfd);
1N/A return fcntl(oldfd, F_DUPFD, newfd);
1N/A#else
1N/A#define DUP2_MAX_FDS 256
1N/A int fdtmp[DUP2_MAX_FDS];
1N/A I32 fdx = 0;
1N/A int fd;
1N/A
1N/A if (oldfd == newfd)
1N/A return oldfd;
1N/A PerlLIO_close(newfd);
1N/A /* good enough for low fd's... */
1N/A while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
1N/A if (fdx >= DUP2_MAX_FDS) {
1N/A PerlLIO_close(fd);
1N/A fd = -1;
1N/A break;
1N/A }
1N/A fdtmp[fdx++] = fd;
1N/A }
1N/A while (fdx > 0)
1N/A PerlLIO_close(fdtmp[--fdx]);
1N/A return fd;
1N/A#endif
1N/A}
1N/A#endif
1N/A
1N/A#ifndef PERL_MICRO
1N/A#ifdef HAS_SIGACTION
1N/A
1N/A#ifdef MACOS_TRADITIONAL
1N/A/* We don't want restart behavior on MacOS */
1N/A#undef SA_RESTART
1N/A#endif
1N/A
1N/ASighandler_t
1N/APerl_rsignal(pTHX_ int signo, Sighandler_t handler)
1N/A{
1N/A struct sigaction act, oact;
1N/A
1N/A#ifdef USE_ITHREADS
1N/A /* only "parent" interpreter can diddle signals */
1N/A if (PL_curinterp != aTHX)
1N/A return SIG_ERR;
1N/A#endif
1N/A
1N/A act.sa_handler = handler;
1N/A sigemptyset(&act.sa_mask);
1N/A act.sa_flags = 0;
1N/A#ifdef SA_RESTART
1N/A if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
1N/A act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
1N/A#endif
1N/A#if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
1N/A if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN)
1N/A act.sa_flags |= SA_NOCLDWAIT;
1N/A#endif
1N/A if (sigaction(signo, &act, &oact) == -1)
1N/A return SIG_ERR;
1N/A else
1N/A return oact.sa_handler;
1N/A}
1N/A
1N/ASighandler_t
1N/APerl_rsignal_state(pTHX_ int signo)
1N/A{
1N/A struct sigaction oact;
1N/A
1N/A if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
1N/A return SIG_ERR;
1N/A else
1N/A return oact.sa_handler;
1N/A}
1N/A
1N/Aint
1N/APerl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
1N/A{
1N/A struct sigaction act;
1N/A
1N/A#ifdef USE_ITHREADS
1N/A /* only "parent" interpreter can diddle signals */
1N/A if (PL_curinterp != aTHX)
1N/A return -1;
1N/A#endif
1N/A
1N/A act.sa_handler = handler;
1N/A sigemptyset(&act.sa_mask);
1N/A act.sa_flags = 0;
1N/A#ifdef SA_RESTART
1N/A if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
1N/A act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
1N/A#endif
1N/A#if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
1N/A if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN)
1N/A act.sa_flags |= SA_NOCLDWAIT;
1N/A#endif
1N/A return sigaction(signo, &act, save);
1N/A}
1N/A
1N/Aint
1N/APerl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
1N/A{
1N/A#ifdef USE_ITHREADS
1N/A /* only "parent" interpreter can diddle signals */
1N/A if (PL_curinterp != aTHX)
1N/A return -1;
1N/A#endif
1N/A
1N/A return sigaction(signo, save, (struct sigaction *)NULL);
1N/A}
1N/A
1N/A#else /* !HAS_SIGACTION */
1N/A
1N/ASighandler_t
1N/APerl_rsignal(pTHX_ int signo, Sighandler_t handler)
1N/A{
1N/A#if defined(USE_ITHREADS) && !defined(WIN32)
1N/A /* only "parent" interpreter can diddle signals */
1N/A if (PL_curinterp != aTHX)
1N/A return SIG_ERR;
1N/A#endif
1N/A
1N/A return PerlProc_signal(signo, handler);
1N/A}
1N/A
1N/Astatic int sig_trapped; /* XXX signals are process-wide anyway, so we
1N/A ignore the implications of this for threading */
1N/A
1N/Astatic
1N/ASignal_t
1N/Asig_trap(int signo)
1N/A{
1N/A sig_trapped++;
1N/A}
1N/A
1N/ASighandler_t
1N/APerl_rsignal_state(pTHX_ int signo)
1N/A{
1N/A Sighandler_t oldsig;
1N/A
1N/A#if defined(USE_ITHREADS) && !defined(WIN32)
1N/A /* only "parent" interpreter can diddle signals */
1N/A if (PL_curinterp != aTHX)
1N/A return SIG_ERR;
1N/A#endif
1N/A
1N/A sig_trapped = 0;
1N/A oldsig = PerlProc_signal(signo, sig_trap);
1N/A PerlProc_signal(signo, oldsig);
1N/A if (sig_trapped)
1N/A PerlProc_kill(PerlProc_getpid(), signo);
1N/A return oldsig;
1N/A}
1N/A
1N/Aint
1N/APerl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
1N/A{
1N/A#if defined(USE_ITHREADS) && !defined(WIN32)
1N/A /* only "parent" interpreter can diddle signals */
1N/A if (PL_curinterp != aTHX)
1N/A return -1;
1N/A#endif
1N/A *save = PerlProc_signal(signo, handler);
1N/A return (*save == SIG_ERR) ? -1 : 0;
1N/A}
1N/A
1N/Aint
1N/APerl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
1N/A{
1N/A#if defined(USE_ITHREADS) && !defined(WIN32)
1N/A /* only "parent" interpreter can diddle signals */
1N/A if (PL_curinterp != aTHX)
1N/A return -1;
1N/A#endif
1N/A return (PerlProc_signal(signo, *save) == SIG_ERR) ? -1 : 0;
1N/A}
1N/A
1N/A#endif /* !HAS_SIGACTION */
1N/A#endif /* !PERL_MICRO */
1N/A
1N/A /* VMS' my_pclose() is in VMS.c; same with OS/2 */
1N/A#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
1N/AI32
1N/APerl_my_pclose(pTHX_ PerlIO *ptr)
1N/A{
1N/A Sigsave_t hstat, istat, qstat;
1N/A int status;
1N/A SV **svp;
1N/A Pid_t pid;
1N/A Pid_t pid2;
1N/A bool close_failed;
1N/A int saved_errno = 0;
1N/A#ifdef VMS
1N/A int saved_vaxc_errno;
1N/A#endif
1N/A#ifdef WIN32
1N/A int saved_win32_errno;
1N/A#endif
1N/A
1N/A LOCK_FDPID_MUTEX;
1N/A svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE);
1N/A UNLOCK_FDPID_MUTEX;
1N/A pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
1N/A SvREFCNT_dec(*svp);
1N/A *svp = &PL_sv_undef;
1N/A#ifdef OS2
1N/A if (pid == -1) { /* Opened by popen. */
1N/A return my_syspclose(ptr);
1N/A }
1N/A#endif
1N/A if ((close_failed = (PerlIO_close(ptr) == EOF))) {
1N/A saved_errno = errno;
1N/A#ifdef VMS
1N/A saved_vaxc_errno = vaxc$errno;
1N/A#endif
1N/A#ifdef WIN32
1N/A saved_win32_errno = GetLastError();
1N/A#endif
1N/A }
1N/A#ifdef UTS
1N/A if(PerlProc_kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */
1N/A#endif
1N/A#ifndef PERL_MICRO
1N/A rsignal_save(SIGHUP, SIG_IGN, &hstat);
1N/A rsignal_save(SIGINT, SIG_IGN, &istat);
1N/A rsignal_save(SIGQUIT, SIG_IGN, &qstat);
1N/A#endif
1N/A do {
1N/A pid2 = wait4pid(pid, &status, 0);
1N/A } while (pid2 == -1 && errno == EINTR);
1N/A#ifndef PERL_MICRO
1N/A rsignal_restore(SIGHUP, &hstat);
1N/A rsignal_restore(SIGINT, &istat);
1N/A rsignal_restore(SIGQUIT, &qstat);
1N/A#endif
1N/A if (close_failed) {
1N/A SETERRNO(saved_errno, saved_vaxc_errno);
1N/A return -1;
1N/A }
1N/A return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status));
1N/A}
1N/A#endif /* !DOSISH */
1N/A
1N/A#if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(MACOS_TRADITIONAL)
1N/AI32
1N/APerl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
1N/A{
1N/A I32 result;
1N/A if (!pid)
1N/A return -1;
1N/A#if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME)
1N/A {
1N/A SV *sv;
1N/A SV** svp;
1N/A char spid[TYPE_CHARS(int)];
1N/A
1N/A if (pid > 0) {
1N/A sprintf(spid, "%"IVdf, (IV)pid);
1N/A svp = hv_fetch(PL_pidstatus,spid,strlen(spid),FALSE);
1N/A if (svp && *svp != &PL_sv_undef) {
1N/A *statusp = SvIVX(*svp);
1N/A (void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD);
1N/A return pid;
1N/A }
1N/A }
1N/A else {
1N/A HE *entry;
1N/A
1N/A hv_iterinit(PL_pidstatus);
1N/A if ((entry = hv_iternext(PL_pidstatus))) {
1N/A SV *sv;
1N/A char spid[TYPE_CHARS(int)];
1N/A
1N/A pid = atoi(hv_iterkey(entry,(I32*)statusp));
1N/A sv = hv_iterval(PL_pidstatus,entry);
1N/A *statusp = SvIVX(sv);
1N/A sprintf(spid, "%"IVdf, (IV)pid);
1N/A (void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD);
1N/A return pid;
1N/A }
1N/A }
1N/A }
1N/A#endif
1N/A#ifdef HAS_WAITPID
1N/A# ifdef HAS_WAITPID_RUNTIME
1N/A if (!HAS_WAITPID_RUNTIME)
1N/A goto hard_way;
1N/A# endif
1N/A result = PerlProc_waitpid(pid,statusp,flags);
1N/A goto finish;
1N/A#endif
1N/A#if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
1N/A result = wait4((pid==-1)?0:pid,statusp,flags,Null(struct rusage *));
1N/A goto finish;
1N/A#endif
1N/A#if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME)
1N/A hard_way:
1N/A {
1N/A if (flags)
1N/A Perl_croak(aTHX_ "Can't do waitpid with flags");
1N/A else {
1N/A while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
1N/A pidgone(result,*statusp);
1N/A if (result < 0)
1N/A *statusp = -1;
1N/A }
1N/A }
1N/A#endif
1N/A finish:
1N/A if (result < 0 && errno == EINTR) {
1N/A PERL_ASYNC_CHECK();
1N/A }
1N/A return result;
1N/A}
1N/A#endif /* !DOSISH || OS2 || WIN32 || NETWARE */
1N/A
1N/Avoid
1N/A/*SUPPRESS 590*/
1N/APerl_pidgone(pTHX_ Pid_t pid, int status)
1N/A{
1N/A register SV *sv;
1N/A char spid[TYPE_CHARS(int)];
1N/A
1N/A sprintf(spid, "%"IVdf, (IV)pid);
1N/A sv = *hv_fetch(PL_pidstatus,spid,strlen(spid),TRUE);
1N/A (void)SvUPGRADE(sv,SVt_IV);
1N/A SvIVX(sv) = status;
1N/A return;
1N/A}
1N/A
1N/A#if defined(atarist) || defined(OS2) || defined(EPOC)
1N/Aint pclose();
1N/A#ifdef HAS_FORK
1N/Aint /* Cannot prototype with I32
1N/A in os2ish.h. */
1N/Amy_syspclose(PerlIO *ptr)
1N/A#else
1N/AI32
1N/APerl_my_pclose(pTHX_ PerlIO *ptr)
1N/A#endif
1N/A{
1N/A /* Needs work for PerlIO ! */
1N/A FILE *f = PerlIO_findFILE(ptr);
1N/A I32 result = pclose(f);
1N/A PerlIO_releaseFILE(ptr,f);
1N/A return result;
1N/A}
1N/A#endif
1N/A
1N/A#if defined(DJGPP)
1N/Aint djgpp_pclose();
1N/AI32
1N/APerl_my_pclose(pTHX_ PerlIO *ptr)
1N/A{
1N/A /* Needs work for PerlIO ! */
1N/A FILE *f = PerlIO_findFILE(ptr);
1N/A I32 result = djgpp_pclose(f);
1N/A result = (result << 8) & 0xff00;
1N/A PerlIO_releaseFILE(ptr,f);
1N/A return result;
1N/A}
1N/A#endif
1N/A
1N/Avoid
1N/APerl_repeatcpy(pTHX_ register char *to, register const char *from, I32 len, register I32 count)
1N/A{
1N/A register I32 todo;
1N/A register const char *frombase = from;
1N/A
1N/A if (len == 1) {
1N/A register const char c = *from;
1N/A while (count-- > 0)
1N/A *to++ = c;
1N/A return;
1N/A }
1N/A while (count-- > 0) {
1N/A for (todo = len; todo > 0; todo--) {
1N/A *to++ = *from++;
1N/A }
1N/A from = frombase;
1N/A }
1N/A}
1N/A
1N/A#ifndef HAS_RENAME
1N/AI32
1N/APerl_same_dirent(pTHX_ char *a, char *b)
1N/A{
1N/A char *fa = strrchr(a,'/');
1N/A char *fb = strrchr(b,'/');
1N/A Stat_t tmpstatbuf1;
1N/A Stat_t tmpstatbuf2;
1N/A SV *tmpsv = sv_newmortal();
1N/A
1N/A if (fa)
1N/A fa++;
1N/A else
1N/A fa = a;
1N/A if (fb)
1N/A fb++;
1N/A else
1N/A fb = b;
1N/A if (strNE(a,b))
1N/A return FALSE;
1N/A if (fa == a)
1N/A sv_setpv(tmpsv, ".");
1N/A else
1N/A sv_setpvn(tmpsv, a, fa - a);
1N/A if (PerlLIO_stat(SvPVX(tmpsv), &tmpstatbuf1) < 0)
1N/A return FALSE;
1N/A if (fb == b)
1N/A sv_setpv(tmpsv, ".");
1N/A else
1N/A sv_setpvn(tmpsv, b, fb - b);
1N/A if (PerlLIO_stat(SvPVX(tmpsv), &tmpstatbuf2) < 0)
1N/A return FALSE;
1N/A return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
1N/A tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
1N/A}
1N/A#endif /* !HAS_RENAME */
1N/A
1N/Achar*
1N/APerl_find_script(pTHX_ char *scriptname, bool dosearch, char **search_ext, I32 flags)
1N/A{
1N/A char *xfound = Nullch;
1N/A char *xfailed = Nullch;
1N/A char tmpbuf[MAXPATHLEN];
1N/A register char *s;
1N/A I32 len = 0;
1N/A int retval;
1N/A#if defined(DOSISH) && !defined(OS2) && !defined(atarist)
1N/A# define SEARCH_EXTS ".bat", ".cmd", NULL
1N/A# define MAX_EXT_LEN 4
1N/A#endif
1N/A#ifdef OS2
1N/A# define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
1N/A# define MAX_EXT_LEN 4
1N/A#endif
1N/A#ifdef VMS
1N/A# define SEARCH_EXTS ".pl", ".com", NULL
1N/A# define MAX_EXT_LEN 4
1N/A#endif
1N/A /* additional extensions to try in each dir if scriptname not found */
1N/A#ifdef SEARCH_EXTS
1N/A char *exts[] = { SEARCH_EXTS };
1N/A char **ext = search_ext ? search_ext : exts;
1N/A int extidx = 0, i = 0;
1N/A char *curext = Nullch;
1N/A#else
1N/A# define MAX_EXT_LEN 0
1N/A#endif
1N/A
1N/A /*
1N/A * If dosearch is true and if scriptname does not contain path
1N/A * delimiters, search the PATH for scriptname.
1N/A *
1N/A * If SEARCH_EXTS is also defined, will look for each
1N/A * scriptname{SEARCH_EXTS} whenever scriptname is not found
1N/A * while searching the PATH.
1N/A *
1N/A * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
1N/A * proceeds as follows:
1N/A * If DOSISH or VMSISH:
1N/A * + look for ./scriptname{,.foo,.bar}
1N/A * + search the PATH for scriptname{,.foo,.bar}
1N/A *
1N/A * If !DOSISH:
1N/A * + look *only* in the PATH for scriptname{,.foo,.bar} (note
1N/A * this will not look in '.' if it's not in the PATH)
1N/A */
1N/A tmpbuf[0] = '\0';
1N/A
1N/A#ifdef VMS
1N/A# ifdef ALWAYS_DEFTYPES
1N/A len = strlen(scriptname);
1N/A if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
1N/A int hasdir, idx = 0, deftypes = 1;
1N/A bool seen_dot = 1;
1N/A
1N/A hasdir = !dosearch || (strpbrk(scriptname,":[</") != Nullch) ;
1N/A# else
1N/A if (dosearch) {
1N/A int hasdir, idx = 0, deftypes = 1;
1N/A bool seen_dot = 1;
1N/A
1N/A hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
1N/A# endif
1N/A /* The first time through, just add SEARCH_EXTS to whatever we
1N/A * already have, so we can check for default file types. */
1N/A while (deftypes ||
1N/A (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
1N/A {
1N/A if (deftypes) {
1N/A deftypes = 0;
1N/A *tmpbuf = '\0';
1N/A }
1N/A if ((strlen(tmpbuf) + strlen(scriptname)
1N/A + MAX_EXT_LEN) >= sizeof tmpbuf)
1N/A continue; /* don't search dir with too-long name */
1N/A strcat(tmpbuf, scriptname);
1N/A#else /* !VMS */
1N/A
1N/A#ifdef DOSISH
1N/A if (strEQ(scriptname, "-"))
1N/A dosearch = 0;
1N/A if (dosearch) { /* Look in '.' first. */
1N/A char *cur = scriptname;
1N/A#ifdef SEARCH_EXTS
1N/A if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
1N/A while (ext[i])
1N/A if (strEQ(ext[i++],curext)) {
1N/A extidx = -1; /* already has an ext */
1N/A break;
1N/A }
1N/A do {
1N/A#endif
1N/A DEBUG_p(PerlIO_printf(Perl_debug_log,
1N/A "Looking for %s\n",cur));
1N/A if (PerlLIO_stat(cur,&PL_statbuf) >= 0
1N/A && !S_ISDIR(PL_statbuf.st_mode)) {
1N/A dosearch = 0;
1N/A scriptname = cur;
1N/A#ifdef SEARCH_EXTS
1N/A break;
1N/A#endif
1N/A }
1N/A#ifdef SEARCH_EXTS
1N/A if (cur == scriptname) {
1N/A len = strlen(scriptname);
1N/A if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
1N/A break;
1N/A cur = strcpy(tmpbuf, scriptname);
1N/A }
1N/A } while (extidx >= 0 && ext[extidx] /* try an extension? */
1N/A && strcpy(tmpbuf+len, ext[extidx++]));
1N/A#endif
1N/A }
1N/A#endif
1N/A
1N/A#ifdef MACOS_TRADITIONAL
1N/A if (dosearch && !strchr(scriptname, ':') &&
1N/A (s = PerlEnv_getenv("Commands")))
1N/A#else
1N/A if (dosearch && !strchr(scriptname, '/')
1N/A#ifdef DOSISH
1N/A && !strchr(scriptname, '\\')
1N/A#endif
1N/A && (s = PerlEnv_getenv("PATH")))
1N/A#endif
1N/A {
1N/A bool seen_dot = 0;
1N/A
1N/A PL_bufend = s + strlen(s);
1N/A while (s < PL_bufend) {
1N/A#ifdef MACOS_TRADITIONAL
1N/A s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
1N/A ',',
1N/A &len);
1N/A#else
1N/A#if defined(atarist) || defined(DOSISH)
1N/A for (len = 0; *s
1N/A# ifdef atarist
1N/A && *s != ','
1N/A# endif
1N/A && *s != ';'; len++, s++) {
1N/A if (len < sizeof tmpbuf)
1N/A tmpbuf[len] = *s;
1N/A }
1N/A if (len < sizeof tmpbuf)
1N/A tmpbuf[len] = '\0';
1N/A#else /* ! (atarist || DOSISH) */
1N/A s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
1N/A ':',
1N/A &len);
1N/A#endif /* ! (atarist || DOSISH) */
1N/A#endif /* MACOS_TRADITIONAL */
1N/A if (s < PL_bufend)
1N/A s++;
1N/A if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
1N/A continue; /* don't search dir with too-long name */
1N/A#ifdef MACOS_TRADITIONAL
1N/A if (len && tmpbuf[len - 1] != ':')
1N/A tmpbuf[len++] = ':';
1N/A#else
1N/A if (len
1N/A#if defined(atarist) || defined(__MINT__) || defined(DOSISH)
1N/A && tmpbuf[len - 1] != '/'
1N/A && tmpbuf[len - 1] != '\\'
1N/A#endif
1N/A )
1N/A tmpbuf[len++] = '/';
1N/A if (len == 2 && tmpbuf[0] == '.')
1N/A seen_dot = 1;
1N/A#endif
1N/A (void)strcpy(tmpbuf + len, scriptname);
1N/A#endif /* !VMS */
1N/A
1N/A#ifdef SEARCH_EXTS
1N/A len = strlen(tmpbuf);
1N/A if (extidx > 0) /* reset after previous loop */
1N/A extidx = 0;
1N/A do {
1N/A#endif
1N/A DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
1N/A retval = PerlLIO_stat(tmpbuf,&PL_statbuf);
1N/A if (S_ISDIR(PL_statbuf.st_mode)) {
1N/A retval = -1;
1N/A }
1N/A#ifdef SEARCH_EXTS
1N/A } while ( retval < 0 /* not there */
1N/A && extidx>=0 && ext[extidx] /* try an extension? */
1N/A && strcpy(tmpbuf+len, ext[extidx++])
1N/A );
1N/A#endif
1N/A if (retval < 0)
1N/A continue;
1N/A if (S_ISREG(PL_statbuf.st_mode)
1N/A && cando(S_IRUSR,TRUE,&PL_statbuf)
1N/A#if !defined(DOSISH) && !defined(MACOS_TRADITIONAL)
1N/A && cando(S_IXUSR,TRUE,&PL_statbuf)
1N/A#endif
1N/A )
1N/A {
1N/A xfound = tmpbuf; /* bingo! */
1N/A break;
1N/A }
1N/A if (!xfailed)
1N/A xfailed = savepv(tmpbuf);
1N/A }
1N/A#ifndef DOSISH
1N/A if (!xfound && !seen_dot && !xfailed &&
1N/A (PerlLIO_stat(scriptname,&PL_statbuf) < 0
1N/A || S_ISDIR(PL_statbuf.st_mode)))
1N/A#endif
1N/A seen_dot = 1; /* Disable message. */
1N/A if (!xfound) {
1N/A if (flags & 1) { /* do or die? */
1N/A Perl_croak(aTHX_ "Can't %s %s%s%s",
1N/A (xfailed ? "execute" : "find"),
1N/A (xfailed ? xfailed : scriptname),
1N/A (xfailed ? "" : " on PATH"),
1N/A (xfailed || seen_dot) ? "" : ", '.' not in PATH");
1N/A }
1N/A scriptname = Nullch;
1N/A }
1N/A if (xfailed)
1N/A Safefree(xfailed);
1N/A scriptname = xfound;
1N/A }
1N/A return (scriptname ? savepv(scriptname) : Nullch);
1N/A}
1N/A
1N/A#ifndef PERL_GET_CONTEXT_DEFINED
1N/A
1N/Avoid *
1N/APerl_get_context(void)
1N/A{
1N/A#if defined(USE_5005THREADS) || defined(USE_ITHREADS)
1N/A# ifdef OLD_PTHREADS_API
1N/A pthread_addr_t t;
1N/A if (pthread_getspecific(PL_thr_key, &t))
1N/A Perl_croak_nocontext("panic: pthread_getspecific");
1N/A return (void*)t;
1N/A# else
1N/A# ifdef I_MACH_CTHREADS
1N/A return (void*)cthread_data(cthread_self());
1N/A# else
1N/A return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
1N/A# endif
1N/A# endif
1N/A#else
1N/A return (void*)NULL;
1N/A#endif
1N/A}
1N/A
1N/Avoid
1N/APerl_set_context(void *t)
1N/A{
1N/A#if defined(USE_5005THREADS) || defined(USE_ITHREADS)
1N/A# ifdef I_MACH_CTHREADS
1N/A cthread_set_data(cthread_self(), t);
1N/A# else
1N/A if (pthread_setspecific(PL_thr_key, t))
1N/A Perl_croak_nocontext("panic: pthread_setspecific");
1N/A# endif
1N/A#endif
1N/A}
1N/A
1N/A#endif /* !PERL_GET_CONTEXT_DEFINED */
1N/A
1N/A#ifdef USE_5005THREADS
1N/A
1N/A#ifdef FAKE_THREADS
1N/A/* Very simplistic scheduler for now */
1N/Avoid
1N/Aschedule(void)
1N/A{
1N/A thr = thr->i.next_run;
1N/A}
1N/A
1N/Avoid
1N/APerl_cond_init(pTHX_ perl_cond *cp)
1N/A{
1N/A *cp = 0;
1N/A}
1N/A
1N/Avoid
1N/APerl_cond_signal(pTHX_ perl_cond *cp)
1N/A{
1N/A perl_os_thread t;
1N/A perl_cond cond = *cp;
1N/A
1N/A if (!cond)
1N/A return;
1N/A t = cond->thread;
1N/A /* Insert t in the runnable queue just ahead of us */
1N/A t->i.next_run = thr->i.next_run;
1N/A thr->i.next_run->i.prev_run = t;
1N/A t->i.prev_run = thr;
1N/A thr->i.next_run = t;
1N/A thr->i.wait_queue = 0;
1N/A /* Remove from the wait queue */
1N/A *cp = cond->next;
1N/A Safefree(cond);
1N/A}
1N/A
1N/Avoid
1N/APerl_cond_broadcast(pTHX_ perl_cond *cp)
1N/A{
1N/A perl_os_thread t;
1N/A perl_cond cond, cond_next;
1N/A
1N/A for (cond = *cp; cond; cond = cond_next) {
1N/A t = cond->thread;
1N/A /* Insert t in the runnable queue just ahead of us */
1N/A t->i.next_run = thr->i.next_run;
1N/A thr->i.next_run->i.prev_run = t;
1N/A t->i.prev_run = thr;
1N/A thr->i.next_run = t;
1N/A thr->i.wait_queue = 0;
1N/A /* Remove from the wait queue */
1N/A cond_next = cond->next;
1N/A Safefree(cond);
1N/A }
1N/A *cp = 0;
1N/A}
1N/A
1N/Avoid
1N/APerl_cond_wait(pTHX_ perl_cond *cp)
1N/A{
1N/A perl_cond cond;
1N/A
1N/A if (thr->i.next_run == thr)
1N/A Perl_croak(aTHX_ "panic: perl_cond_wait called by last runnable thread");
1N/A
1N/A New(666, cond, 1, struct perl_wait_queue);
1N/A cond->thread = thr;
1N/A cond->next = *cp;
1N/A *cp = cond;
1N/A thr->i.wait_queue = cond;
1N/A /* Remove ourselves from runnable queue */
1N/A thr->i.next_run->i.prev_run = thr->i.prev_run;
1N/A thr->i.prev_run->i.next_run = thr->i.next_run;
1N/A}
1N/A#endif /* FAKE_THREADS */
1N/A
1N/AMAGIC *
1N/APerl_condpair_magic(pTHX_ SV *sv)
1N/A{
1N/A MAGIC *mg;
1N/A
1N/A (void)SvUPGRADE(sv, SVt_PVMG);
1N/A mg = mg_find(sv, PERL_MAGIC_mutex);
1N/A if (!mg) {
1N/A condpair_t *cp;
1N/A
1N/A New(53, cp, 1, condpair_t);
1N/A MUTEX_INIT(&cp->mutex);
1N/A COND_INIT(&cp->owner_cond);
1N/A COND_INIT(&cp->cond);
1N/A cp->owner = 0;
1N/A LOCK_CRED_MUTEX; /* XXX need separate mutex? */
1N/A mg = mg_find(sv, PERL_MAGIC_mutex);
1N/A if (mg) {
1N/A /* someone else beat us to initialising it */
1N/A UNLOCK_CRED_MUTEX; /* XXX need separate mutex? */
1N/A MUTEX_DESTROY(&cp->mutex);
1N/A COND_DESTROY(&cp->owner_cond);
1N/A COND_DESTROY(&cp->cond);
1N/A Safefree(cp);
1N/A }
1N/A else {
1N/A sv_magic(sv, Nullsv, PERL_MAGIC_mutex, 0, 0);
1N/A mg = SvMAGIC(sv);
1N/A mg->mg_ptr = (char *)cp;
1N/A mg->mg_len = sizeof(cp);
1N/A UNLOCK_CRED_MUTEX; /* XXX need separate mutex? */
1N/A DEBUG_S(WITH_THR(PerlIO_printf(Perl_debug_log,
1N/A "%p: condpair_magic %p\n", thr, sv)));
1N/A }
1N/A }
1N/A return mg;
1N/A}
1N/A
1N/ASV *
1N/APerl_sv_lock(pTHX_ SV *osv)
1N/A{
1N/A MAGIC *mg;
1N/A SV *sv = osv;
1N/A
1N/A LOCK_SV_LOCK_MUTEX;
1N/A if (SvROK(sv)) {
1N/A sv = SvRV(sv);
1N/A }
1N/A
1N/A mg = condpair_magic(sv);
1N/A MUTEX_LOCK(MgMUTEXP(mg));
1N/A if (MgOWNER(mg) == thr)
1N/A MUTEX_UNLOCK(MgMUTEXP(mg));
1N/A else {
1N/A while (MgOWNER(mg))
1N/A COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
1N/A MgOWNER(mg) = thr;
1N/A DEBUG_S(PerlIO_printf(Perl_debug_log,
1N/A "0x%"UVxf": Perl_lock lock 0x%"UVxf"\n",
1N/A PTR2UV(thr), PTR2UV(sv)));
1N/A MUTEX_UNLOCK(MgMUTEXP(mg));
1N/A SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv);
1N/A }
1N/A UNLOCK_SV_LOCK_MUTEX;
1N/A return sv;
1N/A}
1N/A
1N/A/*
1N/A * Make a new perl thread structure using t as a prototype. Some of the
1N/A * fields for the new thread are copied from the prototype thread, t,
1N/A * so t should not be running in perl at the time this function is
1N/A * called. The use by ext/Thread/Thread.xs in core perl (where t is the
1N/A * thread calling new_struct_thread) clearly satisfies this constraint.
1N/A */
1N/Astruct perl_thread *
1N/APerl_new_struct_thread(pTHX_ struct perl_thread *t)
1N/A{
1N/A#if !defined(PERL_IMPLICIT_CONTEXT)
1N/A struct perl_thread *thr;
1N/A#endif
1N/A SV *sv;
1N/A SV **svp;
1N/A I32 i;
1N/A
1N/A sv = newSVpvn("", 0);
1N/A SvGROW(sv, sizeof(struct perl_thread) + 1);
1N/A SvCUR_set(sv, sizeof(struct perl_thread));
1N/A thr = (Thread) SvPVX(sv);
1N/A#ifdef DEBUGGING
1N/A Poison(thr, 1, struct perl_thread);
1N/A PL_markstack = 0;
1N/A PL_scopestack = 0;
1N/A PL_savestack = 0;
1N/A PL_retstack = 0;
1N/A PL_dirty = 0;
1N/A PL_localizing = 0;
1N/A Zero(&PL_hv_fetch_ent_mh, 1, HE);
1N/A PL_efloatbuf = (char*)NULL;
1N/A PL_efloatsize = 0;
1N/A#else
1N/A Zero(thr, 1, struct perl_thread);
1N/A#endif
1N/A
1N/A thr->oursv = sv;
1N/A init_stacks();
1N/A
1N/A PL_curcop = &PL_compiling;
1N/A thr->interp = t->interp;
1N/A thr->cvcache = newHV();
1N/A thr->threadsv = newAV();
1N/A thr->specific = newAV();
1N/A thr->errsv = newSVpvn("", 0);
1N/A thr->flags = THRf_R_JOINABLE;
1N/A thr->thr_done = 0;
1N/A MUTEX_INIT(&thr->mutex);
1N/A
1N/A JMPENV_BOOTSTRAP;
1N/A
1N/A PL_in_eval = EVAL_NULL; /* ~(EVAL_INEVAL|EVAL_WARNONLY|EVAL_KEEPERR|EVAL_INREQUIRE) */
1N/A PL_restartop = 0;
1N/A
1N/A PL_statname = NEWSV(66,0);
1N/A PL_errors = newSVpvn("", 0);
1N/A PL_maxscream = -1;
1N/A PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
1N/A PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
1N/A PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
1N/A PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
1N/A PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
1N/A PL_regindent = 0;
1N/A PL_reginterp_cnt = 0;
1N/A PL_lastscream = Nullsv;
1N/A PL_screamfirst = 0;
1N/A PL_screamnext = 0;
1N/A PL_reg_start_tmp = 0;
1N/A PL_reg_start_tmpl = 0;
1N/A PL_reg_poscache = Nullch;
1N/A
1N/A PL_peepp = MEMBER_TO_FPTR(Perl_peep);
1N/A
1N/A /* parent thread's data needs to be locked while we make copy */
1N/A MUTEX_LOCK(&t->mutex);
1N/A
1N/A#ifdef PERL_FLEXIBLE_EXCEPTIONS
1N/A PL_protect = t->Tprotect;
1N/A#endif
1N/A
1N/A PL_curcop = t->Tcurcop; /* XXX As good a guess as any? */
1N/A PL_defstash = t->Tdefstash; /* XXX maybe these should */
1N/A PL_curstash = t->Tcurstash; /* always be set to main? */
1N/A
1N/A PL_tainted = t->Ttainted;
1N/A PL_curpm = t->Tcurpm; /* XXX No PMOP ref count */
1N/A PL_rs = newSVsv(t->Trs);
1N/A PL_last_in_gv = Nullgv;
1N/A PL_ofs_sv = t->Tofs_sv ? SvREFCNT_inc(PL_ofs_sv) : Nullsv;
1N/A PL_defoutgv = (GV*)SvREFCNT_inc(t->Tdefoutgv);
1N/A PL_chopset = t->Tchopset;
1N/A PL_bodytarget = newSVsv(t->Tbodytarget);
1N/A PL_toptarget = newSVsv(t->Ttoptarget);
1N/A if (t->Tformtarget == t->Ttoptarget)
1N/A PL_formtarget = PL_toptarget;
1N/A else
1N/A PL_formtarget = PL_bodytarget;
1N/A PL_watchaddr = 0; /* XXX */
1N/A PL_watchok = 0; /* XXX */
1N/A PL_comppad = 0;
1N/A PL_curpad = 0;
1N/A
1N/A /* Initialise all per-thread SVs that the template thread used */
1N/A svp = AvARRAY(t->threadsv);
1N/A for (i = 0; i <= AvFILLp(t->threadsv); i++, svp++) {
1N/A if (*svp && *svp != &PL_sv_undef) {
1N/A SV *sv = newSVsv(*svp);
1N/A av_store(thr->threadsv, i, sv);
1N/A sv_magic(sv, 0, PERL_MAGIC_sv, &PL_threadsv_names[i], 1);
1N/A DEBUG_S(PerlIO_printf(Perl_debug_log,
1N/A "new_struct_thread: copied threadsv %"IVdf" %p->%p\n",
1N/A (IV)i, t, thr));
1N/A }
1N/A }
1N/A thr->threadsvp = AvARRAY(thr->threadsv);
1N/A
1N/A MUTEX_LOCK(&PL_threads_mutex);
1N/A PL_nthreads++;
1N/A thr->tid = ++PL_threadnum;
1N/A thr->next = t->next;
1N/A thr->prev = t;
1N/A t->next = thr;
1N/A thr->next->prev = thr;
1N/A MUTEX_UNLOCK(&PL_threads_mutex);
1N/A
1N/A /* done copying parent's state */
1N/A MUTEX_UNLOCK(&t->mutex);
1N/A
1N/A#ifdef HAVE_THREAD_INTERN
1N/A Perl_init_thread_intern(thr);
1N/A#endif /* HAVE_THREAD_INTERN */
1N/A return thr;
1N/A}
1N/A#endif /* USE_5005THREADS */
1N/A
1N/A#ifdef PERL_GLOBAL_STRUCT
1N/Astruct perl_vars *
1N/APerl_GetVars(pTHX)
1N/A{
1N/A return &PL_Vars;
1N/A}
1N/A#endif
1N/A
1N/Achar **
1N/APerl_get_op_names(pTHX)
1N/A{
1N/A return PL_op_name;
1N/A}
1N/A
1N/Achar **
1N/APerl_get_op_descs(pTHX)
1N/A{
1N/A return PL_op_desc;
1N/A}
1N/A
1N/Achar *
1N/APerl_get_no_modify(pTHX)
1N/A{
1N/A return (char*)PL_no_modify;
1N/A}
1N/A
1N/AU32 *
1N/APerl_get_opargs(pTHX)
1N/A{
1N/A return PL_opargs;
1N/A}
1N/A
1N/APPADDR_t*
1N/APerl_get_ppaddr(pTHX)
1N/A{
1N/A return (PPADDR_t*)PL_ppaddr;
1N/A}
1N/A
1N/A#ifndef HAS_GETENV_LEN
1N/Achar *
1N/APerl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
1N/A{
1N/A char *env_trans = PerlEnv_getenv(env_elem);
1N/A if (env_trans)
1N/A *len = strlen(env_trans);
1N/A return env_trans;
1N/A}
1N/A#endif
1N/A
1N/A
1N/AMGVTBL*
1N/APerl_get_vtbl(pTHX_ int vtbl_id)
1N/A{
1N/A MGVTBL* result = Null(MGVTBL*);
1N/A
1N/A switch(vtbl_id) {
1N/A case want_vtbl_sv:
1N/A result = &PL_vtbl_sv;
1N/A break;
1N/A case want_vtbl_env:
1N/A result = &PL_vtbl_env;
1N/A break;
1N/A case want_vtbl_envelem:
1N/A result = &PL_vtbl_envelem;
1N/A break;
1N/A case want_vtbl_sig:
1N/A result = &PL_vtbl_sig;
1N/A break;
1N/A case want_vtbl_sigelem:
1N/A result = &PL_vtbl_sigelem;
1N/A break;
1N/A case want_vtbl_pack:
1N/A result = &PL_vtbl_pack;
1N/A break;
1N/A case want_vtbl_packelem:
1N/A result = &PL_vtbl_packelem;
1N/A break;
1N/A case want_vtbl_dbline:
1N/A result = &PL_vtbl_dbline;
1N/A break;
1N/A case want_vtbl_isa:
1N/A result = &PL_vtbl_isa;
1N/A break;
1N/A case want_vtbl_isaelem:
1N/A result = &PL_vtbl_isaelem;
1N/A break;
1N/A case want_vtbl_arylen:
1N/A result = &PL_vtbl_arylen;
1N/A break;
1N/A case want_vtbl_glob:
1N/A result = &PL_vtbl_glob;
1N/A break;
1N/A case want_vtbl_mglob:
1N/A result = &PL_vtbl_mglob;
1N/A break;
1N/A case want_vtbl_nkeys:
1N/A result = &PL_vtbl_nkeys;
1N/A break;
1N/A case want_vtbl_taint:
1N/A result = &PL_vtbl_taint;
1N/A break;
1N/A case want_vtbl_substr:
1N/A result = &PL_vtbl_substr;
1N/A break;
1N/A case want_vtbl_vec:
1N/A result = &PL_vtbl_vec;
1N/A break;
1N/A case want_vtbl_pos:
1N/A result = &PL_vtbl_pos;
1N/A break;
1N/A case want_vtbl_bm:
1N/A result = &PL_vtbl_bm;
1N/A break;
1N/A case want_vtbl_fm:
1N/A result = &PL_vtbl_fm;
1N/A break;
1N/A case want_vtbl_uvar:
1N/A result = &PL_vtbl_uvar;
1N/A break;
1N/A#ifdef USE_5005THREADS
1N/A case want_vtbl_mutex:
1N/A result = &PL_vtbl_mutex;
1N/A break;
1N/A#endif
1N/A case want_vtbl_defelem:
1N/A result = &PL_vtbl_defelem;
1N/A break;
1N/A case want_vtbl_regexp:
1N/A result = &PL_vtbl_regexp;
1N/A break;
1N/A case want_vtbl_regdata:
1N/A result = &PL_vtbl_regdata;
1N/A break;
1N/A case want_vtbl_regdatum:
1N/A result = &PL_vtbl_regdatum;
1N/A break;
1N/A#ifdef USE_LOCALE_COLLATE
1N/A case want_vtbl_collxfrm:
1N/A result = &PL_vtbl_collxfrm;
1N/A break;
1N/A#endif
1N/A case want_vtbl_amagic:
1N/A result = &PL_vtbl_amagic;
1N/A break;
1N/A case want_vtbl_amagicelem:
1N/A result = &PL_vtbl_amagicelem;
1N/A break;
1N/A case want_vtbl_backref:
1N/A result = &PL_vtbl_backref;
1N/A break;
1N/A case want_vtbl_utf8:
1N/A result = &PL_vtbl_utf8;
1N/A break;
1N/A }
1N/A return result;
1N/A}
1N/A
1N/AI32
1N/APerl_my_fflush_all(pTHX)
1N/A{
1N/A#if defined(USE_PERLIO) || defined(FFLUSH_NULL) || defined(USE_SFIO)
1N/A return PerlIO_flush(NULL);
1N/A#else
1N/A# if defined(HAS__FWALK)
1N/A extern int fflush(FILE *);
1N/A /* undocumented, unprototyped, but very useful BSDism */
1N/A extern void _fwalk(int (*)(FILE *));
1N/A _fwalk(&fflush);
1N/A return 0;
1N/A# else
1N/A# if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
1N/A long open_max = -1;
1N/A# ifdef PERL_FFLUSH_ALL_FOPEN_MAX
1N/A open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
1N/A# else
1N/A# if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
1N/A open_max = sysconf(_SC_OPEN_MAX);
1N/A# else
1N/A# ifdef FOPEN_MAX
1N/A open_max = FOPEN_MAX;
1N/A# else
1N/A# ifdef OPEN_MAX
1N/A open_max = OPEN_MAX;
1N/A# else
1N/A# ifdef _NFILE
1N/A open_max = _NFILE;
1N/A# endif
1N/A# endif
1N/A# endif
1N/A# endif
1N/A# endif
1N/A if (open_max > 0) {
1N/A long i;
1N/A for (i = 0; i < open_max; i++)
1N/A if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
1N/A STDIO_STREAM_ARRAY[i]._file < open_max &&
1N/A STDIO_STREAM_ARRAY[i]._flag)
1N/A PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
1N/A return 0;
1N/A }
1N/A# endif
1N/A SETERRNO(EBADF,RMS_IFI);
1N/A return EOF;
1N/A# endif
1N/A#endif
1N/A}
1N/A
1N/Avoid
1N/APerl_report_evil_fh(pTHX_ GV *gv, IO *io, I32 op)
1N/A{
1N/A char *func =
1N/A op == OP_READLINE ? "readline" : /* "<HANDLE>" not nice */
1N/A op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */
1N/A PL_op_desc[op];
1N/A char *pars = OP_IS_FILETEST(op) ? "" : "()";
1N/A char *type = OP_IS_SOCKET(op)
1N/A || (gv && io && IoTYPE(io) == IoTYPE_SOCKET)
1N/A ? "socket" : "filehandle";
1N/A char *name = NULL;
1N/A
1N/A if (gv && isGV(gv)) {
1N/A name = GvENAME(gv);
1N/A }
1N/A
1N/A if (op == OP_phoney_OUTPUT_ONLY || op == OP_phoney_INPUT_ONLY) {
1N/A if (ckWARN(WARN_IO)) {
1N/A const char *direction = (op == OP_phoney_INPUT_ONLY) ? "in" : "out";
1N/A if (name && *name)
1N/A Perl_warner(aTHX_ packWARN(WARN_IO),
1N/A "Filehandle %s opened only for %sput",
1N/A name, direction);
1N/A else
1N/A Perl_warner(aTHX_ packWARN(WARN_IO),
1N/A "Filehandle opened only for %sput", direction);
1N/A }
1N/A }
1N/A else {
1N/A char *vile;
1N/A I32 warn_type;
1N/A
1N/A if (gv && io && IoTYPE(io) == IoTYPE_CLOSED) {
1N/A vile = "closed";
1N/A warn_type = WARN_CLOSED;
1N/A }
1N/A else {
1N/A vile = "unopened";
1N/A warn_type = WARN_UNOPENED;
1N/A }
1N/A
1N/A if (ckWARN(warn_type)) {
1N/A if (name && *name) {
1N/A Perl_warner(aTHX_ packWARN(warn_type),
1N/A "%s%s on %s %s %s", func, pars, vile, type, name);
1N/A if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
1N/A Perl_warner(
1N/A aTHX_ packWARN(warn_type),
1N/A "\t(Are you trying to call %s%s on dirhandle %s?)\n",
1N/A func, pars, name
1N/A );
1N/A }
1N/A else {
1N/A Perl_warner(aTHX_ packWARN(warn_type),
1N/A "%s%s on %s %s", func, pars, vile, type);
1N/A if (gv && io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
1N/A Perl_warner(
1N/A aTHX_ packWARN(warn_type),
1N/A "\t(Are you trying to call %s%s on dirhandle?)\n",
1N/A func, pars
1N/A );
1N/A }
1N/A }
1N/A }
1N/A}
1N/A
1N/A#ifdef EBCDIC
1N/A/* in ASCII order, not that it matters */
1N/Astatic const char controllablechars[] = "?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_";
1N/A
1N/Aint
1N/APerl_ebcdic_control(pTHX_ int ch)
1N/A{
1N/A if (ch > 'a') {
1N/A char *ctlp;
1N/A
1N/A if (islower(ch))
1N/A ch = toupper(ch);
1N/A
1N/A if ((ctlp = strchr(controllablechars, ch)) == 0) {
1N/A Perl_die(aTHX_ "unrecognised control character '%c'\n", ch);
1N/A }
1N/A
1N/A if (ctlp == controllablechars)
1N/A return('\177'); /* DEL */
1N/A else
1N/A return((unsigned char)(ctlp - controllablechars - 1));
1N/A } else { /* Want uncontrol */
1N/A if (ch == '\177' || ch == -1)
1N/A return('?');
1N/A else if (ch == '\157')
1N/A return('\177');
1N/A else if (ch == '\174')
1N/A return('\000');
1N/A else if (ch == '^') /* '\137' in 1047, '\260' in 819 */
1N/A return('\036');
1N/A else if (ch == '\155')
1N/A return('\037');
1N/A else if (0 < ch && ch < (sizeof(controllablechars) - 1))
1N/A return(controllablechars[ch+1]);
1N/A else
1N/A Perl_die(aTHX_ "invalid control request: '\\%03o'\n", ch & 0xFF);
1N/A }
1N/A}
1N/A#endif
1N/A
1N/A/* To workaround core dumps from the uninitialised tm_zone we get the
1N/A * system to give us a reasonable struct to copy. This fix means that
1N/A * strftime uses the tm_zone and tm_gmtoff values returned by
1N/A * localtime(time()). That should give the desired result most of the
1N/A * time. But probably not always!
1N/A *
1N/A * This does not address tzname aspects of NETaa14816.
1N/A *
1N/A */
1N/A
1N/A#ifdef HAS_GNULIBC
1N/A# ifndef STRUCT_TM_HASZONE
1N/A# define STRUCT_TM_HASZONE
1N/A# endif
1N/A#endif
1N/A
1N/A#ifdef STRUCT_TM_HASZONE /* Backward compat */
1N/A# ifndef HAS_TM_TM_ZONE
1N/A# define HAS_TM_TM_ZONE
1N/A# endif
1N/A#endif
1N/A
1N/Avoid
1N/APerl_init_tm(pTHX_ struct tm *ptm) /* see mktime, strftime and asctime */
1N/A{
1N/A#ifdef HAS_TM_TM_ZONE
1N/A Time_t now;
1N/A (void)time(&now);
1N/A Copy(localtime(&now), ptm, 1, struct tm);
1N/A#endif
1N/A}
1N/A
1N/A/*
1N/A * mini_mktime - normalise struct tm values without the localtime()
1N/A * semantics (and overhead) of mktime().
1N/A */
1N/Avoid
1N/APerl_mini_mktime(pTHX_ struct tm *ptm)
1N/A{
1N/A int yearday;
1N/A int secs;
1N/A int month, mday, year, jday;
1N/A int odd_cent, odd_year;
1N/A
1N/A#define DAYS_PER_YEAR 365
1N/A#define DAYS_PER_QYEAR (4*DAYS_PER_YEAR+1)
1N/A#define DAYS_PER_CENT (25*DAYS_PER_QYEAR-1)
1N/A#define DAYS_PER_QCENT (4*DAYS_PER_CENT+1)
1N/A#define SECS_PER_HOUR (60*60)
1N/A#define SECS_PER_DAY (24*SECS_PER_HOUR)
1N/A/* parentheses deliberately absent on these two, otherwise they don't work */
1N/A#define MONTH_TO_DAYS 153/5
1N/A#define DAYS_TO_MONTH 5/153
1N/A/* offset to bias by March (month 4) 1st between month/mday & year finding */
1N/A#define YEAR_ADJUST (4*MONTH_TO_DAYS+1)
1N/A/* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */
1N/A#define WEEKDAY_BIAS 6 /* (1+6)%7 makes Sunday 0 again */
1N/A
1N/A/*
1N/A * Year/day algorithm notes:
1N/A *
1N/A * With a suitable offset for numeric value of the month, one can find
1N/A * an offset into the year by considering months to have 30.6 (153/5) days,
1N/A * using integer arithmetic (i.e., with truncation). To avoid too much
1N/A * messing about with leap days, we consider January and February to be
1N/A * the 13th and 14th month of the previous year. After that transformation,
1N/A * we need the month index we use to be high by 1 from 'normal human' usage,
1N/A * so the month index values we use run from 4 through 15.
1N/A *
1N/A * Given that, and the rules for the Gregorian calendar (leap years are those
1N/A * divisible by 4 unless also divisible by 100, when they must be divisible
1N/A * by 400 instead), we can simply calculate the number of days since some
1N/A * arbitrary 'beginning of time' by futzing with the (adjusted) year number,
1N/A * the days we derive from our month index, and adding in the day of the
1N/A * month. The value used here is not adjusted for the actual origin which
1N/A * it normally would use (1 January A.D. 1), since we're not exposing it.
1N/A * We're only building the value so we can turn around and get the
1N/A * normalised values for the year, month, day-of-month, and day-of-year.
1N/A *
1N/A * For going backward, we need to bias the value we're using so that we find
1N/A * the right year value. (Basically, we don't want the contribution of
1N/A * March 1st to the number to apply while deriving the year). Having done
1N/A * that, we 'count up' the contribution to the year number by accounting for
1N/A * full quadracenturies (400-year periods) with their extra leap days, plus
1N/A * the contribution from full centuries (to avoid counting in the lost leap
1N/A * days), plus the contribution from full quad-years (to count in the normal
1N/A * leap days), plus the leftover contribution from any non-leap years.
1N/A * At this point, if we were working with an actual leap day, we'll have 0
1N/A * days left over. This is also true for March 1st, however. So, we have
1N/A * to special-case that result, and (earlier) keep track of the 'odd'
1N/A * century and year contributions. If we got 4 extra centuries in a qcent,
1N/A * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb.
1N/A * Otherwise, we add back in the earlier bias we removed (the 123 from
1N/A * figuring in March 1st), find the month index (integer division by 30.6),
1N/A * and the remainder is the day-of-month. We then have to convert back to
1N/A * 'real' months (including fixing January and February from being 14/15 in
1N/A * the previous year to being in the proper year). After that, to get
1N/A * tm_yday, we work with the normalised year and get a new yearday value for
1N/A * January 1st, which we subtract from the yearday value we had earlier,
1N/A * representing the date we've re-built. This is done from January 1
1N/A * because tm_yday is 0-origin.
1N/A *
1N/A * Since POSIX time routines are only guaranteed to work for times since the
1N/A * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm
1N/A * applies Gregorian calendar rules even to dates before the 16th century
1N/A * doesn't bother me. Besides, you'd need cultural context for a given
1N/A * date to know whether it was Julian or Gregorian calendar, and that's
1N/A * outside the scope for this routine. Since we convert back based on the
1N/A * same rules we used to build the yearday, you'll only get strange results
1N/A * for input which needed normalising, or for the 'odd' century years which
1N/A * were leap years in the Julian calander but not in the Gregorian one.
1N/A * I can live with that.
1N/A *
1N/A * This algorithm also fails to handle years before A.D. 1 gracefully, but
1N/A * that's still outside the scope for POSIX time manipulation, so I don't
1N/A * care.
1N/A */
1N/A
1N/A year = 1900 + ptm->tm_year;
1N/A month = ptm->tm_mon;
1N/A mday = ptm->tm_mday;
1N/A /* allow given yday with no month & mday to dominate the result */
1N/A if (ptm->tm_yday >= 0 && mday <= 0 && month <= 0) {
1N/A month = 0;
1N/A mday = 0;
1N/A jday = 1 + ptm->tm_yday;
1N/A }
1N/A else {
1N/A jday = 0;
1N/A }
1N/A if (month >= 2)
1N/A month+=2;
1N/A else
1N/A month+=14, year--;
1N/A yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400;
1N/A yearday += month*MONTH_TO_DAYS + mday + jday;
1N/A /*
1N/A * Note that we don't know when leap-seconds were or will be,
1N/A * so we have to trust the user if we get something which looks
1N/A * like a sensible leap-second. Wild values for seconds will
1N/A * be rationalised, however.
1N/A */
1N/A if ((unsigned) ptm->tm_sec <= 60) {
1N/A secs = 0;
1N/A }
1N/A else {
1N/A secs = ptm->tm_sec;
1N/A ptm->tm_sec = 0;
1N/A }
1N/A secs += 60 * ptm->tm_min;
1N/A secs += SECS_PER_HOUR * ptm->tm_hour;
1N/A if (secs < 0) {
1N/A if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) {
1N/A /* got negative remainder, but need positive time */
1N/A /* back off an extra day to compensate */
1N/A yearday += (secs/SECS_PER_DAY)-1;
1N/A secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1);
1N/A }
1N/A else {
1N/A yearday += (secs/SECS_PER_DAY);
1N/A secs -= SECS_PER_DAY * (secs/SECS_PER_DAY);
1N/A }
1N/A }
1N/A else if (secs >= SECS_PER_DAY) {
1N/A yearday += (secs/SECS_PER_DAY);
1N/A secs %= SECS_PER_DAY;
1N/A }
1N/A ptm->tm_hour = secs/SECS_PER_HOUR;
1N/A secs %= SECS_PER_HOUR;
1N/A ptm->tm_min = secs/60;
1N/A secs %= 60;
1N/A ptm->tm_sec += secs;
1N/A /* done with time of day effects */
1N/A /*
1N/A * The algorithm for yearday has (so far) left it high by 428.
1N/A * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to
1N/A * bias it by 123 while trying to figure out what year it
1N/A * really represents. Even with this tweak, the reverse
1N/A * translation fails for years before A.D. 0001.
1N/A * It would still fail for Feb 29, but we catch that one below.
1N/A */
1N/A jday = yearday; /* save for later fixup vis-a-vis Jan 1 */
1N/A yearday -= YEAR_ADJUST;
1N/A year = (yearday / DAYS_PER_QCENT) * 400;
1N/A yearday %= DAYS_PER_QCENT;
1N/A odd_cent = yearday / DAYS_PER_CENT;
1N/A year += odd_cent * 100;
1N/A yearday %= DAYS_PER_CENT;
1N/A year += (yearday / DAYS_PER_QYEAR) * 4;
1N/A yearday %= DAYS_PER_QYEAR;
1N/A odd_year = yearday / DAYS_PER_YEAR;
1N/A year += odd_year;
1N/A yearday %= DAYS_PER_YEAR;
1N/A if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */
1N/A month = 1;
1N/A yearday = 29;
1N/A }
1N/A else {
1N/A yearday += YEAR_ADJUST; /* recover March 1st crock */
1N/A month = yearday*DAYS_TO_MONTH;
1N/A yearday -= month*MONTH_TO_DAYS;
1N/A /* recover other leap-year adjustment */
1N/A if (month > 13) {
1N/A month-=14;
1N/A year++;
1N/A }
1N/A else {
1N/A month-=2;
1N/A }
1N/A }
1N/A ptm->tm_year = year - 1900;
1N/A if (yearday) {
1N/A ptm->tm_mday = yearday;
1N/A ptm->tm_mon = month;
1N/A }
1N/A else {
1N/A ptm->tm_mday = 31;
1N/A ptm->tm_mon = month - 1;
1N/A }
1N/A /* re-build yearday based on Jan 1 to get tm_yday */
1N/A year--;
1N/A yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400;
1N/A yearday += 14*MONTH_TO_DAYS + 1;
1N/A ptm->tm_yday = jday - yearday;
1N/A /* fix tm_wday if not overridden by caller */
1N/A if ((unsigned)ptm->tm_wday > 6)
1N/A ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
1N/A}
1N/A
1N/Achar *
1N/APerl_my_strftime(pTHX_ char *fmt, int sec, int min, int hour, int mday, int mon, int year, int wday, int yday, int isdst)
1N/A{
1N/A#ifdef HAS_STRFTIME
1N/A char *buf;
1N/A int buflen;
1N/A struct tm mytm;
1N/A int len;
1N/A
1N/A init_tm(&mytm); /* XXX workaround - see init_tm() above */
1N/A mytm.tm_sec = sec;
1N/A mytm.tm_min = min;
1N/A mytm.tm_hour = hour;
1N/A mytm.tm_mday = mday;
1N/A mytm.tm_mon = mon;
1N/A mytm.tm_year = year;
1N/A mytm.tm_wday = wday;
1N/A mytm.tm_yday = yday;
1N/A mytm.tm_isdst = isdst;
1N/A mini_mktime(&mytm);
1N/A /* use libc to get the values for tm_gmtoff and tm_zone [perl #18238] */
1N/A#if defined(HAS_MKTIME) && (defined(HAS_TM_TM_GMTOFF) || defined(HAS_TM_TM_ZONE))
1N/A STMT_START {
1N/A struct tm mytm2;
1N/A mytm2 = mytm;
1N/A mktime(&mytm2);
1N/A#ifdef HAS_TM_TM_GMTOFF
1N/A mytm.tm_gmtoff = mytm2.tm_gmtoff;
1N/A#endif
1N/A#ifdef HAS_TM_TM_ZONE
1N/A mytm.tm_zone = mytm2.tm_zone;
1N/A#endif
1N/A } STMT_END;
1N/A#endif
1N/A buflen = 64;
1N/A New(0, buf, buflen, char);
1N/A len = strftime(buf, buflen, fmt, &mytm);
1N/A /*
1N/A ** The following is needed to handle to the situation where
1N/A ** tmpbuf overflows. Basically we want to allocate a buffer
1N/A ** and try repeatedly. The reason why it is so complicated
1N/A ** is that getting a return value of 0 from strftime can indicate
1N/A ** one of the following:
1N/A ** 1. buffer overflowed,
1N/A ** 2. illegal conversion specifier, or
1N/A ** 3. the format string specifies nothing to be returned(not
1N/A ** an error). This could be because format is an empty string
1N/A ** or it specifies %p that yields an empty string in some locale.
1N/A ** If there is a better way to make it portable, go ahead by
1N/A ** all means.
1N/A */
1N/A if ((len > 0 && len < buflen) || (len == 0 && *fmt == '\0'))
1N/A return buf;
1N/A else {
1N/A /* Possibly buf overflowed - try again with a bigger buf */
1N/A int fmtlen = strlen(fmt);
1N/A int bufsize = fmtlen + buflen;
1N/A
1N/A New(0, buf, bufsize, char);
1N/A while (buf) {
1N/A buflen = strftime(buf, bufsize, fmt, &mytm);
1N/A if (buflen > 0 && buflen < bufsize)
1N/A break;
1N/A /* heuristic to prevent out-of-memory errors */
1N/A if (bufsize > 100*fmtlen) {
1N/A Safefree(buf);
1N/A buf = NULL;
1N/A break;
1N/A }
1N/A bufsize *= 2;
1N/A Renew(buf, bufsize, char);
1N/A }
1N/A return buf;
1N/A }
1N/A#else
1N/A Perl_croak(aTHX_ "panic: no strftime");
1N/A#endif
1N/A}
1N/A
1N/A
1N/A#define SV_CWD_RETURN_UNDEF \
1N/Asv_setsv(sv, &PL_sv_undef); \
1N/Areturn FALSE
1N/A
1N/A#define SV_CWD_ISDOT(dp) \
1N/A (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
1N/A (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
1N/A
1N/A/*
1N/A=head1 Miscellaneous Functions
1N/A
1N/A=for apidoc getcwd_sv
1N/A
1N/AFill the sv with current working directory
1N/A
1N/A=cut
1N/A*/
1N/A
1N/A/* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars.
1N/A * rewritten again by dougm, optimized for use with xs TARG, and to prefer
1N/A * getcwd(3) if available
1N/A * Comments from the orignal:
1N/A * This is a faster version of getcwd. It's also more dangerous
1N/A * because you might chdir out of a directory that you can't chdir
1N/A * back into. */
1N/A
1N/Aint
1N/APerl_getcwd_sv(pTHX_ register SV *sv)
1N/A{
1N/A#ifndef PERL_MICRO
1N/A
1N/A#ifndef INCOMPLETE_TAINTS
1N/A SvTAINTED_on(sv);
1N/A#endif
1N/A
1N/A#ifdef HAS_GETCWD
1N/A {
1N/A char buf[MAXPATHLEN];
1N/A
1N/A /* Some getcwd()s automatically allocate a buffer of the given
1N/A * size from the heap if they are given a NULL buffer pointer.
1N/A * The problem is that this behaviour is not portable. */
1N/A if (getcwd(buf, sizeof(buf) - 1)) {
1N/A STRLEN len = strlen(buf);
1N/A sv_setpvn(sv, buf, len);
1N/A return TRUE;
1N/A }
1N/A else {
1N/A sv_setsv(sv, &PL_sv_undef);
1N/A return FALSE;
1N/A }
1N/A }
1N/A
1N/A#else
1N/A
1N/A Stat_t statbuf;
1N/A int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
1N/A int namelen, pathlen=0;
1N/A DIR *dir;
1N/A Direntry_t *dp;
1N/A
1N/A (void)SvUPGRADE(sv, SVt_PV);
1N/A
1N/A if (PerlLIO_lstat(".", &statbuf) < 0) {
1N/A SV_CWD_RETURN_UNDEF;
1N/A }
1N/A
1N/A orig_cdev = statbuf.st_dev;
1N/A orig_cino = statbuf.st_ino;
1N/A cdev = orig_cdev;
1N/A cino = orig_cino;
1N/A
1N/A for (;;) {
1N/A odev = cdev;
1N/A oino = cino;
1N/A
1N/A if (PerlDir_chdir("..") < 0) {
1N/A SV_CWD_RETURN_UNDEF;
1N/A }
1N/A if (PerlLIO_stat(".", &statbuf) < 0) {
1N/A SV_CWD_RETURN_UNDEF;
1N/A }
1N/A
1N/A cdev = statbuf.st_dev;
1N/A cino = statbuf.st_ino;
1N/A
1N/A if (odev == cdev && oino == cino) {
1N/A break;
1N/A }
1N/A if (!(dir = PerlDir_open("."))) {
1N/A SV_CWD_RETURN_UNDEF;
1N/A }
1N/A
1N/A while ((dp = PerlDir_read(dir)) != NULL) {
1N/A#ifdef DIRNAMLEN
1N/A namelen = dp->d_namlen;
1N/A#else
1N/A namelen = strlen(dp->d_name);
1N/A#endif
1N/A /* skip . and .. */
1N/A if (SV_CWD_ISDOT(dp)) {
1N/A continue;
1N/A }
1N/A
1N/A if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
1N/A SV_CWD_RETURN_UNDEF;
1N/A }
1N/A
1N/A tdev = statbuf.st_dev;
1N/A tino = statbuf.st_ino;
1N/A if (tino == oino && tdev == odev) {
1N/A break;
1N/A }
1N/A }
1N/A
1N/A if (!dp) {
1N/A SV_CWD_RETURN_UNDEF;
1N/A }
1N/A
1N/A if (pathlen + namelen + 1 >= MAXPATHLEN) {
1N/A SV_CWD_RETURN_UNDEF;
1N/A }
1N/A
1N/A SvGROW(sv, pathlen + namelen + 1);
1N/A
1N/A if (pathlen) {
1N/A /* shift down */
1N/A Move(SvPVX(sv), SvPVX(sv) + namelen + 1, pathlen, char);
1N/A }
1N/A
1N/A /* prepend current directory to the front */
1N/A *SvPVX(sv) = '/';
1N/A Move(dp->d_name, SvPVX(sv)+1, namelen, char);
1N/A pathlen += (namelen + 1);
1N/A
1N/A#ifdef VOID_CLOSEDIR
1N/A PerlDir_close(dir);
1N/A#else
1N/A if (PerlDir_close(dir) < 0) {
1N/A SV_CWD_RETURN_UNDEF;
1N/A }
1N/A#endif
1N/A }
1N/A
1N/A if (pathlen) {
1N/A SvCUR_set(sv, pathlen);
1N/A *SvEND(sv) = '\0';
1N/A SvPOK_only(sv);
1N/A
1N/A if (PerlDir_chdir(SvPVX(sv)) < 0) {
1N/A SV_CWD_RETURN_UNDEF;
1N/A }
1N/A }
1N/A if (PerlLIO_stat(".", &statbuf) < 0) {
1N/A SV_CWD_RETURN_UNDEF;
1N/A }
1N/A
1N/A cdev = statbuf.st_dev;
1N/A cino = statbuf.st_ino;
1N/A
1N/A if (cdev != orig_cdev || cino != orig_cino) {
1N/A Perl_croak(aTHX_ "Unstable directory path, "
1N/A "current directory changed unexpectedly");
1N/A }
1N/A
1N/A return TRUE;
1N/A#endif
1N/A
1N/A#else
1N/A return FALSE;
1N/A#endif
1N/A}
1N/A
1N/A#if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT)
1N/A# define EMULATE_SOCKETPAIR_UDP
1N/A#endif
1N/A
1N/A#ifdef EMULATE_SOCKETPAIR_UDP
1N/Astatic int
1N/AS_socketpair_udp (int fd[2]) {
1N/A dTHX;
1N/A /* Fake a datagram socketpair using UDP to localhost. */
1N/A int sockets[2] = {-1, -1};
1N/A struct sockaddr_in addresses[2];
1N/A int i;
1N/A Sock_size_t size = sizeof(struct sockaddr_in);
1N/A unsigned short port;
1N/A int got;
1N/A
1N/A memset(&addresses, 0, sizeof(addresses));
1N/A i = 1;
1N/A do {
1N/A sockets[i] = PerlSock_socket(AF_INET, SOCK_DGRAM, PF_INET);
1N/A if (sockets[i] == -1)
1N/A goto tidy_up_and_fail;
1N/A
1N/A addresses[i].sin_family = AF_INET;
1N/A addresses[i].sin_addr.s_addr = htonl(INADDR_LOOPBACK);
1N/A addresses[i].sin_port = 0; /* kernel choses port. */
1N/A if (PerlSock_bind(sockets[i], (struct sockaddr *) &addresses[i],
1N/A sizeof(struct sockaddr_in)) == -1)
1N/A goto tidy_up_and_fail;
1N/A } while (i--);
1N/A
1N/A /* Now have 2 UDP sockets. Find out which port each is connected to, and
1N/A for each connect the other socket to it. */
1N/A i = 1;
1N/A do {
1N/A if (PerlSock_getsockname(sockets[i], (struct sockaddr *) &addresses[i],
1N/A &size) == -1)
1N/A goto tidy_up_and_fail;
1N/A if (size != sizeof(struct sockaddr_in))
1N/A goto abort_tidy_up_and_fail;
1N/A /* !1 is 0, !0 is 1 */
1N/A if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i],
1N/A sizeof(struct sockaddr_in)) == -1)
1N/A goto tidy_up_and_fail;
1N/A } while (i--);
1N/A
1N/A /* Now we have 2 sockets connected to each other. I don't trust some other
1N/A process not to have already sent a packet to us (by random) so send
1N/A a packet from each to the other. */
1N/A i = 1;
1N/A do {
1N/A /* I'm going to send my own port number. As a short.
1N/A (Who knows if someone somewhere has sin_port as a bitfield and needs
1N/A this routine. (I'm assuming crays have socketpair)) */
1N/A port = addresses[i].sin_port;
1N/A got = PerlLIO_write(sockets[i], &port, sizeof(port));
1N/A if (got != sizeof(port)) {
1N/A if (got == -1)
1N/A goto tidy_up_and_fail;
1N/A goto abort_tidy_up_and_fail;
1N/A }
1N/A } while (i--);
1N/A
1N/A /* Packets sent. I don't trust them to have arrived though.
1N/A (As I understand it Solaris TCP stack is multithreaded. Non-blocking
1N/A connect to localhost will use a second kernel thread. In 2.6 the
1N/A first thread running the connect() returns before the second completes,
1N/A so EINPROGRESS> In 2.7 the improved stack is faster and connect()
1N/A returns 0. Poor programs have tripped up. One poor program's authors'
1N/A had a 50-1 reverse stock split. Not sure how connected these were.)
1N/A So I don't trust someone not to have an unpredictable UDP stack.
1N/A */
1N/A
1N/A {
1N/A struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */
1N/A int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0];
1N/A fd_set rset;
1N/A
1N/A FD_ZERO(&rset);
1N/A FD_SET(sockets[0], &rset);
1N/A FD_SET(sockets[1], &rset);
1N/A
1N/A got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor);
1N/A if (got != 2 || !FD_ISSET(sockets[0], &rset)
1N/A || !FD_ISSET(sockets[1], &rset)) {
1N/A /* I hope this is portable and appropriate. */
1N/A if (got == -1)
1N/A goto tidy_up_and_fail;
1N/A goto abort_tidy_up_and_fail;
1N/A }
1N/A }
1N/A
1N/A /* And the paranoia department even now doesn't trust it to have arrive
1N/A (hence MSG_DONTWAIT). Or that what arrives was sent by us. */
1N/A {
1N/A struct sockaddr_in readfrom;
1N/A unsigned short buffer[2];
1N/A
1N/A i = 1;
1N/A do {
1N/A#ifdef MSG_DONTWAIT
1N/A got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
1N/A sizeof(buffer), MSG_DONTWAIT,
1N/A (struct sockaddr *) &readfrom, &size);
1N/A#else
1N/A got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
1N/A sizeof(buffer), 0,
1N/A (struct sockaddr *) &readfrom, &size);
1N/A#endif
1N/A
1N/A if (got == -1)
1N/A goto tidy_up_and_fail;
1N/A if (got != sizeof(port)
1N/A || size != sizeof(struct sockaddr_in)
1N/A /* Check other socket sent us its port. */
1N/A || buffer[0] != (unsigned short) addresses[!i].sin_port
1N/A /* Check kernel says we got the datagram from that socket */
1N/A || readfrom.sin_family != addresses[!i].sin_family
1N/A || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr
1N/A || readfrom.sin_port != addresses[!i].sin_port)
1N/A goto abort_tidy_up_and_fail;
1N/A } while (i--);
1N/A }
1N/A /* My caller (my_socketpair) has validated that this is non-NULL */
1N/A fd[0] = sockets[0];
1N/A fd[1] = sockets[1];
1N/A /* I hereby declare this connection open. May God bless all who cross
1N/A her. */
1N/A return 0;
1N/A
1N/A abort_tidy_up_and_fail:
1N/A errno = ECONNABORTED;
1N/A tidy_up_and_fail:
1N/A {
1N/A int save_errno = errno;
1N/A if (sockets[0] != -1)
1N/A PerlLIO_close(sockets[0]);
1N/A if (sockets[1] != -1)
1N/A PerlLIO_close(sockets[1]);
1N/A errno = save_errno;
1N/A return -1;
1N/A }
1N/A}
1N/A#endif /* EMULATE_SOCKETPAIR_UDP */
1N/A
1N/A#if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET)
1N/Aint
1N/APerl_my_socketpair (int family, int type, int protocol, int fd[2]) {
1N/A /* Stevens says that family must be AF_LOCAL, protocol 0.
1N/A I'm going to enforce that, then ignore it, and use TCP (or UDP). */
1N/A dTHX;
1N/A int listener = -1;
1N/A int connector = -1;
1N/A int acceptor = -1;
1N/A struct sockaddr_in listen_addr;
1N/A struct sockaddr_in connect_addr;
1N/A Sock_size_t size;
1N/A
1N/A if (protocol
1N/A#ifdef AF_UNIX
1N/A || family != AF_UNIX
1N/A#endif
1N/A ) {
1N/A errno = EAFNOSUPPORT;
1N/A return -1;
1N/A }
1N/A if (!fd) {
1N/A errno = EINVAL;
1N/A return -1;
1N/A }
1N/A
1N/A#ifdef EMULATE_SOCKETPAIR_UDP
1N/A if (type == SOCK_DGRAM)
1N/A return S_socketpair_udp(fd);
1N/A#endif
1N/A
1N/A listener = PerlSock_socket(AF_INET, type, 0);
1N/A if (listener == -1)
1N/A return -1;
1N/A memset(&listen_addr, 0, sizeof(listen_addr));
1N/A listen_addr.sin_family = AF_INET;
1N/A listen_addr.sin_addr.s_addr = htonl(INADDR_LOOPBACK);
1N/A listen_addr.sin_port = 0; /* kernel choses port. */
1N/A if (PerlSock_bind(listener, (struct sockaddr *) &listen_addr,
1N/A sizeof(listen_addr)) == -1)
1N/A goto tidy_up_and_fail;
1N/A if (PerlSock_listen(listener, 1) == -1)
1N/A goto tidy_up_and_fail;
1N/A
1N/A connector = PerlSock_socket(AF_INET, type, 0);
1N/A if (connector == -1)
1N/A goto tidy_up_and_fail;
1N/A /* We want to find out the port number to connect to. */
1N/A size = sizeof(connect_addr);
1N/A if (PerlSock_getsockname(listener, (struct sockaddr *) &connect_addr,
1N/A &size) == -1)
1N/A goto tidy_up_and_fail;
1N/A if (size != sizeof(connect_addr))
1N/A goto abort_tidy_up_and_fail;
1N/A if (PerlSock_connect(connector, (struct sockaddr *) &connect_addr,
1N/A sizeof(connect_addr)) == -1)
1N/A goto tidy_up_and_fail;
1N/A
1N/A size = sizeof(listen_addr);
1N/A acceptor = PerlSock_accept(listener, (struct sockaddr *) &listen_addr,
1N/A &size);
1N/A if (acceptor == -1)
1N/A goto tidy_up_and_fail;
1N/A if (size != sizeof(listen_addr))
1N/A goto abort_tidy_up_and_fail;
1N/A PerlLIO_close(listener);
1N/A /* Now check we are talking to ourself by matching port and host on the
1N/A two sockets. */
1N/A if (PerlSock_getsockname(connector, (struct sockaddr *) &connect_addr,
1N/A &size) == -1)
1N/A goto tidy_up_and_fail;
1N/A if (size != sizeof(connect_addr)
1N/A || listen_addr.sin_family != connect_addr.sin_family
1N/A || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr
1N/A || listen_addr.sin_port != connect_addr.sin_port) {
1N/A goto abort_tidy_up_and_fail;
1N/A }
1N/A fd[0] = connector;
1N/A fd[1] = acceptor;
1N/A return 0;
1N/A
1N/A abort_tidy_up_and_fail:
1N/A errno = ECONNABORTED; /* I hope this is portable and appropriate. */
1N/A tidy_up_and_fail:
1N/A {
1N/A int save_errno = errno;
1N/A if (listener != -1)
1N/A PerlLIO_close(listener);
1N/A if (connector != -1)
1N/A PerlLIO_close(connector);
1N/A if (acceptor != -1)
1N/A PerlLIO_close(acceptor);
1N/A errno = save_errno;
1N/A return -1;
1N/A }
1N/A}
1N/A#else
1N/A/* In any case have a stub so that there's code corresponding
1N/A * to the my_socketpair in global.sym. */
1N/Aint
1N/APerl_my_socketpair (int family, int type, int protocol, int fd[2]) {
1N/A#ifdef HAS_SOCKETPAIR
1N/A return socketpair(family, type, protocol, fd);
1N/A#else
1N/A return -1;
1N/A#endif
1N/A}
1N/A#endif
1N/A
1N/A/*
1N/A
1N/A=for apidoc sv_nosharing
1N/A
1N/ADummy routine which "shares" an SV when there is no sharing module present.
1N/AExists to avoid test for a NULL function pointer and because it could potentially warn under
1N/Asome level of strict-ness.
1N/A
1N/A=cut
1N/A*/
1N/A
1N/Avoid
1N/APerl_sv_nosharing(pTHX_ SV *sv)
1N/A{
1N/A}
1N/A
1N/A/*
1N/A=for apidoc sv_nolocking
1N/A
1N/ADummy routine which "locks" an SV when there is no locking module present.
1N/AExists to avoid test for a NULL function pointer and because it could potentially warn under
1N/Asome level of strict-ness.
1N/A
1N/A=cut
1N/A*/
1N/A
1N/Avoid
1N/APerl_sv_nolocking(pTHX_ SV *sv)
1N/A{
1N/A}
1N/A
1N/A
1N/A/*
1N/A=for apidoc sv_nounlocking
1N/A
1N/ADummy routine which "unlocks" an SV when there is no locking module present.
1N/AExists to avoid test for a NULL function pointer and because it could potentially warn under
1N/Asome level of strict-ness.
1N/A
1N/A=cut
1N/A*/
1N/A
1N/Avoid
1N/APerl_sv_nounlocking(pTHX_ SV *sv)
1N/A{
1N/A}
1N/A
1N/AU32
1N/APerl_parse_unicode_opts(pTHX_ char **popt)
1N/A{
1N/A char *p = *popt;
1N/A U32 opt = 0;
1N/A
1N/A if (*p) {
1N/A if (isDIGIT(*p)) {
1N/A opt = (U32) atoi(p);
1N/A while (isDIGIT(*p)) p++;
1N/A if (*p && *p != '\n' && *p != '\r')
1N/A Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
1N/A }
1N/A else {
1N/A for (; *p; p++) {
1N/A switch (*p) {
1N/A case PERL_UNICODE_STDIN:
1N/A opt |= PERL_UNICODE_STDIN_FLAG; break;
1N/A case PERL_UNICODE_STDOUT:
1N/A opt |= PERL_UNICODE_STDOUT_FLAG; break;
1N/A case PERL_UNICODE_STDERR:
1N/A opt |= PERL_UNICODE_STDERR_FLAG; break;
1N/A case PERL_UNICODE_STD:
1N/A opt |= PERL_UNICODE_STD_FLAG; break;
1N/A case PERL_UNICODE_IN:
1N/A opt |= PERL_UNICODE_IN_FLAG; break;
1N/A case PERL_UNICODE_OUT:
1N/A opt |= PERL_UNICODE_OUT_FLAG; break;
1N/A case PERL_UNICODE_INOUT:
1N/A opt |= PERL_UNICODE_INOUT_FLAG; break;
1N/A case PERL_UNICODE_LOCALE:
1N/A opt |= PERL_UNICODE_LOCALE_FLAG; break;
1N/A case PERL_UNICODE_ARGV:
1N/A opt |= PERL_UNICODE_ARGV_FLAG; break;
1N/A default:
1N/A if (*p != '\n' && *p != '\r')
1N/A Perl_croak(aTHX_
1N/A "Unknown Unicode option letter '%c'", *p);
1N/A }
1N/A }
1N/A }
1N/A }
1N/A else
1N/A opt = PERL_UNICODE_DEFAULT_FLAGS;
1N/A
1N/A if (opt & ~PERL_UNICODE_ALL_FLAGS)
1N/A Perl_croak(aTHX_ "Unknown Unicode option value %"UVuf,
1N/A (UV) (opt & ~PERL_UNICODE_ALL_FLAGS));
1N/A
1N/A *popt = p;
1N/A
1N/A return opt;
1N/A}
1N/A
1N/AU32
1N/APerl_seed(pTHX)
1N/A{
1N/A /*
1N/A * This is really just a quick hack which grabs various garbage
1N/A * values. It really should be a real hash algorithm which
1N/A * spreads the effect of every input bit onto every output bit,
1N/A * if someone who knows about such things would bother to write it.
1N/A * Might be a good idea to add that function to CORE as well.
1N/A * No numbers below come from careful analysis or anything here,
1N/A * except they are primes and SEED_C1 > 1E6 to get a full-width
1N/A * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
1N/A * probably be bigger too.
1N/A */
1N/A#if RANDBITS > 16
1N/A# define SEED_C1 1000003
1N/A#define SEED_C4 73819
1N/A#else
1N/A# define SEED_C1 25747
1N/A#define SEED_C4 20639
1N/A#endif
1N/A#define SEED_C2 3
1N/A#define SEED_C3 269
1N/A#define SEED_C5 26107
1N/A
1N/A#ifndef PERL_NO_DEV_RANDOM
1N/A int fd;
1N/A#endif
1N/A U32 u;
1N/A#ifdef VMS
1N/A# include <starlet.h>
1N/A /* when[] = (low 32 bits, high 32 bits) of time since epoch
1N/A * in 100-ns units, typically incremented ever 10 ms. */
1N/A unsigned int when[2];
1N/A#else
1N/A# ifdef HAS_GETTIMEOFDAY
1N/A struct timeval when;
1N/A# else
1N/A Time_t when;
1N/A# endif
1N/A#endif
1N/A
1N/A/* This test is an escape hatch, this symbol isn't set by Configure. */
1N/A#ifndef PERL_NO_DEV_RANDOM
1N/A#ifndef PERL_RANDOM_DEVICE
1N/A /* /dev/random isn't used by default because reads from it will block
1N/A * if there isn't enough entropy available. You can compile with
1N/A * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
1N/A * is enough real entropy to fill the seed. */
1N/A# define PERL_RANDOM_DEVICE "/dev/urandom"
1N/A#endif
1N/A fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
1N/A if (fd != -1) {
1N/A if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
1N/A u = 0;
1N/A PerlLIO_close(fd);
1N/A if (u)
1N/A return u;
1N/A }
1N/A#endif
1N/A
1N/A#ifdef VMS
1N/A _ckvmssts(sys$gettim(when));
1N/A u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
1N/A#else
1N/A# ifdef HAS_GETTIMEOFDAY
1N/A PerlProc_gettimeofday(&when,NULL);
1N/A u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
1N/A# else
1N/A (void)time(&when);
1N/A u = (U32)SEED_C1 * when;
1N/A# endif
1N/A#endif
1N/A u += SEED_C3 * (U32)PerlProc_getpid();
1N/A u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
1N/A#ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
1N/A u += SEED_C5 * (U32)PTR2UV(&when);
1N/A#endif
1N/A return u;
1N/A}
1N/A
1N/AUV
1N/APerl_get_hash_seed(pTHX)
1N/A{
1N/A char *s = PerlEnv_getenv("PERL_HASH_SEED");
1N/A UV myseed = 0;
1N/A
1N/A if (s)
1N/A while (isSPACE(*s)) s++;
1N/A if (s && isDIGIT(*s))
1N/A myseed = (UV)Atoul(s);
1N/A else
1N/A#ifdef USE_HASH_SEED_EXPLICIT
1N/A if (s)
1N/A#endif
1N/A {
1N/A /* Compute a random seed */
1N/A (void)seedDrand01((Rand_seed_t)seed());
1N/A myseed = (UV)(Drand01() * (NV)UV_MAX);
1N/A#if RANDBITS < (UVSIZE * 8)
1N/A /* Since there are not enough randbits to to reach all
1N/A * the bits of a UV, the low bits might need extra
1N/A * help. Sum in another random number that will
1N/A * fill in the low bits. */
1N/A myseed +=
1N/A (UV)(Drand01() * (NV)((1 << ((UVSIZE * 8 - RANDBITS))) - 1));
1N/A#endif /* RANDBITS < (UVSIZE * 8) */
1N/A if (myseed == 0) { /* Superparanoia. */
1N/A myseed = (UV)(Drand01() * (NV)UV_MAX); /* One more chance. */
1N/A if (myseed == 0)
1N/A Perl_croak(aTHX_ "Your random numbers are not that random");
1N/A }
1N/A }
1N/A PL_rehash_seed_set = TRUE;
1N/A
1N/A return myseed;
1N/A}