util.c

   1 /*    util.c
   2  *
   3  *    Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
   4  *    2000, 2001, 2002, 2003, by Larry Wall and others
   5  *
   6  *    You may distribute under the terms of either the GNU General Public
   7  *    License or the Artistic License, as specified in the README file.
   8  *
   9  */
  10
  11 /*
  12  * "Very useful, no doubt, that was to Saruman; yet it seems that he was
  13  * not content."  --Gandalf
  14  */
  15
  16 #include "EXTERN.h"
  17 #define PERL_IN_UTIL_C
  18 #include "perl.h"
  19
  20 #ifndef PERL_MICRO
  21 #if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
  22 #include <signal.h>
  23 #endif
  24
  25 #ifndef SIG_ERR
  26 # define SIG_ERR ((Sighandler_t) -1)
  27 #endif
  28 #endif
  29
  30 #ifdef I_SYS_WAIT
  31 #  include <sys/wait.h>
  32 #endif
  33
  34 #ifdef HAS_SELECT
  35 # ifdef I_SYS_SELECT
  36 #  include <sys/select.h>
  37 # endif
  38 #endif
  39
  40 #define FLUSH
  41
  42 #if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC)
  43 #  define FD_CLOEXEC 1                  /* NeXT needs this */
  44 #endif
  45
  46 /* NOTE:  Do not call the next three routines directly.  Use the macros
  47  * in handy.h, so that we can easily redefine everything to do tracking of
  48  * allocated hunks back to the original New to track down any memory leaks.
  49  * XXX This advice seems to be widely ignored :-(   --AD  August 1996.
  50  */
  51
  52 /* paranoid version of system's malloc() */
  53
  54 Malloc_t
  55 Perl_safesysmalloc(MEM_SIZE size)
  56 {
  57     dTHX;
  58     Malloc_t ptr;
  59 #ifdef HAS_64K_LIMIT
  60         if (size > 0xffff) {
  61             PerlIO_printf(Perl_error_log,
  62                           "Allocation too large: %lx\n", size) FLUSH;
  63             my_exit(1);
  64         }
  65 #endif /* HAS_64K_LIMIT */
  66 #ifdef DEBUGGING
  67     if ((long)size < 0)
  68         Perl_croak_nocontext("panic: malloc");
  69 #endif
  70     ptr = (Malloc_t)PerlMem_malloc(size?size:1);        /* malloc(0) is NASTY on our system */
  71     PERL_ALLOC_CHECK(ptr);
  72     DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
  73     if (ptr != Nullch)
  74         return ptr;
  75     else if (PL_nomemok)
  76         return Nullch;
  77     else {
  78         PerlIO_puts(Perl_error_log,PL_no_mem) FLUSH;
  79         my_exit(1);
  80         return Nullch;
  81     }
  82     /*NOTREACHED*/
  83 }
  84
  85 /* paranoid version of system's realloc() */
  86
  87 Malloc_t
  88 Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
  89 {
  90     dTHX;
  91     Malloc_t ptr;
  92 #if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) && !defined(PERL_MICRO)
  93     Malloc_t PerlMem_realloc();
  94 #endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */
  95
  96 #ifdef HAS_64K_LIMIT
  97     if (size > 0xffff) {
  98         PerlIO_printf(Perl_error_log,
  99                       "Reallocation too large: %lx\n", size) FLUSH;
 100         my_exit(1);
 101     }
 102 #endif /* HAS_64K_LIMIT */
 103     if (!size) {
 104         safesysfree(where);
 105         return NULL;
 106     }
 107
 108     if (!where)
 109         return safesysmalloc(size);
 110 #ifdef DEBUGGING
 111     if ((long)size < 0)
 112         Perl_croak_nocontext("panic: realloc");
 113 #endif
 114     ptr = (Malloc_t)PerlMem_realloc(where,size);
 115     PERL_ALLOC_CHECK(ptr);
 116
 117     DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++));
 118     DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
 119
 120     if (ptr != Nullch)
 121         return ptr;
 122     else if (PL_nomemok)
 123         return Nullch;
 124     else {
 125         PerlIO_puts(Perl_error_log,PL_no_mem) FLUSH;
 126         my_exit(1);
 127         return Nullch;
 128     }
 129     /*NOTREACHED*/
 130 }
 131
 132 /* safe version of system's free() */
 133
 134 Free_t
 135 Perl_safesysfree(Malloc_t where)
 136 {
 137 #ifdef PERL_IMPLICIT_SYS
 138     dTHX;
 139 #endif
 140     DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) free\n",PTR2UV(where),(long)PL_an++));
 141     if (where) {
 142         /*SUPPRESS 701*/
 143         PerlMem_free(where);
 144     }
 145 }
 146
 147 /* safe version of system's calloc() */
 148
 149 Malloc_t
 150 Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
 151 {
 152     dTHX;
 153     Malloc_t ptr;
 154
 155 #ifdef HAS_64K_LIMIT
 156     if (size * count > 0xffff) {
 157         PerlIO_printf(Perl_error_log,
 158                       "Allocation too large: %lx\n", size * count) FLUSH;
 159         my_exit(1);
 160     }
 161 #endif /* HAS_64K_LIMIT */
 162 #ifdef DEBUGGING
 163     if ((long)size < 0 || (long)count < 0)
 164         Perl_croak_nocontext("panic: calloc");
 165 #endif
 166     size *= count;
 167     ptr = (Malloc_t)PerlMem_malloc(size?size:1);        /* malloc(0) is NASTY on our system */
 168     PERL_ALLOC_CHECK(ptr);
 169     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));
 170     if (ptr != Nullch) {
 171         memset((void*)ptr, 0, size);
 172         return ptr;
 173     }
 174     else if (PL_nomemok)
 175         return Nullch;
 176     else {
 177         PerlIO_puts(Perl_error_log,PL_no_mem) FLUSH;
 178         my_exit(1);
 179         return Nullch;
 180     }
 181     /*NOTREACHED*/
 182 }
 183
 184 /* These must be defined when not using Perl's malloc for binary
 185  * compatibility */
 186
 187 #ifndef MYMALLOC
 188
 189 Malloc_t Perl_malloc (MEM_SIZE nbytes)
 190 {
 191     dTHXs;
 192     return (Malloc_t)PerlMem_malloc(nbytes);
 193 }
 194
 195 Malloc_t Perl_calloc (MEM_SIZE elements, MEM_SIZE size)
 196 {
 197     dTHXs;
 198     return (Malloc_t)PerlMem_calloc(elements, size);
 199 }
 200
 201 Malloc_t Perl_realloc (Malloc_t where, MEM_SIZE nbytes)
 202 {
 203     dTHXs;
 204     return (Malloc_t)PerlMem_realloc(where, nbytes);
 205 }
 206
 207 Free_t   Perl_mfree (Malloc_t where)
 208 {
 209     dTHXs;
 210     PerlMem_free(where);
 211 }
 212
 213 #endif
 214
 215 /* copy a string up to some (non-backslashed) delimiter, if any */
 216
 217 char *
 218 Perl_delimcpy(pTHX_ register char *to, register char *toend, register char *from, register char *fromend, register int delim, I32 *retlen)
 219 {
 220     register I32 tolen;
 221     for (tolen = 0; from < fromend; from++, tolen++) {
 222         if (*from == '\\') {
 223             if (from[1] == delim)
 224                 from++;
 225             else {
 226                 if (to < toend)
 227                     *to++ = *from;
 228                 tolen++;
 229                 from++;
 230             }
 231         }
 232         else if (*from == delim)
 233             break;
 234         if (to < toend)
 235             *to++ = *from;
 236     }
 237     if (to < toend)
 238         *to = '\0';
 239     *retlen = tolen;
 240     return from;
 241 }
 242
 243 /* return ptr to little string in big string, NULL if not found */
 244 /* This routine was donated by Corey Satten. */
 245
 246 char *
 247 Perl_instr(pTHX_ register const char *big, register const char *little)
 248 {
 249     register const char *s, *x;
 250     register I32 first;
 251
 252     if (!little)
 253         return (char*)big;
 254     first = *little++;
 255     if (!first)
 256         return (char*)big;
 257     while (*big) {
 258         if (*big++ != first)
 259             continue;
 260         for (x=big,s=little; *s; /**/ ) {
 261             if (!*x)
 262                 return Nullch;
 263             if (*s++ != *x++) {
 264                 s--;
 265                 break;
 266             }
 267         }
 268         if (!*s)
 269             return (char*)(big-1);
 270     }
 271     return Nullch;
 272 }
 273
 274 /* same as instr but allow embedded nulls */
 275
 276 char *
 277 Perl_ninstr(pTHX_ register const char *big, register const char *bigend, const char *little, const char *lend)
 278 {
 279     register const char *s, *x;
 280     register I32 first = *little;
 281     register const char *littleend = lend;
 282
 283     if (!first && little >= littleend)
 284         return (char*)big;
 285     if (bigend - big < littleend - little)
 286         return Nullch;
 287     bigend -= littleend - little++;
 288     while (big <= bigend) {
 289         if (*big++ != first)
 290             continue;
 291         for (x=big,s=little; s < littleend; /**/ ) {
 292             if (*s++ != *x++) {
 293                 s--;
 294                 break;
 295             }
 296         }
 297         if (s >= littleend)
 298             return (char*)(big-1);
 299     }
 300     return Nullch;
 301 }
 302
 303 /* reverse of the above--find last substring */
 304
 305 char *
 306 Perl_rninstr(pTHX_ register const char *big, const char *bigend, const char *little, const char *lend)
 307 {
 308     register const char *bigbeg;
 309     register const char *s, *x;
 310     register I32 first = *little;
 311     register const char *littleend = lend;
 312
 313     if (!first && little >= littleend)
 314         return (char*)bigend;
 315     bigbeg = big;
 316     big = bigend - (littleend - little++);
 317     while (big >= bigbeg) {
 318         if (*big-- != first)
 319             continue;
 320         for (x=big+2,s=little; s < littleend; /**/ ) {
 321             if (*s++ != *x++) {
 322                 s--;
 323                 break;
 324             }
 325         }
 326         if (s >= littleend)
 327             return (char*)(big+1);
 328     }
 329     return Nullch;
 330 }
 331
 332 #define FBM_TABLE_OFFSET 2      /* Number of bytes between EOS and table*/
 333
 334 /* As a space optimization, we do not compile tables for strings of length
 335    0 and 1, and for strings of length 2 unless FBMcf_TAIL.  These are
 336    special-cased in fbm_instr().
 337
 338    If FBMcf_TAIL, the table is created as if the string has a trailing \n. */
 339
 340 /*
 341 =head1 Miscellaneous Functions
 342
 343 =for apidoc fbm_compile
 344
 345 Analyses the string in order to make fast searches on it using fbm_instr()
 346 -- the Boyer-Moore algorithm.
 347
 348 =cut
 349 */
 350
 351 void
 352 Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
 353 {
 354     register U8 *s;
 355     register U8 *table;
 356     register U32 i;
 357     STRLEN len;
 358     I32 rarest = 0;
 359     U32 frequency = 256;
 360
 361     if (flags & FBMcf_TAIL) {
 362         MAGIC *mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
 363         sv_catpvn(sv, "\n", 1);         /* Taken into account in fbm_instr() */
 364         if (mg && mg->mg_len >= 0)
 365             mg->mg_len++;
 366     }
 367     s = (U8*)SvPV_force(sv, len);
 368     (void)SvUPGRADE(sv, SVt_PVBM);
 369     if (len == 0)               /* TAIL might be on a zero-length string. */
 370         return;
 371     if (len > 2) {
 372         U8 mlen;
 373         unsigned char *sb;
 374
 375         if (len > 255)
 376             mlen = 255;
 377         else
 378             mlen = (U8)len;
 379         Sv_Grow(sv, len + 256 + FBM_TABLE_OFFSET);
 380         table = (unsigned char*)(SvPVX(sv) + len + FBM_TABLE_OFFSET);
 381         s = table - 1 - FBM_TABLE_OFFSET;       /* last char */
 382         memset((void*)table, mlen, 256);
 383         table[-1] = (U8)flags;
 384         i = 0;
 385         sb = s - mlen + 1;                      /* first char (maybe) */
 386         while (s >= sb) {
 387             if (table[*s] == mlen)
 388                 table[*s] = (U8)i;
 389             s--, i++;
 390         }
 391     }
 392     sv_magic(sv, Nullsv, PERL_MAGIC_bm, Nullch, 0);     /* deep magic */
 393     SvVALID_on(sv);
 394
 395     s = (unsigned char*)(SvPVX(sv));            /* deeper magic */
 396     for (i = 0; i < len; i++) {
 397         if (PL_freq[s[i]] < frequency) {
 398             rarest = i;
 399             frequency = PL_freq[s[i]];
 400         }
 401     }
 402     BmRARE(sv) = s[rarest];
 403     BmPREVIOUS(sv) = (U16)rarest;
 404     BmUSEFUL(sv) = 100;                 /* Initial value */
 405     if (flags & FBMcf_TAIL)
 406         SvTAIL_on(sv);
 407     DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %d\n",
 408                           BmRARE(sv),BmPREVIOUS(sv)));
 409 }
 410
 411 /* If SvTAIL(littlestr), it has a fake '\n' at end. */
 412 /* If SvTAIL is actually due to \Z or \z, this gives false positives
 413    if multiline */
 414
 415 /*
 416 =for apidoc fbm_instr
 417
 418 Returns the location of the SV in the string delimited by C<str> and
 419 C<strend>.  It returns C<Nullch> if the string can't be found.  The C<sv>
 420 does not have to be fbm_compiled, but the search will not be as fast
 421 then.
 422
 423 =cut
 424 */
 425
 426 char *
 427 Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *littlestr, U32 flags)
 428 {
 429     register unsigned char *s;
 430     STRLEN l;
 431     register unsigned char *little = (unsigned char *)SvPV(littlestr,l);
 432     register STRLEN littlelen = l;
 433     register I32 multiline = flags & FBMrf_MULTILINE;
 434
 435     if ((STRLEN)(bigend - big) < littlelen) {
 436         if ( SvTAIL(littlestr)
 437              && ((STRLEN)(bigend - big) == littlelen - 1)
 438              && (littlelen == 1
 439                  || (*big == *little &&
 440                      memEQ((char *)big, (char *)little, littlelen - 1))))
 441             return (char*)big;
 442         return Nullch;
 443     }
 444
 445     if (littlelen <= 2) {               /* Special-cased */
 446
 447         if (littlelen == 1) {
 448             if (SvTAIL(littlestr) && !multiline) { /* Anchor only! */
 449                 /* Know that bigend != big.  */
 450                 if (bigend[-1] == '\n')
 451                     return (char *)(bigend - 1);
 452                 return (char *) bigend;
 453             }
 454             s = big;
 455             while (s < bigend) {
 456                 if (*s == *little)
 457                     return (char *)s;
 458                 s++;
 459             }
 460             if (SvTAIL(littlestr))
 461                 return (char *) bigend;
 462             return Nullch;
 463         }
 464         if (!littlelen)
 465             return (char*)big;          /* Cannot be SvTAIL! */
 466
 467         /* littlelen is 2 */
 468         if (SvTAIL(littlestr) && !multiline) {
 469             if (bigend[-1] == '\n' && bigend[-2] == *little)
 470                 return (char*)bigend - 2;
 471             if (bigend[-1] == *little)
 472                 return (char*)bigend - 1;
 473             return Nullch;
 474         }
 475         {
 476             /* This should be better than FBM if c1 == c2, and almost
 477                as good otherwise: maybe better since we do less indirection.
 478                And we save a lot of memory by caching no table. */
 479             register unsigned char c1 = little[0];
 480             register unsigned char c2 = little[1];
 481
 482             s = big + 1;
 483             bigend--;
 484             if (c1 != c2) {
 485                 while (s <= bigend) {
 486                     if (s[0] == c2) {
 487                         if (s[-1] == c1)
 488                             return (char*)s - 1;
 489                         s += 2;
 490                         continue;
 491                     }
 492                   next_chars:
 493                     if (s[0] == c1) {
 494                         if (s == bigend)
 495                             goto check_1char_anchor;
 496                         if (s[1] == c2)
 497                             return (char*)s;
 498                         else {
 499                             s++;
 500                             goto next_chars;
 501                         }
 502                     }
 503                     else
 504                         s += 2;
 505                 }
 506                 goto check_1char_anchor;
 507             }
 508             /* Now c1 == c2 */
 509             while (s <= bigend) {
 510                 if (s[0] == c1) {
 511                     if (s[-1] == c1)
 512                         return (char*)s - 1;
 513                     if (s == bigend)
 514                         goto check_1char_anchor;
 515                     if (s[1] == c1)
 516                         return (char*)s;
 517                     s += 3;
 518                 }
 519                 else
 520                     s += 2;
 521             }
 522         }
 523       check_1char_anchor:               /* One char and anchor! */
 524         if (SvTAIL(littlestr) && (*bigend == *little))
 525             return (char *)bigend;      /* bigend is already decremented. */
 526         return Nullch;
 527     }
 528     if (SvTAIL(littlestr) && !multiline) {      /* tail anchored? */
 529         s = bigend - littlelen;
 530         if (s >= big && bigend[-1] == '\n' && *s == *little
 531             /* Automatically of length > 2 */
 532             && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
 533         {
 534             return (char*)s;            /* how sweet it is */
 535         }
 536         if (s[1] == *little
 537             && memEQ((char*)s + 2, (char*)little + 1, littlelen - 2))
 538         {
 539             return (char*)s + 1;        /* how sweet it is */
 540         }
 541         return Nullch;
 542     }
 543     if (SvTYPE(littlestr) != SVt_PVBM || !SvVALID(littlestr)) {
 544         char *b = ninstr((char*)big,(char*)bigend,
 545                          (char*)little, (char*)little + littlelen);
 546
 547         if (!b && SvTAIL(littlestr)) {  /* Automatically multiline!  */
 548             /* Chop \n from littlestr: */
 549             s = bigend - littlelen + 1;
 550             if (*s == *little
 551                 && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
 552             {
 553                 return (char*)s;
 554             }
 555             return Nullch;
 556         }
 557         return b;
 558     }
 559
 560     {   /* Do actual FBM.  */
 561         register unsigned char *table = little + littlelen + FBM_TABLE_OFFSET;
 562         register unsigned char *oldlittle;
 563
 564         if (littlelen > (STRLEN)(bigend - big))
 565             return Nullch;
 566         --littlelen;                    /* Last char found by table lookup */
 567
 568         s = big + littlelen;
 569         little += littlelen;            /* last char */
 570         oldlittle = little;
 571         if (s < bigend) {
 572             register I32 tmp;
 573
 574           top2:
 575             /*SUPPRESS 560*/
 576             if ((tmp = table[*s])) {
 577                 if ((s += tmp) < bigend)
 578                     goto top2;
 579                 goto check_end;
 580             }
 581             else {              /* less expensive than calling strncmp() */
 582                 register unsigned char *olds = s;
 583
 584                 tmp = littlelen;
 585
 586                 while (tmp--) {
 587                     if (*--s == *--little)
 588                         continue;
 589                     s = olds + 1;       /* here we pay the price for failure */
 590                     little = oldlittle;
 591                     if (s < bigend)     /* fake up continue to outer loop */
 592                         goto top2;
 593                     goto check_end;
 594                 }
 595                 return (char *)s;
 596             }
 597         }
 598       check_end:
 599         if ( s == bigend && (table[-1] & FBMcf_TAIL)
 600              && memEQ((char *)(bigend - littlelen),
 601                       (char *)(oldlittle - littlelen), littlelen) )
 602             return (char*)bigend - littlelen;
 603         return Nullch;
 604     }
 605 }
 606
 607 /* start_shift, end_shift are positive quantities which give offsets
 608    of ends of some substring of bigstr.
 609    If `last' we want the last occurrence.
 610    old_posp is the way of communication between consequent calls if
 611    the next call needs to find the .
 612    The initial *old_posp should be -1.
 613
 614    Note that we take into account SvTAIL, so one can get extra
 615    optimizations if _ALL flag is set.
 616  */
 617
 618 /* If SvTAIL is actually due to \Z or \z, this gives false positives
 619    if PL_multiline.  In fact if !PL_multiline the authoritative answer
 620    is not supported yet. */
 621
 622 char *
 623 Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last)
 624 {
 625     register unsigned char *s, *x;
 626     register unsigned char *big;
 627     register I32 pos;
 628     register I32 previous;
 629     register I32 first;
 630     register unsigned char *little;
 631     register I32 stop_pos;
 632     register unsigned char *littleend;
 633     I32 found = 0;
 634
 635     if (*old_posp == -1
 636         ? (pos = PL_screamfirst[BmRARE(littlestr)]) < 0
 637         : (((pos = *old_posp), pos += PL_screamnext[pos]) == 0)) {
 638       cant_find:
 639         if ( BmRARE(littlestr) == '\n'
 640              && BmPREVIOUS(littlestr) == SvCUR(littlestr) - 1) {
 641             little = (unsigned char *)(SvPVX(littlestr));
 642             littleend = little + SvCUR(littlestr);
 643             first = *little++;
 644             goto check_tail;
 645         }
 646         return Nullch;
 647     }
 648
 649     little = (unsigned char *)(SvPVX(littlestr));
 650     littleend = little + SvCUR(littlestr);
 651     first = *little++;
 652     /* The value of pos we can start at: */
 653     previous = BmPREVIOUS(littlestr);
 654     big = (unsigned char *)(SvPVX(bigstr));
 655     /* The value of pos we can stop at: */
 656     stop_pos = SvCUR(bigstr) - end_shift - (SvCUR(littlestr) - 1 - previous);
 657     if (previous + start_shift > stop_pos) {
 658 /*
 659   stop_pos does not include SvTAIL in the count, so this check is incorrect
 660   (I think) - see [ID 20010618.006] and t/op/study.t. HVDS 2001/06/19
 661 */
 662 #if 0
 663         if (previous + start_shift == stop_pos + 1) /* A fake '\n'? */
 664             goto check_tail;
 665 #endif
 666         return Nullch;
 667     }
 668     while (pos < previous + start_shift) {
 669         if (!(pos += PL_screamnext[pos]))
 670             goto cant_find;
 671     }
 672     big -= previous;
 673     do {
 674         if (pos >= stop_pos) break;
 675         if (big[pos] != first)
 676             continue;
 677         for (x=big+pos+1,s=little; s < littleend; /**/ ) {
 678             if (*s++ != *x++) {
 679                 s--;
 680                 break;
 681             }
 682         }
 683         if (s == littleend) {
 684             *old_posp = pos;
 685             if (!last) return (char *)(big+pos);
 686             found = 1;
 687         }
 688     } while ( pos += PL_screamnext[pos] );
 689     if (last && found)
 690         return (char *)(big+(*old_posp));
 691   check_tail:
 692     if (!SvTAIL(littlestr) || (end_shift > 0))
 693         return Nullch;
 694     /* Ignore the trailing "\n".  This code is not microoptimized */
 695     big = (unsigned char *)(SvPVX(bigstr) + SvCUR(bigstr));
 696     stop_pos = littleend - little;      /* Actual littlestr len */
 697     if (stop_pos == 0)
 698         return (char*)big;
 699     big -= stop_pos;
 700     if (*big == first
 701         && ((stop_pos == 1) ||
 702             memEQ((char *)(big + 1), (char *)little, stop_pos - 1)))
 703         return (char*)big;
 704     return Nullch;
 705 }
 706
 707 I32
 708 Perl_ibcmp(pTHX_ const char *s1, const char *s2, register I32 len)
 709 {
 710     register U8 *a = (U8 *)s1;
 711     register U8 *b = (U8 *)s2;
 712     while (len--) {
 713         if (*a != *b && *a != PL_fold[*b])
 714             return 1;
 715         a++,b++;
 716     }
 717     return 0;
 718 }
 719
 720 I32
 721 Perl_ibcmp_locale(pTHX_ const char *s1, const char *s2, register I32 len)
 722 {
 723     register U8 *a = (U8 *)s1;
 724     register U8 *b = (U8 *)s2;
 725     while (len--) {
 726         if (*a != *b && *a != PL_fold_locale[*b])
 727             return 1;
 728         a++,b++;
 729     }
 730     return 0;
 731 }
 732
 733 /* copy a string to a safe spot */
 734
 735 /*
 736 =head1 Memory Management
 737
 738 =for apidoc savepv
 739
 740 Perl's version of C<strdup()>. Returns a pointer to a newly allocated
 741 string which is a duplicate of C<pv>. The size of the string is
 742 determined by C<strlen()>. The memory allocated for the new string can
 743 be freed with the C<Safefree()> function.
 744
 745 =cut
 746 */
 747
 748 char *
 749 Perl_savepv(pTHX_ const char *pv)
 750 {
 751     register char *newaddr = Nullch;
 752     if (pv) {
 753         New(902,newaddr,strlen(pv)+1,char);
 754         (void)strcpy(newaddr,pv);
 755     }
 756     return newaddr;
 757 }
 758
 759 /* same thing but with a known length */
 760
 761 /*
 762 =for apidoc savepvn
 763
 764 Perl's version of what C<strndup()> would be if it existed. Returns a
 765 pointer to a newly allocated string which is a duplicate of the first
 766 C<len> bytes from C<pv>. The memory allocated for the new string can be
 767 freed with the C<Safefree()> function.
 768
 769 =cut
 770 */
 771
 772 char *
 773 Perl_savepvn(pTHX_ const char *pv, register I32 len)
 774 {
 775     register char *newaddr;
 776
 777     New(903,newaddr,len+1,char);
 778     /* Give a meaning to NULL pointer mainly for the use in sv_magic() */
 779     if (pv) {
 780         Copy(pv,newaddr,len,char);      /* might not be null terminated */
 781         newaddr[len] = '\0';            /* is now */
 782     }
 783     else {
 784         Zero(newaddr,len+1,char);
 785     }
 786     return newaddr;
 787 }
 788
 789 /*
 790 =for apidoc savesharedpv
 791
 792 A version of C<savepv()> which allocates the duplicate string in memory
 793 which is shared between threads.
 794
 795 =cut
 796 */
 797 char *
 798 Perl_savesharedpv(pTHX_ const char *pv)
 799 {
 800     register char *newaddr = Nullch;
 801     if (pv) {
 802         newaddr = (char*)PerlMemShared_malloc(strlen(pv)+1);
 803         (void)strcpy(newaddr,pv);
 804     }
 805     return newaddr;
 806 }
 807
 808
 809
 810 /* the SV for Perl_form() and mess() is not kept in an arena */
 811
 812 STATIC SV *
 813 S_mess_alloc(pTHX)
 814 {
 815     SV *sv;
 816     XPVMG *any;
 817
 818     if (!PL_dirty)
 819         return sv_2mortal(newSVpvn("",0));
 820
 821     if (PL_mess_sv)
 822         return PL_mess_sv;
 823
 824     /* Create as PVMG now, to avoid any upgrading later */
 825     New(905, sv, 1, SV);
 826     Newz(905, any, 1, XPVMG);
 827     SvFLAGS(sv) = SVt_PVMG;
 828     SvANY(sv) = (void*)any;
 829     SvREFCNT(sv) = 1 << 30; /* practically infinite */
 830     PL_mess_sv = sv;
 831     return sv;
 832 }
 833
 834 #if defined(PERL_IMPLICIT_CONTEXT)
 835 char *
 836 Perl_form_nocontext(const char* pat, ...)
 837 {
 838     dTHX;
 839     char *retval;
 840     va_list args;
 841     va_start(args, pat);
 842     retval = vform(pat, &args);
 843     va_end(args);
 844     return retval;
 845 }
 846 #endif /* PERL_IMPLICIT_CONTEXT */
 847
 848 /*
 849 =head1 Miscellaneous Functions
 850 =for apidoc form
 851
 852 Takes a sprintf-style format pattern and conventional
 853 (non-SV) arguments and returns the formatted string.
 854
 855     (char *) Perl_form(pTHX_ const char* pat, ...)
 856
 857 can be used any place a string (char *) is required:
 858
 859     char * s = Perl_form("%d.%d",major,minor);
 860
 861 Uses a single private buffer so if you want to format several strings you
 862 must explicitly copy the earlier strings away (and free the copies when you
 863 are done).
 864
 865 =cut
 866 */
 867
 868 char *
 869 Perl_form(pTHX_ const char* pat, ...)
 870 {
 871     char *retval;
 872     va_list args;
 873     va_start(args, pat);
 874     retval = vform(pat, &args);
 875     va_end(args);
 876     return retval;
 877 }
 878
 879 char *
 880 Perl_vform(pTHX_ const char *pat, va_list *args)
 881 {
 882     SV *sv = mess_alloc();
 883     sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
 884     return SvPVX(sv);
 885 }
 886
 887 #if defined(PERL_IMPLICIT_CONTEXT)
 888 SV *
 889 Perl_mess_nocontext(const char *pat, ...)
 890 {
 891     dTHX;
 892     SV *retval;
 893     va_list args;
 894     va_start(args, pat);
 895     retval = vmess(pat, &args);
 896     va_end(args);
 897     return retval;
 898 }
 899 #endif /* PERL_IMPLICIT_CONTEXT */
 900
 901 SV *
 902 Perl_mess(pTHX_ const char *pat, ...)
 903 {
 904     SV *retval;
 905     va_list args;
 906     va_start(args, pat);
 907     retval = vmess(pat, &args);
 908     va_end(args);
 909     return retval;
 910 }
 911
 912 STATIC COP*
 913 S_closest_cop(pTHX_ COP *cop, OP *o)
 914 {
 915     /* Look for PL_op starting from o.  cop is the last COP we've seen. */
 916
 917     if (!o || o == PL_op) return cop;
 918
 919     if (o->op_flags & OPf_KIDS) {
 920         OP *kid;
 921         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
 922         {
 923             COP *new_cop;
 924
 925             /* If the OP_NEXTSTATE has been optimised away we can still use it
 926              * the get the file and line number. */
 927
 928             if (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE)
 929                 cop = (COP *)kid;
 930
 931             /* Keep searching, and return when we've found something. */
 932
 933             new_cop = closest_cop(cop, kid);
 934             if (new_cop) return new_cop;
 935         }
 936     }
 937
 938     /* Nothing found. */
 939
 940     return 0;
 941 }
 942
 943 SV *
 944 Perl_vmess(pTHX_ const char *pat, va_list *args)
 945 {
 946     SV *sv = mess_alloc();
 947     static char dgd[] = " during global destruction.\n";
 948     COP *cop;
 949
 950     sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
 951     if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
 952
 953         /*
 954          * Try and find the file and line for PL_op.  This will usually be
 955          * PL_curcop, but it might be a cop that has been optimised away.  We
 956          * can try to find such a cop by searching through the optree starting
 957          * from the sibling of PL_curcop.
 958          */
 959
 960         cop = closest_cop(PL_curcop, PL_curcop->op_sibling);
 961         if (!cop) cop = PL_curcop;
 962
 963         if (CopLINE(cop))
 964             Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf,
 965             OutCopFILE(cop), (IV)CopLINE(cop));
 966         if (GvIO(PL_last_in_gv) && IoLINES(GvIOp(PL_last_in_gv))) {
 967             bool line_mode = (RsSIMPLE(PL_rs) &&
 968                               SvCUR(PL_rs) == 1 && *SvPVX(PL_rs) == '\n');
 969             Perl_sv_catpvf(aTHX_ sv, ", <%s> %s %"IVdf,
 970                            PL_last_in_gv == PL_argvgv ?
 971                            "" : GvNAME(PL_last_in_gv),
 972                            line_mode ? "line" : "chunk",
 973                            (IV)IoLINES(GvIOp(PL_last_in_gv)));
 974         }
 975 #ifdef USE_5005THREADS
 976         if (thr->tid)
 977             Perl_sv_catpvf(aTHX_ sv, " thread %ld", thr->tid);
 978 #endif
 979         sv_catpv(sv, PL_dirty ? dgd : ".\n");
 980     }
 981     return sv;
 982 }
 983
 984 void
 985 Perl_write_to_stderr(pTHX_ const char* message, int msglen)
 986 {
 987     IO *io;
 988     MAGIC *mg;
 989
 990     if (PL_stderrgv && SvREFCNT(PL_stderrgv)
 991         && (io = GvIO(PL_stderrgv))
 992         && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
 993     {
 994         dSP;
 995         ENTER;
 996         SAVETMPS;
 997
 998         save_re_context();
 999         SAVESPTR(PL_stderrgv);
1000         PL_stderrgv = Nullgv;
1001
1002         PUSHSTACKi(PERLSI_MAGIC);
1003
1004         PUSHMARK(SP);
1005         EXTEND(SP,2);
1006         PUSHs(SvTIED_obj((SV*)io, mg));
1007         PUSHs(sv_2mortal(newSVpvn(message, msglen)));
1008         PUTBACK;
1009         call_method("PRINT", G_SCALAR);
1010
1011         POPSTACK;
1012         FREETMPS;
1013         LEAVE;
1014     }
1015     else {
1016 #ifdef USE_SFIO
1017         /* SFIO can really mess with your errno */
1018         int e = errno;
1019 #endif
1020         PerlIO *serr = Perl_error_log;
1021
1022         PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
1023         (void)PerlIO_flush(serr);
1024 #ifdef USE_SFIO
1025         errno = e;
1026 #endif
1027     }
1028 }
1029
1030 OP *
1031 Perl_vdie(pTHX_ const char* pat, va_list *args)
1032 {
1033     char *message;
1034     int was_in_eval = PL_in_eval;
1035     HV *stash;
1036     GV *gv;
1037     CV *cv;
1038     SV *msv;
1039     STRLEN msglen;
1040
1041     DEBUG_S(PerlIO_printf(Perl_debug_log,
1042                           "%p: die: curstack = %p, mainstack = %p\n",
1043                           thr, PL_curstack, PL_mainstack));
1044
1045     if (pat) {
1046         msv = vmess(pat, args);
1047         if (PL_errors && SvCUR(PL_errors)) {
1048             sv_catsv(PL_errors, msv);
1049             message = SvPV(PL_errors, msglen);
1050             SvCUR_set(PL_errors, 0);
1051         }
1052         else
1053             message = SvPV(msv,msglen);
1054     }
1055     else {
1056         message = Nullch;
1057         msglen = 0;
1058     }
1059
1060     DEBUG_S(PerlIO_printf(Perl_debug_log,
1061                           "%p: die: message = %s\ndiehook = %p\n",
1062                           thr, message, PL_diehook));
1063     if (PL_diehook) {
1064         /* sv_2cv might call Perl_croak() */
1065         SV *olddiehook = PL_diehook;
1066         ENTER;
1067         SAVESPTR(PL_diehook);
1068         PL_diehook = Nullsv;
1069         cv = sv_2cv(olddiehook, &stash, &gv, 0);
1070         LEAVE;
1071         if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1072             dSP;
1073             SV *msg;
1074
1075             ENTER;
1076             save_re_context();
1077             if (message) {
1078                 msg = newSVpvn(message, msglen);
1079                 SvREADONLY_on(msg);
1080                 SAVEFREESV(msg);
1081             }
1082             else {
1083                 msg = ERRSV;
1084             }
1085
1086             PUSHSTACKi(PERLSI_DIEHOOK);
1087             PUSHMARK(SP);
1088             XPUSHs(msg);
1089             PUTBACK;
1090             call_sv((SV*)cv, G_DISCARD);
1091             POPSTACK;
1092             LEAVE;
1093         }
1094     }
1095
1096     PL_restartop = die_where(message, msglen);
1097     DEBUG_S(PerlIO_printf(Perl_debug_log,
1098           "%p: die: restartop = %p, was_in_eval = %d, top_env = %p\n",
1099           thr, PL_restartop, was_in_eval, PL_top_env));
1100     if ((!PL_restartop && was_in_eval) || PL_top_env->je_prev)
1101         JMPENV_JUMP(3);
1102     return PL_restartop;
1103 }
1104
1105 #if defined(PERL_IMPLICIT_CONTEXT)
1106 OP *
1107 Perl_die_nocontext(const char* pat, ...)
1108 {
1109     dTHX;
1110     OP *o;
1111     va_list args;
1112     va_start(args, pat);
1113     o = vdie(pat, &args);
1114     va_end(args);
1115     return o;
1116 }
1117 #endif /* PERL_IMPLICIT_CONTEXT */
1118
1119 OP *
1120 Perl_die(pTHX_ const char* pat, ...)
1121 {
1122     OP *o;
1123     va_list args;
1124     va_start(args, pat);
1125     o = vdie(pat, &args);
1126     va_end(args);
1127     return o;
1128 }
1129
1130 void
1131 Perl_vcroak(pTHX_ const char* pat, va_list *args)
1132 {
1133     char *message;
1134     HV *stash;
1135     GV *gv;
1136     CV *cv;
1137     SV *msv;
1138     STRLEN msglen;
1139
1140     if (pat) {
1141         msv = vmess(pat, args);
1142         if (PL_errors && SvCUR(PL_errors)) {
1143             sv_catsv(PL_errors, msv);
1144             message = SvPV(PL_errors, msglen);
1145             SvCUR_set(PL_errors, 0);
1146         }
1147         else
1148             message = SvPV(msv,msglen);
1149     }
1150     else {
1151         message = Nullch;
1152         msglen = 0;
1153     }
1154
1155     DEBUG_S(PerlIO_printf(Perl_debug_log, "croak: 0x%"UVxf" %s",
1156                           PTR2UV(thr), message));
1157
1158     if (PL_diehook) {
1159         /* sv_2cv might call Perl_croak() */
1160         SV *olddiehook = PL_diehook;
1161         ENTER;
1162         SAVESPTR(PL_diehook);
1163         PL_diehook = Nullsv;
1164         cv = sv_2cv(olddiehook, &stash, &gv, 0);
1165         LEAVE;
1166         if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1167             dSP;
1168             SV *msg;
1169
1170             ENTER;
1171             save_re_context();
1172             if (message) {
1173                 msg = newSVpvn(message, msglen);
1174                 SvREADONLY_on(msg);
1175                 SAVEFREESV(msg);
1176             }
1177             else {
1178                 msg = ERRSV;
1179             }
1180
1181             PUSHSTACKi(PERLSI_DIEHOOK);
1182             PUSHMARK(SP);
1183             XPUSHs(msg);
1184             PUTBACK;
1185             call_sv((SV*)cv, G_DISCARD);
1186             POPSTACK;
1187             LEAVE;
1188         }
1189     }
1190     if (PL_in_eval) {
1191         PL_restartop = die_where(message, msglen);
1192         JMPENV_JUMP(3);
1193     }
1194     else if (!message)
1195         message = SvPVx(ERRSV, msglen);
1196
1197     write_to_stderr(message, msglen);
1198     my_failure_exit();
1199 }
1200
1201 #if defined(PERL_IMPLICIT_CONTEXT)
1202 void
1203 Perl_croak_nocontext(const char *pat, ...)
1204 {
1205     dTHX;
1206     va_list args;
1207     va_start(args, pat);
1208     vcroak(pat, &args);
1209     /* NOTREACHED */
1210     va_end(args);
1211 }
1212 #endif /* PERL_IMPLICIT_CONTEXT */
1213
1214 /*
1215 =head1 Warning and Dieing
1216
1217 =for apidoc croak
1218
1219 This is the XSUB-writer's interface to Perl's C<die> function.
1220 Normally use this function the same way you use the C C<printf>
1221 function.  See C<warn>.
1222
1223 If you want to throw an exception object, assign the object to
1224 C<$@> and then pass C<Nullch> to croak():
1225
1226    errsv = get_sv("@", TRUE);
1227    sv_setsv(errsv, exception_object);
1228    croak(Nullch);
1229
1230 =cut
1231 */
1232
1233 void
1234 Perl_croak(pTHX_ const char *pat, ...)
1235 {
1236     va_list args;
1237     va_start(args, pat);
1238     vcroak(pat, &args);
1239     /* NOTREACHED */
1240     va_end(args);
1241 }
1242
1243 void
1244 Perl_vwarn(pTHX_ const char* pat, va_list *args)
1245 {
1246     char *message;
1247     HV *stash;
1248     GV *gv;
1249     CV *cv;
1250     SV *msv;
1251     STRLEN msglen;
1252
1253     msv = vmess(pat, args);
1254     message = SvPV(msv, msglen);
1255
1256     if (PL_warnhook) {
1257         /* sv_2cv might call Perl_warn() */
1258         SV *oldwarnhook = PL_warnhook;
1259         ENTER;
1260         SAVESPTR(PL_warnhook);
1261         PL_warnhook = Nullsv;
1262         cv = sv_2cv(oldwarnhook, &stash, &gv, 0);
1263         LEAVE;
1264         if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1265             dSP;
1266             SV *msg;
1267
1268             ENTER;
1269             save_re_context();
1270             msg = newSVpvn(message, msglen);
1271             SvREADONLY_on(msg);
1272             SAVEFREESV(msg);
1273
1274             PUSHSTACKi(PERLSI_WARNHOOK);
1275             PUSHMARK(SP);
1276             XPUSHs(msg);
1277             PUTBACK;
1278             call_sv((SV*)cv, G_DISCARD);
1279             POPSTACK;
1280             LEAVE;
1281             return;
1282         }
1283     }
1284
1285     write_to_stderr(message, msglen);
1286 }
1287
1288 #if defined(PERL_IMPLICIT_CONTEXT)
1289 void
1290 Perl_warn_nocontext(const char *pat, ...)
1291 {
1292     dTHX;
1293     va_list args;
1294     va_start(args, pat);
1295     vwarn(pat, &args);
1296     va_end(args);
1297 }
1298 #endif /* PERL_IMPLICIT_CONTEXT */
1299
1300 /*
1301 =for apidoc warn
1302
1303 This is the XSUB-writer's interface to Perl's C<warn> function.  Use this
1304 function the same way you use the C C<printf> function.  See
1305 C<croak>.
1306
1307 =cut
1308 */
1309
1310 void
1311 Perl_warn(pTHX_ const char *pat, ...)
1312 {
1313     va_list args;
1314     va_start(args, pat);
1315     vwarn(pat, &args);
1316     va_end(args);
1317 }
1318
1319 #if defined(PERL_IMPLICIT_CONTEXT)
1320 void
1321 Perl_warner_nocontext(U32 err, const char *pat, ...)
1322 {
1323     dTHX;
1324     va_list args;
1325     va_start(args, pat);
1326     vwarner(err, pat, &args);
1327     va_end(args);
1328 }
1329 #endif /* PERL_IMPLICIT_CONTEXT */
1330
1331 void
1332 Perl_warner(pTHX_ U32  err, const char* pat,...)
1333 {
1334     va_list args;
1335     va_start(args, pat);
1336     vwarner(err, pat, &args);
1337     va_end(args);
1338 }
1339
1340 void
1341 Perl_vwarner(pTHX_ U32  err, const char* pat, va_list* args)
1342 {
1343     char *message;
1344     HV *stash;
1345     GV *gv;
1346     CV *cv;
1347     SV *msv;
1348     STRLEN msglen;
1349
1350     msv = vmess(pat, args);
1351     message = SvPV(msv, msglen);
1352
1353     if (ckDEAD(err)) {
1354 #ifdef USE_5005THREADS
1355         DEBUG_S(PerlIO_printf(Perl_debug_log, "croak: 0x%"UVxf" %s", PTR2UV(thr), message));
1356 #endif /* USE_5005THREADS */
1357         if (PL_diehook) {
1358             /* sv_2cv might call Perl_croak() */
1359             SV *olddiehook = PL_diehook;
1360             ENTER;
1361             SAVESPTR(PL_diehook);
1362             PL_diehook = Nullsv;
1363             cv = sv_2cv(olddiehook, &stash, &gv, 0);
1364             LEAVE;
1365             if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1366                 dSP;
1367                 SV *msg;
1368
1369                 ENTER;
1370                 save_re_context();
1371                 msg = newSVpvn(message, msglen);
1372                 SvREADONLY_on(msg);
1373                 SAVEFREESV(msg);
1374
1375                 PUSHSTACKi(PERLSI_DIEHOOK);
1376                 PUSHMARK(sp);
1377                 XPUSHs(msg);
1378                 PUTBACK;
1379                 call_sv((SV*)cv, G_DISCARD);
1380                 POPSTACK;
1381                 LEAVE;
1382             }
1383         }
1384         if (PL_in_eval) {
1385             PL_restartop = die_where(message, msglen);
1386             JMPENV_JUMP(3);
1387         }
1388         write_to_stderr(message, msglen);
1389         my_failure_exit();
1390     }
1391     else {
1392         if (PL_warnhook) {
1393             /* sv_2cv might call Perl_warn() */
1394             SV *oldwarnhook = PL_warnhook;
1395             ENTER;
1396             SAVESPTR(PL_warnhook);
1397             PL_warnhook = Nullsv;
1398             cv = sv_2cv(oldwarnhook, &stash, &gv, 0);
1399             LEAVE;
1400             if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1401                 dSP;
1402                 SV *msg;
1403
1404                 ENTER;
1405                 save_re_context();
1406                 msg = newSVpvn(message, msglen);
1407                 SvREADONLY_on(msg);
1408                 SAVEFREESV(msg);
1409
1410                 PUSHSTACKi(PERLSI_WARNHOOK);
1411                 PUSHMARK(sp);
1412                 XPUSHs(msg);
1413                 PUTBACK;
1414                 call_sv((SV*)cv, G_DISCARD);
1415                 POPSTACK;
1416                 LEAVE;
1417                 return;
1418             }
1419         }
1420         write_to_stderr(message, msglen);
1421     }
1422 }
1423
1424 /* since we've already done strlen() for both nam and val
1425  * we can use that info to make things faster than
1426  * sprintf(s, "%s=%s", nam, val)
1427  */
1428 #define my_setenv_format(s, nam, nlen, val, vlen) \
1429    Copy(nam, s, nlen, char); \
1430    *(s+nlen) = '='; \
1431    Copy(val, s+(nlen+1), vlen, char); \
1432    *(s+(nlen+1+vlen)) = '\0'
1433
1434 #ifdef USE_ENVIRON_ARRAY
1435        /* VMS' my_setenv() is in vms.c */
1436 #if !defined(WIN32) && !defined(NETWARE)
1437 void
1438 Perl_my_setenv(pTHX_ char *nam, char *val)
1439 {
1440 #ifdef USE_ITHREADS
1441   /* only parent thread can modify process environment */
1442   if (PL_curinterp == aTHX)
1443 #endif
1444   {
1445 #ifndef PERL_USE_SAFE_PUTENV
1446     /* most putenv()s leak, so we manipulate environ directly */
1447     register I32 i=setenv_getix(nam);           /* where does it go? */
1448     int nlen, vlen;
1449
1450     if (environ == PL_origenviron) {    /* need we copy environment? */
1451         I32 j;
1452         I32 max;
1453         char **tmpenv;
1454
1455         /*SUPPRESS 530*/
1456         for (max = i; environ[max]; max++) ;
1457         tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*));
1458         for (j=0; j<max; j++) {         /* copy environment */
1459             int len = strlen(environ[j]);
1460             tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char));
1461             Copy(environ[j], tmpenv[j], len+1, char);
1462         }
1463         tmpenv[max] = Nullch;
1464         environ = tmpenv;               /* tell exec where it is now */
1465     }
1466     if (!val) {
1467         safesysfree(environ[i]);
1468         while (environ[i]) {
1469             environ[i] = environ[i+1];
1470             i++;
1471         }
1472         return;
1473     }
1474     if (!environ[i]) {                  /* does not exist yet */
1475         environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
1476         environ[i+1] = Nullch;  /* make sure it's null terminated */
1477     }
1478     else
1479         safesysfree(environ[i]);
1480     nlen = strlen(nam);
1481     vlen = strlen(val);
1482
1483     environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char));
1484     /* all that work just for this */
1485     my_setenv_format(environ[i], nam, nlen, val, vlen);
1486
1487 #else   /* PERL_USE_SAFE_PUTENV */
1488 #   if defined(__CYGWIN__) || defined( EPOC)
1489     setenv(nam, val, 1);
1490 #   else
1491     char *new_env;
1492     int nlen = strlen(nam), vlen;
1493     if (!val) {
1494         val = "";
1495     }
1496     vlen = strlen(val);
1497     new_env = (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
1498     /* all that work just for this */
1499     my_setenv_format(new_env, nam, nlen, val, vlen);
1500     (void)putenv(new_env);
1501 #   endif /* __CYGWIN__ */
1502 #endif  /* PERL_USE_SAFE_PUTENV */
1503   }
1504 }
1505
1506 #else /* WIN32 || NETWARE */
1507
1508 void
1509 Perl_my_setenv(pTHX_ char *nam,char *val)
1510 {
1511     register char *envstr;
1512     int nlen = strlen(nam), vlen;
1513
1514     if (!val) {
1515         val = "";
1516     }
1517     vlen = strlen(val);
1518     New(904, envstr, nlen+vlen+2, char);
1519     my_setenv_format(envstr, nam, nlen, val, vlen);
1520     (void)PerlEnv_putenv(envstr);
1521     Safefree(envstr);
1522 }
1523
1524 #endif /* WIN32 || NETWARE */
1525
1526 #ifndef PERL_MICRO
1527 I32
1528 Perl_setenv_getix(pTHX_ char *nam)
1529 {
1530     register I32 i, len = strlen(nam);
1531
1532     for (i = 0; environ[i]; i++) {
1533         if (
1534 #ifdef WIN32
1535             strnicmp(environ[i],nam,len) == 0
1536 #else
1537             strnEQ(environ[i],nam,len)
1538 #endif
1539             && environ[i][len] == '=')
1540             break;                      /* strnEQ must come first to avoid */
1541     }                                   /* potential SEGV's */
1542     return i;
1543 }
1544 #endif /* !PERL_MICRO */
1545
1546 #endif /* !VMS && !EPOC*/
1547
1548 #ifdef UNLINK_ALL_VERSIONS
1549 I32
1550 Perl_unlnk(pTHX_ char *f)       /* unlink all versions of a file */
1551 {
1552     I32 i;
1553
1554     for (i = 0; PerlLIO_unlink(f) >= 0; i++) ;
1555     return i ? 0 : -1;
1556 }
1557 #endif
1558
1559 /* this is a drop-in replacement for bcopy() */
1560 #if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY))
1561 char *
1562 Perl_my_bcopy(register const char *from,register char *to,register I32 len)
1563 {
1564     char *retval = to;
1565
1566     if (from - to >= 0) {
1567         while (len--)
1568             *to++ = *from++;
1569     }
1570     else {
1571         to += len;
1572         from += len;
1573         while (len--)
1574             *(--to) = *(--from);
1575     }
1576     return retval;
1577 }
1578 #endif
1579
1580 /* this is a drop-in replacement for memset() */
1581 #ifndef HAS_MEMSET
1582 void *
1583 Perl_my_memset(register char *loc, register I32 ch, register I32 len)
1584 {
1585     char *retval = loc;
1586
1587     while (len--)
1588         *loc++ = ch;
1589     return retval;
1590 }
1591 #endif
1592
1593 /* this is a drop-in replacement for bzero() */
1594 #if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
1595 char *
1596 Perl_my_bzero(register char *loc, register I32 len)
1597 {
1598     char *retval = loc;
1599
1600     while (len--)
1601         *loc++ = 0;
1602     return retval;
1603 }
1604 #endif
1605
1606 /* this is a drop-in replacement for memcmp() */
1607 #if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
1608 I32
1609 Perl_my_memcmp(const char *s1, const char *s2, register I32 len)
1610 {
1611     register U8 *a = (U8 *)s1;
1612     register U8 *b = (U8 *)s2;
1613     register I32 tmp;
1614
1615     while (len--) {
1616         if (tmp = *a++ - *b++)
1617             return tmp;
1618     }
1619     return 0;
1620 }
1621 #endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */
1622
1623 #ifndef HAS_VPRINTF
1624
1625 #ifdef USE_CHAR_VSPRINTF
1626 char *
1627 #else
1628 int
1629 #endif
1630 vsprintf(char *dest, const char *pat, char *args)
1631 {
1632     FILE fakebuf;
1633
1634     fakebuf._ptr = dest;
1635     fakebuf._cnt = 32767;
1636 #ifndef _IOSTRG
1637 #define _IOSTRG 0
1638 #endif
1639     fakebuf._flag = _IOWRT|_IOSTRG;
1640     _doprnt(pat, args, &fakebuf);       /* what a kludge */
1641     (void)putc('\0', &fakebuf);
1642 #ifdef USE_CHAR_VSPRINTF
1643     return(dest);
1644 #else
1645     return 0;           /* perl doesn't use return value */
1646 #endif
1647 }
1648
1649 #endif /* HAS_VPRINTF */
1650
1651 #ifdef MYSWAP
1652 #if BYTEORDER != 0x4321
1653 short
1654 Perl_my_swap(pTHX_ short s)
1655 {
1656 #if (BYTEORDER & 1) == 0
1657     short result;
1658
1659     result = ((s & 255) << 8) + ((s >> 8) & 255);
1660     return result;
1661 #else
1662     return s;
1663 #endif
1664 }
1665
1666 long
1667 Perl_my_htonl(pTHX_ long l)
1668 {
1669     union {
1670         long result;
1671         char c[sizeof(long)];
1672     } u;
1673
1674 #if BYTEORDER == 0x1234
1675     u.c[0] = (l >> 24) & 255;
1676     u.c[1] = (l >> 16) & 255;
1677     u.c[2] = (l >> 8) & 255;
1678     u.c[3] = l & 255;
1679     return u.result;
1680 #else
1681 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
1682     Perl_croak(aTHX_ "Unknown BYTEORDER\n");
1683 #else
1684     register I32 o;
1685     register I32 s;
1686
1687     for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
1688         u.c[o & 0xf] = (l >> s) & 255;
1689     }
1690     return u.result;
1691 #endif
1692 #endif
1693 }
1694
1695 long
1696 Perl_my_ntohl(pTHX_ long l)
1697 {
1698     union {
1699         long l;
1700         char c[sizeof(long)];
1701     } u;
1702
1703 #if BYTEORDER == 0x1234
1704     u.c[0] = (l >> 24) & 255;
1705     u.c[1] = (l >> 16) & 255;
1706     u.c[2] = (l >> 8) & 255;
1707     u.c[3] = l & 255;
1708     return u.l;
1709 #else
1710 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
1711     Perl_croak(aTHX_ "Unknown BYTEORDER\n");
1712 #else
1713     register I32 o;
1714     register I32 s;
1715
1716     u.l = l;
1717     l = 0;
1718     for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
1719         l |= (u.c[o & 0xf] & 255) << s;
1720     }
1721     return l;
1722 #endif
1723 #endif
1724 }
1725
1726 #endif /* BYTEORDER != 0x4321 */
1727 #endif /* MYSWAP */
1728
1729 /*
1730  * Little-endian byte order functions - 'v' for 'VAX', or 'reVerse'.
1731  * If these functions are defined,
1732  * the BYTEORDER is neither 0x1234 nor 0x4321.
1733  * However, this is not assumed.
1734  * -DWS
1735  */
1736
1737 #define HTOV(name,type)                                         \
1738         type                                                    \
1739         name (register type n)                                  \
1740         {                                                       \
1741             union {                                             \
1742                 type value;                                     \
1743                 char c[sizeof(type)];                           \
1744             } u;                                                \
1745             register I32 i;                                     \
1746             register I32 s;                                     \
1747             for (i = 0, s = 0; i < sizeof(u.c); i++, s += 8) {  \
1748                 u.c[i] = (n >> s) & 0xFF;                       \
1749             }                                                   \
1750             return u.value;                                     \
1751         }
1752
1753 #define VTOH(name,type)                                         \
1754         type                                                    \
1755         name (register type n)                                  \
1756         {                                                       \
1757             union {                                             \
1758                 type value;                                     \
1759                 char c[sizeof(type)];                           \
1760             } u;                                                \
1761             register I32 i;                                     \
1762             register I32 s;                                     \
1763             u.value = n;                                        \
1764             n = 0;                                              \
1765             for (i = 0, s = 0; i < sizeof(u.c); i++, s += 8) {  \
1766                 n += (u.c[i] & 0xFF) << s;                      \
1767             }                                                   \
1768             return n;                                           \
1769         }
1770
1771 #if defined(HAS_HTOVS) && !defined(htovs)
1772 HTOV(htovs,short)
1773 #endif
1774 #if defined(HAS_HTOVL) && !defined(htovl)
1775 HTOV(htovl,long)
1776 #endif
1777 #if defined(HAS_VTOHS) && !defined(vtohs)
1778 VTOH(vtohs,short)
1779 #endif
1780 #if defined(HAS_VTOHL) && !defined(vtohl)
1781 VTOH(vtohl,long)
1782 #endif
1783
1784 PerlIO *
1785 Perl_my_popen_list(pTHX_ char *mode, int n, SV **args)
1786 {
1787 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) && !defined(NETWARE)
1788     int p[2];
1789     register I32 This, that;
1790     register Pid_t pid;
1791     SV *sv;
1792     I32 did_pipes = 0;
1793     int pp[2];
1794
1795     PERL_FLUSHALL_FOR_CHILD;
1796     This = (*mode == 'w');
1797     that = !This;
1798     if (PL_tainting) {
1799         taint_env();
1800         taint_proper("Insecure %s%s", "EXEC");
1801     }
1802     if (PerlProc_pipe(p) < 0)
1803         return Nullfp;
1804     /* Try for another pipe pair for error return */
1805     if (PerlProc_pipe(pp) >= 0)
1806         did_pipes = 1;
1807     while ((pid = PerlProc_fork()) < 0) {
1808         if (errno != EAGAIN) {
1809             PerlLIO_close(p[This]);
1810             PerlLIO_close(p[that]);
1811             if (did_pipes) {
1812                 PerlLIO_close(pp[0]);
1813                 PerlLIO_close(pp[1]);
1814             }
1815             return Nullfp;
1816         }
1817         sleep(5);
1818     }
1819     if (pid == 0) {
1820         /* Child */
1821 #undef THIS
1822 #undef THAT
1823 #define THIS that
1824 #define THAT This
1825         /* Close parent's end of error status pipe (if any) */
1826         if (did_pipes) {
1827             PerlLIO_close(pp[0]);
1828 #if defined(HAS_FCNTL) && defined(F_SETFD)
1829             /* Close error pipe automatically if exec works */
1830             fcntl(pp[1], F_SETFD, FD_CLOEXEC);
1831 #endif
1832         }
1833         /* Now dup our end of _the_ pipe to right position */
1834         if (p[THIS] != (*mode == 'r')) {
1835             PerlLIO_dup2(p[THIS], *mode == 'r');
1836             PerlLIO_close(p[THIS]);
1837             if (p[THAT] != (*mode == 'r'))      /* if dup2() didn't close it */
1838                 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
1839         }
1840         else
1841             PerlLIO_close(p[THAT]);     /* close parent's end of _the_ pipe */
1842 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
1843         /* No automatic close - do it by hand */
1844 #  ifndef NOFILE
1845 #  define NOFILE 20
1846 #  endif
1847         {
1848             int fd;
1849
1850             for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) {
1851                 if (fd != pp[1])
1852                     PerlLIO_close(fd);
1853             }
1854         }
1855 #endif
1856         do_aexec5(Nullsv, args-1, args-1+n, pp[1], did_pipes);
1857         PerlProc__exit(1);
1858 #undef THIS
1859 #undef THAT
1860     }
1861     /* Parent */
1862     do_execfree();      /* free any memory malloced by child on fork */
1863     if (did_pipes)
1864         PerlLIO_close(pp[1]);
1865     /* Keep the lower of the two fd numbers */
1866     if (p[that] < p[This]) {
1867         PerlLIO_dup2(p[This], p[that]);
1868         PerlLIO_close(p[This]);
1869         p[This] = p[that];
1870     }
1871     else
1872         PerlLIO_close(p[that]);         /* close child's end of pipe */
1873
1874     LOCK_FDPID_MUTEX;
1875     sv = *av_fetch(PL_fdpid,p[This],TRUE);
1876     UNLOCK_FDPID_MUTEX;
1877     (void)SvUPGRADE(sv,SVt_IV);
1878     SvIVX(sv) = pid;
1879     PL_forkprocess = pid;
1880     /* If we managed to get status pipe check for exec fail */
1881     if (did_pipes && pid > 0) {
1882         int errkid;
1883         int n = 0, n1;
1884
1885         while (n < sizeof(int)) {
1886             n1 = PerlLIO_read(pp[0],
1887                               (void*)(((char*)&errkid)+n),
1888                               (sizeof(int)) - n);
1889             if (n1 <= 0)
1890                 break;
1891             n += n1;
1892         }
1893         PerlLIO_close(pp[0]);
1894         did_pipes = 0;
1895         if (n) {                        /* Error */
1896             int pid2, status;
1897             PerlLIO_close(p[This]);
1898             if (n != sizeof(int))
1899                 Perl_croak(aTHX_ "panic: kid popen errno read");
1900             do {
1901                 pid2 = wait4pid(pid, &status, 0);
1902             } while (pid2 == -1 && errno == EINTR);
1903             errno = errkid;             /* Propagate errno from kid */
1904             return Nullfp;
1905         }
1906     }
1907     if (did_pipes)
1908          PerlLIO_close(pp[0]);
1909     return PerlIO_fdopen(p[This], mode);
1910 #else
1911     Perl_croak(aTHX_ "List form of piped open not implemented");
1912     return (PerlIO *) NULL;
1913 #endif
1914 }
1915
1916     /* VMS' my_popen() is in VMS.c, same with OS/2. */
1917 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
1918 PerlIO *
1919 Perl_my_popen(pTHX_ char *cmd, char *mode)
1920 {
1921     int p[2];
1922     register I32 This, that;
1923     register Pid_t pid;
1924     SV *sv;
1925     I32 doexec = strNE(cmd,"-");
1926     I32 did_pipes = 0;
1927     int pp[2];
1928
1929     PERL_FLUSHALL_FOR_CHILD;
1930 #ifdef OS2
1931     if (doexec) {
1932         return my_syspopen(aTHX_ cmd,mode);
1933     }
1934 #endif
1935     This = (*mode == 'w');
1936     that = !This;
1937     if (doexec && PL_tainting) {
1938         taint_env();
1939         taint_proper("Insecure %s%s", "EXEC");
1940     }
1941     if (PerlProc_pipe(p) < 0)
1942         return Nullfp;
1943     if (doexec && PerlProc_pipe(pp) >= 0)
1944         did_pipes = 1;
1945     while ((pid = PerlProc_fork()) < 0) {
1946         if (errno != EAGAIN) {
1947             PerlLIO_close(p[This]);
1948             PerlLIO_close(p[that]);
1949             if (did_pipes) {
1950                 PerlLIO_close(pp[0]);
1951                 PerlLIO_close(pp[1]);
1952             }
1953             if (!doexec)
1954                 Perl_croak(aTHX_ "Can't fork");
1955             return Nullfp;
1956         }
1957         sleep(5);
1958     }
1959     if (pid == 0) {
1960         GV* tmpgv;
1961
1962 #undef THIS
1963 #undef THAT
1964 #define THIS that
1965 #define THAT This
1966         if (did_pipes) {
1967             PerlLIO_close(pp[0]);
1968 #if defined(HAS_FCNTL) && defined(F_SETFD)
1969             fcntl(pp[1], F_SETFD, FD_CLOEXEC);
1970 #endif
1971         }
1972         if (p[THIS] != (*mode == 'r')) {
1973             PerlLIO_dup2(p[THIS], *mode == 'r');
1974             PerlLIO_close(p[THIS]);
1975             if (p[THAT] != (*mode == 'r'))      /* if dup2() didn't close it */
1976                 PerlLIO_close(p[THAT]);
1977         }
1978         else
1979             PerlLIO_close(p[THAT]);
1980 #ifndef OS2
1981         if (doexec) {
1982 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
1983             int fd;
1984
1985 #ifndef NOFILE
1986 #define NOFILE 20
1987 #endif
1988             {
1989                 int fd;
1990
1991                 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
1992                     if (fd != pp[1])
1993                         PerlLIO_close(fd);
1994             }
1995 #endif
1996             /* may or may not use the shell */
1997             do_exec3(cmd, pp[1], did_pipes);
1998             PerlProc__exit(1);
1999         }
2000 #endif  /* defined OS2 */
2001         /*SUPPRESS 560*/
2002         if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) {
2003             SvREADONLY_off(GvSV(tmpgv));
2004             sv_setiv(GvSV(tmpgv), PerlProc_getpid());
2005             SvREADONLY_on(GvSV(tmpgv));
2006         }
2007 #ifdef THREADS_HAVE_PIDS
2008         PL_ppid = (IV)getppid();
2009 #endif
2010         PL_forkprocess = 0;
2011         hv_clear(PL_pidstatus); /* we have no children */
2012         return Nullfp;
2013 #undef THIS
2014 #undef THAT
2015     }
2016     do_execfree();      /* free any memory malloced by child on vfork */
2017     if (did_pipes)
2018         PerlLIO_close(pp[1]);
2019     if (p[that] < p[This]) {
2020         PerlLIO_dup2(p[This], p[that]);
2021         PerlLIO_close(p[This]);
2022         p[This] = p[that];
2023     }
2024     else
2025         PerlLIO_close(p[that]);
2026
2027     LOCK_FDPID_MUTEX;
2028     sv = *av_fetch(PL_fdpid,p[This],TRUE);
2029     UNLOCK_FDPID_MUTEX;
2030     (void)SvUPGRADE(sv,SVt_IV);
2031     SvIVX(sv) = pid;
2032     PL_forkprocess = pid;
2033     if (did_pipes && pid > 0) {
2034         int errkid;
2035         int n = 0, n1;
2036
2037         while (n < sizeof(int)) {
2038             n1 = PerlLIO_read(pp[0],
2039                               (void*)(((char*)&errkid)+n),
2040                               (sizeof(int)) - n);
2041             if (n1 <= 0)
2042                 break;
2043             n += n1;
2044         }
2045         PerlLIO_close(pp[0]);
2046         did_pipes = 0;
2047         if (n) {                        /* Error */
2048             int pid2, status;
2049             PerlLIO_close(p[This]);
2050             if (n != sizeof(int))
2051                 Perl_croak(aTHX_ "panic: kid popen errno read");
2052             do {
2053                 pid2 = wait4pid(pid, &status, 0);
2054             } while (pid2 == -1 && errno == EINTR);
2055             errno = errkid;             /* Propagate errno from kid */
2056             return Nullfp;
2057         }
2058     }
2059     if (did_pipes)
2060          PerlLIO_close(pp[0]);
2061     return PerlIO_fdopen(p[This], mode);
2062 }
2063 #else
2064 #if defined(atarist) || defined(EPOC)
2065 FILE *popen();
2066 PerlIO *
2067 Perl_my_popen(pTHX_ char *cmd, char *mode)
2068 {
2069     PERL_FLUSHALL_FOR_CHILD;
2070     /* Call system's popen() to get a FILE *, then import it.
2071        used 0 for 2nd parameter to PerlIO_importFILE;
2072        apparently not used
2073     */
2074     return PerlIO_importFILE(popen(cmd, mode), 0);
2075 }
2076 #else
2077 #if defined(DJGPP)
2078 FILE *djgpp_popen();
2079 PerlIO *
2080 Perl_my_popen(pTHX_ char *cmd, char *mode)
2081 {
2082     PERL_FLUSHALL_FOR_CHILD;
2083     /* Call system's popen() to get a FILE *, then import it.
2084        used 0 for 2nd parameter to PerlIO_importFILE;
2085        apparently not used
2086     */
2087     return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
2088 }
2089 #endif
2090 #endif
2091
2092 #endif /* !DOSISH */
2093
2094 /* this is called in parent before the fork() */
2095 void
2096 Perl_atfork_lock(void)
2097 {
2098 #if defined(USE_5005THREADS) || defined(USE_ITHREADS)
2099     /* locks must be held in locking order (if any) */
2100 #  ifdef MYMALLOC
2101     MUTEX_LOCK(&PL_malloc_mutex);
2102 #  endif
2103     OP_REFCNT_LOCK;
2104 #endif
2105 }
2106
2107 /* this is called in both parent and child after the fork() */
2108 void
2109 Perl_atfork_unlock(void)
2110 {
2111 #if defined(USE_5005THREADS) || defined(USE_ITHREADS)
2112     /* locks must be released in same order as in atfork_lock() */
2113 #  ifdef MYMALLOC
2114     MUTEX_UNLOCK(&PL_malloc_mutex);
2115 #  endif
2116     OP_REFCNT_UNLOCK;
2117 #endif
2118 }
2119
2120 Pid_t
2121 Perl_my_fork(void)
2122 {
2123 #if defined(HAS_FORK)
2124     Pid_t pid;
2125 #if (defined(USE_5005THREADS) || defined(USE_ITHREADS)) && !defined(HAS_PTHREAD_ATFORK)
2126     atfork_lock();
2127     pid = fork();
2128     atfork_unlock();
2129 #else
2130     /* atfork_lock() and atfork_unlock() are installed as pthread_atfork()
2131      * handlers elsewhere in the code */
2132     pid = fork();
2133 #endif
2134     return pid;
2135 #else
2136     /* this "canna happen" since nothing should be calling here if !HAS_FORK */
2137     Perl_croak_nocontext("fork() not available");
2138     return 0;
2139 #endif /* HAS_FORK */
2140 }
2141
2142 #ifdef DUMP_FDS
2143 void
2144 Perl_dump_fds(pTHX_ char *s)
2145 {
2146     int fd;
2147     Stat_t tmpstatbuf;
2148
2149     PerlIO_printf(Perl_debug_log,"%s", s);
2150     for (fd = 0; fd < 32; fd++) {
2151         if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0)
2152             PerlIO_printf(Perl_debug_log," %d",fd);
2153     }
2154     PerlIO_printf(Perl_debug_log,"\n");
2155 }
2156 #endif  /* DUMP_FDS */
2157
2158 #ifndef HAS_DUP2
2159 int
2160 dup2(int oldfd, int newfd)
2161 {
2162 #if defined(HAS_FCNTL) && defined(F_DUPFD)
2163     if (oldfd == newfd)
2164         return oldfd;
2165     PerlLIO_close(newfd);
2166     return fcntl(oldfd, F_DUPFD, newfd);
2167 #else
2168 #define DUP2_MAX_FDS 256
2169     int fdtmp[DUP2_MAX_FDS];
2170     I32 fdx = 0;
2171     int fd;
2172
2173     if (oldfd == newfd)
2174         return oldfd;
2175     PerlLIO_close(newfd);
2176     /* good enough for low fd's... */
2177     while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
2178         if (fdx >= DUP2_MAX_FDS) {
2179             PerlLIO_close(fd);
2180             fd = -1;
2181             break;
2182         }
2183         fdtmp[fdx++] = fd;
2184     }
2185     while (fdx > 0)
2186         PerlLIO_close(fdtmp[--fdx]);
2187     return fd;
2188 #endif
2189 }
2190 #endif
2191
2192 #ifndef PERL_MICRO
2193 #ifdef HAS_SIGACTION
2194
2195 #ifdef MACOS_TRADITIONAL
2196 /* We don't want restart behavior on MacOS */
2197 #undef SA_RESTART
2198 #endif
2199
2200 Sighandler_t
2201 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2202 {
2203     struct sigaction act, oact;
2204
2205 #ifdef USE_ITHREADS
2206     /* only "parent" interpreter can diddle signals */
2207     if (PL_curinterp != aTHX)
2208         return SIG_ERR;
2209 #endif
2210
2211     act.sa_handler = handler;
2212     sigemptyset(&act.sa_mask);
2213     act.sa_flags = 0;
2214 #ifdef SA_RESTART
2215     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2216         act.sa_flags |= SA_RESTART;     /* SVR4, 4.3+BSD */
2217 #endif
2218 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2219     if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN)
2220         act.sa_flags |= SA_NOCLDWAIT;
2221 #endif
2222     if (sigaction(signo, &act, &oact) == -1)
2223         return SIG_ERR;
2224     else
2225         return oact.sa_handler;
2226 }
2227
2228 Sighandler_t
2229 Perl_rsignal_state(pTHX_ int signo)
2230 {
2231     struct sigaction oact;
2232
2233     if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
2234         return SIG_ERR;
2235     else
2236         return oact.sa_handler;
2237 }
2238
2239 int
2240 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2241 {
2242     struct sigaction act;
2243
2244 #ifdef USE_ITHREADS
2245     /* only "parent" interpreter can diddle signals */
2246     if (PL_curinterp != aTHX)
2247         return -1;
2248 #endif
2249
2250     act.sa_handler = handler;
2251     sigemptyset(&act.sa_mask);
2252     act.sa_flags = 0;
2253 #ifdef SA_RESTART
2254     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2255         act.sa_flags |= SA_RESTART;     /* SVR4, 4.3+BSD */
2256 #endif
2257 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2258     if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN)
2259         act.sa_flags |= SA_NOCLDWAIT;
2260 #endif
2261     return sigaction(signo, &act, save);
2262 }
2263
2264 int
2265 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2266 {
2267 #ifdef USE_ITHREADS
2268     /* only "parent" interpreter can diddle signals */
2269     if (PL_curinterp != aTHX)
2270         return -1;
2271 #endif
2272
2273     return sigaction(signo, save, (struct sigaction *)NULL);
2274 }
2275
2276 #else /* !HAS_SIGACTION */
2277
2278 Sighandler_t
2279 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2280 {
2281 #if defined(USE_ITHREADS) && !defined(WIN32)
2282     /* only "parent" interpreter can diddle signals */
2283     if (PL_curinterp != aTHX)
2284         return SIG_ERR;
2285 #endif
2286
2287     return PerlProc_signal(signo, handler);
2288 }
2289
2290 static int sig_trapped; /* XXX signals are process-wide anyway, so we
2291                            ignore the implications of this for threading */
2292
2293 static
2294 Signal_t
2295 sig_trap(int signo)
2296 {
2297     sig_trapped++;
2298 }
2299
2300 Sighandler_t
2301 Perl_rsignal_state(pTHX_ int signo)
2302 {
2303     Sighandler_t oldsig;
2304
2305 #if defined(USE_ITHREADS) && !defined(WIN32)
2306     /* only "parent" interpreter can diddle signals */
2307     if (PL_curinterp != aTHX)
2308         return SIG_ERR;
2309 #endif
2310
2311     sig_trapped = 0;
2312     oldsig = PerlProc_signal(signo, sig_trap);
2313     PerlProc_signal(signo, oldsig);
2314     if (sig_trapped)
2315         PerlProc_kill(PerlProc_getpid(), signo);
2316     return oldsig;
2317 }
2318
2319 int
2320 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2321 {
2322 #if defined(USE_ITHREADS) && !defined(WIN32)
2323     /* only "parent" interpreter can diddle signals */
2324     if (PL_curinterp != aTHX)
2325         return -1;
2326 #endif
2327     *save = PerlProc_signal(signo, handler);
2328     return (*save == SIG_ERR) ? -1 : 0;
2329 }
2330
2331 int
2332 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2333 {
2334 #if defined(USE_ITHREADS) && !defined(WIN32)
2335     /* only "parent" interpreter can diddle signals */
2336     if (PL_curinterp != aTHX)
2337         return -1;
2338 #endif
2339     return (PerlProc_signal(signo, *save) == SIG_ERR) ? -1 : 0;
2340 }
2341
2342 #endif /* !HAS_SIGACTION */
2343 #endif /* !PERL_MICRO */
2344
2345     /* VMS' my_pclose() is in VMS.c; same with OS/2 */
2346 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
2347 I32
2348 Perl_my_pclose(pTHX_ PerlIO *ptr)
2349 {
2350     Sigsave_t hstat, istat, qstat;
2351     int status;
2352     SV **svp;
2353     Pid_t pid;
2354     Pid_t pid2;
2355     bool close_failed;
2356     int saved_errno = 0;
2357 #ifdef VMS
2358     int saved_vaxc_errno;
2359 #endif
2360 #ifdef WIN32
2361     int saved_win32_errno;
2362 #endif
2363
2364     LOCK_FDPID_MUTEX;
2365     svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE);
2366     UNLOCK_FDPID_MUTEX;
2367     pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
2368     SvREFCNT_dec(*svp);
2369     *svp = &PL_sv_undef;
2370 #ifdef OS2
2371     if (pid == -1) {                    /* Opened by popen. */
2372         return my_syspclose(ptr);
2373     }
2374 #endif
2375     if ((close_failed = (PerlIO_close(ptr) == EOF))) {
2376         saved_errno = errno;
2377 #ifdef VMS
2378         saved_vaxc_errno = vaxc$errno;
2379 #endif
2380 #ifdef WIN32
2381         saved_win32_errno = GetLastError();
2382 #endif
2383     }
2384 #ifdef UTS
2385     if(PerlProc_kill(pid, 0) < 0) { return(pid); }   /* HOM 12/23/91 */
2386 #endif
2387 #ifndef PERL_MICRO
2388     rsignal_save(SIGHUP, SIG_IGN, &hstat);
2389     rsignal_save(SIGINT, SIG_IGN, &istat);
2390     rsignal_save(SIGQUIT, SIG_IGN, &qstat);
2391 #endif
2392     do {
2393         pid2 = wait4pid(pid, &status, 0);
2394     } while (pid2 == -1 && errno == EINTR);
2395 #ifndef PERL_MICRO
2396     rsignal_restore(SIGHUP, &hstat);
2397     rsignal_restore(SIGINT, &istat);
2398     rsignal_restore(SIGQUIT, &qstat);
2399 #endif
2400     if (close_failed) {
2401         SETERRNO(saved_errno, saved_vaxc_errno);
2402         return -1;
2403     }
2404     return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status));
2405 }
2406 #endif /* !DOSISH */
2407
2408 #if  (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(MACOS_TRADITIONAL)
2409 I32
2410 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
2411 {
2412     I32 result;
2413     if (!pid)
2414         return -1;
2415 #if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME)
2416     {
2417         SV *sv;
2418         SV** svp;
2419         char spid[TYPE_CHARS(int)];
2420
2421         if (pid > 0) {
2422             sprintf(spid, "%"IVdf, (IV)pid);
2423             svp = hv_fetch(PL_pidstatus,spid,strlen(spid),FALSE);
2424             if (svp && *svp != &PL_sv_undef) {
2425                 *statusp = SvIVX(*svp);
2426                 (void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD);
2427                 return pid;
2428             }
2429         }
2430         else {
2431             HE *entry;
2432
2433             hv_iterinit(PL_pidstatus);
2434             if ((entry = hv_iternext(PL_pidstatus))) {
2435                 SV *sv;
2436                 char spid[TYPE_CHARS(int)];
2437
2438                 pid = atoi(hv_iterkey(entry,(I32*)statusp));
2439                 sv = hv_iterval(PL_pidstatus,entry);
2440                 *statusp = SvIVX(sv);
2441                 sprintf(spid, "%"IVdf, (IV)pid);
2442                 (void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD);
2443                 return pid;
2444             }
2445         }
2446     }
2447 #endif
2448 #ifdef HAS_WAITPID
2449 #  ifdef HAS_WAITPID_RUNTIME
2450     if (!HAS_WAITPID_RUNTIME)
2451         goto hard_way;
2452 #  endif
2453     result = PerlProc_waitpid(pid,statusp,flags);
2454     goto finish;
2455 #endif
2456 #if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
2457     result = wait4((pid==-1)?0:pid,statusp,flags,Null(struct rusage *));
2458     goto finish;
2459 #endif
2460 #if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME)
2461   hard_way:
2462     {
2463         if (flags)
2464             Perl_croak(aTHX_ "Can't do waitpid with flags");
2465         else {
2466             while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
2467                 pidgone(result,*statusp);
2468             if (result < 0)
2469                 *statusp = -1;
2470         }
2471     }
2472 #endif
2473   finish:
2474     if (result < 0 && errno == EINTR) {
2475         PERL_ASYNC_CHECK();
2476     }
2477     return result;
2478 }
2479 #endif /* !DOSISH || OS2 || WIN32 || NETWARE */
2480
2481 void
2482 /*SUPPRESS 590*/
2483 Perl_pidgone(pTHX_ Pid_t pid, int status)
2484 {
2485     register SV *sv;
2486     char spid[TYPE_CHARS(int)];
2487
2488     sprintf(spid, "%"IVdf, (IV)pid);
2489     sv = *hv_fetch(PL_pidstatus,spid,strlen(spid),TRUE);
2490     (void)SvUPGRADE(sv,SVt_IV);
2491     SvIVX(sv) = status;
2492     return;
2493 }
2494
2495 #if defined(atarist) || defined(OS2) || defined(EPOC)
2496 int pclose();
2497 #ifdef HAS_FORK
2498 int                                     /* Cannot prototype with I32
2499                                            in os2ish.h. */
2500 my_syspclose(PerlIO *ptr)
2501 #else
2502 I32
2503 Perl_my_pclose(pTHX_ PerlIO *ptr)
2504 #endif
2505 {
2506     /* Needs work for PerlIO ! */
2507     FILE *f = PerlIO_findFILE(ptr);
2508     I32 result = pclose(f);
2509     PerlIO_releaseFILE(ptr,f);
2510     return result;
2511 }
2512 #endif
2513
2514 #if defined(DJGPP)
2515 int djgpp_pclose();
2516 I32
2517 Perl_my_pclose(pTHX_ PerlIO *ptr)
2518 {
2519     /* Needs work for PerlIO ! */
2520     FILE *f = PerlIO_findFILE(ptr);
2521     I32 result = djgpp_pclose(f);
2522     result = (result << 8) & 0xff00;
2523     PerlIO_releaseFILE(ptr,f);
2524     return result;
2525 }
2526 #endif
2527
2528 void
2529 Perl_repeatcpy(pTHX_ register char *to, register const char *from, I32 len, register I32 count)
2530 {
2531     register I32 todo;
2532     register const char *frombase = from;
2533
2534     if (len == 1) {
2535         register const char c = *from;
2536         while (count-- > 0)
2537             *to++ = c;
2538         return;
2539     }
2540     while (count-- > 0) {
2541         for (todo = len; todo > 0; todo--) {
2542             *to++ = *from++;
2543         }
2544         from = frombase;
2545     }
2546 }
2547
2548 #ifndef HAS_RENAME
2549 I32
2550 Perl_same_dirent(pTHX_ char *a, char *b)
2551 {
2552     char *fa = strrchr(a,'/');
2553     char *fb = strrchr(b,'/');
2554     Stat_t tmpstatbuf1;
2555     Stat_t tmpstatbuf2;
2556     SV *tmpsv = sv_newmortal();
2557
2558     if (fa)
2559         fa++;
2560     else
2561         fa = a;
2562     if (fb)
2563         fb++;
2564     else
2565         fb = b;
2566     if (strNE(a,b))
2567         return FALSE;
2568     if (fa == a)
2569         sv_setpv(tmpsv, ".");
2570     else
2571         sv_setpvn(tmpsv, a, fa - a);
2572     if (PerlLIO_stat(SvPVX(tmpsv), &tmpstatbuf1) < 0)
2573         return FALSE;
2574     if (fb == b)
2575         sv_setpv(tmpsv, ".");
2576     else
2577         sv_setpvn(tmpsv, b, fb - b);
2578     if (PerlLIO_stat(SvPVX(tmpsv), &tmpstatbuf2) < 0)
2579         return FALSE;
2580     return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
2581            tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
2582 }
2583 #endif /* !HAS_RENAME */
2584
2585 char*
2586 Perl_find_script(pTHX_ char *scriptname, bool dosearch, char **search_ext, I32 flags)
2587 {
2588     char *xfound = Nullch;
2589     char *xfailed = Nullch;
2590     char tmpbuf[MAXPATHLEN];
2591     register char *s;
2592     I32 len = 0;
2593     int retval;
2594 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
2595 #  define SEARCH_EXTS ".bat", ".cmd", NULL
2596 #  define MAX_EXT_LEN 4
2597 #endif
2598 #ifdef OS2
2599 #  define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
2600 #  define MAX_EXT_LEN 4
2601 #endif
2602 #ifdef VMS
2603 #  define SEARCH_EXTS ".pl", ".com", NULL
2604 #  define MAX_EXT_LEN 4
2605 #endif
2606     /* additional extensions to try in each dir if scriptname not found */
2607 #ifdef SEARCH_EXTS
2608     char *exts[] = { SEARCH_EXTS };
2609     char **ext = search_ext ? search_ext : exts;
2610     int extidx = 0, i = 0;
2611     char *curext = Nullch;
2612 #else
2613 #  define MAX_EXT_LEN 0
2614 #endif
2615
2616     /*
2617      * If dosearch is true and if scriptname does not contain path
2618      * delimiters, search the PATH for scriptname.
2619      *
2620      * If SEARCH_EXTS is also defined, will look for each
2621      * scriptname{SEARCH_EXTS} whenever scriptname is not found
2622      * while searching the PATH.
2623      *
2624      * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
2625      * proceeds as follows:
2626      *   If DOSISH or VMSISH:
2627      *     + look for ./scriptname{,.foo,.bar}
2628      *     + search the PATH for scriptname{,.foo,.bar}
2629      *
2630      *   If !DOSISH:
2631      *     + look *only* in the PATH for scriptname{,.foo,.bar} (note
2632      *       this will not look in '.' if it's not in the PATH)
2633      */
2634     tmpbuf[0] = '\0';
2635
2636 #ifdef VMS
2637 #  ifdef ALWAYS_DEFTYPES
2638     len = strlen(scriptname);
2639     if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
2640         int hasdir, idx = 0, deftypes = 1;
2641         bool seen_dot = 1;
2642
2643         hasdir = !dosearch || (strpbrk(scriptname,":[</") != Nullch) ;
2644 #  else
2645     if (dosearch) {
2646         int hasdir, idx = 0, deftypes = 1;
2647         bool seen_dot = 1;
2648
2649         hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
2650 #  endif
2651         /* The first time through, just add SEARCH_EXTS to whatever we
2652          * already have, so we can check for default file types. */
2653         while (deftypes ||
2654                (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
2655         {
2656             if (deftypes) {
2657                 deftypes = 0;
2658                 *tmpbuf = '\0';
2659             }
2660             if ((strlen(tmpbuf) + strlen(scriptname)
2661                  + MAX_EXT_LEN) >= sizeof tmpbuf)
2662                 continue;       /* don't search dir with too-long name */
2663             strcat(tmpbuf, scriptname);
2664 #else  /* !VMS */
2665
2666 #ifdef DOSISH
2667     if (strEQ(scriptname, "-"))
2668         dosearch = 0;
2669     if (dosearch) {             /* Look in '.' first. */
2670         char *cur = scriptname;
2671 #ifdef SEARCH_EXTS
2672         if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
2673             while (ext[i])
2674                 if (strEQ(ext[i++],curext)) {
2675                     extidx = -1;                /* already has an ext */
2676                     break;
2677                 }
2678         do {
2679 #endif
2680             DEBUG_p(PerlIO_printf(Perl_debug_log,
2681                                   "Looking for %s\n",cur));
2682             if (PerlLIO_stat(cur,&PL_statbuf) >= 0
2683                 && !S_ISDIR(PL_statbuf.st_mode)) {
2684                 dosearch = 0;
2685                 scriptname = cur;
2686 #ifdef SEARCH_EXTS
2687                 break;
2688 #endif
2689             }
2690 #ifdef SEARCH_EXTS
2691             if (cur == scriptname) {
2692                 len = strlen(scriptname);
2693                 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
2694                     break;
2695                 cur = strcpy(tmpbuf, scriptname);
2696             }
2697         } while (extidx >= 0 && ext[extidx]     /* try an extension? */
2698                  && strcpy(tmpbuf+len, ext[extidx++]));
2699 #endif
2700     }
2701 #endif
2702
2703 #ifdef MACOS_TRADITIONAL
2704     if (dosearch && !strchr(scriptname, ':') &&
2705         (s = PerlEnv_getenv("Commands")))
2706 #else
2707     if (dosearch && !strchr(scriptname, '/')
2708 #ifdef DOSISH
2709                  && !strchr(scriptname, '\\')
2710 #endif
2711                  && (s = PerlEnv_getenv("PATH")))
2712 #endif
2713     {
2714         bool seen_dot = 0;
2715
2716         PL_bufend = s + strlen(s);
2717         while (s < PL_bufend) {
2718 #ifdef MACOS_TRADITIONAL
2719             s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
2720                         ',',
2721                         &len);
2722 #else
2723 #if defined(atarist) || defined(DOSISH)
2724             for (len = 0; *s
2725 #  ifdef atarist
2726                     && *s != ','
2727 #  endif
2728                     && *s != ';'; len++, s++) {
2729                 if (len < sizeof tmpbuf)
2730                     tmpbuf[len] = *s;
2731             }
2732             if (len < sizeof tmpbuf)
2733                 tmpbuf[len] = '\0';
2734 #else  /* ! (atarist || DOSISH) */
2735             s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
2736                         ':',
2737                         &len);
2738 #endif /* ! (atarist || DOSISH) */
2739 #endif /* MACOS_TRADITIONAL */
2740             if (s < PL_bufend)
2741                 s++;
2742             if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
2743                 continue;       /* don't search dir with too-long name */
2744 #ifdef MACOS_TRADITIONAL
2745             if (len && tmpbuf[len - 1] != ':')
2746                 tmpbuf[len++] = ':';
2747 #else
2748             if (len
2749 #if defined(atarist) || defined(__MINT__) || defined(DOSISH)
2750                 && tmpbuf[len - 1] != '/'
2751                 && tmpbuf[len - 1] != '\\'
2752 #endif
2753                )
2754                 tmpbuf[len++] = '/';
2755             if (len == 2 && tmpbuf[0] == '.')
2756                 seen_dot = 1;
2757 #endif
2758             (void)strcpy(tmpbuf + len, scriptname);
2759 #endif  /* !VMS */
2760
2761 #ifdef SEARCH_EXTS
2762             len = strlen(tmpbuf);
2763             if (extidx > 0)     /* reset after previous loop */
2764                 extidx = 0;
2765             do {
2766 #endif
2767                 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
2768                 retval = PerlLIO_stat(tmpbuf,&PL_statbuf);
2769                 if (S_ISDIR(PL_statbuf.st_mode)) {
2770                     retval = -1;
2771                 }
2772 #ifdef SEARCH_EXTS
2773             } while (  retval < 0               /* not there */
2774                     && extidx>=0 && ext[extidx] /* try an extension? */
2775                     && strcpy(tmpbuf+len, ext[extidx++])
2776                 );
2777 #endif
2778             if (retval < 0)
2779                 continue;
2780             if (S_ISREG(PL_statbuf.st_mode)
2781                 && cando(S_IRUSR,TRUE,&PL_statbuf)
2782 #if !defined(DOSISH) && !defined(MACOS_TRADITIONAL)
2783                 && cando(S_IXUSR,TRUE,&PL_statbuf)
2784 #endif
2785                 )
2786             {
2787                 xfound = tmpbuf;                /* bingo! */
2788                 break;
2789             }
2790             if (!xfailed)
2791                 xfailed = savepv(tmpbuf);
2792         }
2793 #ifndef DOSISH
2794         if (!xfound && !seen_dot && !xfailed &&
2795             (PerlLIO_stat(scriptname,&PL_statbuf) < 0
2796              || S_ISDIR(PL_statbuf.st_mode)))
2797 #endif
2798             seen_dot = 1;                       /* Disable message. */
2799         if (!xfound) {
2800             if (flags & 1) {                    /* do or die? */
2801                 Perl_croak(aTHX_ "Can't %s %s%s%s",
2802                       (xfailed ? "execute" : "find"),
2803                       (xfailed ? xfailed : scriptname),
2804                       (xfailed ? "" : " on PATH"),
2805                       (xfailed || seen_dot) ? "" : ", '.' not in PATH");
2806             }
2807             scriptname = Nullch;
2808         }
2809         if (xfailed)
2810             Safefree(xfailed);
2811         scriptname = xfound;
2812     }
2813     return (scriptname ? savepv(scriptname) : Nullch);
2814 }
2815
2816 #ifndef PERL_GET_CONTEXT_DEFINED
2817
2818 void *
2819 Perl_get_context(void)
2820 {
2821 #if defined(USE_5005THREADS) || defined(USE_ITHREADS)
2822 #  ifdef OLD_PTHREADS_API
2823     pthread_addr_t t;
2824     if (pthread_getspecific(PL_thr_key, &t))
2825         Perl_croak_nocontext("panic: pthread_getspecific");
2826     return (void*)t;
2827 #  else
2828 #    ifdef I_MACH_CTHREADS
2829     return (void*)cthread_data(cthread_self());
2830 #    else
2831     return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
2832 #    endif
2833 #  endif
2834 #else
2835     return (void*)NULL;
2836 #endif
2837 }
2838
2839 void
2840 Perl_set_context(void *t)
2841 {
2842 #if defined(USE_5005THREADS) || defined(USE_ITHREADS)
2843 #  ifdef I_MACH_CTHREADS
2844     cthread_set_data(cthread_self(), t);
2845 #  else
2846     if (pthread_setspecific(PL_thr_key, t))
2847         Perl_croak_nocontext("panic: pthread_setspecific");
2848 #  endif
2849 #endif
2850 }
2851
2852 #endif /* !PERL_GET_CONTEXT_DEFINED */
2853
2854 #ifdef USE_5005THREADS
2855
2856 #ifdef FAKE_THREADS
2857 /* Very simplistic scheduler for now */
2858 void
2859 schedule(void)
2860 {
2861     thr = thr->i.next_run;
2862 }
2863
2864 void
2865 Perl_cond_init(pTHX_ perl_cond *cp)
2866 {
2867     *cp = 0;
2868 }
2869
2870 void
2871 Perl_cond_signal(pTHX_ perl_cond *cp)
2872 {
2873     perl_os_thread t;
2874     perl_cond cond = *cp;
2875
2876     if (!cond)
2877         return;
2878     t = cond->thread;
2879     /* Insert t in the runnable queue just ahead of us */
2880     t->i.next_run = thr->i.next_run;
2881     thr->i.next_run->i.prev_run = t;
2882     t->i.prev_run = thr;
2883     thr->i.next_run = t;
2884     thr->i.wait_queue = 0;
2885     /* Remove from the wait queue */
2886     *cp = cond->next;
2887     Safefree(cond);
2888 }
2889
2890 void
2891 Perl_cond_broadcast(pTHX_ perl_cond *cp)
2892 {
2893     perl_os_thread t;
2894     perl_cond cond, cond_next;
2895
2896     for (cond = *cp; cond; cond = cond_next) {
2897         t = cond->thread;
2898         /* Insert t in the runnable queue just ahead of us */
2899         t->i.next_run = thr->i.next_run;
2900         thr->i.next_run->i.prev_run = t;
2901         t->i.prev_run = thr;
2902         thr->i.next_run = t;
2903         thr->i.wait_queue = 0;
2904         /* Remove from the wait queue */
2905         cond_next = cond->next;
2906         Safefree(cond);
2907     }
2908     *cp = 0;
2909 }
2910
2911 void
2912 Perl_cond_wait(pTHX_ perl_cond *cp)
2913 {
2914     perl_cond cond;
2915
2916     if (thr->i.next_run == thr)
2917         Perl_croak(aTHX_ "panic: perl_cond_wait called by last runnable thread");
2918
2919     New(666, cond, 1, struct perl_wait_queue);
2920     cond->thread = thr;
2921     cond->next = *cp;
2922     *cp = cond;
2923     thr->i.wait_queue = cond;
2924     /* Remove ourselves from runnable queue */
2925     thr->i.next_run->i.prev_run = thr->i.prev_run;
2926     thr->i.prev_run->i.next_run = thr->i.next_run;
2927 }
2928 #endif /* FAKE_THREADS */
2929
2930 MAGIC *
2931 Perl_condpair_magic(pTHX_ SV *sv)
2932 {
2933     MAGIC *mg;
2934
2935     (void)SvUPGRADE(sv, SVt_PVMG);
2936     mg = mg_find(sv, PERL_MAGIC_mutex);
2937     if (!mg) {
2938         condpair_t *cp;
2939
2940         New(53, cp, 1, condpair_t);
2941         MUTEX_INIT(&cp->mutex);
2942         COND_INIT(&cp->owner_cond);
2943         COND_INIT(&cp->cond);
2944         cp->owner = 0;
2945         LOCK_CRED_MUTEX;                /* XXX need separate mutex? */
2946         mg = mg_find(sv, PERL_MAGIC_mutex);
2947         if (mg) {
2948             /* someone else beat us to initialising it */
2949             UNLOCK_CRED_MUTEX;          /* XXX need separate mutex? */
2950             MUTEX_DESTROY(&cp->mutex);
2951             COND_DESTROY(&cp->owner_cond);
2952             COND_DESTROY(&cp->cond);
2953             Safefree(cp);
2954         }
2955         else {
2956             sv_magic(sv, Nullsv, PERL_MAGIC_mutex, 0, 0);
2957             mg = SvMAGIC(sv);
2958             mg->mg_ptr = (char *)cp;
2959             mg->mg_len = sizeof(cp);
2960             UNLOCK_CRED_MUTEX;          /* XXX need separate mutex? */
2961             DEBUG_S(WITH_THR(PerlIO_printf(Perl_debug_log,
2962                                            "%p: condpair_magic %p\n", thr, sv)));
2963         }
2964     }
2965     return mg;
2966 }
2967
2968 SV *
2969 Perl_sv_lock(pTHX_ SV *osv)
2970 {
2971     MAGIC *mg;
2972     SV *sv = osv;
2973
2974     LOCK_SV_LOCK_MUTEX;
2975     if (SvROK(sv)) {
2976         sv = SvRV(sv);
2977     }
2978
2979     mg = condpair_magic(sv);
2980     MUTEX_LOCK(MgMUTEXP(mg));
2981     if (MgOWNER(mg) == thr)
2982         MUTEX_UNLOCK(MgMUTEXP(mg));
2983     else {
2984         while (MgOWNER(mg))
2985             COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
2986         MgOWNER(mg) = thr;
2987         DEBUG_S(PerlIO_printf(Perl_debug_log,
2988                               "0x%"UVxf": Perl_lock lock 0x%"UVxf"\n",
2989                               PTR2UV(thr), PTR2UV(sv)));
2990         MUTEX_UNLOCK(MgMUTEXP(mg));
2991         SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv);
2992     }
2993     UNLOCK_SV_LOCK_MUTEX;
2994     return sv;
2995 }
2996
2997 /*
2998  * Make a new perl thread structure using t as a prototype. Some of the
2999  * fields for the new thread are copied from the prototype thread, t,
3000  * so t should not be running in perl at the time this function is
3001  * called. The use by ext/Thread/Thread.xs in core perl (where t is the
3002  * thread calling new_struct_thread) clearly satisfies this constraint.
3003  */
3004 struct perl_thread *
3005 Perl_new_struct_thread(pTHX_ struct perl_thread *t)
3006 {
3007 #if !defined(PERL_IMPLICIT_CONTEXT)
3008     struct perl_thread *thr;
3009 #endif
3010     SV *sv;
3011     SV **svp;
3012     I32 i;
3013
3014     sv = newSVpvn("", 0);
3015     SvGROW(sv, sizeof(struct perl_thread) + 1);
3016     SvCUR_set(sv, sizeof(struct perl_thread));
3017     thr = (Thread) SvPVX(sv);
3018 #ifdef DEBUGGING
3019     Poison(thr, 1, struct perl_thread);
3020     PL_markstack = 0;
3021     PL_scopestack = 0;
3022     PL_savestack = 0;
3023     PL_retstack = 0;
3024     PL_dirty = 0;
3025     PL_localizing = 0;
3026     Zero(&PL_hv_fetch_ent_mh, 1, HE);
3027     PL_efloatbuf = (char*)NULL;
3028     PL_efloatsize = 0;
3029 #else
3030     Zero(thr, 1, struct perl_thread);
3031 #endif
3032
3033     thr->oursv = sv;
3034     init_stacks();
3035
3036     PL_curcop = &PL_compiling;
3037     thr->interp = t->interp;
3038     thr->cvcache = newHV();
3039     thr->threadsv = newAV();
3040     thr->specific = newAV();
3041     thr->errsv = newSVpvn("", 0);
3042     thr->flags = THRf_R_JOINABLE;
3043     thr->thr_done = 0;
3044     MUTEX_INIT(&thr->mutex);
3045
3046     JMPENV_BOOTSTRAP;
3047
3048     PL_in_eval = EVAL_NULL;     /* ~(EVAL_INEVAL|EVAL_WARNONLY|EVAL_KEEPERR|EVAL_INREQUIRE) */
3049     PL_restartop = 0;
3050
3051     PL_statname = NEWSV(66,0);
3052     PL_errors = newSVpvn("", 0);
3053     PL_maxscream = -1;
3054     PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
3055     PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
3056     PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
3057     PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
3058     PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
3059     PL_regindent = 0;
3060     PL_reginterp_cnt = 0;
3061     PL_lastscream = Nullsv;
3062     PL_screamfirst = 0;
3063     PL_screamnext = 0;
3064     PL_reg_start_tmp = 0;
3065     PL_reg_start_tmpl = 0;
3066     PL_reg_poscache = Nullch;
3067
3068     PL_peepp = MEMBER_TO_FPTR(Perl_peep);
3069
3070     /* parent thread's data needs to be locked while we make copy */
3071     MUTEX_LOCK(&t->mutex);
3072
3073 #ifdef PERL_FLEXIBLE_EXCEPTIONS
3074     PL_protect = t->Tprotect;
3075 #endif
3076
3077     PL_curcop = t->Tcurcop;       /* XXX As good a guess as any? */
3078     PL_defstash = t->Tdefstash;   /* XXX maybe these should */
3079     PL_curstash = t->Tcurstash;   /* always be set to main? */
3080
3081     PL_tainted = t->Ttainted;
3082     PL_curpm = t->Tcurpm;       /* XXX No PMOP ref count */
3083     PL_rs = newSVsv(t->Trs);
3084     PL_last_in_gv = Nullgv;
3085     PL_ofs_sv = t->Tofs_sv ? SvREFCNT_inc(PL_ofs_sv) : Nullsv;
3086     PL_defoutgv = (GV*)SvREFCNT_inc(t->Tdefoutgv);
3087     PL_chopset = t->Tchopset;
3088     PL_bodytarget = newSVsv(t->Tbodytarget);
3089     PL_toptarget = newSVsv(t->Ttoptarget);
3090     if (t->Tformtarget == t->Ttoptarget)
3091         PL_formtarget = PL_toptarget;
3092     else
3093         PL_formtarget = PL_bodytarget;
3094     PL_watchaddr = 0; /* XXX */
3095     PL_watchok = 0; /* XXX */
3096     PL_comppad = 0;
3097     PL_curpad = 0;
3098
3099     /* Initialise all per-thread SVs that the template thread used */
3100     svp = AvARRAY(t->threadsv);
3101     for (i = 0; i <= AvFILLp(t->threadsv); i++, svp++) {
3102         if (*svp && *svp != &PL_sv_undef) {
3103             SV *sv = newSVsv(*svp);
3104             av_store(thr->threadsv, i, sv);
3105             sv_magic(sv, 0, PERL_MAGIC_sv, &PL_threadsv_names[i], 1);
3106             DEBUG_S(PerlIO_printf(Perl_debug_log,
3107                 "new_struct_thread: copied threadsv %"IVdf" %p->%p\n",
3108                                   (IV)i, t, thr));
3109         }
3110     }
3111     thr->threadsvp = AvARRAY(thr->threadsv);
3112
3113     MUTEX_LOCK(&PL_threads_mutex);
3114     PL_nthreads++;
3115     thr->tid = ++PL_threadnum;
3116     thr->next = t->next;
3117     thr->prev = t;
3118     t->next = thr;
3119     thr->next->prev = thr;
3120     MUTEX_UNLOCK(&PL_threads_mutex);
3121
3122     /* done copying parent's state */
3123     MUTEX_UNLOCK(&t->mutex);
3124
3125 #ifdef HAVE_THREAD_INTERN
3126     Perl_init_thread_intern(thr);
3127 #endif /* HAVE_THREAD_INTERN */
3128     return thr;
3129 }
3130 #endif /* USE_5005THREADS */
3131
3132 #ifdef PERL_GLOBAL_STRUCT
3133 struct perl_vars *
3134 Perl_GetVars(pTHX)
3135 {
3136  return &PL_Vars;
3137 }
3138 #endif
3139
3140 char **
3141 Perl_get_op_names(pTHX)
3142 {
3143  return PL_op_name;
3144 }
3145
3146 char **
3147 Perl_get_op_descs(pTHX)
3148 {
3149  return PL_op_desc;
3150 }
3151
3152 char *
3153 Perl_get_no_modify(pTHX)
3154 {
3155  return (char*)PL_no_modify;
3156 }
3157
3158 U32 *
3159 Perl_get_opargs(pTHX)
3160 {
3161  return PL_opargs;
3162 }
3163
3164 PPADDR_t*
3165 Perl_get_ppaddr(pTHX)
3166 {
3167  return (PPADDR_t*)PL_ppaddr;
3168 }
3169
3170 #ifndef HAS_GETENV_LEN
3171 char *
3172 Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
3173 {
3174     char *env_trans = PerlEnv_getenv(env_elem);
3175     if (env_trans)
3176         *len = strlen(env_trans);
3177     return env_trans;
3178 }
3179 #endif
3180
3181
3182 MGVTBL*
3183 Perl_get_vtbl(pTHX_ int vtbl_id)
3184 {
3185     MGVTBL* result = Null(MGVTBL*);
3186
3187     switch(vtbl_id) {
3188     case want_vtbl_sv:
3189         result = &PL_vtbl_sv;
3190         break;
3191     case want_vtbl_env:
3192         result = &PL_vtbl_env;
3193         break;
3194     case want_vtbl_envelem:
3195         result = &PL_vtbl_envelem;
3196         break;
3197     case want_vtbl_sig:
3198         result = &PL_vtbl_sig;
3199         break;
3200     case want_vtbl_sigelem:
3201         result = &PL_vtbl_sigelem;
3202         break;
3203     case want_vtbl_pack:
3204         result = &PL_vtbl_pack;
3205         break;
3206     case want_vtbl_packelem:
3207         result = &PL_vtbl_packelem;
3208         break;
3209     case want_vtbl_dbline:
3210         result = &PL_vtbl_dbline;
3211         break;
3212     case want_vtbl_isa:
3213         result = &PL_vtbl_isa;
3214         break;
3215     case want_vtbl_isaelem:
3216         result = &PL_vtbl_isaelem;
3217         break;
3218     case want_vtbl_arylen:
3219         result = &PL_vtbl_arylen;
3220         break;
3221     case want_vtbl_glob:
3222         result = &PL_vtbl_glob;
3223         break;
3224     case want_vtbl_mglob:
3225         result = &PL_vtbl_mglob;
3226         break;
3227     case want_vtbl_nkeys:
3228         result = &PL_vtbl_nkeys;
3229         break;
3230     case want_vtbl_taint:
3231         result = &PL_vtbl_taint;
3232         break;
3233     case want_vtbl_substr:
3234         result = &PL_vtbl_substr;
3235         break;
3236     case want_vtbl_vec:
3237         result = &PL_vtbl_vec;
3238         break;
3239     case want_vtbl_pos:
3240         result = &PL_vtbl_pos;
3241         break;
3242     case want_vtbl_bm:
3243         result = &PL_vtbl_bm;
3244         break;
3245     case want_vtbl_fm:
3246         result = &PL_vtbl_fm;
3247         break;
3248     case want_vtbl_uvar:
3249         result = &PL_vtbl_uvar;
3250         break;
3251 #ifdef USE_5005THREADS
3252     case want_vtbl_mutex:
3253         result = &PL_vtbl_mutex;
3254         break;
3255 #endif
3256     case want_vtbl_defelem:
3257         result = &PL_vtbl_defelem;
3258         break;
3259     case want_vtbl_regexp:
3260         result = &PL_vtbl_regexp;
3261         break;
3262     case want_vtbl_regdata:
3263         result = &PL_vtbl_regdata;
3264         break;
3265     case want_vtbl_regdatum:
3266         result = &PL_vtbl_regdatum;
3267         break;
3268 #ifdef USE_LOCALE_COLLATE
3269     case want_vtbl_collxfrm:
3270         result = &PL_vtbl_collxfrm;
3271         break;
3272 #endif
3273     case want_vtbl_amagic:
3274         result = &PL_vtbl_amagic;
3275         break;
3276     case want_vtbl_amagicelem:
3277         result = &PL_vtbl_amagicelem;
3278         break;
3279     case want_vtbl_backref:
3280         result = &PL_vtbl_backref;
3281         break;
3282     case want_vtbl_utf8:
3283         result = &PL_vtbl_utf8;
3284         break;
3285     }
3286     return result;
3287 }
3288
3289 I32
3290 Perl_my_fflush_all(pTHX)
3291 {
3292 #if defined(USE_PERLIO) || defined(FFLUSH_NULL) || defined(USE_SFIO)
3293     return PerlIO_flush(NULL);
3294 #else
3295 # if defined(HAS__FWALK)
3296     extern int fflush(FILE *);
3297     /* undocumented, unprototyped, but very useful BSDism */
3298     extern void _fwalk(int (*)(FILE *));
3299     _fwalk(&fflush);
3300     return 0;
3301 # else
3302 #  if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
3303     long open_max = -1;
3304 #   ifdef PERL_FFLUSH_ALL_FOPEN_MAX
3305     open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
3306 #   else
3307 #    if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
3308     open_max = sysconf(_SC_OPEN_MAX);
3309 #     else
3310 #      ifdef FOPEN_MAX
3311     open_max = FOPEN_MAX;
3312 #      else
3313 #       ifdef OPEN_MAX
3314     open_max = OPEN_MAX;
3315 #       else
3316 #        ifdef _NFILE
3317     open_max = _NFILE;
3318 #        endif
3319 #       endif
3320 #      endif
3321 #     endif
3322 #    endif
3323     if (open_max > 0) {
3324       long i;
3325       for (i = 0; i < open_max; i++)
3326             if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
3327                 STDIO_STREAM_ARRAY[i]._file < open_max &&
3328                 STDIO_STREAM_ARRAY[i]._flag)
3329                 PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
3330       return 0;
3331     }
3332 #  endif
3333     SETERRNO(EBADF,RMS_IFI);
3334     return EOF;
3335 # endif
3336 #endif
3337 }
3338
3339 void
3340 Perl_report_evil_fh(pTHX_ GV *gv, IO *io, I32 op)
3341 {
3342     char *func =
3343         op == OP_READLINE   ? "readline"  :     /* "<HANDLE>" not nice */
3344         op == OP_LEAVEWRITE ? "write" :         /* "write exit" not nice */
3345         PL_op_desc[op];
3346     char *pars = OP_IS_FILETEST(op) ? "" : "()";
3347     char *type = OP_IS_SOCKET(op)
3348             || (gv && io && IoTYPE(io) == IoTYPE_SOCKET)
3349                 ?  "socket" : "filehandle";
3350     char *name = NULL;
3351
3352     if (gv && isGV(gv)) {
3353         name = GvENAME(gv);
3354     }
3355
3356     if (op == OP_phoney_OUTPUT_ONLY || op == OP_phoney_INPUT_ONLY) {
3357         if (ckWARN(WARN_IO)) {
3358             const char *direction = (op == OP_phoney_INPUT_ONLY) ? "in" : "out";
3359             if (name && *name)
3360                 Perl_warner(aTHX_ packWARN(WARN_IO),
3361                             "Filehandle %s opened only for %sput",
3362                             name, direction);
3363             else
3364                 Perl_warner(aTHX_ packWARN(WARN_IO),
3365                             "Filehandle opened only for %sput", direction);
3366         }
3367     }
3368     else {
3369         char *vile;
3370         I32   warn_type;
3371
3372         if (gv && io && IoTYPE(io) == IoTYPE_CLOSED) {
3373             vile = "closed";
3374             warn_type = WARN_CLOSED;
3375         }
3376         else {
3377             vile = "unopened";
3378             warn_type = WARN_UNOPENED;
3379         }
3380
3381         if (ckWARN(warn_type)) {
3382             if (name && *name) {
3383                 Perl_warner(aTHX_ packWARN(warn_type),
3384                             "%s%s on %s %s %s", func, pars, vile, type, name);
3385                 if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3386                     Perl_warner(
3387                         aTHX_ packWARN(warn_type),
3388                         "\t(Are you trying to call %s%s on dirhandle %s?)\n",
3389                         func, pars, name
3390                     );
3391             }
3392             else {
3393                 Perl_warner(aTHX_ packWARN(warn_type),
3394                             "%s%s on %s %s", func, pars, vile, type);
3395                 if (gv && io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3396                     Perl_warner(
3397                         aTHX_ packWARN(warn_type),
3398                         "\t(Are you trying to call %s%s on dirhandle?)\n",
3399                         func, pars
3400                     );
3401             }
3402         }
3403     }
3404 }
3405
3406 #ifdef EBCDIC
3407 /* in ASCII order, not that it matters */
3408 static const char controllablechars[] = "?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_";
3409
3410 int
3411 Perl_ebcdic_control(pTHX_ int ch)
3412 {
3413     if (ch > 'a') {
3414         char *ctlp;
3415
3416         if (islower(ch))
3417             ch = toupper(ch);
3418
3419         if ((ctlp = strchr(controllablechars, ch)) == 0) {
3420             Perl_die(aTHX_ "unrecognised control character '%c'\n", ch);
3421         }
3422
3423         if (ctlp == controllablechars)
3424             return('\177'); /* DEL */
3425         else
3426             return((unsigned char)(ctlp - controllablechars - 1));
3427     } else { /* Want uncontrol */
3428         if (ch == '\177' || ch == -1)
3429             return('?');
3430         else if (ch == '\157')
3431             return('\177');
3432         else if (ch == '\174')
3433             return('\000');
3434         else if (ch == '^')    /* '\137' in 1047, '\260' in 819 */
3435             return('\036');
3436         else if (ch == '\155')
3437             return('\037');
3438         else if (0 < ch && ch < (sizeof(controllablechars) - 1))
3439             return(controllablechars[ch+1]);
3440         else
3441             Perl_die(aTHX_ "invalid control request: '\\%03o'\n", ch & 0xFF);
3442     }
3443 }
3444 #endif
3445
3446 /* To workaround core dumps from the uninitialised tm_zone we get the
3447  * system to give us a reasonable struct to copy.  This fix means that
3448  * strftime uses the tm_zone and tm_gmtoff values returned by
3449  * localtime(time()). That should give the desired result most of the
3450  * time. But probably not always!
3451  *
3452  * This does not address tzname aspects of NETaa14816.
3453  *
3454  */
3455
3456 #ifdef HAS_GNULIBC
3457 # ifndef STRUCT_TM_HASZONE
3458 #    define STRUCT_TM_HASZONE
3459 # endif
3460 #endif
3461
3462 #ifdef STRUCT_TM_HASZONE /* Backward compat */
3463 # ifndef HAS_TM_TM_ZONE
3464 #    define HAS_TM_TM_ZONE
3465 # endif
3466 #endif
3467
3468 void
3469 Perl_init_tm(pTHX_ struct tm *ptm)      /* see mktime, strftime and asctime */
3470 {
3471 #ifdef HAS_TM_TM_ZONE
3472     Time_t now;
3473     (void)time(&now);
3474     Copy(localtime(&now), ptm, 1, struct tm);
3475 #endif
3476 }
3477
3478 /*
3479  * mini_mktime - normalise struct tm values without the localtime()
3480  * semantics (and overhead) of mktime().
3481  */
3482 void
3483 Perl_mini_mktime(pTHX_ struct tm *ptm)
3484 {
3485     int yearday;
3486     int secs;
3487     int month, mday, year, jday;
3488     int odd_cent, odd_year;
3489
3490 #define DAYS_PER_YEAR   365
3491 #define DAYS_PER_QYEAR  (4*DAYS_PER_YEAR+1)
3492 #define DAYS_PER_CENT   (25*DAYS_PER_QYEAR-1)
3493 #define DAYS_PER_QCENT  (4*DAYS_PER_CENT+1)
3494 #define SECS_PER_HOUR   (60*60)
3495 #define SECS_PER_DAY    (24*SECS_PER_HOUR)
3496 /* parentheses deliberately absent on these two, otherwise they don't work */
3497 #define MONTH_TO_DAYS   153/5
3498 #define DAYS_TO_MONTH   5/153
3499 /* offset to bias by March (month 4) 1st between month/mday & year finding */
3500 #define YEAR_ADJUST     (4*MONTH_TO_DAYS+1)
3501 /* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */
3502 #define WEEKDAY_BIAS    6       /* (1+6)%7 makes Sunday 0 again */
3503
3504 /*
3505  * Year/day algorithm notes:
3506  *
3507  * With a suitable offset for numeric value of the month, one can find
3508  * an offset into the year by considering months to have 30.6 (153/5) days,
3509  * using integer arithmetic (i.e., with truncation).  To avoid too much
3510  * messing about with leap days, we consider January and February to be
3511  * the 13th and 14th month of the previous year.  After that transformation,
3512  * we need the month index we use to be high by 1 from 'normal human' usage,
3513  * so the month index values we use run from 4 through 15.
3514  *
3515  * Given that, and the rules for the Gregorian calendar (leap years are those
3516  * divisible by 4 unless also divisible by 100, when they must be divisible
3517  * by 400 instead), we can simply calculate the number of days since some
3518  * arbitrary 'beginning of time' by futzing with the (adjusted) year number,
3519  * the days we derive from our month index, and adding in the day of the
3520  * month.  The value used here is not adjusted for the actual origin which
3521  * it normally would use (1 January A.D. 1), since we're not exposing it.
3522  * We're only building the value so we can turn around and get the
3523  * normalised values for the year, month, day-of-month, and day-of-year.
3524  *
3525  * For going backward, we need to bias the value we're using so that we find
3526  * the right year value.  (Basically, we don't want the contribution of
3527  * March 1st to the number to apply while deriving the year).  Having done
3528  * that, we 'count up' the contribution to the year number by accounting for
3529  * full quadracenturies (400-year periods) with their extra leap days, plus
3530  * the contribution from full centuries (to avoid counting in the lost leap
3531  * days), plus the contribution from full quad-years (to count in the normal
3532  * leap days), plus the leftover contribution from any non-leap years.
3533  * At this point, if we were working with an actual leap day, we'll have 0
3534  * days left over.  This is also true for March 1st, however.  So, we have
3535  * to special-case that result, and (earlier) keep track of the 'odd'
3536  * century and year contributions.  If we got 4 extra centuries in a qcent,
3537  * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb.
3538  * Otherwise, we add back in the earlier bias we removed (the 123 from
3539  * figuring in March 1st), find the month index (integer division by 30.6),
3540  * and the remainder is the day-of-month.  We then have to convert back to
3541  * 'real' months (including fixing January and February from being 14/15 in
3542  * the previous year to being in the proper year).  After that, to get
3543  * tm_yday, we work with the normalised year and get a new yearday value for
3544  * January 1st, which we subtract from the yearday value we had earlier,
3545  * representing the date we've re-built.  This is done from January 1
3546  * because tm_yday is 0-origin.
3547  *
3548  * Since POSIX time routines are only guaranteed to work for times since the
3549  * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm
3550  * applies Gregorian calendar rules even to dates before the 16th century
3551  * doesn't bother me.  Besides, you'd need cultural context for a given
3552  * date to know whether it was Julian or Gregorian calendar, and that's
3553  * outside the scope for this routine.  Since we convert back based on the
3554  * same rules we used to build the yearday, you'll only get strange results
3555  * for input which needed normalising, or for the 'odd' century years which
3556  * were leap years in the Julian calander but not in the Gregorian one.
3557  * I can live with that.
3558  *
3559  * This algorithm also fails to handle years before A.D. 1 gracefully, but
3560  * that's still outside the scope for POSIX time manipulation, so I don't
3561  * care.
3562  */
3563
3564     year = 1900 + ptm->tm_year;
3565     month = ptm->tm_mon;
3566     mday = ptm->tm_mday;
3567     /* allow given yday with no month & mday to dominate the result */
3568     if (ptm->tm_yday >= 0 && mday <= 0 && month <= 0) {
3569         month = 0;
3570         mday = 0;
3571         jday = 1 + ptm->tm_yday;
3572     }
3573     else {
3574         jday = 0;
3575     }
3576     if (month >= 2)
3577         month+=2;
3578     else
3579         month+=14, year--;
3580     yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400;
3581     yearday += month*MONTH_TO_DAYS + mday + jday;
3582     /*
3583      * Note that we don't know when leap-seconds were or will be,
3584      * so we have to trust the user if we get something which looks
3585      * like a sensible leap-second.  Wild values for seconds will
3586      * be rationalised, however.
3587      */
3588     if ((unsigned) ptm->tm_sec <= 60) {
3589         secs = 0;
3590     }
3591     else {
3592         secs = ptm->tm_sec;
3593         ptm->tm_sec = 0;
3594     }
3595     secs += 60 * ptm->tm_min;
3596     secs += SECS_PER_HOUR * ptm->tm_hour;
3597     if (secs < 0) {
3598         if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) {
3599             /* got negative remainder, but need positive time */
3600             /* back off an extra day to compensate */
3601             yearday += (secs/SECS_PER_DAY)-1;
3602             secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1);
3603         }
3604         else {
3605             yearday += (secs/SECS_PER_DAY);
3606             secs -= SECS_PER_DAY * (secs/SECS_PER_DAY);
3607         }
3608     }
3609     else if (secs >= SECS_PER_DAY) {
3610         yearday += (secs/SECS_PER_DAY);
3611         secs %= SECS_PER_DAY;
3612     }
3613     ptm->tm_hour = secs/SECS_PER_HOUR;
3614     secs %= SECS_PER_HOUR;
3615     ptm->tm_min = secs/60;
3616     secs %= 60;
3617     ptm->tm_sec += secs;
3618     /* done with time of day effects */
3619     /*
3620      * The algorithm for yearday has (so far) left it high by 428.
3621      * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to
3622      * bias it by 123 while trying to figure out what year it
3623      * really represents.  Even with this tweak, the reverse
3624      * translation fails for years before A.D. 0001.
3625      * It would still fail for Feb 29, but we catch that one below.
3626      */
3627     jday = yearday;     /* save for later fixup vis-a-vis Jan 1 */
3628     yearday -= YEAR_ADJUST;
3629     year = (yearday / DAYS_PER_QCENT) * 400;
3630     yearday %= DAYS_PER_QCENT;
3631     odd_cent = yearday / DAYS_PER_CENT;
3632     year += odd_cent * 100;
3633     yearday %= DAYS_PER_CENT;
3634     year += (yearday / DAYS_PER_QYEAR) * 4;
3635     yearday %= DAYS_PER_QYEAR;
3636     odd_year = yearday / DAYS_PER_YEAR;
3637     year += odd_year;
3638     yearday %= DAYS_PER_YEAR;
3639     if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */
3640         month = 1;
3641         yearday = 29;
3642     }
3643     else {
3644         yearday += YEAR_ADJUST; /* recover March 1st crock */
3645         month = yearday*DAYS_TO_MONTH;
3646         yearday -= month*MONTH_TO_DAYS;
3647         /* recover other leap-year adjustment */
3648         if (month > 13) {
3649             month-=14;
3650             year++;
3651         }
3652         else {
3653             month-=2;
3654         }
3655     }
3656     ptm->tm_year = year - 1900;
3657     if (yearday) {
3658       ptm->tm_mday = yearday;
3659       ptm->tm_mon = month;
3660     }
3661     else {
3662       ptm->tm_mday = 31;
3663       ptm->tm_mon = month - 1;
3664     }
3665     /* re-build yearday based on Jan 1 to get tm_yday */
3666     year--;
3667     yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400;
3668     yearday += 14*MONTH_TO_DAYS + 1;
3669     ptm->tm_yday = jday - yearday;
3670     /* fix tm_wday if not overridden by caller */
3671     if ((unsigned)ptm->tm_wday > 6)
3672         ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
3673 }
3674
3675 char *
3676 Perl_my_strftime(pTHX_ char *fmt, int sec, int min, int hour, int mday, int mon, int year, int wday, int yday, int isdst)
3677 {
3678 #ifdef HAS_STRFTIME
3679   char *buf;
3680   int buflen;
3681   struct tm mytm;
3682   int len;
3683
3684   init_tm(&mytm);       /* XXX workaround - see init_tm() above */
3685   mytm.tm_sec = sec;
3686   mytm.tm_min = min;
3687   mytm.tm_hour = hour;
3688   mytm.tm_mday = mday;
3689   mytm.tm_mon = mon;
3690   mytm.tm_year = year;
3691   mytm.tm_wday = wday;
3692   mytm.tm_yday = yday;
3693   mytm.tm_isdst = isdst;
3694   mini_mktime(&mytm);
3695   /* use libc to get the values for tm_gmtoff and tm_zone [perl #18238] */
3696 #if defined(HAS_MKTIME) && (defined(HAS_TM_TM_GMTOFF) || defined(HAS_TM_TM_ZONE))
3697   STMT_START {
3698     struct tm mytm2;
3699     mytm2 = mytm;
3700     mktime(&mytm2);
3701 #ifdef HAS_TM_TM_GMTOFF
3702     mytm.tm_gmtoff = mytm2.tm_gmtoff;
3703 #endif
3704 #ifdef HAS_TM_TM_ZONE
3705     mytm.tm_zone = mytm2.tm_zone;
3706 #endif
3707   } STMT_END;
3708 #endif
3709   buflen = 64;
3710   New(0, buf, buflen, char);
3711   len = strftime(buf, buflen, fmt, &mytm);
3712   /*
3713   ** The following is needed to handle to the situation where
3714   ** tmpbuf overflows.  Basically we want to allocate a buffer
3715   ** and try repeatedly.  The reason why it is so complicated
3716   ** is that getting a return value of 0 from strftime can indicate
3717   ** one of the following:
3718   ** 1. buffer overflowed,
3719   ** 2. illegal conversion specifier, or
3720   ** 3. the format string specifies nothing to be returned(not
3721   **      an error).  This could be because format is an empty string
3722   **    or it specifies %p that yields an empty string in some locale.
3723   ** If there is a better way to make it portable, go ahead by
3724   ** all means.
3725   */
3726   if ((len > 0 && len < buflen) || (len == 0 && *fmt == '\0'))
3727     return buf;
3728   else {
3729     /* Possibly buf overflowed - try again with a bigger buf */
3730     int     fmtlen = strlen(fmt);
3731     int     bufsize = fmtlen + buflen;
3732
3733     New(0, buf, bufsize, char);
3734     while (buf) {
3735       buflen = strftime(buf, bufsize, fmt, &mytm);
3736       if (buflen > 0 && buflen < bufsize)
3737         break;
3738       /* heuristic to prevent out-of-memory errors */
3739       if (bufsize > 100*fmtlen) {
3740         Safefree(buf);
3741         buf = NULL;
3742         break;
3743       }
3744       bufsize *= 2;
3745       Renew(buf, bufsize, char);
3746     }
3747     return buf;
3748   }
3749 #else
3750   Perl_croak(aTHX_ "panic: no strftime");
3751 #endif
3752 }
3753
3754
3755 #define SV_CWD_RETURN_UNDEF \
3756 sv_setsv(sv, &PL_sv_undef); \
3757 return FALSE
3758
3759 #define SV_CWD_ISDOT(dp) \
3760     (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
3761         (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
3762
3763 /*
3764 =head1 Miscellaneous Functions
3765
3766 =for apidoc getcwd_sv
3767
3768 Fill the sv with current working directory
3769
3770 =cut
3771 */
3772
3773 /* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars.
3774  * rewritten again by dougm, optimized for use with xs TARG, and to prefer
3775  * getcwd(3) if available
3776  * Comments from the orignal:
3777  *     This is a faster version of getcwd.  It's also more dangerous
3778  *     because you might chdir out of a directory that you can't chdir
3779  *     back into. */
3780
3781 int
3782 Perl_getcwd_sv(pTHX_ register SV *sv)
3783 {
3784 #ifndef PERL_MICRO
3785
3786 #ifndef INCOMPLETE_TAINTS
3787     SvTAINTED_on(sv);
3788 #endif
3789
3790 #ifdef HAS_GETCWD
3791     {
3792         char buf[MAXPATHLEN];
3793
3794         /* Some getcwd()s automatically allocate a buffer of the given
3795          * size from the heap if they are given a NULL buffer pointer.
3796          * The problem is that this behaviour is not portable. */
3797         if (getcwd(buf, sizeof(buf) - 1)) {
3798             STRLEN len = strlen(buf);
3799             sv_setpvn(sv, buf, len);
3800             return TRUE;
3801         }
3802         else {
3803             sv_setsv(sv, &PL_sv_undef);
3804             return FALSE;
3805         }
3806     }
3807
3808 #else
3809
3810     Stat_t statbuf;
3811     int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
3812     int namelen, pathlen=0;
3813     DIR *dir;
3814     Direntry_t *dp;
3815
3816     (void)SvUPGRADE(sv, SVt_PV);
3817
3818     if (PerlLIO_lstat(".", &statbuf) < 0) {
3819         SV_CWD_RETURN_UNDEF;
3820     }
3821
3822     orig_cdev = statbuf.st_dev;
3823     orig_cino = statbuf.st_ino;
3824     cdev = orig_cdev;
3825     cino = orig_cino;
3826
3827     for (;;) {
3828         odev = cdev;
3829         oino = cino;
3830
3831         if (PerlDir_chdir("..") < 0) {
3832             SV_CWD_RETURN_UNDEF;
3833         }
3834         if (PerlLIO_stat(".", &statbuf) < 0) {
3835             SV_CWD_RETURN_UNDEF;
3836         }
3837
3838         cdev = statbuf.st_dev;
3839         cino = statbuf.st_ino;
3840
3841         if (odev == cdev && oino == cino) {
3842             break;
3843         }
3844         if (!(dir = PerlDir_open("."))) {
3845             SV_CWD_RETURN_UNDEF;
3846         }
3847
3848         while ((dp = PerlDir_read(dir)) != NULL) {
3849 #ifdef DIRNAMLEN
3850             namelen = dp->d_namlen;
3851 #else
3852             namelen = strlen(dp->d_name);
3853 #endif
3854             /* skip . and .. */
3855             if (SV_CWD_ISDOT(dp)) {
3856                 continue;
3857             }
3858
3859             if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
3860                 SV_CWD_RETURN_UNDEF;
3861             }
3862
3863             tdev = statbuf.st_dev;
3864             tino = statbuf.st_ino;
3865             if (tino == oino && tdev == odev) {
3866                 break;
3867             }
3868         }
3869
3870         if (!dp) {
3871             SV_CWD_RETURN_UNDEF;
3872         }
3873
3874         if (pathlen + namelen + 1 >= MAXPATHLEN) {
3875             SV_CWD_RETURN_UNDEF;
3876         }
3877
3878         SvGROW(sv, pathlen + namelen + 1);
3879
3880         if (pathlen) {
3881             /* shift down */
3882             Move(SvPVX(sv), SvPVX(sv) + namelen + 1, pathlen, char);
3883         }
3884
3885         /* prepend current directory to the front */
3886         *SvPVX(sv) = '/';
3887         Move(dp->d_name, SvPVX(sv)+1, namelen, char);
3888         pathlen += (namelen + 1);
3889
3890 #ifdef VOID_CLOSEDIR
3891         PerlDir_close(dir);
3892 #else
3893         if (PerlDir_close(dir) < 0) {
3894             SV_CWD_RETURN_UNDEF;
3895         }
3896 #endif
3897     }
3898
3899     if (pathlen) {
3900         SvCUR_set(sv, pathlen);
3901         *SvEND(sv) = '\0';
3902         SvPOK_only(sv);
3903
3904         if (PerlDir_chdir(SvPVX(sv)) < 0) {
3905             SV_CWD_RETURN_UNDEF;
3906         }
3907     }
3908     if (PerlLIO_stat(".", &statbuf) < 0) {
3909         SV_CWD_RETURN_UNDEF;
3910     }
3911
3912     cdev = statbuf.st_dev;
3913     cino = statbuf.st_ino;
3914
3915     if (cdev != orig_cdev || cino != orig_cino) {
3916         Perl_croak(aTHX_ "Unstable directory path, "
3917                    "current directory changed unexpectedly");
3918     }
3919
3920     return TRUE;
3921 #endif
3922
3923 #else
3924     return FALSE;
3925 #endif
3926 }
3927
3928 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT)
3929 #   define EMULATE_SOCKETPAIR_UDP
3930 #endif
3931
3932 #ifdef EMULATE_SOCKETPAIR_UDP
3933 static int
3934 S_socketpair_udp (int fd[2]) {
3935     dTHX;
3936     /* Fake a datagram socketpair using UDP to localhost.  */
3937     int sockets[2] = {-1, -1};
3938     struct sockaddr_in addresses[2];
3939     int i;
3940     Sock_size_t size = sizeof(struct sockaddr_in);
3941     unsigned short port;
3942     int got;
3943
3944     memset(&addresses, 0, sizeof(addresses));
3945     i = 1;
3946     do {
3947         sockets[i] = PerlSock_socket(AF_INET, SOCK_DGRAM, PF_INET);
3948         if (sockets[i] == -1)
3949             goto tidy_up_and_fail;
3950
3951         addresses[i].sin_family = AF_INET;
3952         addresses[i].sin_addr.s_addr = htonl(INADDR_LOOPBACK);
3953         addresses[i].sin_port = 0;      /* kernel choses port.  */
3954         if (PerlSock_bind(sockets[i], (struct sockaddr *) &addresses[i],
3955                 sizeof(struct sockaddr_in)) == -1)
3956             goto tidy_up_and_fail;
3957     } while (i--);
3958
3959     /* Now have 2 UDP sockets. Find out which port each is connected to, and
3960        for each connect the other socket to it.  */
3961     i = 1;
3962     do {
3963         if (PerlSock_getsockname(sockets[i], (struct sockaddr *) &addresses[i],
3964                 &size) == -1)
3965             goto tidy_up_and_fail;
3966         if (size != sizeof(struct sockaddr_in))
3967             goto abort_tidy_up_and_fail;
3968         /* !1 is 0, !0 is 1 */
3969         if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i],
3970                 sizeof(struct sockaddr_in)) == -1)
3971             goto tidy_up_and_fail;
3972     } while (i--);
3973
3974     /* Now we have 2 sockets connected to each other. I don't trust some other
3975        process not to have already sent a packet to us (by random) so send
3976        a packet from each to the other.  */
3977     i = 1;
3978     do {
3979         /* I'm going to send my own port number.  As a short.
3980            (Who knows if someone somewhere has sin_port as a bitfield and needs
3981            this routine. (I'm assuming crays have socketpair)) */
3982         port = addresses[i].sin_port;
3983         got = PerlLIO_write(sockets[i], &port, sizeof(port));
3984         if (got != sizeof(port)) {
3985             if (got == -1)
3986                 goto tidy_up_and_fail;
3987             goto abort_tidy_up_and_fail;
3988         }
3989     } while (i--);
3990
3991     /* Packets sent. I don't trust them to have arrived though.
3992        (As I understand it Solaris TCP stack is multithreaded. Non-blocking
3993        connect to localhost will use a second kernel thread. In 2.6 the
3994        first thread running the connect() returns before the second completes,
3995        so EINPROGRESS> In 2.7 the improved stack is faster and connect()
3996        returns 0. Poor programs have tripped up. One poor program's authors'
3997        had a 50-1 reverse stock split. Not sure how connected these were.)
3998        So I don't trust someone not to have an unpredictable UDP stack.
3999     */
4000
4001     {
4002         struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */
4003         int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0];
4004         fd_set rset;
4005
4006         FD_ZERO(&rset);
4007         FD_SET(sockets[0], &rset);
4008         FD_SET(sockets[1], &rset);
4009
4010         got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor);
4011         if (got != 2 || !FD_ISSET(sockets[0], &rset)
4012                 || !FD_ISSET(sockets[1], &rset)) {
4013             /* I hope this is portable and appropriate.  */
4014             if (got == -1)
4015                 goto tidy_up_and_fail;
4016             goto abort_tidy_up_and_fail;
4017         }
4018     }
4019
4020     /* And the paranoia department even now doesn't trust it to have arrive
4021        (hence MSG_DONTWAIT). Or that what arrives was sent by us.  */
4022     {
4023         struct sockaddr_in readfrom;
4024         unsigned short buffer[2];
4025
4026         i = 1;
4027         do {
4028 #ifdef MSG_DONTWAIT
4029             got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4030                     sizeof(buffer), MSG_DONTWAIT,
4031                     (struct sockaddr *) &readfrom, &size);
4032 #else
4033             got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4034                     sizeof(buffer), 0,
4035                     (struct sockaddr *) &readfrom, &size);
4036 #endif
4037
4038             if (got == -1)
4039                 goto tidy_up_and_fail;
4040             if (got != sizeof(port)
4041                     || size != sizeof(struct sockaddr_in)
4042                     /* Check other socket sent us its port.  */
4043                     || buffer[0] != (unsigned short) addresses[!i].sin_port
4044                     /* Check kernel says we got the datagram from that socket */
4045                     || readfrom.sin_family != addresses[!i].sin_family
4046                     || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr
4047                     || readfrom.sin_port != addresses[!i].sin_port)
4048                 goto abort_tidy_up_and_fail;
4049         } while (i--);
4050     }
4051     /* My caller (my_socketpair) has validated that this is non-NULL  */
4052     fd[0] = sockets[0];
4053     fd[1] = sockets[1];
4054     /* I hereby declare this connection open.  May God bless all who cross
4055        her.  */
4056     return 0;
4057
4058   abort_tidy_up_and_fail:
4059     errno = ECONNABORTED;
4060   tidy_up_and_fail:
4061     {
4062         int save_errno = errno;
4063         if (sockets[0] != -1)
4064             PerlLIO_close(sockets[0]);
4065         if (sockets[1] != -1)
4066             PerlLIO_close(sockets[1]);
4067         errno = save_errno;
4068         return -1;
4069     }
4070 }
4071 #endif /*  EMULATE_SOCKETPAIR_UDP */
4072
4073 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET)
4074 int
4075 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4076     /* Stevens says that family must be AF_LOCAL, protocol 0.
4077        I'm going to enforce that, then ignore it, and use TCP (or UDP).  */
4078     dTHX;
4079     int listener = -1;
4080     int connector = -1;
4081     int acceptor = -1;
4082     struct sockaddr_in listen_addr;
4083     struct sockaddr_in connect_addr;
4084     Sock_size_t size;
4085
4086     if (protocol
4087 #ifdef AF_UNIX
4088         || family != AF_UNIX
4089 #endif
4090     ) {
4091         errno = EAFNOSUPPORT;
4092         return -1;
4093     }
4094     if (!fd) {
4095         errno = EINVAL;
4096         return -1;
4097     }
4098
4099 #ifdef EMULATE_SOCKETPAIR_UDP
4100     if (type == SOCK_DGRAM)
4101         return S_socketpair_udp(fd);
4102 #endif
4103
4104     listener = PerlSock_socket(AF_INET, type, 0);
4105     if (listener == -1)
4106         return -1;
4107     memset(&listen_addr, 0, sizeof(listen_addr));
4108     listen_addr.sin_family = AF_INET;
4109     listen_addr.sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4110     listen_addr.sin_port = 0;   /* kernel choses port.  */
4111     if (PerlSock_bind(listener, (struct sockaddr *) &listen_addr,
4112             sizeof(listen_addr)) == -1)
4113         goto tidy_up_and_fail;
4114     if (PerlSock_listen(listener, 1) == -1)
4115         goto tidy_up_and_fail;
4116
4117     connector = PerlSock_socket(AF_INET, type, 0);
4118     if (connector == -1)
4119         goto tidy_up_and_fail;
4120     /* We want to find out the port number to connect to.  */
4121     size = sizeof(connect_addr);
4122     if (PerlSock_getsockname(listener, (struct sockaddr *) &connect_addr,
4123             &size) == -1)
4124         goto tidy_up_and_fail;
4125     if (size != sizeof(connect_addr))
4126         goto abort_tidy_up_and_fail;
4127     if (PerlSock_connect(connector, (struct sockaddr *) &connect_addr,
4128             sizeof(connect_addr)) == -1)
4129         goto tidy_up_and_fail;
4130
4131     size = sizeof(listen_addr);
4132     acceptor = PerlSock_accept(listener, (struct sockaddr *) &listen_addr,
4133             &size);
4134     if (acceptor == -1)
4135         goto tidy_up_and_fail;
4136     if (size != sizeof(listen_addr))
4137         goto abort_tidy_up_and_fail;
4138     PerlLIO_close(listener);
4139     /* Now check we are talking to ourself by matching port and host on the
4140        two sockets.  */
4141     if (PerlSock_getsockname(connector, (struct sockaddr *) &connect_addr,
4142             &size) == -1)
4143         goto tidy_up_and_fail;
4144     if (size != sizeof(connect_addr)
4145             || listen_addr.sin_family != connect_addr.sin_family
4146             || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr
4147             || listen_addr.sin_port != connect_addr.sin_port) {
4148         goto abort_tidy_up_and_fail;
4149     }
4150     fd[0] = connector;
4151     fd[1] = acceptor;
4152     return 0;
4153
4154   abort_tidy_up_and_fail:
4155   errno = ECONNABORTED; /* I hope this is portable and appropriate.  */
4156   tidy_up_and_fail:
4157     {
4158         int save_errno = errno;
4159         if (listener != -1)
4160             PerlLIO_close(listener);
4161         if (connector != -1)
4162             PerlLIO_close(connector);
4163         if (acceptor != -1)
4164             PerlLIO_close(acceptor);
4165         errno = save_errno;
4166         return -1;
4167     }
4168 }
4169 #else
4170 /* In any case have a stub so that there's code corresponding
4171  * to the my_socketpair in global.sym. */
4172 int
4173 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4174 #ifdef HAS_SOCKETPAIR
4175     return socketpair(family, type, protocol, fd);
4176 #else
4177     return -1;
4178 #endif
4179 }
4180 #endif
4181
4182 /*
4183
4184 =for apidoc sv_nosharing
4185
4186 Dummy routine which "shares" an SV when there is no sharing module present.
4187 Exists to avoid test for a NULL function pointer and because it could potentially warn under
4188 some level of strict-ness.
4189
4190 =cut
4191 */
4192
4193 void
4194 Perl_sv_nosharing(pTHX_ SV *sv)
4195 {
4196 }
4197
4198 /*
4199 =for apidoc sv_nolocking
4200
4201 Dummy routine which "locks" an SV when there is no locking module present.
4202 Exists to avoid test for a NULL function pointer and because it could potentially warn under
4203 some level of strict-ness.
4204
4205 =cut
4206 */
4207
4208 void
4209 Perl_sv_nolocking(pTHX_ SV *sv)
4210 {
4211 }
4212
4213
4214 /*
4215 =for apidoc sv_nounlocking
4216
4217 Dummy routine which "unlocks" an SV when there is no locking module present.
4218 Exists to avoid test for a NULL function pointer and because it could potentially warn under
4219 some level of strict-ness.
4220
4221 =cut
4222 */
4223
4224 void
4225 Perl_sv_nounlocking(pTHX_ SV *sv)
4226 {
4227 }
4228
4229 U32
4230 Perl_parse_unicode_opts(pTHX_ char **popt)
4231 {
4232   char *p = *popt;
4233   U32 opt = 0;
4234
4235   if (*p) {
4236        if (isDIGIT(*p)) {
4237             opt = (U32) atoi(p);
4238             while (isDIGIT(*p)) p++;
4239             if (*p && *p != '\n' && *p != '\r')
4240                  Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
4241        }
4242        else {
4243             for (; *p; p++) {
4244                  switch (*p) {
4245                  case PERL_UNICODE_STDIN:
4246                       opt |= PERL_UNICODE_STDIN_FLAG;   break;
4247                  case PERL_UNICODE_STDOUT:
4248                       opt |= PERL_UNICODE_STDOUT_FLAG;  break;
4249                  case PERL_UNICODE_STDERR:
4250                       opt |= PERL_UNICODE_STDERR_FLAG;  break;
4251                  case PERL_UNICODE_STD:
4252                       opt |= PERL_UNICODE_STD_FLAG;     break;
4253                  case PERL_UNICODE_IN:
4254                       opt |= PERL_UNICODE_IN_FLAG;      break;
4255                  case PERL_UNICODE_OUT:
4256                       opt |= PERL_UNICODE_OUT_FLAG;     break;
4257                  case PERL_UNICODE_INOUT:
4258                       opt |= PERL_UNICODE_INOUT_FLAG;   break;
4259                  case PERL_UNICODE_LOCALE:
4260                       opt |= PERL_UNICODE_LOCALE_FLAG;  break;
4261                  case PERL_UNICODE_ARGV:
4262                       opt |= PERL_UNICODE_ARGV_FLAG;    break;
4263                  default:
4264                       if (*p != '\n' && *p != '\r')
4265                           Perl_croak(aTHX_
4266                                      "Unknown Unicode option letter '%c'", *p);
4267                  }
4268             }
4269        }
4270   }
4271   else
4272        opt = PERL_UNICODE_DEFAULT_FLAGS;
4273
4274   if (opt & ~PERL_UNICODE_ALL_FLAGS)
4275        Perl_croak(aTHX_ "Unknown Unicode option value %"UVuf,
4276                   (UV) (opt & ~PERL_UNICODE_ALL_FLAGS));
4277
4278   *popt = p;
4279
4280   return opt;
4281 }
4282
4283 U32
4284 Perl_seed(pTHX)
4285 {
4286     /*
4287      * This is really just a quick hack which grabs various garbage
4288      * values.  It really should be a real hash algorithm which
4289      * spreads the effect of every input bit onto every output bit,
4290      * if someone who knows about such things would bother to write it.
4291      * Might be a good idea to add that function to CORE as well.
4292      * No numbers below come from careful analysis or anything here,
4293      * except they are primes and SEED_C1 > 1E6 to get a full-width
4294      * value from (tv_sec * SEED_C1 + tv_usec).  The multipliers should
4295      * probably be bigger too.
4296      */
4297 #if RANDBITS > 16
4298 #  define SEED_C1       1000003
4299 #define   SEED_C4       73819
4300 #else
4301 #  define SEED_C1       25747
4302 #define   SEED_C4       20639
4303 #endif
4304 #define   SEED_C2       3
4305 #define   SEED_C3       269
4306 #define   SEED_C5       26107
4307
4308 #ifndef PERL_NO_DEV_RANDOM
4309     int fd;
4310 #endif
4311     U32 u;
4312 #ifdef VMS
4313 #  include <starlet.h>
4314     /* when[] = (low 32 bits, high 32 bits) of time since epoch
4315      * in 100-ns units, typically incremented ever 10 ms.        */
4316     unsigned int when[2];
4317 #else
4318 #  ifdef HAS_GETTIMEOFDAY
4319     struct timeval when;
4320 #  else
4321     Time_t when;
4322 #  endif
4323 #endif
4324
4325 /* This test is an escape hatch, this symbol isn't set by Configure. */
4326 #ifndef PERL_NO_DEV_RANDOM
4327 #ifndef PERL_RANDOM_DEVICE
4328    /* /dev/random isn't used by default because reads from it will block
4329     * if there isn't enough entropy available.  You can compile with
4330     * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
4331     * is enough real entropy to fill the seed. */
4332 #  define PERL_RANDOM_DEVICE "/dev/urandom"
4333 #endif
4334     fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
4335     if (fd != -1) {
4336         if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
4337             u = 0;
4338         PerlLIO_close(fd);
4339         if (u)
4340             return u;
4341     }
4342 #endif
4343
4344 #ifdef VMS
4345     _ckvmssts(sys$gettim(when));
4346     u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
4347 #else
4348 #  ifdef HAS_GETTIMEOFDAY
4349     PerlProc_gettimeofday(&when,NULL);
4350     u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
4351 #  else
4352     (void)time(&when);
4353     u = (U32)SEED_C1 * when;
4354 #  endif
4355 #endif
4356     u += SEED_C3 * (U32)PerlProc_getpid();
4357     u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
4358 #ifndef PLAN9           /* XXX Plan9 assembler chokes on this; fix needed  */
4359     u += SEED_C5 * (U32)PTR2UV(&when);
4360 #endif
4361     return u;
4362 }
4363
4364 UV
4365 Perl_get_hash_seed(pTHX)
4366 {
4367      char *s = PerlEnv_getenv("PERL_HASH_SEED");
4368      UV myseed = 0;
4369
4370      if (s)
4371           while (isSPACE(*s)) s++;
4372      if (s && isDIGIT(*s))
4373           myseed = (UV)Atoul(s);
4374      else
4375 #ifdef USE_HASH_SEED_EXPLICIT
4376      if (s)
4377 #endif
4378      {
4379           /* Compute a random seed */
4380           (void)seedDrand01((Rand_seed_t)seed());
4381           PL_srand_called = TRUE;
4382           myseed = (UV)(Drand01() * (NV)UV_MAX);
4383 #if RANDBITS < (UVSIZE * 8)
4384           /* Since there are not enough randbits to to reach all
4385            * the bits of a UV, the low bits might need extra
4386            * help.  Sum in another random number that will
4387            * fill in the low bits. */
4388           myseed +=
4389                (UV)(Drand01() * (NV)((1 << ((UVSIZE * 8 - RANDBITS))) - 1));
4390 #endif /* RANDBITS < (UVSIZE * 8) */
4391      }
4392      PL_hash_seed_set = TRUE;
4393
4394      return myseed;
4395 }