util.c

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