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