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         sv_catpv(sv, PL_dirty ? dgd : ".\n");
 976     }
 977     return sv;
 978 }
 979
 980 void
 981 Perl_write_to_stderr(pTHX_ const char* message, int msglen)
 982 {
 983     IO *io;
 984     MAGIC *mg;
 985
 986     if (PL_stderrgv && SvREFCNT(PL_stderrgv)
 987         && (io = GvIO(PL_stderrgv))
 988         && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
 989     {
 990         dSP;
 991         ENTER;
 992         SAVETMPS;
 993
 994         save_re_context();
 995         SAVESPTR(PL_stderrgv);
 996         PL_stderrgv = Nullgv;
 997
 998         PUSHSTACKi(PERLSI_MAGIC);
 999
1000         PUSHMARK(SP);
1001         EXTEND(SP,2);
1002         PUSHs(SvTIED_obj((SV*)io, mg));
1003         PUSHs(sv_2mortal(newSVpvn(message, msglen)));
1004         PUTBACK;
1005         call_method("PRINT", G_SCALAR);
1006
1007         POPSTACK;
1008         FREETMPS;
1009         LEAVE;
1010     }
1011     else {
1012 #ifdef USE_SFIO
1013         /* SFIO can really mess with your errno */
1014         int e = errno;
1015 #endif
1016         PerlIO *serr = Perl_error_log;
1017
1018         PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
1019         (void)PerlIO_flush(serr);
1020 #ifdef USE_SFIO
1021         errno = e;
1022 #endif
1023     }
1024 }
1025
1026 OP *
1027 Perl_vdie(pTHX_ const char* pat, va_list *args)
1028 {
1029     char *message;
1030     int was_in_eval = PL_in_eval;
1031     HV *stash;
1032     GV *gv;
1033     CV *cv;
1034     SV *msv;
1035     STRLEN msglen;
1036     I32 utf8 = 0;
1037
1038     DEBUG_S(PerlIO_printf(Perl_debug_log,
1039                           "%p: die: curstack = %p, mainstack = %p\n",
1040                           thr, PL_curstack, PL_mainstack));
1041
1042     if (pat) {
1043         msv = vmess(pat, args);
1044         if (PL_errors && SvCUR(PL_errors)) {
1045             sv_catsv(PL_errors, msv);
1046             message = SvPV(PL_errors, msglen);
1047             SvCUR_set(PL_errors, 0);
1048         }
1049         else
1050             message = SvPV(msv,msglen);
1051         utf8 = SvUTF8(msv);
1052     }
1053     else {
1054         message = Nullch;
1055         msglen = 0;
1056     }
1057
1058     DEBUG_S(PerlIO_printf(Perl_debug_log,
1059                           "%p: die: message = %s\ndiehook = %p\n",
1060                           thr, message, PL_diehook));
1061     if (PL_diehook) {
1062         /* sv_2cv might call Perl_croak() */
1063         SV *olddiehook = PL_diehook;
1064         ENTER;
1065         SAVESPTR(PL_diehook);
1066         PL_diehook = Nullsv;
1067         cv = sv_2cv(olddiehook, &stash, &gv, 0);
1068         LEAVE;
1069         if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1070             dSP;
1071             SV *msg;
1072
1073             ENTER;
1074             save_re_context();
1075             if (message) {
1076                 msg = newSVpvn(message, msglen);
1077                 SvFLAGS(msg) |= utf8;
1078                 SvREADONLY_on(msg);
1079                 SAVEFREESV(msg);
1080             }
1081             else {
1082                 msg = ERRSV;
1083             }
1084
1085             PUSHSTACKi(PERLSI_DIEHOOK);
1086             PUSHMARK(SP);
1087             XPUSHs(msg);
1088             PUTBACK;
1089             call_sv((SV*)cv, G_DISCARD);
1090             POPSTACK;
1091             LEAVE;
1092         }
1093     }
1094
1095     PL_restartop = die_where(message, msglen);
1096     SvFLAGS(ERRSV) |= utf8;
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     I32 utf8 = 0;
1140
1141     if (pat) {
1142         msv = vmess(pat, args);
1143         if (PL_errors && SvCUR(PL_errors)) {
1144             sv_catsv(PL_errors, msv);
1145             message = SvPV(PL_errors, msglen);
1146             SvCUR_set(PL_errors, 0);
1147         }
1148         else
1149             message = SvPV(msv,msglen);
1150         utf8 = SvUTF8(msv);
1151     }
1152     else {
1153         message = Nullch;
1154         msglen = 0;
1155     }
1156
1157     DEBUG_S(PerlIO_printf(Perl_debug_log, "croak: 0x%"UVxf" %s",
1158                           PTR2UV(thr), message));
1159
1160     if (PL_diehook) {
1161         /* sv_2cv might call Perl_croak() */
1162         SV *olddiehook = PL_diehook;
1163         ENTER;
1164         SAVESPTR(PL_diehook);
1165         PL_diehook = Nullsv;
1166         cv = sv_2cv(olddiehook, &stash, &gv, 0);
1167         LEAVE;
1168         if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1169             dSP;
1170             SV *msg;
1171
1172             ENTER;
1173             save_re_context();
1174             if (message) {
1175                 msg = newSVpvn(message, msglen);
1176                 SvFLAGS(msg) |= utf8;
1177                 SvREADONLY_on(msg);
1178                 SAVEFREESV(msg);
1179             }
1180             else {
1181                 msg = ERRSV;
1182             }
1183
1184             PUSHSTACKi(PERLSI_DIEHOOK);
1185             PUSHMARK(SP);
1186             XPUSHs(msg);
1187             PUTBACK;
1188             call_sv((SV*)cv, G_DISCARD);
1189             POPSTACK;
1190             LEAVE;
1191         }
1192     }
1193     if (PL_in_eval) {
1194         PL_restartop = die_where(message, msglen);
1195         SvFLAGS(ERRSV) |= utf8;
1196         JMPENV_JUMP(3);
1197     }
1198     else if (!message)
1199         message = SvPVx(ERRSV, msglen);
1200
1201     write_to_stderr(message, msglen);
1202     my_failure_exit();
1203 }
1204
1205 #if defined(PERL_IMPLICIT_CONTEXT)
1206 void
1207 Perl_croak_nocontext(const char *pat, ...)
1208 {
1209     dTHX;
1210     va_list args;
1211     va_start(args, pat);
1212     vcroak(pat, &args);
1213     /* NOTREACHED */
1214     va_end(args);
1215 }
1216 #endif /* PERL_IMPLICIT_CONTEXT */
1217
1218 /*
1219 =head1 Warning and Dieing
1220
1221 =for apidoc croak
1222
1223 This is the XSUB-writer's interface to Perl's C<die> function.
1224 Normally use this function the same way you use the C C<printf>
1225 function.  See C<warn>.
1226
1227 If you want to throw an exception object, assign the object to
1228 C<$@> and then pass C<Nullch> to croak():
1229
1230    errsv = get_sv("@", TRUE);
1231    sv_setsv(errsv, exception_object);
1232    croak(Nullch);
1233
1234 =cut
1235 */
1236
1237 void
1238 Perl_croak(pTHX_ const char *pat, ...)
1239 {
1240     va_list args;
1241     va_start(args, pat);
1242     vcroak(pat, &args);
1243     /* NOTREACHED */
1244     va_end(args);
1245 }
1246
1247 void
1248 Perl_vwarn(pTHX_ const char* pat, va_list *args)
1249 {
1250     char *message;
1251     HV *stash;
1252     GV *gv;
1253     CV *cv;
1254     SV *msv;
1255     STRLEN msglen;
1256     I32 utf8 = 0;
1257
1258     msv = vmess(pat, args);
1259     utf8 = SvUTF8(msv);
1260     message = SvPV(msv, msglen);
1261
1262     if (PL_warnhook) {
1263         /* sv_2cv might call Perl_warn() */
1264         SV *oldwarnhook = PL_warnhook;
1265         ENTER;
1266         SAVESPTR(PL_warnhook);
1267         PL_warnhook = Nullsv;
1268         cv = sv_2cv(oldwarnhook, &stash, &gv, 0);
1269         LEAVE;
1270         if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1271             dSP;
1272             SV *msg;
1273
1274             ENTER;
1275             save_re_context();
1276             msg = newSVpvn(message, msglen);
1277             SvFLAGS(msg) |= utf8;
1278             SvREADONLY_on(msg);
1279             SAVEFREESV(msg);
1280
1281             PUSHSTACKi(PERLSI_WARNHOOK);
1282             PUSHMARK(SP);
1283             XPUSHs(msg);
1284             PUTBACK;
1285             call_sv((SV*)cv, G_DISCARD);
1286             POPSTACK;
1287             LEAVE;
1288             return;
1289         }
1290     }
1291
1292     write_to_stderr(message, msglen);
1293 }
1294
1295 #if defined(PERL_IMPLICIT_CONTEXT)
1296 void
1297 Perl_warn_nocontext(const char *pat, ...)
1298 {
1299     dTHX;
1300     va_list args;
1301     va_start(args, pat);
1302     vwarn(pat, &args);
1303     va_end(args);
1304 }
1305 #endif /* PERL_IMPLICIT_CONTEXT */
1306
1307 /*
1308 =for apidoc warn
1309
1310 This is the XSUB-writer's interface to Perl's C<warn> function.  Use this
1311 function the same way you use the C C<printf> function.  See
1312 C<croak>.
1313
1314 =cut
1315 */
1316
1317 void
1318 Perl_warn(pTHX_ const char *pat, ...)
1319 {
1320     va_list args;
1321     va_start(args, pat);
1322     vwarn(pat, &args);
1323     va_end(args);
1324 }
1325
1326 #if defined(PERL_IMPLICIT_CONTEXT)
1327 void
1328 Perl_warner_nocontext(U32 err, const char *pat, ...)
1329 {
1330     dTHX;
1331     va_list args;
1332     va_start(args, pat);
1333     vwarner(err, pat, &args);
1334     va_end(args);
1335 }
1336 #endif /* PERL_IMPLICIT_CONTEXT */
1337
1338 void
1339 Perl_warner(pTHX_ U32  err, const char* pat,...)
1340 {
1341     va_list args;
1342     va_start(args, pat);
1343     vwarner(err, pat, &args);
1344     va_end(args);
1345 }
1346
1347 void
1348 Perl_vwarner(pTHX_ U32  err, const char* pat, va_list* args)
1349 {
1350     char *message;
1351     HV *stash;
1352     GV *gv;
1353     CV *cv;
1354     SV *msv;
1355     STRLEN msglen;
1356     I32 utf8 = 0;
1357
1358     msv = vmess(pat, args);
1359     message = SvPV(msv, msglen);
1360     utf8 = SvUTF8(msv);
1361
1362     if (ckDEAD(err)) {
1363         if (PL_diehook) {
1364             /* sv_2cv might call Perl_croak() */
1365             SV *olddiehook = PL_diehook;
1366             ENTER;
1367             SAVESPTR(PL_diehook);
1368             PL_diehook = Nullsv;
1369             cv = sv_2cv(olddiehook, &stash, &gv, 0);
1370             LEAVE;
1371             if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1372                 dSP;
1373                 SV *msg;
1374
1375                 ENTER;
1376                 save_re_context();
1377                 msg = newSVpvn(message, msglen);
1378                 SvFLAGS(msg) |= utf8;
1379                 SvREADONLY_on(msg);
1380                 SAVEFREESV(msg);
1381
1382                 PUSHSTACKi(PERLSI_DIEHOOK);
1383                 PUSHMARK(sp);
1384                 XPUSHs(msg);
1385                 PUTBACK;
1386                 call_sv((SV*)cv, G_DISCARD);
1387                 POPSTACK;
1388                 LEAVE;
1389             }
1390         }
1391         if (PL_in_eval) {
1392             PL_restartop = die_where(message, msglen);
1393             SvFLAGS(ERRSV) |= utf8;
1394             JMPENV_JUMP(3);
1395         }
1396         write_to_stderr(message, msglen);
1397         my_failure_exit();
1398     }
1399     else {
1400         if (PL_warnhook) {
1401             /* sv_2cv might call Perl_warn() */
1402             SV *oldwarnhook = PL_warnhook;
1403             ENTER;
1404             SAVESPTR(PL_warnhook);
1405             PL_warnhook = Nullsv;
1406             cv = sv_2cv(oldwarnhook, &stash, &gv, 0);
1407             LEAVE;
1408             if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1409                 dSP;
1410                 SV *msg;
1411
1412                 ENTER;
1413                 save_re_context();
1414                 msg = newSVpvn(message, msglen);
1415                 SvFLAGS(msg) |= utf8;
1416                 SvREADONLY_on(msg);
1417                 SAVEFREESV(msg);
1418
1419                 PUSHSTACKi(PERLSI_WARNHOOK);
1420                 PUSHMARK(sp);
1421                 XPUSHs(msg);
1422                 PUTBACK;
1423                 call_sv((SV*)cv, G_DISCARD);
1424                 POPSTACK;
1425                 LEAVE;
1426                 return;
1427             }
1428         }
1429         write_to_stderr(message, msglen);
1430     }
1431 }
1432
1433 /* since we've already done strlen() for both nam and val
1434  * we can use that info to make things faster than
1435  * sprintf(s, "%s=%s", nam, val)
1436  */
1437 #define my_setenv_format(s, nam, nlen, val, vlen) \
1438    Copy(nam, s, nlen, char); \
1439    *(s+nlen) = '='; \
1440    Copy(val, s+(nlen+1), vlen, char); \
1441    *(s+(nlen+1+vlen)) = '\0'
1442
1443 #ifdef USE_ENVIRON_ARRAY
1444        /* VMS' my_setenv() is in vms.c */
1445 #if !defined(WIN32) && !defined(NETWARE)
1446 void
1447 Perl_my_setenv(pTHX_ char *nam, char *val)
1448 {
1449 #ifdef USE_ITHREADS
1450   /* only parent thread can modify process environment */
1451   if (PL_curinterp == aTHX)
1452 #endif
1453   {
1454 #ifndef PERL_USE_SAFE_PUTENV
1455     /* most putenv()s leak, so we manipulate environ directly */
1456     register I32 i=setenv_getix(nam);           /* where does it go? */
1457     int nlen, vlen;
1458
1459     if (environ == PL_origenviron) {    /* need we copy environment? */
1460         I32 j;
1461         I32 max;
1462         char **tmpenv;
1463
1464         /*SUPPRESS 530*/
1465         for (max = i; environ[max]; max++) ;
1466         tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*));
1467         for (j=0; j<max; j++) {         /* copy environment */
1468             int len = strlen(environ[j]);
1469             tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char));
1470             Copy(environ[j], tmpenv[j], len+1, char);
1471         }
1472         tmpenv[max] = Nullch;
1473         environ = tmpenv;               /* tell exec where it is now */
1474     }
1475     if (!val) {
1476         safesysfree(environ[i]);
1477         while (environ[i]) {
1478             environ[i] = environ[i+1];
1479             i++;
1480         }
1481         return;
1482     }
1483     if (!environ[i]) {                  /* does not exist yet */
1484         environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
1485         environ[i+1] = Nullch;  /* make sure it's null terminated */
1486     }
1487     else
1488         safesysfree(environ[i]);
1489     nlen = strlen(nam);
1490     vlen = strlen(val);
1491
1492     environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char));
1493     /* all that work just for this */
1494     my_setenv_format(environ[i], nam, nlen, val, vlen);
1495
1496 #else   /* PERL_USE_SAFE_PUTENV */
1497 #   if defined(__CYGWIN__) || defined( EPOC)
1498     setenv(nam, val, 1);
1499 #   else
1500     char *new_env;
1501     int nlen = strlen(nam), vlen;
1502     if (!val) {
1503         val = "";
1504     }
1505     vlen = strlen(val);
1506     new_env = (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
1507     /* all that work just for this */
1508     my_setenv_format(new_env, nam, nlen, val, vlen);
1509     (void)putenv(new_env);
1510 #   endif /* __CYGWIN__ */
1511 #endif  /* PERL_USE_SAFE_PUTENV */
1512   }
1513 }
1514
1515 #else /* WIN32 || NETWARE */
1516
1517 void
1518 Perl_my_setenv(pTHX_ char *nam,char *val)
1519 {
1520     register char *envstr;
1521     int nlen = strlen(nam), vlen;
1522
1523     if (!val) {
1524         val = "";
1525     }
1526     vlen = strlen(val);
1527     New(904, envstr, nlen+vlen+2, char);
1528     my_setenv_format(envstr, nam, nlen, val, vlen);
1529     (void)PerlEnv_putenv(envstr);
1530     Safefree(envstr);
1531 }
1532
1533 #endif /* WIN32 || NETWARE */
1534
1535 #ifndef PERL_MICRO
1536 I32
1537 Perl_setenv_getix(pTHX_ char *nam)
1538 {
1539     register I32 i, len = strlen(nam);
1540
1541     for (i = 0; environ[i]; i++) {
1542         if (
1543 #ifdef WIN32
1544             strnicmp(environ[i],nam,len) == 0
1545 #else
1546             strnEQ(environ[i],nam,len)
1547 #endif
1548             && environ[i][len] == '=')
1549             break;                      /* strnEQ must come first to avoid */
1550     }                                   /* potential SEGV's */
1551     return i;
1552 }
1553 #endif /* !PERL_MICRO */
1554
1555 #endif /* !VMS && !EPOC*/
1556
1557 #ifdef UNLINK_ALL_VERSIONS
1558 I32
1559 Perl_unlnk(pTHX_ char *f)       /* unlink all versions of a file */
1560 {
1561     I32 i;
1562
1563     for (i = 0; PerlLIO_unlink(f) >= 0; i++) ;
1564     return i ? 0 : -1;
1565 }
1566 #endif
1567
1568 /* this is a drop-in replacement for bcopy() */
1569 #if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY))
1570 char *
1571 Perl_my_bcopy(register const char *from,register char *to,register I32 len)
1572 {
1573     char *retval = to;
1574
1575     if (from - to >= 0) {
1576         while (len--)
1577             *to++ = *from++;
1578     }
1579     else {
1580         to += len;
1581         from += len;
1582         while (len--)
1583             *(--to) = *(--from);
1584     }
1585     return retval;
1586 }
1587 #endif
1588
1589 /* this is a drop-in replacement for memset() */
1590 #ifndef HAS_MEMSET
1591 void *
1592 Perl_my_memset(register char *loc, register I32 ch, register I32 len)
1593 {
1594     char *retval = loc;
1595
1596     while (len--)
1597         *loc++ = ch;
1598     return retval;
1599 }
1600 #endif
1601
1602 /* this is a drop-in replacement for bzero() */
1603 #if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
1604 char *
1605 Perl_my_bzero(register char *loc, register I32 len)
1606 {
1607     char *retval = loc;
1608
1609     while (len--)
1610         *loc++ = 0;
1611     return retval;
1612 }
1613 #endif
1614
1615 /* this is a drop-in replacement for memcmp() */
1616 #if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
1617 I32
1618 Perl_my_memcmp(const char *s1, const char *s2, register I32 len)
1619 {
1620     register U8 *a = (U8 *)s1;
1621     register U8 *b = (U8 *)s2;
1622     register I32 tmp;
1623
1624     while (len--) {
1625         if (tmp = *a++ - *b++)
1626             return tmp;
1627     }
1628     return 0;
1629 }
1630 #endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */
1631
1632 #ifndef HAS_VPRINTF
1633
1634 #ifdef USE_CHAR_VSPRINTF
1635 char *
1636 #else
1637 int
1638 #endif
1639 vsprintf(char *dest, const char *pat, char *args)
1640 {
1641     FILE fakebuf;
1642
1643     fakebuf._ptr = dest;
1644     fakebuf._cnt = 32767;
1645 #ifndef _IOSTRG
1646 #define _IOSTRG 0
1647 #endif
1648     fakebuf._flag = _IOWRT|_IOSTRG;
1649     _doprnt(pat, args, &fakebuf);       /* what a kludge */
1650     (void)putc('\0', &fakebuf);
1651 #ifdef USE_CHAR_VSPRINTF
1652     return(dest);
1653 #else
1654     return 0;           /* perl doesn't use return value */
1655 #endif
1656 }
1657
1658 #endif /* HAS_VPRINTF */
1659
1660 #ifdef MYSWAP
1661 #if BYTEORDER != 0x4321
1662 short
1663 Perl_my_swap(pTHX_ short s)
1664 {
1665 #if (BYTEORDER & 1) == 0
1666     short result;
1667
1668     result = ((s & 255) << 8) + ((s >> 8) & 255);
1669     return result;
1670 #else
1671     return s;
1672 #endif
1673 }
1674
1675 long
1676 Perl_my_htonl(pTHX_ long l)
1677 {
1678     union {
1679         long result;
1680         char c[sizeof(long)];
1681     } u;
1682
1683 #if BYTEORDER == 0x1234
1684     u.c[0] = (l >> 24) & 255;
1685     u.c[1] = (l >> 16) & 255;
1686     u.c[2] = (l >> 8) & 255;
1687     u.c[3] = l & 255;
1688     return u.result;
1689 #else
1690 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
1691     Perl_croak(aTHX_ "Unknown BYTEORDER\n");
1692 #else
1693     register I32 o;
1694     register I32 s;
1695
1696     for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
1697         u.c[o & 0xf] = (l >> s) & 255;
1698     }
1699     return u.result;
1700 #endif
1701 #endif
1702 }
1703
1704 long
1705 Perl_my_ntohl(pTHX_ long l)
1706 {
1707     union {
1708         long l;
1709         char c[sizeof(long)];
1710     } u;
1711
1712 #if BYTEORDER == 0x1234
1713     u.c[0] = (l >> 24) & 255;
1714     u.c[1] = (l >> 16) & 255;
1715     u.c[2] = (l >> 8) & 255;
1716     u.c[3] = l & 255;
1717     return u.l;
1718 #else
1719 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
1720     Perl_croak(aTHX_ "Unknown BYTEORDER\n");
1721 #else
1722     register I32 o;
1723     register I32 s;
1724
1725     u.l = l;
1726     l = 0;
1727     for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
1728         l |= (u.c[o & 0xf] & 255) << s;
1729     }
1730     return l;
1731 #endif
1732 #endif
1733 }
1734
1735 #endif /* BYTEORDER != 0x4321 */
1736 #endif /* MYSWAP */
1737
1738 /*
1739  * Little-endian byte order functions - 'v' for 'VAX', or 'reVerse'.
1740  * If these functions are defined,
1741  * the BYTEORDER is neither 0x1234 nor 0x4321.
1742  * However, this is not assumed.
1743  * -DWS
1744  */
1745
1746 #define HTOV(name,type)                                         \
1747         type                                                    \
1748         name (register type n)                                  \
1749         {                                                       \
1750             union {                                             \
1751                 type value;                                     \
1752                 char c[sizeof(type)];                           \
1753             } u;                                                \
1754             register I32 i;                                     \
1755             register I32 s;                                     \
1756             for (i = 0, s = 0; i < sizeof(u.c); i++, s += 8) {  \
1757                 u.c[i] = (n >> s) & 0xFF;                       \
1758             }                                                   \
1759             return u.value;                                     \
1760         }
1761
1762 #define VTOH(name,type)                                         \
1763         type                                                    \
1764         name (register type n)                                  \
1765         {                                                       \
1766             union {                                             \
1767                 type value;                                     \
1768                 char c[sizeof(type)];                           \
1769             } u;                                                \
1770             register I32 i;                                     \
1771             register I32 s;                                     \
1772             u.value = n;                                        \
1773             n = 0;                                              \
1774             for (i = 0, s = 0; i < sizeof(u.c); i++, s += 8) {  \
1775                 n += (u.c[i] & 0xFF) << s;                      \
1776             }                                                   \
1777             return n;                                           \
1778         }
1779
1780 #if defined(HAS_HTOVS) && !defined(htovs)
1781 HTOV(htovs,short)
1782 #endif
1783 #if defined(HAS_HTOVL) && !defined(htovl)
1784 HTOV(htovl,long)
1785 #endif
1786 #if defined(HAS_VTOHS) && !defined(vtohs)
1787 VTOH(vtohs,short)
1788 #endif
1789 #if defined(HAS_VTOHL) && !defined(vtohl)
1790 VTOH(vtohl,long)
1791 #endif
1792
1793 PerlIO *
1794 Perl_my_popen_list(pTHX_ char *mode, int n, SV **args)
1795 {
1796 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) && !defined(NETWARE)
1797     int p[2];
1798     register I32 This, that;
1799     register Pid_t pid;
1800     SV *sv;
1801     I32 did_pipes = 0;
1802     int pp[2];
1803
1804     PERL_FLUSHALL_FOR_CHILD;
1805     This = (*mode == 'w');
1806     that = !This;
1807     if (PL_tainting) {
1808         taint_env();
1809         taint_proper("Insecure %s%s", "EXEC");
1810     }
1811     if (PerlProc_pipe(p) < 0)
1812         return Nullfp;
1813     /* Try for another pipe pair for error return */
1814     if (PerlProc_pipe(pp) >= 0)
1815         did_pipes = 1;
1816     while ((pid = PerlProc_fork()) < 0) {
1817         if (errno != EAGAIN) {
1818             PerlLIO_close(p[This]);
1819             PerlLIO_close(p[that]);
1820             if (did_pipes) {
1821                 PerlLIO_close(pp[0]);
1822                 PerlLIO_close(pp[1]);
1823             }
1824             return Nullfp;
1825         }
1826         sleep(5);
1827     }
1828     if (pid == 0) {
1829         /* Child */
1830 #undef THIS
1831 #undef THAT
1832 #define THIS that
1833 #define THAT This
1834         /* Close parent's end of error status pipe (if any) */
1835         if (did_pipes) {
1836             PerlLIO_close(pp[0]);
1837 #if defined(HAS_FCNTL) && defined(F_SETFD)
1838             /* Close error pipe automatically if exec works */
1839             fcntl(pp[1], F_SETFD, FD_CLOEXEC);
1840 #endif
1841         }
1842         /* Now dup our end of _the_ pipe to right position */
1843         if (p[THIS] != (*mode == 'r')) {
1844             PerlLIO_dup2(p[THIS], *mode == 'r');
1845             PerlLIO_close(p[THIS]);
1846             if (p[THAT] != (*mode == 'r'))      /* if dup2() didn't close it */
1847                 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
1848         }
1849         else
1850             PerlLIO_close(p[THAT]);     /* close parent's end of _the_ pipe */
1851 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
1852         /* No automatic close - do it by hand */
1853 #  ifndef NOFILE
1854 #  define NOFILE 20
1855 #  endif
1856         {
1857             int fd;
1858
1859             for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) {
1860                 if (fd != pp[1])
1861                     PerlLIO_close(fd);
1862             }
1863         }
1864 #endif
1865         do_aexec5(Nullsv, args-1, args-1+n, pp[1], did_pipes);
1866         PerlProc__exit(1);
1867 #undef THIS
1868 #undef THAT
1869     }
1870     /* Parent */
1871     do_execfree();      /* free any memory malloced by child on fork */
1872     if (did_pipes)
1873         PerlLIO_close(pp[1]);
1874     /* Keep the lower of the two fd numbers */
1875     if (p[that] < p[This]) {
1876         PerlLIO_dup2(p[This], p[that]);
1877         PerlLIO_close(p[This]);
1878         p[This] = p[that];
1879     }
1880     else
1881         PerlLIO_close(p[that]);         /* close child's end of pipe */
1882
1883     LOCK_FDPID_MUTEX;
1884     sv = *av_fetch(PL_fdpid,p[This],TRUE);
1885     UNLOCK_FDPID_MUTEX;
1886     (void)SvUPGRADE(sv,SVt_IV);
1887     SvIVX(sv) = pid;
1888     PL_forkprocess = pid;
1889     /* If we managed to get status pipe check for exec fail */
1890     if (did_pipes && pid > 0) {
1891         int errkid;
1892         int n = 0, n1;
1893
1894         while (n < sizeof(int)) {
1895             n1 = PerlLIO_read(pp[0],
1896                               (void*)(((char*)&errkid)+n),
1897                               (sizeof(int)) - n);
1898             if (n1 <= 0)
1899                 break;
1900             n += n1;
1901         }
1902         PerlLIO_close(pp[0]);
1903         did_pipes = 0;
1904         if (n) {                        /* Error */
1905             int pid2, status;
1906             PerlLIO_close(p[This]);
1907             if (n != sizeof(int))
1908                 Perl_croak(aTHX_ "panic: kid popen errno read");
1909             do {
1910                 pid2 = wait4pid(pid, &status, 0);
1911             } while (pid2 == -1 && errno == EINTR);
1912             errno = errkid;             /* Propagate errno from kid */
1913             return Nullfp;
1914         }
1915     }
1916     if (did_pipes)
1917          PerlLIO_close(pp[0]);
1918     return PerlIO_fdopen(p[This], mode);
1919 #else
1920     Perl_croak(aTHX_ "List form of piped open not implemented");
1921     return (PerlIO *) NULL;
1922 #endif
1923 }
1924
1925     /* VMS' my_popen() is in VMS.c, same with OS/2. */
1926 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
1927 PerlIO *
1928 Perl_my_popen(pTHX_ char *cmd, char *mode)
1929 {
1930     int p[2];
1931     register I32 This, that;
1932     register Pid_t pid;
1933     SV *sv;
1934     I32 doexec = strNE(cmd,"-");
1935     I32 did_pipes = 0;
1936     int pp[2];
1937
1938     PERL_FLUSHALL_FOR_CHILD;
1939 #ifdef OS2
1940     if (doexec) {
1941         return my_syspopen(aTHX_ cmd,mode);
1942     }
1943 #endif
1944     This = (*mode == 'w');
1945     that = !This;
1946     if (doexec && PL_tainting) {
1947         taint_env();
1948         taint_proper("Insecure %s%s", "EXEC");
1949     }
1950     if (PerlProc_pipe(p) < 0)
1951         return Nullfp;
1952     if (doexec && PerlProc_pipe(pp) >= 0)
1953         did_pipes = 1;
1954     while ((pid = PerlProc_fork()) < 0) {
1955         if (errno != EAGAIN) {
1956             PerlLIO_close(p[This]);
1957             PerlLIO_close(p[that]);
1958             if (did_pipes) {
1959                 PerlLIO_close(pp[0]);
1960                 PerlLIO_close(pp[1]);
1961             }
1962             if (!doexec)
1963                 Perl_croak(aTHX_ "Can't fork");
1964             return Nullfp;
1965         }
1966         sleep(5);
1967     }
1968     if (pid == 0) {
1969         GV* tmpgv;
1970
1971 #undef THIS
1972 #undef THAT
1973 #define THIS that
1974 #define THAT This
1975         if (did_pipes) {
1976             PerlLIO_close(pp[0]);
1977 #if defined(HAS_FCNTL) && defined(F_SETFD)
1978             fcntl(pp[1], F_SETFD, FD_CLOEXEC);
1979 #endif
1980         }
1981         if (p[THIS] != (*mode == 'r')) {
1982             PerlLIO_dup2(p[THIS], *mode == 'r');
1983             PerlLIO_close(p[THIS]);
1984             if (p[THAT] != (*mode == 'r'))      /* if dup2() didn't close it */
1985                 PerlLIO_close(p[THAT]);
1986         }
1987         else
1988             PerlLIO_close(p[THAT]);
1989 #ifndef OS2
1990         if (doexec) {
1991 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
1992             int fd;
1993
1994 #ifndef NOFILE
1995 #define NOFILE 20
1996 #endif
1997             {
1998                 int fd;
1999
2000                 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
2001                     if (fd != pp[1])
2002                         PerlLIO_close(fd);
2003             }
2004 #endif
2005             /* may or may not use the shell */
2006             do_exec3(cmd, pp[1], did_pipes);
2007             PerlProc__exit(1);
2008         }
2009 #endif  /* defined OS2 */
2010         /*SUPPRESS 560*/
2011         if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) {
2012             SvREADONLY_off(GvSV(tmpgv));
2013             sv_setiv(GvSV(tmpgv), PerlProc_getpid());
2014             SvREADONLY_on(GvSV(tmpgv));
2015         }
2016 #ifdef THREADS_HAVE_PIDS
2017         PL_ppid = (IV)getppid();
2018 #endif
2019         PL_forkprocess = 0;
2020         hv_clear(PL_pidstatus); /* we have no children */
2021         return Nullfp;
2022 #undef THIS
2023 #undef THAT
2024     }
2025     do_execfree();      /* free any memory malloced by child on vfork */
2026     if (did_pipes)
2027         PerlLIO_close(pp[1]);
2028     if (p[that] < p[This]) {
2029         PerlLIO_dup2(p[This], p[that]);
2030         PerlLIO_close(p[This]);
2031         p[This] = p[that];
2032     }
2033     else
2034         PerlLIO_close(p[that]);
2035
2036     LOCK_FDPID_MUTEX;
2037     sv = *av_fetch(PL_fdpid,p[This],TRUE);
2038     UNLOCK_FDPID_MUTEX;
2039     (void)SvUPGRADE(sv,SVt_IV);
2040     SvIVX(sv) = pid;
2041     PL_forkprocess = pid;
2042     if (did_pipes && pid > 0) {
2043         int errkid;
2044         int n = 0, n1;
2045
2046         while (n < sizeof(int)) {
2047             n1 = PerlLIO_read(pp[0],
2048                               (void*)(((char*)&errkid)+n),
2049                               (sizeof(int)) - n);
2050             if (n1 <= 0)
2051                 break;
2052             n += n1;
2053         }
2054         PerlLIO_close(pp[0]);
2055         did_pipes = 0;
2056         if (n) {                        /* Error */
2057             int pid2, status;
2058             PerlLIO_close(p[This]);
2059             if (n != sizeof(int))
2060                 Perl_croak(aTHX_ "panic: kid popen errno read");
2061             do {
2062                 pid2 = wait4pid(pid, &status, 0);
2063             } while (pid2 == -1 && errno == EINTR);
2064             errno = errkid;             /* Propagate errno from kid */
2065             return Nullfp;
2066         }
2067     }
2068     if (did_pipes)
2069          PerlLIO_close(pp[0]);
2070     return PerlIO_fdopen(p[This], mode);
2071 }
2072 #else
2073 #if defined(atarist) || defined(EPOC)
2074 FILE *popen();
2075 PerlIO *
2076 Perl_my_popen(pTHX_ char *cmd, char *mode)
2077 {
2078     PERL_FLUSHALL_FOR_CHILD;
2079     /* Call system's popen() to get a FILE *, then import it.
2080        used 0 for 2nd parameter to PerlIO_importFILE;
2081        apparently not used
2082     */
2083     return PerlIO_importFILE(popen(cmd, mode), 0);
2084 }
2085 #else
2086 #if defined(DJGPP)
2087 FILE *djgpp_popen();
2088 PerlIO *
2089 Perl_my_popen(pTHX_ char *cmd, char *mode)
2090 {
2091     PERL_FLUSHALL_FOR_CHILD;
2092     /* Call system's popen() to get a FILE *, then import it.
2093        used 0 for 2nd parameter to PerlIO_importFILE;
2094        apparently not used
2095     */
2096     return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
2097 }
2098 #endif
2099 #endif
2100
2101 #endif /* !DOSISH */
2102
2103 /* this is called in parent before the fork() */
2104 void
2105 Perl_atfork_lock(void)
2106 {
2107 #if defined(USE_ITHREADS)
2108     /* locks must be held in locking order (if any) */
2109 #  ifdef MYMALLOC
2110     MUTEX_LOCK(&PL_malloc_mutex);
2111 #  endif
2112     OP_REFCNT_LOCK;
2113 #endif
2114 }
2115
2116 /* this is called in both parent and child after the fork() */
2117 void
2118 Perl_atfork_unlock(void)
2119 {
2120 #if defined(USE_ITHREADS)
2121     /* locks must be released in same order as in atfork_lock() */
2122 #  ifdef MYMALLOC
2123     MUTEX_UNLOCK(&PL_malloc_mutex);
2124 #  endif
2125     OP_REFCNT_UNLOCK;
2126 #endif
2127 }
2128
2129 Pid_t
2130 Perl_my_fork(void)
2131 {
2132 #if defined(HAS_FORK)
2133     Pid_t pid;
2134 #if defined(USE_ITHREADS) && !defined(HAS_PTHREAD_ATFORK)
2135     atfork_lock();
2136     pid = fork();
2137     atfork_unlock();
2138 #else
2139     /* atfork_lock() and atfork_unlock() are installed as pthread_atfork()
2140      * handlers elsewhere in the code */
2141     pid = fork();
2142 #endif
2143     return pid;
2144 #else
2145     /* this "canna happen" since nothing should be calling here if !HAS_FORK */
2146     Perl_croak_nocontext("fork() not available");
2147     return 0;
2148 #endif /* HAS_FORK */
2149 }
2150
2151 #ifdef DUMP_FDS
2152 void
2153 Perl_dump_fds(pTHX_ char *s)
2154 {
2155     int fd;
2156     Stat_t tmpstatbuf;
2157
2158     PerlIO_printf(Perl_debug_log,"%s", s);
2159     for (fd = 0; fd < 32; fd++) {
2160         if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0)
2161             PerlIO_printf(Perl_debug_log," %d",fd);
2162     }
2163     PerlIO_printf(Perl_debug_log,"\n");
2164 }
2165 #endif  /* DUMP_FDS */
2166
2167 #ifndef HAS_DUP2
2168 int
2169 dup2(int oldfd, int newfd)
2170 {
2171 #if defined(HAS_FCNTL) && defined(F_DUPFD)
2172     if (oldfd == newfd)
2173         return oldfd;
2174     PerlLIO_close(newfd);
2175     return fcntl(oldfd, F_DUPFD, newfd);
2176 #else
2177 #define DUP2_MAX_FDS 256
2178     int fdtmp[DUP2_MAX_FDS];
2179     I32 fdx = 0;
2180     int fd;
2181
2182     if (oldfd == newfd)
2183         return oldfd;
2184     PerlLIO_close(newfd);
2185     /* good enough for low fd's... */
2186     while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
2187         if (fdx >= DUP2_MAX_FDS) {
2188             PerlLIO_close(fd);
2189             fd = -1;
2190             break;
2191         }
2192         fdtmp[fdx++] = fd;
2193     }
2194     while (fdx > 0)
2195         PerlLIO_close(fdtmp[--fdx]);
2196     return fd;
2197 #endif
2198 }
2199 #endif
2200
2201 #ifndef PERL_MICRO
2202 #ifdef HAS_SIGACTION
2203
2204 #ifdef MACOS_TRADITIONAL
2205 /* We don't want restart behavior on MacOS */
2206 #undef SA_RESTART
2207 #endif
2208
2209 Sighandler_t
2210 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2211 {
2212     struct sigaction act, oact;
2213
2214 #ifdef USE_ITHREADS
2215     /* only "parent" interpreter can diddle signals */
2216     if (PL_curinterp != aTHX)
2217         return SIG_ERR;
2218 #endif
2219
2220     act.sa_handler = handler;
2221     sigemptyset(&act.sa_mask);
2222     act.sa_flags = 0;
2223 #ifdef SA_RESTART
2224     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2225         act.sa_flags |= SA_RESTART;     /* SVR4, 4.3+BSD */
2226 #endif
2227 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2228     if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN)
2229         act.sa_flags |= SA_NOCLDWAIT;
2230 #endif
2231     if (sigaction(signo, &act, &oact) == -1)
2232         return SIG_ERR;
2233     else
2234         return oact.sa_handler;
2235 }
2236
2237 Sighandler_t
2238 Perl_rsignal_state(pTHX_ int signo)
2239 {
2240     struct sigaction oact;
2241
2242     if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
2243         return SIG_ERR;
2244     else
2245         return oact.sa_handler;
2246 }
2247
2248 int
2249 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2250 {
2251     struct sigaction act;
2252
2253 #ifdef USE_ITHREADS
2254     /* only "parent" interpreter can diddle signals */
2255     if (PL_curinterp != aTHX)
2256         return -1;
2257 #endif
2258
2259     act.sa_handler = handler;
2260     sigemptyset(&act.sa_mask);
2261     act.sa_flags = 0;
2262 #ifdef SA_RESTART
2263     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2264         act.sa_flags |= SA_RESTART;     /* SVR4, 4.3+BSD */
2265 #endif
2266 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2267     if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN)
2268         act.sa_flags |= SA_NOCLDWAIT;
2269 #endif
2270     return sigaction(signo, &act, save);
2271 }
2272
2273 int
2274 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2275 {
2276 #ifdef USE_ITHREADS
2277     /* only "parent" interpreter can diddle signals */
2278     if (PL_curinterp != aTHX)
2279         return -1;
2280 #endif
2281
2282     return sigaction(signo, save, (struct sigaction *)NULL);
2283 }
2284
2285 #else /* !HAS_SIGACTION */
2286
2287 Sighandler_t
2288 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2289 {
2290 #if defined(USE_ITHREADS) && !defined(WIN32)
2291     /* only "parent" interpreter can diddle signals */
2292     if (PL_curinterp != aTHX)
2293         return SIG_ERR;
2294 #endif
2295
2296     return PerlProc_signal(signo, handler);
2297 }
2298
2299 static int sig_trapped; /* XXX signals are process-wide anyway, so we
2300                            ignore the implications of this for threading */
2301
2302 static
2303 Signal_t
2304 sig_trap(int signo)
2305 {
2306     sig_trapped++;
2307 }
2308
2309 Sighandler_t
2310 Perl_rsignal_state(pTHX_ int signo)
2311 {
2312     Sighandler_t oldsig;
2313
2314 #if defined(USE_ITHREADS) && !defined(WIN32)
2315     /* only "parent" interpreter can diddle signals */
2316     if (PL_curinterp != aTHX)
2317         return SIG_ERR;
2318 #endif
2319
2320     sig_trapped = 0;
2321     oldsig = PerlProc_signal(signo, sig_trap);
2322     PerlProc_signal(signo, oldsig);
2323     if (sig_trapped)
2324         PerlProc_kill(PerlProc_getpid(), signo);
2325     return oldsig;
2326 }
2327
2328 int
2329 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2330 {
2331 #if defined(USE_ITHREADS) && !defined(WIN32)
2332     /* only "parent" interpreter can diddle signals */
2333     if (PL_curinterp != aTHX)
2334         return -1;
2335 #endif
2336     *save = PerlProc_signal(signo, handler);
2337     return (*save == SIG_ERR) ? -1 : 0;
2338 }
2339
2340 int
2341 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2342 {
2343 #if defined(USE_ITHREADS) && !defined(WIN32)
2344     /* only "parent" interpreter can diddle signals */
2345     if (PL_curinterp != aTHX)
2346         return -1;
2347 #endif
2348     return (PerlProc_signal(signo, *save) == SIG_ERR) ? -1 : 0;
2349 }
2350
2351 #endif /* !HAS_SIGACTION */
2352 #endif /* !PERL_MICRO */
2353
2354     /* VMS' my_pclose() is in VMS.c; same with OS/2 */
2355 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
2356 I32
2357 Perl_my_pclose(pTHX_ PerlIO *ptr)
2358 {
2359     Sigsave_t hstat, istat, qstat;
2360     int status;
2361     SV **svp;
2362     Pid_t pid;
2363     Pid_t pid2;
2364     bool close_failed;
2365     int saved_errno = 0;
2366 #ifdef VMS
2367     int saved_vaxc_errno;
2368 #endif
2369 #ifdef WIN32
2370     int saved_win32_errno;
2371 #endif
2372
2373     LOCK_FDPID_MUTEX;
2374     svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE);
2375     UNLOCK_FDPID_MUTEX;
2376     pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
2377     SvREFCNT_dec(*svp);
2378     *svp = &PL_sv_undef;
2379 #ifdef OS2
2380     if (pid == -1) {                    /* Opened by popen. */
2381         return my_syspclose(ptr);
2382     }
2383 #endif
2384     if ((close_failed = (PerlIO_close(ptr) == EOF))) {
2385         saved_errno = errno;
2386 #ifdef VMS
2387         saved_vaxc_errno = vaxc$errno;
2388 #endif
2389 #ifdef WIN32
2390         saved_win32_errno = GetLastError();
2391 #endif
2392     }
2393 #ifdef UTS
2394     if(PerlProc_kill(pid, 0) < 0) { return(pid); }   /* HOM 12/23/91 */
2395 #endif
2396 #ifndef PERL_MICRO
2397     rsignal_save(SIGHUP, SIG_IGN, &hstat);
2398     rsignal_save(SIGINT, SIG_IGN, &istat);
2399     rsignal_save(SIGQUIT, SIG_IGN, &qstat);
2400 #endif
2401     do {
2402         pid2 = wait4pid(pid, &status, 0);
2403     } while (pid2 == -1 && errno == EINTR);
2404 #ifndef PERL_MICRO
2405     rsignal_restore(SIGHUP, &hstat);
2406     rsignal_restore(SIGINT, &istat);
2407     rsignal_restore(SIGQUIT, &qstat);
2408 #endif
2409     if (close_failed) {
2410         SETERRNO(saved_errno, saved_vaxc_errno);
2411         return -1;
2412     }
2413     return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status));
2414 }
2415 #endif /* !DOSISH */
2416
2417 #if  (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(MACOS_TRADITIONAL)
2418 I32
2419 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
2420 {
2421     I32 result;
2422     if (!pid)
2423         return -1;
2424 #if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME)
2425     {
2426         SV *sv;
2427         SV** svp;
2428         char spid[TYPE_CHARS(int)];
2429
2430         if (pid > 0) {
2431             sprintf(spid, "%"IVdf, (IV)pid);
2432             svp = hv_fetch(PL_pidstatus,spid,strlen(spid),FALSE);
2433             if (svp && *svp != &PL_sv_undef) {
2434                 *statusp = SvIVX(*svp);
2435                 (void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD);
2436                 return pid;
2437             }
2438         }
2439         else {
2440             HE *entry;
2441
2442             hv_iterinit(PL_pidstatus);
2443             if ((entry = hv_iternext(PL_pidstatus))) {
2444                 SV *sv;
2445                 char spid[TYPE_CHARS(int)];
2446
2447                 pid = atoi(hv_iterkey(entry,(I32*)statusp));
2448                 sv = hv_iterval(PL_pidstatus,entry);
2449                 *statusp = SvIVX(sv);
2450                 sprintf(spid, "%"IVdf, (IV)pid);
2451                 (void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD);
2452                 return pid;
2453             }
2454         }
2455     }
2456 #endif
2457 #ifdef HAS_WAITPID
2458 #  ifdef HAS_WAITPID_RUNTIME
2459     if (!HAS_WAITPID_RUNTIME)
2460         goto hard_way;
2461 #  endif
2462     result = PerlProc_waitpid(pid,statusp,flags);
2463     goto finish;
2464 #endif
2465 #if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
2466     result = wait4((pid==-1)?0:pid,statusp,flags,Null(struct rusage *));
2467     goto finish;
2468 #endif
2469 #if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME)
2470   hard_way:
2471     {
2472         if (flags)
2473             Perl_croak(aTHX_ "Can't do waitpid with flags");
2474         else {
2475             while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
2476                 pidgone(result,*statusp);
2477             if (result < 0)
2478                 *statusp = -1;
2479         }
2480     }
2481 #endif
2482   finish:
2483     if (result < 0 && errno == EINTR) {
2484         PERL_ASYNC_CHECK();
2485     }
2486     return result;
2487 }
2488 #endif /* !DOSISH || OS2 || WIN32 || NETWARE */
2489
2490 void
2491 /*SUPPRESS 590*/
2492 Perl_pidgone(pTHX_ Pid_t pid, int status)
2493 {
2494     register SV *sv;
2495     char spid[TYPE_CHARS(int)];
2496
2497     sprintf(spid, "%"IVdf, (IV)pid);
2498     sv = *hv_fetch(PL_pidstatus,spid,strlen(spid),TRUE);
2499     (void)SvUPGRADE(sv,SVt_IV);
2500     SvIVX(sv) = status;
2501     return;
2502 }
2503
2504 #if defined(atarist) || defined(OS2) || defined(EPOC)
2505 int pclose();
2506 #ifdef HAS_FORK
2507 int                                     /* Cannot prototype with I32
2508                                            in os2ish.h. */
2509 my_syspclose(PerlIO *ptr)
2510 #else
2511 I32
2512 Perl_my_pclose(pTHX_ PerlIO *ptr)
2513 #endif
2514 {
2515     /* Needs work for PerlIO ! */
2516     FILE *f = PerlIO_findFILE(ptr);
2517     I32 result = pclose(f);
2518     PerlIO_releaseFILE(ptr,f);
2519     return result;
2520 }
2521 #endif
2522
2523 #if defined(DJGPP)
2524 int djgpp_pclose();
2525 I32
2526 Perl_my_pclose(pTHX_ PerlIO *ptr)
2527 {
2528     /* Needs work for PerlIO ! */
2529     FILE *f = PerlIO_findFILE(ptr);
2530     I32 result = djgpp_pclose(f);
2531     result = (result << 8) & 0xff00;
2532     PerlIO_releaseFILE(ptr,f);
2533     return result;
2534 }
2535 #endif
2536
2537 void
2538 Perl_repeatcpy(pTHX_ register char *to, register const char *from, I32 len, register I32 count)
2539 {
2540     register I32 todo;
2541     register const char *frombase = from;
2542
2543     if (len == 1) {
2544         register const char c = *from;
2545         while (count-- > 0)
2546             *to++ = c;
2547         return;
2548     }
2549     while (count-- > 0) {
2550         for (todo = len; todo > 0; todo--) {
2551             *to++ = *from++;
2552         }
2553         from = frombase;
2554     }
2555 }
2556
2557 #ifndef HAS_RENAME
2558 I32
2559 Perl_same_dirent(pTHX_ char *a, char *b)
2560 {
2561     char *fa = strrchr(a,'/');
2562     char *fb = strrchr(b,'/');
2563     Stat_t tmpstatbuf1;
2564     Stat_t tmpstatbuf2;
2565     SV *tmpsv = sv_newmortal();
2566
2567     if (fa)
2568         fa++;
2569     else
2570         fa = a;
2571     if (fb)
2572         fb++;
2573     else
2574         fb = b;
2575     if (strNE(a,b))
2576         return FALSE;
2577     if (fa == a)
2578         sv_setpv(tmpsv, ".");
2579     else
2580         sv_setpvn(tmpsv, a, fa - a);
2581     if (PerlLIO_stat(SvPVX(tmpsv), &tmpstatbuf1) < 0)
2582         return FALSE;
2583     if (fb == b)
2584         sv_setpv(tmpsv, ".");
2585     else
2586         sv_setpvn(tmpsv, b, fb - b);
2587     if (PerlLIO_stat(SvPVX(tmpsv), &tmpstatbuf2) < 0)
2588         return FALSE;
2589     return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
2590            tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
2591 }
2592 #endif /* !HAS_RENAME */
2593
2594 char*
2595 Perl_find_script(pTHX_ char *scriptname, bool dosearch, char **search_ext, I32 flags)
2596 {
2597     char *xfound = Nullch;
2598     char *xfailed = Nullch;
2599     char tmpbuf[MAXPATHLEN];
2600     register char *s;
2601     I32 len = 0;
2602     int retval;
2603 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
2604 #  define SEARCH_EXTS ".bat", ".cmd", NULL
2605 #  define MAX_EXT_LEN 4
2606 #endif
2607 #ifdef OS2
2608 #  define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
2609 #  define MAX_EXT_LEN 4
2610 #endif
2611 #ifdef VMS
2612 #  define SEARCH_EXTS ".pl", ".com", NULL
2613 #  define MAX_EXT_LEN 4
2614 #endif
2615     /* additional extensions to try in each dir if scriptname not found */
2616 #ifdef SEARCH_EXTS
2617     char *exts[] = { SEARCH_EXTS };
2618     char **ext = search_ext ? search_ext : exts;
2619     int extidx = 0, i = 0;
2620     char *curext = Nullch;
2621 #else
2622 #  define MAX_EXT_LEN 0
2623 #endif
2624
2625     /*
2626      * If dosearch is true and if scriptname does not contain path
2627      * delimiters, search the PATH for scriptname.
2628      *
2629      * If SEARCH_EXTS is also defined, will look for each
2630      * scriptname{SEARCH_EXTS} whenever scriptname is not found
2631      * while searching the PATH.
2632      *
2633      * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
2634      * proceeds as follows:
2635      *   If DOSISH or VMSISH:
2636      *     + look for ./scriptname{,.foo,.bar}
2637      *     + search the PATH for scriptname{,.foo,.bar}
2638      *
2639      *   If !DOSISH:
2640      *     + look *only* in the PATH for scriptname{,.foo,.bar} (note
2641      *       this will not look in '.' if it's not in the PATH)
2642      */
2643     tmpbuf[0] = '\0';
2644
2645 #ifdef VMS
2646 #  ifdef ALWAYS_DEFTYPES
2647     len = strlen(scriptname);
2648     if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
2649         int hasdir, idx = 0, deftypes = 1;
2650         bool seen_dot = 1;
2651
2652         hasdir = !dosearch || (strpbrk(scriptname,":[</") != Nullch) ;
2653 #  else
2654     if (dosearch) {
2655         int hasdir, idx = 0, deftypes = 1;
2656         bool seen_dot = 1;
2657
2658         hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
2659 #  endif
2660         /* The first time through, just add SEARCH_EXTS to whatever we
2661          * already have, so we can check for default file types. */
2662         while (deftypes ||
2663                (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
2664         {
2665             if (deftypes) {
2666                 deftypes = 0;
2667                 *tmpbuf = '\0';
2668             }
2669             if ((strlen(tmpbuf) + strlen(scriptname)
2670                  + MAX_EXT_LEN) >= sizeof tmpbuf)
2671                 continue;       /* don't search dir with too-long name */
2672             strcat(tmpbuf, scriptname);
2673 #else  /* !VMS */
2674
2675 #ifdef DOSISH
2676     if (strEQ(scriptname, "-"))
2677         dosearch = 0;
2678     if (dosearch) {             /* Look in '.' first. */
2679         char *cur = scriptname;
2680 #ifdef SEARCH_EXTS
2681         if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
2682             while (ext[i])
2683                 if (strEQ(ext[i++],curext)) {
2684                     extidx = -1;                /* already has an ext */
2685                     break;
2686                 }
2687         do {
2688 #endif
2689             DEBUG_p(PerlIO_printf(Perl_debug_log,
2690                                   "Looking for %s\n",cur));
2691             if (PerlLIO_stat(cur,&PL_statbuf) >= 0
2692                 && !S_ISDIR(PL_statbuf.st_mode)) {
2693                 dosearch = 0;
2694                 scriptname = cur;
2695 #ifdef SEARCH_EXTS
2696                 break;
2697 #endif
2698             }
2699 #ifdef SEARCH_EXTS
2700             if (cur == scriptname) {
2701                 len = strlen(scriptname);
2702                 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
2703                     break;
2704                 cur = strcpy(tmpbuf, scriptname);
2705             }
2706         } while (extidx >= 0 && ext[extidx]     /* try an extension? */
2707                  && strcpy(tmpbuf+len, ext[extidx++]));
2708 #endif
2709     }
2710 #endif
2711
2712 #ifdef MACOS_TRADITIONAL
2713     if (dosearch && !strchr(scriptname, ':') &&
2714         (s = PerlEnv_getenv("Commands")))
2715 #else
2716     if (dosearch && !strchr(scriptname, '/')
2717 #ifdef DOSISH
2718                  && !strchr(scriptname, '\\')
2719 #endif
2720                  && (s = PerlEnv_getenv("PATH")))
2721 #endif
2722     {
2723         bool seen_dot = 0;
2724
2725         PL_bufend = s + strlen(s);
2726         while (s < PL_bufend) {
2727 #ifdef MACOS_TRADITIONAL
2728             s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
2729                         ',',
2730                         &len);
2731 #else
2732 #if defined(atarist) || defined(DOSISH)
2733             for (len = 0; *s
2734 #  ifdef atarist
2735                     && *s != ','
2736 #  endif
2737                     && *s != ';'; len++, s++) {
2738                 if (len < sizeof tmpbuf)
2739                     tmpbuf[len] = *s;
2740             }
2741             if (len < sizeof tmpbuf)
2742                 tmpbuf[len] = '\0';
2743 #else  /* ! (atarist || DOSISH) */
2744             s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
2745                         ':',
2746                         &len);
2747 #endif /* ! (atarist || DOSISH) */
2748 #endif /* MACOS_TRADITIONAL */
2749             if (s < PL_bufend)
2750                 s++;
2751             if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
2752                 continue;       /* don't search dir with too-long name */
2753 #ifdef MACOS_TRADITIONAL
2754             if (len && tmpbuf[len - 1] != ':')
2755                 tmpbuf[len++] = ':';
2756 #else
2757             if (len
2758 #if defined(atarist) || defined(__MINT__) || defined(DOSISH)
2759                 && tmpbuf[len - 1] != '/'
2760                 && tmpbuf[len - 1] != '\\'
2761 #endif
2762                )
2763                 tmpbuf[len++] = '/';
2764             if (len == 2 && tmpbuf[0] == '.')
2765                 seen_dot = 1;
2766 #endif
2767             (void)strcpy(tmpbuf + len, scriptname);
2768 #endif  /* !VMS */
2769
2770 #ifdef SEARCH_EXTS
2771             len = strlen(tmpbuf);
2772             if (extidx > 0)     /* reset after previous loop */
2773                 extidx = 0;
2774             do {
2775 #endif
2776                 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
2777                 retval = PerlLIO_stat(tmpbuf,&PL_statbuf);
2778                 if (S_ISDIR(PL_statbuf.st_mode)) {
2779                     retval = -1;
2780                 }
2781 #ifdef SEARCH_EXTS
2782             } while (  retval < 0               /* not there */
2783                     && extidx>=0 && ext[extidx] /* try an extension? */
2784                     && strcpy(tmpbuf+len, ext[extidx++])
2785                 );
2786 #endif
2787             if (retval < 0)
2788                 continue;
2789             if (S_ISREG(PL_statbuf.st_mode)
2790                 && cando(S_IRUSR,TRUE,&PL_statbuf)
2791 #if !defined(DOSISH) && !defined(MACOS_TRADITIONAL)
2792                 && cando(S_IXUSR,TRUE,&PL_statbuf)
2793 #endif
2794                 )
2795             {
2796                 xfound = tmpbuf;                /* bingo! */
2797                 break;
2798             }
2799             if (!xfailed)
2800                 xfailed = savepv(tmpbuf);
2801         }
2802 #ifndef DOSISH
2803         if (!xfound && !seen_dot && !xfailed &&
2804             (PerlLIO_stat(scriptname,&PL_statbuf) < 0
2805              || S_ISDIR(PL_statbuf.st_mode)))
2806 #endif
2807             seen_dot = 1;                       /* Disable message. */
2808         if (!xfound) {
2809             if (flags & 1) {                    /* do or die? */
2810                 Perl_croak(aTHX_ "Can't %s %s%s%s",
2811                       (xfailed ? "execute" : "find"),
2812                       (xfailed ? xfailed : scriptname),
2813                       (xfailed ? "" : " on PATH"),
2814                       (xfailed || seen_dot) ? "" : ", '.' not in PATH");
2815             }
2816             scriptname = Nullch;
2817         }
2818         if (xfailed)
2819             Safefree(xfailed);
2820         scriptname = xfound;
2821     }
2822     return (scriptname ? savepv(scriptname) : Nullch);
2823 }
2824
2825 #ifndef PERL_GET_CONTEXT_DEFINED
2826
2827 void *
2828 Perl_get_context(void)
2829 {
2830 #if defined(USE_ITHREADS)
2831 #  ifdef OLD_PTHREADS_API
2832     pthread_addr_t t;
2833     if (pthread_getspecific(PL_thr_key, &t))
2834         Perl_croak_nocontext("panic: pthread_getspecific");
2835     return (void*)t;
2836 #  else
2837 #    ifdef I_MACH_CTHREADS
2838     return (void*)cthread_data(cthread_self());
2839 #    else
2840     return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
2841 #    endif
2842 #  endif
2843 #else
2844     return (void*)NULL;
2845 #endif
2846 }
2847
2848 void
2849 Perl_set_context(void *t)
2850 {
2851 #if defined(USE_ITHREADS)
2852 #  ifdef I_MACH_CTHREADS
2853     cthread_set_data(cthread_self(), t);
2854 #  else
2855     if (pthread_setspecific(PL_thr_key, t))
2856         Perl_croak_nocontext("panic: pthread_setspecific");
2857 #  endif
2858 #endif
2859 }
2860
2861 #endif /* !PERL_GET_CONTEXT_DEFINED */
2862
2863 #ifdef PERL_GLOBAL_STRUCT
2864 struct perl_vars *
2865 Perl_GetVars(pTHX)
2866 {
2867  return &PL_Vars;
2868 }
2869 #endif
2870
2871 char **
2872 Perl_get_op_names(pTHX)
2873 {
2874  return PL_op_name;
2875 }
2876
2877 char **
2878 Perl_get_op_descs(pTHX)
2879 {
2880  return PL_op_desc;
2881 }
2882
2883 char *
2884 Perl_get_no_modify(pTHX)
2885 {
2886  return (char*)PL_no_modify;
2887 }
2888
2889 U32 *
2890 Perl_get_opargs(pTHX)
2891 {
2892  return PL_opargs;
2893 }
2894
2895 PPADDR_t*
2896 Perl_get_ppaddr(pTHX)
2897 {
2898  return (PPADDR_t*)PL_ppaddr;
2899 }
2900
2901 #ifndef HAS_GETENV_LEN
2902 char *
2903 Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
2904 {
2905     char *env_trans = PerlEnv_getenv(env_elem);
2906     if (env_trans)
2907         *len = strlen(env_trans);
2908     return env_trans;
2909 }
2910 #endif
2911
2912
2913 MGVTBL*
2914 Perl_get_vtbl(pTHX_ int vtbl_id)
2915 {
2916     MGVTBL* result = Null(MGVTBL*);
2917
2918     switch(vtbl_id) {
2919     case want_vtbl_sv:
2920         result = &PL_vtbl_sv;
2921         break;
2922     case want_vtbl_env:
2923         result = &PL_vtbl_env;
2924         break;
2925     case want_vtbl_envelem:
2926         result = &PL_vtbl_envelem;
2927         break;
2928     case want_vtbl_sig:
2929         result = &PL_vtbl_sig;
2930         break;
2931     case want_vtbl_sigelem:
2932         result = &PL_vtbl_sigelem;
2933         break;
2934     case want_vtbl_pack:
2935         result = &PL_vtbl_pack;
2936         break;
2937     case want_vtbl_packelem:
2938         result = &PL_vtbl_packelem;
2939         break;
2940     case want_vtbl_dbline:
2941         result = &PL_vtbl_dbline;
2942         break;
2943     case want_vtbl_isa:
2944         result = &PL_vtbl_isa;
2945         break;
2946     case want_vtbl_isaelem:
2947         result = &PL_vtbl_isaelem;
2948         break;
2949     case want_vtbl_arylen:
2950         result = &PL_vtbl_arylen;
2951         break;
2952     case want_vtbl_glob:
2953         result = &PL_vtbl_glob;
2954         break;
2955     case want_vtbl_mglob:
2956         result = &PL_vtbl_mglob;
2957         break;
2958     case want_vtbl_nkeys:
2959         result = &PL_vtbl_nkeys;
2960         break;
2961     case want_vtbl_taint:
2962         result = &PL_vtbl_taint;
2963         break;
2964     case want_vtbl_substr:
2965         result = &PL_vtbl_substr;
2966         break;
2967     case want_vtbl_vec:
2968         result = &PL_vtbl_vec;
2969         break;
2970     case want_vtbl_pos:
2971         result = &PL_vtbl_pos;
2972         break;
2973     case want_vtbl_bm:
2974         result = &PL_vtbl_bm;
2975         break;
2976     case want_vtbl_fm:
2977         result = &PL_vtbl_fm;
2978         break;
2979     case want_vtbl_uvar:
2980         result = &PL_vtbl_uvar;
2981         break;
2982     case want_vtbl_defelem:
2983         result = &PL_vtbl_defelem;
2984         break;
2985     case want_vtbl_regexp:
2986         result = &PL_vtbl_regexp;
2987         break;
2988     case want_vtbl_regdata:
2989         result = &PL_vtbl_regdata;
2990         break;
2991     case want_vtbl_regdatum:
2992         result = &PL_vtbl_regdatum;
2993         break;
2994 #ifdef USE_LOCALE_COLLATE
2995     case want_vtbl_collxfrm:
2996         result = &PL_vtbl_collxfrm;
2997         break;
2998 #endif
2999     case want_vtbl_amagic:
3000         result = &PL_vtbl_amagic;
3001         break;
3002     case want_vtbl_amagicelem:
3003         result = &PL_vtbl_amagicelem;
3004         break;
3005     case want_vtbl_backref:
3006         result = &PL_vtbl_backref;
3007         break;
3008     case want_vtbl_utf8:
3009         result = &PL_vtbl_utf8;
3010         break;
3011     }
3012     return result;
3013 }
3014
3015 I32
3016 Perl_my_fflush_all(pTHX)
3017 {
3018 #if defined(USE_PERLIO) || defined(FFLUSH_NULL) || defined(USE_SFIO)
3019     return PerlIO_flush(NULL);
3020 #else
3021 # if defined(HAS__FWALK)
3022     extern int fflush(FILE *);
3023     /* undocumented, unprototyped, but very useful BSDism */
3024     extern void _fwalk(int (*)(FILE *));
3025     _fwalk(&fflush);
3026     return 0;
3027 # else
3028 #  if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
3029     long open_max = -1;
3030 #   ifdef PERL_FFLUSH_ALL_FOPEN_MAX
3031     open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
3032 #   else
3033 #    if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
3034     open_max = sysconf(_SC_OPEN_MAX);
3035 #     else
3036 #      ifdef FOPEN_MAX
3037     open_max = FOPEN_MAX;
3038 #      else
3039 #       ifdef OPEN_MAX
3040     open_max = OPEN_MAX;
3041 #       else
3042 #        ifdef _NFILE
3043     open_max = _NFILE;
3044 #        endif
3045 #       endif
3046 #      endif
3047 #     endif
3048 #    endif
3049     if (open_max > 0) {
3050       long i;
3051       for (i = 0; i < open_max; i++)
3052             if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
3053                 STDIO_STREAM_ARRAY[i]._file < open_max &&
3054                 STDIO_STREAM_ARRAY[i]._flag)
3055                 PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
3056       return 0;
3057     }
3058 #  endif
3059     SETERRNO(EBADF,RMS_IFI);
3060     return EOF;
3061 # endif
3062 #endif
3063 }
3064
3065 void
3066 Perl_report_evil_fh(pTHX_ GV *gv, IO *io, I32 op)
3067 {
3068     char *func =
3069         op == OP_READLINE   ? "readline"  :     /* "<HANDLE>" not nice */
3070         op == OP_LEAVEWRITE ? "write" :         /* "write exit" not nice */
3071         PL_op_desc[op];
3072     char *pars = OP_IS_FILETEST(op) ? "" : "()";
3073     char *type = OP_IS_SOCKET(op)
3074             || (gv && io && IoTYPE(io) == IoTYPE_SOCKET)
3075                 ?  "socket" : "filehandle";
3076     char *name = NULL;
3077
3078     if (gv && isGV(gv)) {
3079         name = GvENAME(gv);
3080     }
3081
3082     if (op == OP_phoney_OUTPUT_ONLY || op == OP_phoney_INPUT_ONLY) {
3083         if (ckWARN(WARN_IO)) {
3084             const char *direction = (op == OP_phoney_INPUT_ONLY) ? "in" : "out";
3085             if (name && *name)
3086                 Perl_warner(aTHX_ packWARN(WARN_IO),
3087                             "Filehandle %s opened only for %sput",
3088                             name, direction);
3089             else
3090                 Perl_warner(aTHX_ packWARN(WARN_IO),
3091                             "Filehandle opened only for %sput", direction);
3092         }
3093     }
3094     else {
3095         char *vile;
3096         I32   warn_type;
3097
3098         if (gv && io && IoTYPE(io) == IoTYPE_CLOSED) {
3099             vile = "closed";
3100             warn_type = WARN_CLOSED;
3101         }
3102         else {
3103             vile = "unopened";
3104             warn_type = WARN_UNOPENED;
3105         }
3106
3107         if (ckWARN(warn_type)) {
3108             if (name && *name) {
3109                 Perl_warner(aTHX_ packWARN(warn_type),
3110                             "%s%s on %s %s %s", func, pars, vile, type, name);
3111                 if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3112                     Perl_warner(
3113                         aTHX_ packWARN(warn_type),
3114                         "\t(Are you trying to call %s%s on dirhandle %s?)\n",
3115                         func, pars, name
3116                     );
3117             }
3118             else {
3119                 Perl_warner(aTHX_ packWARN(warn_type),
3120                             "%s%s on %s %s", func, pars, vile, type);
3121                 if (gv && io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3122                     Perl_warner(
3123                         aTHX_ packWARN(warn_type),
3124                         "\t(Are you trying to call %s%s on dirhandle?)\n",
3125                         func, pars
3126                     );
3127             }
3128         }
3129     }
3130 }
3131
3132 #ifdef EBCDIC
3133 /* in ASCII order, not that it matters */
3134 static const char controllablechars[] = "?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_";
3135
3136 int
3137 Perl_ebcdic_control(pTHX_ int ch)
3138 {
3139     if (ch > 'a') {
3140         char *ctlp;
3141
3142         if (islower(ch))
3143             ch = toupper(ch);
3144
3145         if ((ctlp = strchr(controllablechars, ch)) == 0) {
3146             Perl_die(aTHX_ "unrecognised control character '%c'\n", ch);
3147         }
3148
3149         if (ctlp == controllablechars)
3150             return('\177'); /* DEL */
3151         else
3152             return((unsigned char)(ctlp - controllablechars - 1));
3153     } else { /* Want uncontrol */
3154         if (ch == '\177' || ch == -1)
3155             return('?');
3156         else if (ch == '\157')
3157             return('\177');
3158         else if (ch == '\174')
3159             return('\000');
3160         else if (ch == '^')    /* '\137' in 1047, '\260' in 819 */
3161             return('\036');
3162         else if (ch == '\155')
3163             return('\037');
3164         else if (0 < ch && ch < (sizeof(controllablechars) - 1))
3165             return(controllablechars[ch+1]);
3166         else
3167             Perl_die(aTHX_ "invalid control request: '\\%03o'\n", ch & 0xFF);
3168     }
3169 }
3170 #endif
3171
3172 /* To workaround core dumps from the uninitialised tm_zone we get the
3173  * system to give us a reasonable struct to copy.  This fix means that
3174  * strftime uses the tm_zone and tm_gmtoff values returned by
3175  * localtime(time()). That should give the desired result most of the
3176  * time. But probably not always!
3177  *
3178  * This does not address tzname aspects of NETaa14816.
3179  *
3180  */
3181
3182 #ifdef HAS_GNULIBC
3183 # ifndef STRUCT_TM_HASZONE
3184 #    define STRUCT_TM_HASZONE
3185 # endif
3186 #endif
3187
3188 #ifdef STRUCT_TM_HASZONE /* Backward compat */
3189 # ifndef HAS_TM_TM_ZONE
3190 #    define HAS_TM_TM_ZONE
3191 # endif
3192 #endif
3193
3194 void
3195 Perl_init_tm(pTHX_ struct tm *ptm)      /* see mktime, strftime and asctime */
3196 {
3197 #ifdef HAS_TM_TM_ZONE
3198     Time_t now;
3199     (void)time(&now);
3200     Copy(localtime(&now), ptm, 1, struct tm);
3201 #endif
3202 }
3203
3204 /*
3205  * mini_mktime - normalise struct tm values without the localtime()
3206  * semantics (and overhead) of mktime().
3207  */
3208 void
3209 Perl_mini_mktime(pTHX_ struct tm *ptm)
3210 {
3211     int yearday;
3212     int secs;
3213     int month, mday, year, jday;
3214     int odd_cent, odd_year;
3215
3216 #define DAYS_PER_YEAR   365
3217 #define DAYS_PER_QYEAR  (4*DAYS_PER_YEAR+1)
3218 #define DAYS_PER_CENT   (25*DAYS_PER_QYEAR-1)
3219 #define DAYS_PER_QCENT  (4*DAYS_PER_CENT+1)
3220 #define SECS_PER_HOUR   (60*60)
3221 #define SECS_PER_DAY    (24*SECS_PER_HOUR)
3222 /* parentheses deliberately absent on these two, otherwise they don't work */
3223 #define MONTH_TO_DAYS   153/5
3224 #define DAYS_TO_MONTH   5/153
3225 /* offset to bias by March (month 4) 1st between month/mday & year finding */
3226 #define YEAR_ADJUST     (4*MONTH_TO_DAYS+1)
3227 /* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */
3228 #define WEEKDAY_BIAS    6       /* (1+6)%7 makes Sunday 0 again */
3229
3230 /*
3231  * Year/day algorithm notes:
3232  *
3233  * With a suitable offset for numeric value of the month, one can find
3234  * an offset into the year by considering months to have 30.6 (153/5) days,
3235  * using integer arithmetic (i.e., with truncation).  To avoid too much
3236  * messing about with leap days, we consider January and February to be
3237  * the 13th and 14th month of the previous year.  After that transformation,
3238  * we need the month index we use to be high by 1 from 'normal human' usage,
3239  * so the month index values we use run from 4 through 15.
3240  *
3241  * Given that, and the rules for the Gregorian calendar (leap years are those
3242  * divisible by 4 unless also divisible by 100, when they must be divisible
3243  * by 400 instead), we can simply calculate the number of days since some
3244  * arbitrary 'beginning of time' by futzing with the (adjusted) year number,
3245  * the days we derive from our month index, and adding in the day of the
3246  * month.  The value used here is not adjusted for the actual origin which
3247  * it normally would use (1 January A.D. 1), since we're not exposing it.
3248  * We're only building the value so we can turn around and get the
3249  * normalised values for the year, month, day-of-month, and day-of-year.
3250  *
3251  * For going backward, we need to bias the value we're using so that we find
3252  * the right year value.  (Basically, we don't want the contribution of
3253  * March 1st to the number to apply while deriving the year).  Having done
3254  * that, we 'count up' the contribution to the year number by accounting for
3255  * full quadracenturies (400-year periods) with their extra leap days, plus
3256  * the contribution from full centuries (to avoid counting in the lost leap
3257  * days), plus the contribution from full quad-years (to count in the normal
3258  * leap days), plus the leftover contribution from any non-leap years.
3259  * At this point, if we were working with an actual leap day, we'll have 0
3260  * days left over.  This is also true for March 1st, however.  So, we have
3261  * to special-case that result, and (earlier) keep track of the 'odd'
3262  * century and year contributions.  If we got 4 extra centuries in a qcent,
3263  * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb.
3264  * Otherwise, we add back in the earlier bias we removed (the 123 from
3265  * figuring in March 1st), find the month index (integer division by 30.6),
3266  * and the remainder is the day-of-month.  We then have to convert back to
3267  * 'real' months (including fixing January and February from being 14/15 in
3268  * the previous year to being in the proper year).  After that, to get
3269  * tm_yday, we work with the normalised year and get a new yearday value for
3270  * January 1st, which we subtract from the yearday value we had earlier,
3271  * representing the date we've re-built.  This is done from January 1
3272  * because tm_yday is 0-origin.
3273  *
3274  * Since POSIX time routines are only guaranteed to work for times since the
3275  * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm
3276  * applies Gregorian calendar rules even to dates before the 16th century
3277  * doesn't bother me.  Besides, you'd need cultural context for a given
3278  * date to know whether it was Julian or Gregorian calendar, and that's
3279  * outside the scope for this routine.  Since we convert back based on the
3280  * same rules we used to build the yearday, you'll only get strange results
3281  * for input which needed normalising, or for the 'odd' century years which
3282  * were leap years in the Julian calander but not in the Gregorian one.
3283  * I can live with that.
3284  *
3285  * This algorithm also fails to handle years before A.D. 1 gracefully, but
3286  * that's still outside the scope for POSIX time manipulation, so I don't
3287  * care.
3288  */
3289
3290     year = 1900 + ptm->tm_year;
3291     month = ptm->tm_mon;
3292     mday = ptm->tm_mday;
3293     /* allow given yday with no month & mday to dominate the result */
3294     if (ptm->tm_yday >= 0 && mday <= 0 && month <= 0) {
3295         month = 0;
3296         mday = 0;
3297         jday = 1 + ptm->tm_yday;
3298     }
3299     else {
3300         jday = 0;
3301     }
3302     if (month >= 2)
3303         month+=2;
3304     else
3305         month+=14, year--;
3306     yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400;
3307     yearday += month*MONTH_TO_DAYS + mday + jday;
3308     /*
3309      * Note that we don't know when leap-seconds were or will be,
3310      * so we have to trust the user if we get something which looks
3311      * like a sensible leap-second.  Wild values for seconds will
3312      * be rationalised, however.
3313      */
3314     if ((unsigned) ptm->tm_sec <= 60) {
3315         secs = 0;
3316     }
3317     else {
3318         secs = ptm->tm_sec;
3319         ptm->tm_sec = 0;
3320     }
3321     secs += 60 * ptm->tm_min;
3322     secs += SECS_PER_HOUR * ptm->tm_hour;
3323     if (secs < 0) {
3324         if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) {
3325             /* got negative remainder, but need positive time */
3326             /* back off an extra day to compensate */
3327             yearday += (secs/SECS_PER_DAY)-1;
3328             secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1);
3329         }
3330         else {
3331             yearday += (secs/SECS_PER_DAY);
3332             secs -= SECS_PER_DAY * (secs/SECS_PER_DAY);
3333         }
3334     }
3335     else if (secs >= SECS_PER_DAY) {
3336         yearday += (secs/SECS_PER_DAY);
3337         secs %= SECS_PER_DAY;
3338     }
3339     ptm->tm_hour = secs/SECS_PER_HOUR;
3340     secs %= SECS_PER_HOUR;
3341     ptm->tm_min = secs/60;
3342     secs %= 60;
3343     ptm->tm_sec += secs;
3344     /* done with time of day effects */
3345     /*
3346      * The algorithm for yearday has (so far) left it high by 428.
3347      * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to
3348      * bias it by 123 while trying to figure out what year it
3349      * really represents.  Even with this tweak, the reverse
3350      * translation fails for years before A.D. 0001.
3351      * It would still fail for Feb 29, but we catch that one below.
3352      */
3353     jday = yearday;     /* save for later fixup vis-a-vis Jan 1 */
3354     yearday -= YEAR_ADJUST;
3355     year = (yearday / DAYS_PER_QCENT) * 400;
3356     yearday %= DAYS_PER_QCENT;
3357     odd_cent = yearday / DAYS_PER_CENT;
3358     year += odd_cent * 100;
3359     yearday %= DAYS_PER_CENT;
3360     year += (yearday / DAYS_PER_QYEAR) * 4;
3361     yearday %= DAYS_PER_QYEAR;
3362     odd_year = yearday / DAYS_PER_YEAR;
3363     year += odd_year;
3364     yearday %= DAYS_PER_YEAR;
3365     if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */
3366         month = 1;
3367         yearday = 29;
3368     }
3369     else {
3370         yearday += YEAR_ADJUST; /* recover March 1st crock */
3371         month = yearday*DAYS_TO_MONTH;
3372         yearday -= month*MONTH_TO_DAYS;
3373         /* recover other leap-year adjustment */
3374         if (month > 13) {
3375             month-=14;
3376             year++;
3377         }
3378         else {
3379             month-=2;
3380         }
3381     }
3382     ptm->tm_year = year - 1900;
3383     if (yearday) {
3384       ptm->tm_mday = yearday;
3385       ptm->tm_mon = month;
3386     }
3387     else {
3388       ptm->tm_mday = 31;
3389       ptm->tm_mon = month - 1;
3390     }
3391     /* re-build yearday based on Jan 1 to get tm_yday */
3392     year--;
3393     yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400;
3394     yearday += 14*MONTH_TO_DAYS + 1;
3395     ptm->tm_yday = jday - yearday;
3396     /* fix tm_wday if not overridden by caller */
3397     if ((unsigned)ptm->tm_wday > 6)
3398         ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
3399 }
3400
3401 char *
3402 Perl_my_strftime(pTHX_ char *fmt, int sec, int min, int hour, int mday, int mon, int year, int wday, int yday, int isdst)
3403 {
3404 #ifdef HAS_STRFTIME
3405   char *buf;
3406   int buflen;
3407   struct tm mytm;
3408   int len;
3409
3410   init_tm(&mytm);       /* XXX workaround - see init_tm() above */
3411   mytm.tm_sec = sec;
3412   mytm.tm_min = min;
3413   mytm.tm_hour = hour;
3414   mytm.tm_mday = mday;
3415   mytm.tm_mon = mon;
3416   mytm.tm_year = year;
3417   mytm.tm_wday = wday;
3418   mytm.tm_yday = yday;
3419   mytm.tm_isdst = isdst;
3420   mini_mktime(&mytm);
3421   /* use libc to get the values for tm_gmtoff and tm_zone [perl #18238] */
3422 #if defined(HAS_MKTIME) && (defined(HAS_TM_TM_GMTOFF) || defined(HAS_TM_TM_ZONE))
3423   STMT_START {
3424     struct tm mytm2;
3425     mytm2 = mytm;
3426     mktime(&mytm2);
3427 #ifdef HAS_TM_TM_GMTOFF
3428     mytm.tm_gmtoff = mytm2.tm_gmtoff;
3429 #endif
3430 #ifdef HAS_TM_TM_ZONE
3431     mytm.tm_zone = mytm2.tm_zone;
3432 #endif
3433   } STMT_END;
3434 #endif
3435   buflen = 64;
3436   New(0, buf, buflen, char);
3437   len = strftime(buf, buflen, fmt, &mytm);
3438   /*
3439   ** The following is needed to handle to the situation where
3440   ** tmpbuf overflows.  Basically we want to allocate a buffer
3441   ** and try repeatedly.  The reason why it is so complicated
3442   ** is that getting a return value of 0 from strftime can indicate
3443   ** one of the following:
3444   ** 1. buffer overflowed,
3445   ** 2. illegal conversion specifier, or
3446   ** 3. the format string specifies nothing to be returned(not
3447   **      an error).  This could be because format is an empty string
3448   **    or it specifies %p that yields an empty string in some locale.
3449   ** If there is a better way to make it portable, go ahead by
3450   ** all means.
3451   */
3452   if ((len > 0 && len < buflen) || (len == 0 && *fmt == '\0'))
3453     return buf;
3454   else {
3455     /* Possibly buf overflowed - try again with a bigger buf */
3456     int     fmtlen = strlen(fmt);
3457     int     bufsize = fmtlen + buflen;
3458
3459     New(0, buf, bufsize, char);
3460     while (buf) {
3461       buflen = strftime(buf, bufsize, fmt, &mytm);
3462       if (buflen > 0 && buflen < bufsize)
3463         break;
3464       /* heuristic to prevent out-of-memory errors */
3465       if (bufsize > 100*fmtlen) {
3466         Safefree(buf);
3467         buf = NULL;
3468         break;
3469       }
3470       bufsize *= 2;
3471       Renew(buf, bufsize, char);
3472     }
3473     return buf;
3474   }
3475 #else
3476   Perl_croak(aTHX_ "panic: no strftime");
3477 #endif
3478 }
3479
3480
3481 #define SV_CWD_RETURN_UNDEF \
3482 sv_setsv(sv, &PL_sv_undef); \
3483 return FALSE
3484
3485 #define SV_CWD_ISDOT(dp) \
3486     (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
3487         (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
3488
3489 /*
3490 =head1 Miscellaneous Functions
3491
3492 =for apidoc getcwd_sv
3493
3494 Fill the sv with current working directory
3495
3496 =cut
3497 */
3498
3499 /* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars.
3500  * rewritten again by dougm, optimized for use with xs TARG, and to prefer
3501  * getcwd(3) if available
3502  * Comments from the orignal:
3503  *     This is a faster version of getcwd.  It's also more dangerous
3504  *     because you might chdir out of a directory that you can't chdir
3505  *     back into. */
3506
3507 int
3508 Perl_getcwd_sv(pTHX_ register SV *sv)
3509 {
3510 #ifndef PERL_MICRO
3511
3512 #ifndef INCOMPLETE_TAINTS
3513     SvTAINTED_on(sv);
3514 #endif
3515
3516 #ifdef HAS_GETCWD
3517     {
3518         char buf[MAXPATHLEN];
3519
3520         /* Some getcwd()s automatically allocate a buffer of the given
3521          * size from the heap if they are given a NULL buffer pointer.
3522          * The problem is that this behaviour is not portable. */
3523         if (getcwd(buf, sizeof(buf) - 1)) {
3524             STRLEN len = strlen(buf);
3525             sv_setpvn(sv, buf, len);
3526             return TRUE;
3527         }
3528         else {
3529             sv_setsv(sv, &PL_sv_undef);
3530             return FALSE;
3531         }
3532     }
3533
3534 #else
3535
3536     Stat_t statbuf;
3537     int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
3538     int namelen, pathlen=0;
3539     DIR *dir;
3540     Direntry_t *dp;
3541
3542     (void)SvUPGRADE(sv, SVt_PV);
3543
3544     if (PerlLIO_lstat(".", &statbuf) < 0) {
3545         SV_CWD_RETURN_UNDEF;
3546     }
3547
3548     orig_cdev = statbuf.st_dev;
3549     orig_cino = statbuf.st_ino;
3550     cdev = orig_cdev;
3551     cino = orig_cino;
3552
3553     for (;;) {
3554         odev = cdev;
3555         oino = cino;
3556
3557         if (PerlDir_chdir("..") < 0) {
3558             SV_CWD_RETURN_UNDEF;
3559         }
3560         if (PerlLIO_stat(".", &statbuf) < 0) {
3561             SV_CWD_RETURN_UNDEF;
3562         }
3563
3564         cdev = statbuf.st_dev;
3565         cino = statbuf.st_ino;
3566
3567         if (odev == cdev && oino == cino) {
3568             break;
3569         }
3570         if (!(dir = PerlDir_open("."))) {
3571             SV_CWD_RETURN_UNDEF;
3572         }
3573
3574         while ((dp = PerlDir_read(dir)) != NULL) {
3575 #ifdef DIRNAMLEN
3576             namelen = dp->d_namlen;
3577 #else
3578             namelen = strlen(dp->d_name);
3579 #endif
3580             /* skip . and .. */
3581             if (SV_CWD_ISDOT(dp)) {
3582                 continue;
3583             }
3584
3585             if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
3586                 SV_CWD_RETURN_UNDEF;
3587             }
3588
3589             tdev = statbuf.st_dev;
3590             tino = statbuf.st_ino;
3591             if (tino == oino && tdev == odev) {
3592                 break;
3593             }
3594         }
3595
3596         if (!dp) {
3597             SV_CWD_RETURN_UNDEF;
3598         }
3599
3600         if (pathlen + namelen + 1 >= MAXPATHLEN) {
3601             SV_CWD_RETURN_UNDEF;
3602         }
3603
3604         SvGROW(sv, pathlen + namelen + 1);
3605
3606         if (pathlen) {
3607             /* shift down */
3608             Move(SvPVX(sv), SvPVX(sv) + namelen + 1, pathlen, char);
3609         }
3610
3611         /* prepend current directory to the front */
3612         *SvPVX(sv) = '/';
3613         Move(dp->d_name, SvPVX(sv)+1, namelen, char);
3614         pathlen += (namelen + 1);
3615
3616 #ifdef VOID_CLOSEDIR
3617         PerlDir_close(dir);
3618 #else
3619         if (PerlDir_close(dir) < 0) {
3620             SV_CWD_RETURN_UNDEF;
3621         }
3622 #endif
3623     }
3624
3625     if (pathlen) {
3626         SvCUR_set(sv, pathlen);
3627         *SvEND(sv) = '\0';
3628         SvPOK_only(sv);
3629
3630         if (PerlDir_chdir(SvPVX(sv)) < 0) {
3631             SV_CWD_RETURN_UNDEF;
3632         }
3633     }
3634     if (PerlLIO_stat(".", &statbuf) < 0) {
3635         SV_CWD_RETURN_UNDEF;
3636     }
3637
3638     cdev = statbuf.st_dev;
3639     cino = statbuf.st_ino;
3640
3641     if (cdev != orig_cdev || cino != orig_cino) {
3642         Perl_croak(aTHX_ "Unstable directory path, "
3643                    "current directory changed unexpectedly");
3644     }
3645
3646     return TRUE;
3647 #endif
3648
3649 #else
3650     return FALSE;
3651 #endif
3652 }
3653
3654 /*
3655 =for apidoc scan_version
3656
3657 Returns a pointer to the next character after the parsed
3658 version string, as well as upgrading the passed in SV to
3659 an RV.
3660
3661 Function must be called with an already existing SV like
3662
3663     sv = NEWSV(92,0);
3664     s = scan_version(s,sv);
3665
3666 Performs some preprocessing to the string to ensure that
3667 it has the correct characteristics of a version.  Flags the
3668 object if it contains an underscore (which denotes this
3669 is a beta version).
3670
3671 =cut
3672 */
3673
3674 char *
3675 Perl_scan_version(pTHX_ char *s, SV *rv)
3676 {
3677     const char *start = s;
3678     char *pos = s;
3679     I32 saw_period = 0;
3680     bool saw_under = 0;
3681     SV* sv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
3682     (void)sv_upgrade(sv, SVt_PVAV); /* needs to be an AV type */
3683
3684     /* pre-scan the imput string to check for decimals */
3685     while ( *pos == '.' || *pos == '_' || isDIGIT(*pos) )
3686     {
3687         if ( *pos == '.' )
3688         {
3689             if ( saw_under )
3690                 Perl_croak(aTHX_ "Invalid version format (underscores before decimal)");
3691             saw_period++ ;
3692         }
3693         else if ( *pos == '_' )
3694         {
3695             if ( saw_under )
3696                 Perl_croak(aTHX_ "Invalid version format (multiple underscores)");
3697             saw_under = 1;
3698         }
3699         pos++;
3700     }
3701     pos = s;
3702
3703     if (*pos == 'v') pos++;  /* get past 'v' */
3704     while (isDIGIT(*pos))
3705         pos++;
3706     if (!isALPHA(*pos)) {
3707         I32 rev;
3708
3709         if (*s == 'v') s++;  /* get past 'v' */
3710
3711         for (;;) {
3712             rev = 0;
3713             {
3714                 /* this is atoi() that delimits on underscores */
3715                 char *end = pos;
3716                 I32 mult = 1;
3717                 I32 orev;
3718                 if ( s < pos && s > start && *(s-1) == '_' ) {
3719                         mult *= -1;     /* beta version */
3720                 }
3721                 /* the following if() will only be true after the decimal
3722                  * point of a version originally created with a bare
3723                  * floating point number, i.e. not quoted in any way
3724                  */
3725                 if ( s > start+1 && saw_period == 1 && !saw_under ) {
3726                     mult = 100;
3727                     while ( s < end ) {
3728                         orev = rev;
3729                         rev += (*s - '0') * mult;
3730                         mult /= 10;
3731                         if ( PERL_ABS(orev) > PERL_ABS(rev) )
3732                             Perl_croak(aTHX_ "Integer overflow in version");
3733                         s++;
3734                     }
3735                 }
3736                 else {
3737                     while (--end >= s) {
3738                         orev = rev;
3739                         rev += (*end - '0') * mult;
3740                         mult *= 10;
3741                         if ( PERL_ABS(orev) > PERL_ABS(rev) )
3742                             Perl_croak(aTHX_ "Integer overflow in version");
3743                     }
3744                 }
3745             }
3746
3747             /* Append revision */
3748             av_push((AV *)sv, newSViv(rev));
3749             if ( (*pos == '.' || *pos == '_') && isDIGIT(pos[1]))
3750                 s = ++pos;
3751             else if ( isDIGIT(*pos) )
3752                 s = pos;
3753             else {
3754                 s = pos;
3755                 break;
3756             }
3757             while ( isDIGIT(*pos) ) {
3758                 if ( !saw_under && saw_period == 1 && pos-s == 3 )
3759                     break;
3760                 pos++;
3761             }
3762         }
3763     }
3764     return s;
3765 }
3766
3767 /*
3768 =for apidoc new_version
3769
3770 Returns a new version object based on the passed in SV:
3771
3772     SV *sv = new_version(SV *ver);
3773
3774 Does not alter the passed in ver SV.  See "upg_version" if you
3775 want to upgrade the SV.
3776
3777 =cut
3778 */
3779
3780 SV *
3781 Perl_new_version(pTHX_ SV *ver)
3782 {
3783     SV *rv = newSV(0);
3784     char *version;
3785     if ( SvNOK(ver) ) /* may get too much accuracy */
3786     {
3787         char tbuf[64];
3788         sprintf(tbuf,"%.9"NVgf, SvNVX(ver));
3789         version = savepv(tbuf);
3790     }
3791 #ifdef SvVOK
3792     else if ( SvVOK(ver) ) { /* already a v-string */
3793         MAGIC* mg = mg_find(ver,PERL_MAGIC_vstring);
3794         version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
3795     }
3796 #endif
3797     else /* must be a string or something like a string */
3798     {
3799         version = (char *)SvPV(ver,PL_na);
3800     }
3801     version = scan_version(version,rv);
3802     return rv;
3803 }
3804
3805 /*
3806 =for apidoc upg_version
3807
3808 In-place upgrade of the supplied SV to a version object.
3809
3810     SV *sv = upg_version(SV *sv);
3811
3812 Returns a pointer to the upgraded SV.
3813
3814 =cut
3815 */
3816
3817 SV *
3818 Perl_upg_version(pTHX_ SV *ver)
3819 {
3820     char *version = savepvn(SvPVX(ver),SvCUR(ver));
3821 #ifdef SvVOK
3822     if ( SvVOK(ver) ) { /* already a v-string */
3823         MAGIC* mg = mg_find(ver,PERL_MAGIC_vstring);
3824         version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
3825     }
3826 #endif
3827     version = scan_version(version,ver);
3828     return ver;
3829 }
3830
3831
3832 /*
3833 =for apidoc vnumify
3834
3835 Accepts a version object and returns the normalized floating
3836 point representation.  Call like:
3837
3838     sv = vnumify(rv);
3839
3840 NOTE: you can pass either the object directly or the SV
3841 contained within the RV.
3842
3843 =cut
3844 */
3845
3846 SV *
3847 Perl_vnumify(pTHX_ SV *vs)
3848 {
3849     I32 i, len, digit;
3850     SV *sv = NEWSV(92,0);
3851     if ( SvROK(vs) )
3852         vs = SvRV(vs);
3853     len = av_len((AV *)vs);
3854     if ( len == -1 )
3855     {
3856         Perl_sv_catpv(aTHX_ sv,"0");
3857         return sv;
3858     }
3859     digit = SvIVX(*av_fetch((AV *)vs, 0, 0));
3860     Perl_sv_setpvf(aTHX_ sv,"%d.", PERL_ABS(digit));
3861     for ( i = 1 ; i <= len ; i++ )
3862     {
3863         digit = SvIVX(*av_fetch((AV *)vs, i, 0));
3864         Perl_sv_catpvf(aTHX_ sv,"%03d", PERL_ABS(digit));
3865     }
3866     if ( len == 0 )
3867          Perl_sv_catpv(aTHX_ sv,"000");
3868     sv_setnv(sv, SvNV(sv));
3869     return sv;
3870 }
3871
3872 /*
3873 =for apidoc vstringify
3874
3875 Accepts a version object and returns the normalized string
3876 representation.  Call like:
3877
3878     sv = vstringify(rv);
3879
3880 NOTE: you can pass either the object directly or the SV
3881 contained within the RV.
3882
3883 =cut
3884 */
3885
3886 SV *
3887 Perl_vstringify(pTHX_ SV *vs)
3888 {
3889     I32 i, len, digit;
3890     SV *sv = NEWSV(92,0);
3891     if ( SvROK(vs) )
3892         vs = SvRV(vs);
3893     len = av_len((AV *)vs);
3894     if ( len == -1 )
3895     {
3896         Perl_sv_catpv(aTHX_ sv,"");
3897         return sv;
3898     }
3899     digit = SvIVX(*av_fetch((AV *)vs, 0, 0));
3900     Perl_sv_setpvf(aTHX_ sv,"%"IVdf,(IV)digit);
3901     for ( i = 1 ; i <= len ; i++ )
3902     {
3903         digit = SvIVX(*av_fetch((AV *)vs, i, 0));
3904         if ( digit < 0 )
3905             Perl_sv_catpvf(aTHX_ sv,"_%"IVdf,(IV)-digit);
3906         else
3907             Perl_sv_catpvf(aTHX_ sv,".%"IVdf,(IV)digit);
3908     }
3909     if ( len == 0 )
3910          Perl_sv_catpv(aTHX_ sv,".0");
3911     return sv;
3912 }
3913
3914 /*
3915 =for apidoc vcmp
3916
3917 Version object aware cmp.  Both operands must already have been
3918 converted into version objects.
3919
3920 =cut
3921 */
3922
3923 int
3924 Perl_vcmp(pTHX_ SV *lsv, SV *rsv)
3925 {
3926     I32 i,l,m,r,retval;
3927     if ( SvROK(lsv) )
3928         lsv = SvRV(lsv);
3929     if ( SvROK(rsv) )
3930         rsv = SvRV(rsv);
3931     l = av_len((AV *)lsv);
3932     r = av_len((AV *)rsv);
3933     m = l < r ? l : r;
3934     retval = 0;
3935     i = 0;
3936     while ( i <= m && retval == 0 )
3937     {
3938         I32 left  = SvIV(*av_fetch((AV *)lsv,i,0));
3939         I32 right = SvIV(*av_fetch((AV *)rsv,i,0));
3940         bool lbeta = left  < 0 ? 1 : 0;
3941         bool rbeta = right < 0 ? 1 : 0;
3942         left  = PERL_ABS(left);
3943         right = PERL_ABS(right);
3944         if ( left < right || (left == right && lbeta && !rbeta) )
3945             retval = -1;
3946         if ( left > right || (left == right && rbeta && !lbeta) )
3947             retval = +1;
3948         i++;
3949     }
3950
3951     if ( l != r && retval == 0 ) /* possible match except for trailing 0 */
3952     {
3953         if ( !( l < r && r-l == 1 && SvIV(*av_fetch((AV *)rsv,r,0)) == 0 ) &&
3954              !( l-r == 1 && SvIV(*av_fetch((AV *)lsv,l,0)) == 0 ) )
3955         {
3956             retval = l < r ? -1 : +1; /* not a match after all */
3957         }
3958     }
3959     return retval;
3960 }
3961
3962 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT)
3963 #   define EMULATE_SOCKETPAIR_UDP
3964 #endif
3965
3966 #ifdef EMULATE_SOCKETPAIR_UDP
3967 static int
3968 S_socketpair_udp (int fd[2]) {
3969     dTHX;
3970     /* Fake a datagram socketpair using UDP to localhost.  */
3971     int sockets[2] = {-1, -1};
3972     struct sockaddr_in addresses[2];
3973     int i;
3974     Sock_size_t size = sizeof(struct sockaddr_in);
3975     unsigned short port;
3976     int got;
3977
3978     memset(&addresses, 0, sizeof(addresses));
3979     i = 1;
3980     do {
3981         sockets[i] = PerlSock_socket(AF_INET, SOCK_DGRAM, PF_INET);
3982         if (sockets[i] == -1)
3983             goto tidy_up_and_fail;
3984
3985         addresses[i].sin_family = AF_INET;
3986         addresses[i].sin_addr.s_addr = htonl(INADDR_LOOPBACK);
3987         addresses[i].sin_port = 0;      /* kernel choses port.  */
3988         if (PerlSock_bind(sockets[i], (struct sockaddr *) &addresses[i],
3989                 sizeof(struct sockaddr_in)) == -1)
3990             goto tidy_up_and_fail;
3991     } while (i--);
3992
3993     /* Now have 2 UDP sockets. Find out which port each is connected to, and
3994        for each connect the other socket to it.  */
3995     i = 1;
3996     do {
3997         if (PerlSock_getsockname(sockets[i], (struct sockaddr *) &addresses[i],
3998                 &size) == -1)
3999             goto tidy_up_and_fail;
4000         if (size != sizeof(struct sockaddr_in))
4001             goto abort_tidy_up_and_fail;
4002         /* !1 is 0, !0 is 1 */
4003         if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i],
4004                 sizeof(struct sockaddr_in)) == -1)
4005             goto tidy_up_and_fail;
4006     } while (i--);
4007
4008     /* Now we have 2 sockets connected to each other. I don't trust some other
4009        process not to have already sent a packet to us (by random) so send
4010        a packet from each to the other.  */
4011     i = 1;
4012     do {
4013         /* I'm going to send my own port number.  As a short.
4014            (Who knows if someone somewhere has sin_port as a bitfield and needs
4015            this routine. (I'm assuming crays have socketpair)) */
4016         port = addresses[i].sin_port;
4017         got = PerlLIO_write(sockets[i], &port, sizeof(port));
4018         if (got != sizeof(port)) {
4019             if (got == -1)
4020                 goto tidy_up_and_fail;
4021             goto abort_tidy_up_and_fail;
4022         }
4023     } while (i--);
4024
4025     /* Packets sent. I don't trust them to have arrived though.
4026        (As I understand it Solaris TCP stack is multithreaded. Non-blocking
4027        connect to localhost will use a second kernel thread. In 2.6 the
4028        first thread running the connect() returns before the second completes,
4029        so EINPROGRESS> In 2.7 the improved stack is faster and connect()
4030        returns 0. Poor programs have tripped up. One poor program's authors'
4031        had a 50-1 reverse stock split. Not sure how connected these were.)
4032        So I don't trust someone not to have an unpredictable UDP stack.
4033     */
4034
4035     {
4036         struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */
4037         int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0];
4038         fd_set rset;
4039
4040         FD_ZERO(&rset);
4041         FD_SET(sockets[0], &rset);
4042         FD_SET(sockets[1], &rset);
4043
4044         got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor);
4045         if (got != 2 || !FD_ISSET(sockets[0], &rset)
4046                 || !FD_ISSET(sockets[1], &rset)) {
4047             /* I hope this is portable and appropriate.  */
4048             if (got == -1)
4049                 goto tidy_up_and_fail;
4050             goto abort_tidy_up_and_fail;
4051         }
4052     }
4053
4054     /* And the paranoia department even now doesn't trust it to have arrive
4055        (hence MSG_DONTWAIT). Or that what arrives was sent by us.  */
4056     {
4057         struct sockaddr_in readfrom;
4058         unsigned short buffer[2];
4059
4060         i = 1;
4061         do {
4062 #ifdef MSG_DONTWAIT
4063             got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4064                     sizeof(buffer), MSG_DONTWAIT,
4065                     (struct sockaddr *) &readfrom, &size);
4066 #else
4067             got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4068                     sizeof(buffer), 0,
4069                     (struct sockaddr *) &readfrom, &size);
4070 #endif
4071
4072             if (got == -1)
4073                 goto tidy_up_and_fail;
4074             if (got != sizeof(port)
4075                     || size != sizeof(struct sockaddr_in)
4076                     /* Check other socket sent us its port.  */
4077                     || buffer[0] != (unsigned short) addresses[!i].sin_port
4078                     /* Check kernel says we got the datagram from that socket */
4079                     || readfrom.sin_family != addresses[!i].sin_family
4080                     || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr
4081                     || readfrom.sin_port != addresses[!i].sin_port)
4082                 goto abort_tidy_up_and_fail;
4083         } while (i--);
4084     }
4085     /* My caller (my_socketpair) has validated that this is non-NULL  */
4086     fd[0] = sockets[0];
4087     fd[1] = sockets[1];
4088     /* I hereby declare this connection open.  May God bless all who cross
4089        her.  */
4090     return 0;
4091
4092   abort_tidy_up_and_fail:
4093     errno = ECONNABORTED;
4094   tidy_up_and_fail:
4095     {
4096         int save_errno = errno;
4097         if (sockets[0] != -1)
4098             PerlLIO_close(sockets[0]);
4099         if (sockets[1] != -1)
4100             PerlLIO_close(sockets[1]);
4101         errno = save_errno;
4102         return -1;
4103     }
4104 }
4105 #endif /*  EMULATE_SOCKETPAIR_UDP */
4106
4107 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET)
4108 int
4109 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4110     /* Stevens says that family must be AF_LOCAL, protocol 0.
4111        I'm going to enforce that, then ignore it, and use TCP (or UDP).  */
4112     dTHX;
4113     int listener = -1;
4114     int connector = -1;
4115     int acceptor = -1;
4116     struct sockaddr_in listen_addr;
4117     struct sockaddr_in connect_addr;
4118     Sock_size_t size;
4119
4120     if (protocol
4121 #ifdef AF_UNIX
4122         || family != AF_UNIX
4123 #endif
4124     ) {
4125         errno = EAFNOSUPPORT;
4126         return -1;
4127     }
4128     if (!fd) {
4129         errno = EINVAL;
4130         return -1;
4131     }
4132
4133 #ifdef EMULATE_SOCKETPAIR_UDP
4134     if (type == SOCK_DGRAM)
4135         return S_socketpair_udp(fd);
4136 #endif
4137
4138     listener = PerlSock_socket(AF_INET, type, 0);
4139     if (listener == -1)
4140         return -1;
4141     memset(&listen_addr, 0, sizeof(listen_addr));
4142     listen_addr.sin_family = AF_INET;
4143     listen_addr.sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4144     listen_addr.sin_port = 0;   /* kernel choses port.  */
4145     if (PerlSock_bind(listener, (struct sockaddr *) &listen_addr,
4146             sizeof(listen_addr)) == -1)
4147         goto tidy_up_and_fail;
4148     if (PerlSock_listen(listener, 1) == -1)
4149         goto tidy_up_and_fail;
4150
4151     connector = PerlSock_socket(AF_INET, type, 0);
4152     if (connector == -1)
4153         goto tidy_up_and_fail;
4154     /* We want to find out the port number to connect to.  */
4155     size = sizeof(connect_addr);
4156     if (PerlSock_getsockname(listener, (struct sockaddr *) &connect_addr,
4157             &size) == -1)
4158         goto tidy_up_and_fail;
4159     if (size != sizeof(connect_addr))
4160         goto abort_tidy_up_and_fail;
4161     if (PerlSock_connect(connector, (struct sockaddr *) &connect_addr,
4162             sizeof(connect_addr)) == -1)
4163         goto tidy_up_and_fail;
4164
4165     size = sizeof(listen_addr);
4166     acceptor = PerlSock_accept(listener, (struct sockaddr *) &listen_addr,
4167             &size);
4168     if (acceptor == -1)
4169         goto tidy_up_and_fail;
4170     if (size != sizeof(listen_addr))
4171         goto abort_tidy_up_and_fail;
4172     PerlLIO_close(listener);
4173     /* Now check we are talking to ourself by matching port and host on the
4174        two sockets.  */
4175     if (PerlSock_getsockname(connector, (struct sockaddr *) &connect_addr,
4176             &size) == -1)
4177         goto tidy_up_and_fail;
4178     if (size != sizeof(connect_addr)
4179             || listen_addr.sin_family != connect_addr.sin_family
4180             || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr
4181             || listen_addr.sin_port != connect_addr.sin_port) {
4182         goto abort_tidy_up_and_fail;
4183     }
4184     fd[0] = connector;
4185     fd[1] = acceptor;
4186     return 0;
4187
4188   abort_tidy_up_and_fail:
4189   errno = ECONNABORTED; /* I hope this is portable and appropriate.  */
4190   tidy_up_and_fail:
4191     {
4192         int save_errno = errno;
4193         if (listener != -1)
4194             PerlLIO_close(listener);
4195         if (connector != -1)
4196             PerlLIO_close(connector);
4197         if (acceptor != -1)
4198             PerlLIO_close(acceptor);
4199         errno = save_errno;
4200         return -1;
4201     }
4202 }
4203 #else
4204 /* In any case have a stub so that there's code corresponding
4205  * to the my_socketpair in global.sym. */
4206 int
4207 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4208 #ifdef HAS_SOCKETPAIR
4209     return socketpair(family, type, protocol, fd);
4210 #else
4211     return -1;
4212 #endif
4213 }
4214 #endif
4215
4216 /*
4217
4218 =for apidoc sv_nosharing
4219
4220 Dummy routine which "shares" an SV when there is no sharing module present.
4221 Exists to avoid test for a NULL function pointer and because it could potentially warn under
4222 some level of strict-ness.
4223
4224 =cut
4225 */
4226
4227 void
4228 Perl_sv_nosharing(pTHX_ SV *sv)
4229 {
4230 }
4231
4232 /*
4233 =for apidoc sv_nolocking
4234
4235 Dummy routine which "locks" an SV when there is no locking module present.
4236 Exists to avoid test for a NULL function pointer and because it could potentially warn under
4237 some level of strict-ness.
4238
4239 =cut
4240 */
4241
4242 void
4243 Perl_sv_nolocking(pTHX_ SV *sv)
4244 {
4245 }
4246
4247
4248 /*
4249 =for apidoc sv_nounlocking
4250
4251 Dummy routine which "unlocks" an SV when there is no locking module present.
4252 Exists to avoid test for a NULL function pointer and because it could potentially warn under
4253 some level of strict-ness.
4254
4255 =cut
4256 */
4257
4258 void
4259 Perl_sv_nounlocking(pTHX_ SV *sv)
4260 {
4261 }
4262
4263 U32
4264 Perl_parse_unicode_opts(pTHX_ char **popt)
4265 {
4266   char *p = *popt;
4267   U32 opt = 0;
4268
4269   if (*p) {
4270        if (isDIGIT(*p)) {
4271             opt = (U32) atoi(p);
4272             while (isDIGIT(*p)) p++;
4273             if (*p && *p != '\n' && *p != '\r')
4274                  Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
4275        }
4276        else {
4277             for (; *p; p++) {
4278                  switch (*p) {
4279                  case PERL_UNICODE_STDIN:
4280                       opt |= PERL_UNICODE_STDIN_FLAG;   break;
4281                  case PERL_UNICODE_STDOUT:
4282                       opt |= PERL_UNICODE_STDOUT_FLAG;  break;
4283                  case PERL_UNICODE_STDERR:
4284                       opt |= PERL_UNICODE_STDERR_FLAG;  break;
4285                  case PERL_UNICODE_STD:
4286                       opt |= PERL_UNICODE_STD_FLAG;     break;
4287                  case PERL_UNICODE_IN:
4288                       opt |= PERL_UNICODE_IN_FLAG;      break;
4289                  case PERL_UNICODE_OUT:
4290                       opt |= PERL_UNICODE_OUT_FLAG;     break;
4291                  case PERL_UNICODE_INOUT:
4292                       opt |= PERL_UNICODE_INOUT_FLAG;   break;
4293                  case PERL_UNICODE_LOCALE:
4294                       opt |= PERL_UNICODE_LOCALE_FLAG;  break;
4295                  case PERL_UNICODE_ARGV:
4296                       opt |= PERL_UNICODE_ARGV_FLAG;    break;
4297                  default:
4298                       if (*p != '\n' && *p != '\r')
4299                           Perl_croak(aTHX_
4300                                      "Unknown Unicode option letter '%c'", *p);
4301                  }
4302             }
4303        }
4304   }
4305   else
4306        opt = PERL_UNICODE_DEFAULT_FLAGS;
4307
4308   if (opt & ~PERL_UNICODE_ALL_FLAGS)
4309        Perl_croak(aTHX_ "Unknown Unicode option value %"UVuf,
4310                   (UV) (opt & ~PERL_UNICODE_ALL_FLAGS));
4311
4312   *popt = p;
4313
4314   return opt;
4315 }
4316
4317 U32
4318 Perl_seed(pTHX)
4319 {
4320     /*
4321      * This is really just a quick hack which grabs various garbage
4322      * values.  It really should be a real hash algorithm which
4323      * spreads the effect of every input bit onto every output bit,
4324      * if someone who knows about such things would bother to write it.
4325      * Might be a good idea to add that function to CORE as well.
4326      * No numbers below come from careful analysis or anything here,
4327      * except they are primes and SEED_C1 > 1E6 to get a full-width
4328      * value from (tv_sec * SEED_C1 + tv_usec).  The multipliers should
4329      * probably be bigger too.
4330      */
4331 #if RANDBITS > 16
4332 #  define SEED_C1       1000003
4333 #define   SEED_C4       73819
4334 #else
4335 #  define SEED_C1       25747
4336 #define   SEED_C4       20639
4337 #endif
4338 #define   SEED_C2       3
4339 #define   SEED_C3       269
4340 #define   SEED_C5       26107
4341
4342 #ifndef PERL_NO_DEV_RANDOM
4343     int fd;
4344 #endif
4345     U32 u;
4346 #ifdef VMS
4347 #  include <starlet.h>
4348     /* when[] = (low 32 bits, high 32 bits) of time since epoch
4349      * in 100-ns units, typically incremented ever 10 ms.        */
4350     unsigned int when[2];
4351 #else
4352 #  ifdef HAS_GETTIMEOFDAY
4353     struct timeval when;
4354 #  else
4355     Time_t when;
4356 #  endif
4357 #endif
4358
4359 /* This test is an escape hatch, this symbol isn't set by Configure. */
4360 #ifndef PERL_NO_DEV_RANDOM
4361 #ifndef PERL_RANDOM_DEVICE
4362    /* /dev/random isn't used by default because reads from it will block
4363     * if there isn't enough entropy available.  You can compile with
4364     * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
4365     * is enough real entropy to fill the seed. */
4366 #  define PERL_RANDOM_DEVICE "/dev/urandom"
4367 #endif
4368     fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
4369     if (fd != -1) {
4370         if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
4371             u = 0;
4372         PerlLIO_close(fd);
4373         if (u)
4374             return u;
4375     }
4376 #endif
4377
4378 #ifdef VMS
4379     _ckvmssts(sys$gettim(when));
4380     u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
4381 #else
4382 #  ifdef HAS_GETTIMEOFDAY
4383     PerlProc_gettimeofday(&when,NULL);
4384     u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
4385 #  else
4386     (void)time(&when);
4387     u = (U32)SEED_C1 * when;
4388 #  endif
4389 #endif
4390     u += SEED_C3 * (U32)PerlProc_getpid();
4391     u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
4392 #ifndef PLAN9           /* XXX Plan9 assembler chokes on this; fix needed  */
4393     u += SEED_C5 * (U32)PTR2UV(&when);
4394 #endif
4395     return u;
4396 }
4397
4398 UV
4399 Perl_get_hash_seed(pTHX)
4400 {
4401      char *s = PerlEnv_getenv("PERL_HASH_SEED");
4402      UV myseed = 0;
4403
4404      if (s)
4405           while (isSPACE(*s)) s++;
4406      if (s && isDIGIT(*s))
4407           myseed = (UV)Atoul(s);
4408      else
4409 #ifdef USE_HASH_SEED_EXPLICIT
4410      if (s)
4411 #endif
4412      {
4413           /* Compute a random seed */
4414           (void)seedDrand01((Rand_seed_t)seed());
4415           PL_srand_called = TRUE;
4416           myseed = (UV)(Drand01() * (NV)UV_MAX);
4417 #if RANDBITS < (UVSIZE * 8)
4418           /* Since there are not enough randbits to to reach all
4419            * the bits of a UV, the low bits might need extra
4420            * help.  Sum in another random number that will
4421            * fill in the low bits. */
4422           myseed +=
4423                (UV)(Drand01() * (NV)((1 << ((UVSIZE * 8 - RANDBITS))) - 1));
4424 #endif /* RANDBITS < (UVSIZE * 8) */
4425           if (myseed == 0) { /* Superparanoia. */
4426               myseed = (UV)(Drand01() * (NV)UV_MAX); /* One more chance. */
4427               if (myseed == 0)
4428                   Perl_croak(aTHX_ "Your random numbers are not that random");
4429           }
4430      }
4431      PL_hash_seed_set = TRUE;
4432
4433      return myseed;
4434 }