util.c

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