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 #ifdef MACOS_TRADITIONAL
2176 /* We don't want restart behavior on MacOS */
2177 #undef SA_RESTART
2178 #endif
2179
2180 Sighandler_t
2181 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2182 {
2183     struct sigaction act, oact;
2184
2185 #ifdef USE_ITHREADS
2186     /* only "parent" interpreter can diddle signals */
2187     if (PL_curinterp != aTHX)
2188         return SIG_ERR;
2189 #endif
2190
2191     act.sa_handler = handler;
2192     sigemptyset(&act.sa_mask);
2193     act.sa_flags = 0;
2194 #ifdef SA_RESTART
2195 #if defined(PERL_OLD_SIGNALS)
2196     act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
2197 #endif
2198 #endif
2199 #ifdef SA_NOCLDWAIT
2200     if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN)
2201         act.sa_flags |= SA_NOCLDWAIT;
2202 #endif
2203     if (sigaction(signo, &act, &oact) == -1)
2204         return SIG_ERR;
2205     else
2206         return oact.sa_handler;
2207 }
2208
2209 Sighandler_t
2210 Perl_rsignal_state(pTHX_ int signo)
2211 {
2212     struct sigaction oact;
2213
2214     if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
2215         return SIG_ERR;
2216     else
2217         return oact.sa_handler;
2218 }
2219
2220 int
2221 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2222 {
2223     struct sigaction act;
2224
2225 #ifdef USE_ITHREADS
2226     /* only "parent" interpreter can diddle signals */
2227     if (PL_curinterp != aTHX)
2228         return -1;
2229 #endif
2230
2231     act.sa_handler = handler;
2232     sigemptyset(&act.sa_mask);
2233     act.sa_flags = 0;
2234 #ifdef SA_RESTART
2235 #if defined(PERL_OLD_SIGNALS)
2236     act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
2237 #endif
2238 #endif
2239 #ifdef SA_NOCLDWAIT
2240     if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN)
2241         act.sa_flags |= SA_NOCLDWAIT;
2242 #endif
2243     return sigaction(signo, &act, save);
2244 }
2245
2246 int
2247 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2248 {
2249 #ifdef USE_ITHREADS
2250     /* only "parent" interpreter can diddle signals */
2251     if (PL_curinterp != aTHX)
2252         return -1;
2253 #endif
2254
2255     return sigaction(signo, save, (struct sigaction *)NULL);
2256 }
2257
2258 #else /* !HAS_SIGACTION */
2259
2260 Sighandler_t
2261 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2262 {
2263 #if defined(USE_ITHREADS) && !defined(WIN32)
2264     /* only "parent" interpreter can diddle signals */
2265     if (PL_curinterp != aTHX)
2266         return SIG_ERR;
2267 #endif
2268
2269     return PerlProc_signal(signo, handler);
2270 }
2271
2272 static int sig_trapped; /* XXX signals are process-wide anyway, so we
2273                            ignore the implications of this for threading */
2274
2275 static
2276 Signal_t
2277 sig_trap(int signo)
2278 {
2279     sig_trapped++;
2280 }
2281
2282 Sighandler_t
2283 Perl_rsignal_state(pTHX_ int signo)
2284 {
2285     Sighandler_t oldsig;
2286
2287 #if defined(USE_ITHREADS) && !defined(WIN32)
2288     /* only "parent" interpreter can diddle signals */
2289     if (PL_curinterp != aTHX)
2290         return SIG_ERR;
2291 #endif
2292
2293     sig_trapped = 0;
2294     oldsig = PerlProc_signal(signo, sig_trap);
2295     PerlProc_signal(signo, oldsig);
2296     if (sig_trapped)
2297         PerlProc_kill(PerlProc_getpid(), signo);
2298     return oldsig;
2299 }
2300
2301 int
2302 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2303 {
2304 #if defined(USE_ITHREADS) && !defined(WIN32)
2305     /* only "parent" interpreter can diddle signals */
2306     if (PL_curinterp != aTHX)
2307         return -1;
2308 #endif
2309     *save = PerlProc_signal(signo, handler);
2310     return (*save == SIG_ERR) ? -1 : 0;
2311 }
2312
2313 int
2314 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2315 {
2316 #if defined(USE_ITHREADS) && !defined(WIN32)
2317     /* only "parent" interpreter can diddle signals */
2318     if (PL_curinterp != aTHX)
2319         return -1;
2320 #endif
2321     return (PerlProc_signal(signo, *save) == SIG_ERR) ? -1 : 0;
2322 }
2323
2324 #endif /* !HAS_SIGACTION */
2325 #endif /* !PERL_MICRO */
2326
2327     /* VMS' my_pclose() is in VMS.c; same with OS/2 */
2328 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
2329 I32
2330 Perl_my_pclose(pTHX_ PerlIO *ptr)
2331 {
2332     Sigsave_t hstat, istat, qstat;
2333     int status;
2334     SV **svp;
2335     Pid_t pid;
2336     Pid_t pid2;
2337     bool close_failed;
2338     int saved_errno = 0;
2339 #ifdef VMS
2340     int saved_vaxc_errno;
2341 #endif
2342 #ifdef WIN32
2343     int saved_win32_errno;
2344 #endif
2345
2346     LOCK_FDPID_MUTEX;
2347     svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE);
2348     UNLOCK_FDPID_MUTEX;
2349     pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
2350     SvREFCNT_dec(*svp);
2351     *svp = &PL_sv_undef;
2352 #ifdef OS2
2353     if (pid == -1) {                    /* Opened by popen. */
2354         return my_syspclose(ptr);
2355     }
2356 #endif
2357     if ((close_failed = (PerlIO_close(ptr) == EOF))) {
2358         saved_errno = errno;
2359 #ifdef VMS
2360         saved_vaxc_errno = vaxc$errno;
2361 #endif
2362 #ifdef WIN32
2363         saved_win32_errno = GetLastError();
2364 #endif
2365     }
2366 #ifdef UTS
2367     if(PerlProc_kill(pid, 0) < 0) { return(pid); }   /* HOM 12/23/91 */
2368 #endif
2369 #ifndef PERL_MICRO
2370     rsignal_save(SIGHUP, SIG_IGN, &hstat);
2371     rsignal_save(SIGINT, SIG_IGN, &istat);
2372     rsignal_save(SIGQUIT, SIG_IGN, &qstat);
2373 #endif
2374     do {
2375         pid2 = wait4pid(pid, &status, 0);
2376     } while (pid2 == -1 && errno == EINTR);
2377 #ifndef PERL_MICRO
2378     rsignal_restore(SIGHUP, &hstat);
2379     rsignal_restore(SIGINT, &istat);
2380     rsignal_restore(SIGQUIT, &qstat);
2381 #endif
2382     if (close_failed) {
2383         SETERRNO(saved_errno, saved_vaxc_errno);
2384         return -1;
2385     }
2386     return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status));
2387 }
2388 #endif /* !DOSISH */
2389
2390 #if  (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(MACOS_TRADITIONAL)
2391 I32
2392 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
2393 {
2394     I32 result;
2395     if (!pid)
2396         return -1;
2397 #if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME)
2398     {
2399         SV *sv;
2400         SV** svp;
2401         char spid[TYPE_CHARS(int)];
2402
2403         if (pid > 0) {
2404             sprintf(spid, "%"IVdf, (IV)pid);
2405             svp = hv_fetch(PL_pidstatus,spid,strlen(spid),FALSE);
2406             if (svp && *svp != &PL_sv_undef) {
2407                 *statusp = SvIVX(*svp);
2408                 (void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD);
2409                 return pid;
2410             }
2411         }
2412         else {
2413             HE *entry;
2414
2415             hv_iterinit(PL_pidstatus);
2416             if ((entry = hv_iternext(PL_pidstatus))) {
2417                 SV *sv;
2418                 char spid[TYPE_CHARS(int)];
2419
2420                 pid = atoi(hv_iterkey(entry,(I32*)statusp));
2421                 sv = hv_iterval(PL_pidstatus,entry);
2422                 *statusp = SvIVX(sv);
2423                 sprintf(spid, "%"IVdf, (IV)pid);
2424                 (void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD);
2425                 return pid;
2426             }
2427         }
2428     }
2429 #endif
2430 #ifdef HAS_WAITPID
2431 #  ifdef HAS_WAITPID_RUNTIME
2432     if (!HAS_WAITPID_RUNTIME)
2433         goto hard_way;
2434 #  endif
2435     result = PerlProc_waitpid(pid,statusp,flags);
2436     goto finish;
2437 #endif
2438 #if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
2439     result = wait4((pid==-1)?0:pid,statusp,flags,Null(struct rusage *));
2440     goto finish;
2441 #endif
2442 #if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME)
2443   hard_way:
2444     {
2445         if (flags)
2446             Perl_croak(aTHX_ "Can't do waitpid with flags");
2447         else {
2448             while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
2449                 pidgone(result,*statusp);
2450             if (result < 0)
2451                 *statusp = -1;
2452         }
2453     }
2454 #endif
2455   finish:
2456     if (result < 0 && errno == EINTR) {
2457         PERL_ASYNC_CHECK();
2458     }
2459     return result;
2460 }
2461 #endif /* !DOSISH || OS2 || WIN32 || NETWARE */
2462
2463 void
2464 /*SUPPRESS 590*/
2465 Perl_pidgone(pTHX_ Pid_t pid, int status)
2466 {
2467     register SV *sv;
2468     char spid[TYPE_CHARS(int)];
2469
2470     sprintf(spid, "%"IVdf, (IV)pid);
2471     sv = *hv_fetch(PL_pidstatus,spid,strlen(spid),TRUE);
2472     (void)SvUPGRADE(sv,SVt_IV);
2473     SvIVX(sv) = status;
2474     return;
2475 }
2476
2477 #if defined(atarist) || defined(OS2) || defined(EPOC)
2478 int pclose();
2479 #ifdef HAS_FORK
2480 int                                     /* Cannot prototype with I32
2481                                            in os2ish.h. */
2482 my_syspclose(PerlIO *ptr)
2483 #else
2484 I32
2485 Perl_my_pclose(pTHX_ PerlIO *ptr)
2486 #endif
2487 {
2488     /* Needs work for PerlIO ! */
2489     FILE *f = PerlIO_findFILE(ptr);
2490     I32 result = pclose(f);
2491     PerlIO_releaseFILE(ptr,f);
2492     return result;
2493 }
2494 #endif
2495
2496 #if defined(DJGPP)
2497 int djgpp_pclose();
2498 I32
2499 Perl_my_pclose(pTHX_ PerlIO *ptr)
2500 {
2501     /* Needs work for PerlIO ! */
2502     FILE *f = PerlIO_findFILE(ptr);
2503     I32 result = djgpp_pclose(f);
2504     result = (result << 8) & 0xff00;
2505     PerlIO_releaseFILE(ptr,f);
2506     return result;
2507 }
2508 #endif
2509
2510 void
2511 Perl_repeatcpy(pTHX_ register char *to, register const char *from, I32 len, register I32 count)
2512 {
2513     register I32 todo;
2514     register const char *frombase = from;
2515
2516     if (len == 1) {
2517         register const char c = *from;
2518         while (count-- > 0)
2519             *to++ = c;
2520         return;
2521     }
2522     while (count-- > 0) {
2523         for (todo = len; todo > 0; todo--) {
2524             *to++ = *from++;
2525         }
2526         from = frombase;
2527     }
2528 }
2529
2530 #ifndef HAS_RENAME
2531 I32
2532 Perl_same_dirent(pTHX_ char *a, char *b)
2533 {
2534     char *fa = strrchr(a,'/');
2535     char *fb = strrchr(b,'/');
2536     Stat_t tmpstatbuf1;
2537     Stat_t tmpstatbuf2;
2538     SV *tmpsv = sv_newmortal();
2539
2540     if (fa)
2541         fa++;
2542     else
2543         fa = a;
2544     if (fb)
2545         fb++;
2546     else
2547         fb = b;
2548     if (strNE(a,b))
2549         return FALSE;
2550     if (fa == a)
2551         sv_setpv(tmpsv, ".");
2552     else
2553         sv_setpvn(tmpsv, a, fa - a);
2554     if (PerlLIO_stat(SvPVX(tmpsv), &tmpstatbuf1) < 0)
2555         return FALSE;
2556     if (fb == b)
2557         sv_setpv(tmpsv, ".");
2558     else
2559         sv_setpvn(tmpsv, b, fb - b);
2560     if (PerlLIO_stat(SvPVX(tmpsv), &tmpstatbuf2) < 0)
2561         return FALSE;
2562     return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
2563            tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
2564 }
2565 #endif /* !HAS_RENAME */
2566
2567 char*
2568 Perl_find_script(pTHX_ char *scriptname, bool dosearch, char **search_ext, I32 flags)
2569 {
2570     char *xfound = Nullch;
2571     char *xfailed = Nullch;
2572     char tmpbuf[MAXPATHLEN];
2573     register char *s;
2574     I32 len = 0;
2575     int retval;
2576 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
2577 #  define SEARCH_EXTS ".bat", ".cmd", NULL
2578 #  define MAX_EXT_LEN 4
2579 #endif
2580 #ifdef OS2
2581 #  define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
2582 #  define MAX_EXT_LEN 4
2583 #endif
2584 #ifdef VMS
2585 #  define SEARCH_EXTS ".pl", ".com", NULL
2586 #  define MAX_EXT_LEN 4
2587 #endif
2588     /* additional extensions to try in each dir if scriptname not found */
2589 #ifdef SEARCH_EXTS
2590     char *exts[] = { SEARCH_EXTS };
2591     char **ext = search_ext ? search_ext : exts;
2592     int extidx = 0, i = 0;
2593     char *curext = Nullch;
2594 #else
2595 #  define MAX_EXT_LEN 0
2596 #endif
2597
2598     /*
2599      * If dosearch is true and if scriptname does not contain path
2600      * delimiters, search the PATH for scriptname.
2601      *
2602      * If SEARCH_EXTS is also defined, will look for each
2603      * scriptname{SEARCH_EXTS} whenever scriptname is not found
2604      * while searching the PATH.
2605      *
2606      * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
2607      * proceeds as follows:
2608      *   If DOSISH or VMSISH:
2609      *     + look for ./scriptname{,.foo,.bar}
2610      *     + search the PATH for scriptname{,.foo,.bar}
2611      *
2612      *   If !DOSISH:
2613      *     + look *only* in the PATH for scriptname{,.foo,.bar} (note
2614      *       this will not look in '.' if it's not in the PATH)
2615      */
2616     tmpbuf[0] = '\0';
2617
2618 #ifdef VMS
2619 #  ifdef ALWAYS_DEFTYPES
2620     len = strlen(scriptname);
2621     if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
2622         int hasdir, idx = 0, deftypes = 1;
2623         bool seen_dot = 1;
2624
2625         hasdir = !dosearch || (strpbrk(scriptname,":[</") != Nullch) ;
2626 #  else
2627     if (dosearch) {
2628         int hasdir, idx = 0, deftypes = 1;
2629         bool seen_dot = 1;
2630
2631         hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
2632 #  endif
2633         /* The first time through, just add SEARCH_EXTS to whatever we
2634          * already have, so we can check for default file types. */
2635         while (deftypes ||
2636                (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
2637         {
2638             if (deftypes) {
2639                 deftypes = 0;
2640                 *tmpbuf = '\0';
2641             }
2642             if ((strlen(tmpbuf) + strlen(scriptname)
2643                  + MAX_EXT_LEN) >= sizeof tmpbuf)
2644                 continue;       /* don't search dir with too-long name */
2645             strcat(tmpbuf, scriptname);
2646 #else  /* !VMS */
2647
2648 #ifdef DOSISH
2649     if (strEQ(scriptname, "-"))
2650         dosearch = 0;
2651     if (dosearch) {             /* Look in '.' first. */
2652         char *cur = scriptname;
2653 #ifdef SEARCH_EXTS
2654         if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
2655             while (ext[i])
2656                 if (strEQ(ext[i++],curext)) {
2657                     extidx = -1;                /* already has an ext */
2658                     break;
2659                 }
2660         do {
2661 #endif
2662             DEBUG_p(PerlIO_printf(Perl_debug_log,
2663                                   "Looking for %s\n",cur));
2664             if (PerlLIO_stat(cur,&PL_statbuf) >= 0
2665                 && !S_ISDIR(PL_statbuf.st_mode)) {
2666                 dosearch = 0;
2667                 scriptname = cur;
2668 #ifdef SEARCH_EXTS
2669                 break;
2670 #endif
2671             }
2672 #ifdef SEARCH_EXTS
2673             if (cur == scriptname) {
2674                 len = strlen(scriptname);
2675                 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
2676                     break;
2677                 cur = strcpy(tmpbuf, scriptname);
2678             }
2679         } while (extidx >= 0 && ext[extidx]     /* try an extension? */
2680                  && strcpy(tmpbuf+len, ext[extidx++]));
2681 #endif
2682     }
2683 #endif
2684
2685 #ifdef MACOS_TRADITIONAL
2686     if (dosearch && !strchr(scriptname, ':') &&
2687         (s = PerlEnv_getenv("Commands")))
2688 #else
2689     if (dosearch && !strchr(scriptname, '/')
2690 #ifdef DOSISH
2691                  && !strchr(scriptname, '\\')
2692 #endif
2693                  && (s = PerlEnv_getenv("PATH")))
2694 #endif
2695     {
2696         bool seen_dot = 0;
2697
2698         PL_bufend = s + strlen(s);
2699         while (s < PL_bufend) {
2700 #ifdef MACOS_TRADITIONAL
2701             s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
2702                         ',',
2703                         &len);
2704 #else
2705 #if defined(atarist) || defined(DOSISH)
2706             for (len = 0; *s
2707 #  ifdef atarist
2708                     && *s != ','
2709 #  endif
2710                     && *s != ';'; len++, s++) {
2711                 if (len < sizeof tmpbuf)
2712                     tmpbuf[len] = *s;
2713             }
2714             if (len < sizeof tmpbuf)
2715                 tmpbuf[len] = '\0';
2716 #else  /* ! (atarist || DOSISH) */
2717             s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
2718                         ':',
2719                         &len);
2720 #endif /* ! (atarist || DOSISH) */
2721 #endif /* MACOS_TRADITIONAL */
2722             if (s < PL_bufend)
2723                 s++;
2724             if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
2725                 continue;       /* don't search dir with too-long name */
2726 #ifdef MACOS_TRADITIONAL
2727             if (len && tmpbuf[len - 1] != ':')
2728                 tmpbuf[len++] = ':';
2729 #else
2730             if (len
2731 #if defined(atarist) || defined(__MINT__) || defined(DOSISH)
2732                 && tmpbuf[len - 1] != '/'
2733                 && tmpbuf[len - 1] != '\\'
2734 #endif
2735                )
2736                 tmpbuf[len++] = '/';
2737             if (len == 2 && tmpbuf[0] == '.')
2738                 seen_dot = 1;
2739 #endif
2740             (void)strcpy(tmpbuf + len, scriptname);
2741 #endif  /* !VMS */
2742
2743 #ifdef SEARCH_EXTS
2744             len = strlen(tmpbuf);
2745             if (extidx > 0)     /* reset after previous loop */
2746                 extidx = 0;
2747             do {
2748 #endif
2749                 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
2750                 retval = PerlLIO_stat(tmpbuf,&PL_statbuf);
2751                 if (S_ISDIR(PL_statbuf.st_mode)) {
2752                     retval = -1;
2753                 }
2754 #ifdef SEARCH_EXTS
2755             } while (  retval < 0               /* not there */
2756                     && extidx>=0 && ext[extidx] /* try an extension? */
2757                     && strcpy(tmpbuf+len, ext[extidx++])
2758                 );
2759 #endif
2760             if (retval < 0)
2761                 continue;
2762             if (S_ISREG(PL_statbuf.st_mode)
2763                 && cando(S_IRUSR,TRUE,&PL_statbuf)
2764 #if !defined(DOSISH) && !defined(MACOS_TRADITIONAL)
2765                 && cando(S_IXUSR,TRUE,&PL_statbuf)
2766 #endif
2767                 )
2768             {
2769                 xfound = tmpbuf;                /* bingo! */
2770                 break;
2771             }
2772             if (!xfailed)
2773                 xfailed = savepv(tmpbuf);
2774         }
2775 #ifndef DOSISH
2776         if (!xfound && !seen_dot && !xfailed &&
2777             (PerlLIO_stat(scriptname,&PL_statbuf) < 0
2778              || S_ISDIR(PL_statbuf.st_mode)))
2779 #endif
2780             seen_dot = 1;                       /* Disable message. */
2781         if (!xfound) {
2782             if (flags & 1) {                    /* do or die? */
2783                 Perl_croak(aTHX_ "Can't %s %s%s%s",
2784                       (xfailed ? "execute" : "find"),
2785                       (xfailed ? xfailed : scriptname),
2786                       (xfailed ? "" : " on PATH"),
2787                       (xfailed || seen_dot) ? "" : ", '.' not in PATH");
2788             }
2789             scriptname = Nullch;
2790         }
2791         if (xfailed)
2792             Safefree(xfailed);
2793         scriptname = xfound;
2794     }
2795     return (scriptname ? savepv(scriptname) : Nullch);
2796 }
2797
2798 #ifndef PERL_GET_CONTEXT_DEFINED
2799
2800 void *
2801 Perl_get_context(void)
2802 {
2803 #if defined(USE_ITHREADS)
2804 #  ifdef OLD_PTHREADS_API
2805     pthread_addr_t t;
2806     if (pthread_getspecific(PL_thr_key, &t))
2807         Perl_croak_nocontext("panic: pthread_getspecific");
2808     return (void*)t;
2809 #  else
2810 #    ifdef I_MACH_CTHREADS
2811     return (void*)cthread_data(cthread_self());
2812 #    else
2813     return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
2814 #    endif
2815 #  endif
2816 #else
2817     return (void*)NULL;
2818 #endif
2819 }
2820
2821 void
2822 Perl_set_context(void *t)
2823 {
2824 #if defined(USE_ITHREADS)
2825 #  ifdef I_MACH_CTHREADS
2826     cthread_set_data(cthread_self(), t);
2827 #  else
2828     if (pthread_setspecific(PL_thr_key, t))
2829         Perl_croak_nocontext("panic: pthread_setspecific");
2830 #  endif
2831 #endif
2832 }
2833
2834 #endif /* !PERL_GET_CONTEXT_DEFINED */
2835
2836 #ifdef PERL_GLOBAL_STRUCT
2837 struct perl_vars *
2838 Perl_GetVars(pTHX)
2839 {
2840  return &PL_Vars;
2841 }
2842 #endif
2843
2844 char **
2845 Perl_get_op_names(pTHX)
2846 {
2847  return PL_op_name;
2848 }
2849
2850 char **
2851 Perl_get_op_descs(pTHX)
2852 {
2853  return PL_op_desc;
2854 }
2855
2856 char *
2857 Perl_get_no_modify(pTHX)
2858 {
2859  return (char*)PL_no_modify;
2860 }
2861
2862 U32 *
2863 Perl_get_opargs(pTHX)
2864 {
2865  return PL_opargs;
2866 }
2867
2868 PPADDR_t*
2869 Perl_get_ppaddr(pTHX)
2870 {
2871  return (PPADDR_t*)PL_ppaddr;
2872 }
2873
2874 #ifndef HAS_GETENV_LEN
2875 char *
2876 Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
2877 {
2878     char *env_trans = PerlEnv_getenv(env_elem);
2879     if (env_trans)
2880         *len = strlen(env_trans);
2881     return env_trans;
2882 }
2883 #endif
2884
2885
2886 MGVTBL*
2887 Perl_get_vtbl(pTHX_ int vtbl_id)
2888 {
2889     MGVTBL* result = Null(MGVTBL*);
2890
2891     switch(vtbl_id) {
2892     case want_vtbl_sv:
2893         result = &PL_vtbl_sv;
2894         break;
2895     case want_vtbl_env:
2896         result = &PL_vtbl_env;
2897         break;
2898     case want_vtbl_envelem:
2899         result = &PL_vtbl_envelem;
2900         break;
2901     case want_vtbl_sig:
2902         result = &PL_vtbl_sig;
2903         break;
2904     case want_vtbl_sigelem:
2905         result = &PL_vtbl_sigelem;
2906         break;
2907     case want_vtbl_pack:
2908         result = &PL_vtbl_pack;
2909         break;
2910     case want_vtbl_packelem:
2911         result = &PL_vtbl_packelem;
2912         break;
2913     case want_vtbl_dbline:
2914         result = &PL_vtbl_dbline;
2915         break;
2916     case want_vtbl_isa:
2917         result = &PL_vtbl_isa;
2918         break;
2919     case want_vtbl_isaelem:
2920         result = &PL_vtbl_isaelem;
2921         break;
2922     case want_vtbl_arylen:
2923         result = &PL_vtbl_arylen;
2924         break;
2925     case want_vtbl_glob:
2926         result = &PL_vtbl_glob;
2927         break;
2928     case want_vtbl_mglob:
2929         result = &PL_vtbl_mglob;
2930         break;
2931     case want_vtbl_nkeys:
2932         result = &PL_vtbl_nkeys;
2933         break;
2934     case want_vtbl_taint:
2935         result = &PL_vtbl_taint;
2936         break;
2937     case want_vtbl_substr:
2938         result = &PL_vtbl_substr;
2939         break;
2940     case want_vtbl_vec:
2941         result = &PL_vtbl_vec;
2942         break;
2943     case want_vtbl_pos:
2944         result = &PL_vtbl_pos;
2945         break;
2946     case want_vtbl_bm:
2947         result = &PL_vtbl_bm;
2948         break;
2949     case want_vtbl_fm:
2950         result = &PL_vtbl_fm;
2951         break;
2952     case want_vtbl_uvar:
2953         result = &PL_vtbl_uvar;
2954         break;
2955     case want_vtbl_defelem:
2956         result = &PL_vtbl_defelem;
2957         break;
2958     case want_vtbl_regexp:
2959         result = &PL_vtbl_regexp;
2960         break;
2961     case want_vtbl_regdata:
2962         result = &PL_vtbl_regdata;
2963         break;
2964     case want_vtbl_regdatum:
2965         result = &PL_vtbl_regdatum;
2966         break;
2967 #ifdef USE_LOCALE_COLLATE
2968     case want_vtbl_collxfrm:
2969         result = &PL_vtbl_collxfrm;
2970         break;
2971 #endif
2972     case want_vtbl_amagic:
2973         result = &PL_vtbl_amagic;
2974         break;
2975     case want_vtbl_amagicelem:
2976         result = &PL_vtbl_amagicelem;
2977         break;
2978     case want_vtbl_backref:
2979         result = &PL_vtbl_backref;
2980         break;
2981     }
2982     return result;
2983 }
2984
2985 I32
2986 Perl_my_fflush_all(pTHX)
2987 {
2988 #if defined(USE_PERLIO) || defined(FFLUSH_NULL) || defined(USE_SFIO)
2989     return PerlIO_flush(NULL);
2990 #else
2991 # if defined(HAS__FWALK)
2992     extern int fflush(FILE *);
2993     /* undocumented, unprototyped, but very useful BSDism */
2994     extern void _fwalk(int (*)(FILE *));
2995     _fwalk(&fflush);
2996     return 0;
2997 # else
2998 #  if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
2999     long open_max = -1;
3000 #   ifdef PERL_FFLUSH_ALL_FOPEN_MAX
3001     open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
3002 #   else
3003 #    if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
3004     open_max = sysconf(_SC_OPEN_MAX);
3005 #     else
3006 #      ifdef FOPEN_MAX
3007     open_max = FOPEN_MAX;
3008 #      else
3009 #       ifdef OPEN_MAX
3010     open_max = OPEN_MAX;
3011 #       else
3012 #        ifdef _NFILE
3013     open_max = _NFILE;
3014 #        endif
3015 #       endif
3016 #      endif
3017 #     endif
3018 #    endif
3019     if (open_max > 0) {
3020       long i;
3021       for (i = 0; i < open_max; i++)
3022             if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
3023                 STDIO_STREAM_ARRAY[i]._file < open_max &&
3024                 STDIO_STREAM_ARRAY[i]._flag)
3025                 PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
3026       return 0;
3027     }
3028 #  endif
3029     SETERRNO(EBADF,RMS_IFI);
3030     return EOF;
3031 # endif
3032 #endif
3033 }
3034
3035 void
3036 Perl_report_evil_fh(pTHX_ GV *gv, IO *io, I32 op)
3037 {
3038     char *func =
3039         op == OP_READLINE   ? "readline"  :     /* "<HANDLE>" not nice */
3040         op == OP_LEAVEWRITE ? "write" :         /* "write exit" not nice */
3041         PL_op_desc[op];
3042     char *pars = OP_IS_FILETEST(op) ? "" : "()";
3043     char *type = OP_IS_SOCKET(op)
3044             || (gv && io && IoTYPE(io) == IoTYPE_SOCKET)
3045                 ?  "socket" : "filehandle";
3046     char *name = NULL;
3047
3048     if (gv && isGV(gv)) {
3049         name = GvENAME(gv);
3050     }
3051
3052     if (op == OP_phoney_OUTPUT_ONLY || op == OP_phoney_INPUT_ONLY) {
3053         if (ckWARN(WARN_IO)) {
3054             const char *direction = (op == OP_phoney_INPUT_ONLY) ? "in" : "out";
3055             if (name && *name)
3056                 Perl_warner(aTHX_ packWARN(WARN_IO),
3057                             "Filehandle %s opened only for %sput",
3058                             name, direction);
3059             else
3060                 Perl_warner(aTHX_ packWARN(WARN_IO),
3061                             "Filehandle opened only for %sput", direction);
3062         }
3063     }
3064     else {
3065         char *vile;
3066         I32   warn_type;
3067
3068         if (gv && io && IoTYPE(io) == IoTYPE_CLOSED) {
3069             vile = "closed";
3070             warn_type = WARN_CLOSED;
3071         }
3072         else {
3073             vile = "unopened";
3074             warn_type = WARN_UNOPENED;
3075         }
3076
3077         if (ckWARN(warn_type)) {
3078             if (name && *name) {
3079                 Perl_warner(aTHX_ packWARN(warn_type),
3080                             "%s%s on %s %s %s", func, pars, vile, type, name);
3081                 if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3082                     Perl_warner(
3083                         aTHX_ packWARN(warn_type),
3084                         "\t(Are you trying to call %s%s on dirhandle %s?)\n",
3085                         func, pars, name
3086                     );
3087             }
3088             else {
3089                 Perl_warner(aTHX_ packWARN(warn_type),
3090                             "%s%s on %s %s", func, pars, vile, type);
3091                 if (gv && io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3092                     Perl_warner(
3093                         aTHX_ packWARN(warn_type),
3094                         "\t(Are you trying to call %s%s on dirhandle?)\n",
3095                         func, pars
3096                     );
3097             }
3098         }
3099     }
3100 }
3101
3102 #ifdef EBCDIC
3103 /* in ASCII order, not that it matters */
3104 static const char controllablechars[] = "?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_";
3105
3106 int
3107 Perl_ebcdic_control(pTHX_ int ch)
3108 {
3109     if (ch > 'a') {
3110         char *ctlp;
3111
3112         if (islower(ch))
3113             ch = toupper(ch);
3114
3115         if ((ctlp = strchr(controllablechars, ch)) == 0) {
3116             Perl_die(aTHX_ "unrecognised control character '%c'\n", ch);
3117         }
3118
3119         if (ctlp == controllablechars)
3120             return('\177'); /* DEL */
3121         else
3122             return((unsigned char)(ctlp - controllablechars - 1));
3123     } else { /* Want uncontrol */
3124         if (ch == '\177' || ch == -1)
3125             return('?');
3126         else if (ch == '\157')
3127             return('\177');
3128         else if (ch == '\174')
3129             return('\000');
3130         else if (ch == '^')    /* '\137' in 1047, '\260' in 819 */
3131             return('\036');
3132         else if (ch == '\155')
3133             return('\037');
3134         else if (0 < ch && ch < (sizeof(controllablechars) - 1))
3135             return(controllablechars[ch+1]);
3136         else
3137             Perl_die(aTHX_ "invalid control request: '\\%03o'\n", ch & 0xFF);
3138     }
3139 }
3140 #endif
3141
3142 /* To workaround core dumps from the uninitialised tm_zone we get the
3143  * system to give us a reasonable struct to copy.  This fix means that
3144  * strftime uses the tm_zone and tm_gmtoff values returned by
3145  * localtime(time()). That should give the desired result most of the
3146  * time. But probably not always!
3147  *
3148  * This does not address tzname aspects of NETaa14816.
3149  *
3150  */
3151
3152 #ifdef HAS_GNULIBC
3153 # ifndef STRUCT_TM_HASZONE
3154 #    define STRUCT_TM_HASZONE
3155 # endif
3156 #endif
3157
3158 #ifdef STRUCT_TM_HASZONE /* Backward compat */
3159 # ifndef HAS_TM_TM_ZONE
3160 #    define HAS_TM_TM_ZONE
3161 # endif
3162 #endif
3163
3164 void
3165 Perl_init_tm(pTHX_ struct tm *ptm)      /* see mktime, strftime and asctime */
3166 {
3167 #ifdef HAS_TM_TM_ZONE
3168     Time_t now;
3169     (void)time(&now);
3170     Copy(localtime(&now), ptm, 1, struct tm);
3171 #endif
3172 }
3173
3174 /*
3175  * mini_mktime - normalise struct tm values without the localtime()
3176  * semantics (and overhead) of mktime().
3177  */
3178 void
3179 Perl_mini_mktime(pTHX_ struct tm *ptm)
3180 {
3181     int yearday;
3182     int secs;
3183     int month, mday, year, jday;
3184     int odd_cent, odd_year;
3185
3186 #define DAYS_PER_YEAR   365
3187 #define DAYS_PER_QYEAR  (4*DAYS_PER_YEAR+1)
3188 #define DAYS_PER_CENT   (25*DAYS_PER_QYEAR-1)
3189 #define DAYS_PER_QCENT  (4*DAYS_PER_CENT+1)
3190 #define SECS_PER_HOUR   (60*60)
3191 #define SECS_PER_DAY    (24*SECS_PER_HOUR)
3192 /* parentheses deliberately absent on these two, otherwise they don't work */
3193 #define MONTH_TO_DAYS   153/5
3194 #define DAYS_TO_MONTH   5/153
3195 /* offset to bias by March (month 4) 1st between month/mday & year finding */
3196 #define YEAR_ADJUST     (4*MONTH_TO_DAYS+1)
3197 /* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */
3198 #define WEEKDAY_BIAS    6       /* (1+6)%7 makes Sunday 0 again */
3199
3200 /*
3201  * Year/day algorithm notes:
3202  *
3203  * With a suitable offset for numeric value of the month, one can find
3204  * an offset into the year by considering months to have 30.6 (153/5) days,
3205  * using integer arithmetic (i.e., with truncation).  To avoid too much
3206  * messing about with leap days, we consider January and February to be
3207  * the 13th and 14th month of the previous year.  After that transformation,
3208  * we need the month index we use to be high by 1 from 'normal human' usage,
3209  * so the month index values we use run from 4 through 15.
3210  *
3211  * Given that, and the rules for the Gregorian calendar (leap years are those
3212  * divisible by 4 unless also divisible by 100, when they must be divisible
3213  * by 400 instead), we can simply calculate the number of days since some
3214  * arbitrary 'beginning of time' by futzing with the (adjusted) year number,
3215  * the days we derive from our month index, and adding in the day of the
3216  * month.  The value used here is not adjusted for the actual origin which
3217  * it normally would use (1 January A.D. 1), since we're not exposing it.
3218  * We're only building the value so we can turn around and get the
3219  * normalised values for the year, month, day-of-month, and day-of-year.
3220  *
3221  * For going backward, we need to bias the value we're using so that we find
3222  * the right year value.  (Basically, we don't want the contribution of
3223  * March 1st to the number to apply while deriving the year).  Having done
3224  * that, we 'count up' the contribution to the year number by accounting for
3225  * full quadracenturies (400-year periods) with their extra leap days, plus
3226  * the contribution from full centuries (to avoid counting in the lost leap
3227  * days), plus the contribution from full quad-years (to count in the normal
3228  * leap days), plus the leftover contribution from any non-leap years.
3229  * At this point, if we were working with an actual leap day, we'll have 0
3230  * days left over.  This is also true for March 1st, however.  So, we have
3231  * to special-case that result, and (earlier) keep track of the 'odd'
3232  * century and year contributions.  If we got 4 extra centuries in a qcent,
3233  * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb.
3234  * Otherwise, we add back in the earlier bias we removed (the 123 from
3235  * figuring in March 1st), find the month index (integer division by 30.6),
3236  * and the remainder is the day-of-month.  We then have to convert back to
3237  * 'real' months (including fixing January and February from being 14/15 in
3238  * the previous year to being in the proper year).  After that, to get
3239  * tm_yday, we work with the normalised year and get a new yearday value for
3240  * January 1st, which we subtract from the yearday value we had earlier,
3241  * representing the date we've re-built.  This is done from January 1
3242  * because tm_yday is 0-origin.
3243  *
3244  * Since POSIX time routines are only guaranteed to work for times since the
3245  * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm
3246  * applies Gregorian calendar rules even to dates before the 16th century
3247  * doesn't bother me.  Besides, you'd need cultural context for a given
3248  * date to know whether it was Julian or Gregorian calendar, and that's
3249  * outside the scope for this routine.  Since we convert back based on the
3250  * same rules we used to build the yearday, you'll only get strange results
3251  * for input which needed normalising, or for the 'odd' century years which
3252  * were leap years in the Julian calander but not in the Gregorian one.
3253  * I can live with that.
3254  *
3255  * This algorithm also fails to handle years before A.D. 1 gracefully, but
3256  * that's still outside the scope for POSIX time manipulation, so I don't
3257  * care.
3258  */
3259
3260     year = 1900 + ptm->tm_year;
3261     month = ptm->tm_mon;
3262     mday = ptm->tm_mday;
3263     /* allow given yday with no month & mday to dominate the result */
3264     if (ptm->tm_yday >= 0 && mday <= 0 && month <= 0) {
3265         month = 0;
3266         mday = 0;
3267         jday = 1 + ptm->tm_yday;
3268     }
3269     else {
3270         jday = 0;
3271     }
3272     if (month >= 2)
3273         month+=2;
3274     else
3275         month+=14, year--;
3276     yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400;
3277     yearday += month*MONTH_TO_DAYS + mday + jday;
3278     /*
3279      * Note that we don't know when leap-seconds were or will be,
3280      * so we have to trust the user if we get something which looks
3281      * like a sensible leap-second.  Wild values for seconds will
3282      * be rationalised, however.
3283      */
3284     if ((unsigned) ptm->tm_sec <= 60) {
3285         secs = 0;
3286     }
3287     else {
3288         secs = ptm->tm_sec;
3289         ptm->tm_sec = 0;
3290     }
3291     secs += 60 * ptm->tm_min;
3292     secs += SECS_PER_HOUR * ptm->tm_hour;
3293     if (secs < 0) {
3294         if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) {
3295             /* got negative remainder, but need positive time */
3296             /* back off an extra day to compensate */
3297             yearday += (secs/SECS_PER_DAY)-1;
3298             secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1);
3299         }
3300         else {
3301             yearday += (secs/SECS_PER_DAY);
3302             secs -= SECS_PER_DAY * (secs/SECS_PER_DAY);
3303         }
3304     }
3305     else if (secs >= SECS_PER_DAY) {
3306         yearday += (secs/SECS_PER_DAY);
3307         secs %= SECS_PER_DAY;
3308     }
3309     ptm->tm_hour = secs/SECS_PER_HOUR;
3310     secs %= SECS_PER_HOUR;
3311     ptm->tm_min = secs/60;
3312     secs %= 60;
3313     ptm->tm_sec += secs;
3314     /* done with time of day effects */
3315     /*
3316      * The algorithm for yearday has (so far) left it high by 428.
3317      * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to
3318      * bias it by 123 while trying to figure out what year it
3319      * really represents.  Even with this tweak, the reverse
3320      * translation fails for years before A.D. 0001.
3321      * It would still fail for Feb 29, but we catch that one below.
3322      */
3323     jday = yearday;     /* save for later fixup vis-a-vis Jan 1 */
3324     yearday -= YEAR_ADJUST;
3325     year = (yearday / DAYS_PER_QCENT) * 400;
3326     yearday %= DAYS_PER_QCENT;
3327     odd_cent = yearday / DAYS_PER_CENT;
3328     year += odd_cent * 100;
3329     yearday %= DAYS_PER_CENT;
3330     year += (yearday / DAYS_PER_QYEAR) * 4;
3331     yearday %= DAYS_PER_QYEAR;
3332     odd_year = yearday / DAYS_PER_YEAR;
3333     year += odd_year;
3334     yearday %= DAYS_PER_YEAR;
3335     if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */
3336         month = 1;
3337         yearday = 29;
3338     }
3339     else {
3340         yearday += YEAR_ADJUST; /* recover March 1st crock */
3341         month = yearday*DAYS_TO_MONTH;
3342         yearday -= month*MONTH_TO_DAYS;
3343         /* recover other leap-year adjustment */
3344         if (month > 13) {
3345             month-=14;
3346             year++;
3347         }
3348         else {
3349             month-=2;
3350         }
3351     }
3352     ptm->tm_year = year - 1900;
3353     if (yearday) {
3354       ptm->tm_mday = yearday;
3355       ptm->tm_mon = month;
3356     }
3357     else {
3358       ptm->tm_mday = 31;
3359       ptm->tm_mon = month - 1;
3360     }
3361     /* re-build yearday based on Jan 1 to get tm_yday */
3362     year--;
3363     yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400;
3364     yearday += 14*MONTH_TO_DAYS + 1;
3365     ptm->tm_yday = jday - yearday;
3366     /* fix tm_wday if not overridden by caller */
3367     if ((unsigned)ptm->tm_wday > 6)
3368         ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
3369 }
3370
3371 char *
3372 Perl_my_strftime(pTHX_ char *fmt, int sec, int min, int hour, int mday, int mon, int year, int wday, int yday, int isdst)
3373 {
3374 #ifdef HAS_STRFTIME
3375   char *buf;
3376   int buflen;
3377   struct tm mytm;
3378   int len;
3379
3380   init_tm(&mytm);       /* XXX workaround - see init_tm() above */
3381   mytm.tm_sec = sec;
3382   mytm.tm_min = min;
3383   mytm.tm_hour = hour;
3384   mytm.tm_mday = mday;
3385   mytm.tm_mon = mon;
3386   mytm.tm_year = year;
3387   mytm.tm_wday = wday;
3388   mytm.tm_yday = yday;
3389   mytm.tm_isdst = isdst;
3390   mini_mktime(&mytm);
3391   /* use libc to get the values for tm_gmtoff and tm_zone [perl #18238] */
3392 #if defined(HAS_MKTIME) && (defined(HAS_TM_TM_GMTOFF) || defined(HAS_TM_TM_ZONE))
3393   STMT_START {
3394     struct tm mytm2;
3395     mytm2 = mytm;
3396     mktime(&mytm2);
3397 #ifdef HAS_TM_TM_GMTOFF
3398     mytm.tm_gmtoff = mytm2.tm_gmtoff;
3399 #endif
3400 #ifdef HAS_TM_TM_ZONE
3401     mytm.tm_zone = mytm2.tm_zone;
3402 #endif
3403   } STMT_END;
3404 #endif
3405   buflen = 64;
3406   New(0, buf, buflen, char);
3407   len = strftime(buf, buflen, fmt, &mytm);
3408   /*
3409   ** The following is needed to handle to the situation where
3410   ** tmpbuf overflows.  Basically we want to allocate a buffer
3411   ** and try repeatedly.  The reason why it is so complicated
3412   ** is that getting a return value of 0 from strftime can indicate
3413   ** one of the following:
3414   ** 1. buffer overflowed,
3415   ** 2. illegal conversion specifier, or
3416   ** 3. the format string specifies nothing to be returned(not
3417   **      an error).  This could be because format is an empty string
3418   **    or it specifies %p that yields an empty string in some locale.
3419   ** If there is a better way to make it portable, go ahead by
3420   ** all means.
3421   */
3422   if ((len > 0 && len < buflen) || (len == 0 && *fmt == '\0'))
3423     return buf;
3424   else {
3425     /* Possibly buf overflowed - try again with a bigger buf */
3426     int     fmtlen = strlen(fmt);
3427     int     bufsize = fmtlen + buflen;
3428
3429     New(0, buf, bufsize, char);
3430     while (buf) {
3431       buflen = strftime(buf, bufsize, fmt, &mytm);
3432       if (buflen > 0 && buflen < bufsize)
3433         break;
3434       /* heuristic to prevent out-of-memory errors */
3435       if (bufsize > 100*fmtlen) {
3436         Safefree(buf);
3437         buf = NULL;
3438         break;
3439       }
3440       bufsize *= 2;
3441       Renew(buf, bufsize, char);
3442     }
3443     return buf;
3444   }
3445 #else
3446   Perl_croak(aTHX_ "panic: no strftime");
3447 #endif
3448 }
3449
3450
3451 #define SV_CWD_RETURN_UNDEF \
3452 sv_setsv(sv, &PL_sv_undef); \
3453 return FALSE
3454
3455 #define SV_CWD_ISDOT(dp) \
3456     (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
3457         (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
3458
3459 /*
3460 =head1 Miscellaneous Functions
3461
3462 =for apidoc getcwd_sv
3463
3464 Fill the sv with current working directory
3465
3466 =cut
3467 */
3468
3469 /* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars.
3470  * rewritten again by dougm, optimized for use with xs TARG, and to prefer
3471  * getcwd(3) if available
3472  * Comments from the orignal:
3473  *     This is a faster version of getcwd.  It's also more dangerous
3474  *     because you might chdir out of a directory that you can't chdir
3475  *     back into. */
3476
3477 int
3478 Perl_getcwd_sv(pTHX_ register SV *sv)
3479 {
3480 #ifndef PERL_MICRO
3481
3482 #ifndef INCOMPLETE_TAINTS
3483     SvTAINTED_on(sv);
3484 #endif
3485
3486 #ifdef HAS_GETCWD
3487     {
3488         char buf[MAXPATHLEN];
3489
3490         /* Some getcwd()s automatically allocate a buffer of the given
3491          * size from the heap if they are given a NULL buffer pointer.
3492          * The problem is that this behaviour is not portable. */
3493         if (getcwd(buf, sizeof(buf) - 1)) {
3494             STRLEN len = strlen(buf);
3495             sv_setpvn(sv, buf, len);
3496             return TRUE;
3497         }
3498         else {
3499             sv_setsv(sv, &PL_sv_undef);
3500             return FALSE;
3501         }
3502     }
3503
3504 #else
3505
3506     Stat_t statbuf;
3507     int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
3508     int namelen, pathlen=0;
3509     DIR *dir;
3510     Direntry_t *dp;
3511
3512     (void)SvUPGRADE(sv, SVt_PV);
3513
3514     if (PerlLIO_lstat(".", &statbuf) < 0) {
3515         SV_CWD_RETURN_UNDEF;
3516     }
3517
3518     orig_cdev = statbuf.st_dev;
3519     orig_cino = statbuf.st_ino;
3520     cdev = orig_cdev;
3521     cino = orig_cino;
3522
3523     for (;;) {
3524         odev = cdev;
3525         oino = cino;
3526
3527         if (PerlDir_chdir("..") < 0) {
3528             SV_CWD_RETURN_UNDEF;
3529         }
3530         if (PerlLIO_stat(".", &statbuf) < 0) {
3531             SV_CWD_RETURN_UNDEF;
3532         }
3533
3534         cdev = statbuf.st_dev;
3535         cino = statbuf.st_ino;
3536
3537         if (odev == cdev && oino == cino) {
3538             break;
3539         }
3540         if (!(dir = PerlDir_open("."))) {
3541             SV_CWD_RETURN_UNDEF;
3542         }
3543
3544         while ((dp = PerlDir_read(dir)) != NULL) {
3545 #ifdef DIRNAMLEN
3546             namelen = dp->d_namlen;
3547 #else
3548             namelen = strlen(dp->d_name);
3549 #endif
3550             /* skip . and .. */
3551             if (SV_CWD_ISDOT(dp)) {
3552                 continue;
3553             }
3554
3555             if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
3556                 SV_CWD_RETURN_UNDEF;
3557             }
3558
3559             tdev = statbuf.st_dev;
3560             tino = statbuf.st_ino;
3561             if (tino == oino && tdev == odev) {
3562                 break;
3563             }
3564         }
3565
3566         if (!dp) {
3567             SV_CWD_RETURN_UNDEF;
3568         }
3569
3570         if (pathlen + namelen + 1 >= MAXPATHLEN) {
3571             SV_CWD_RETURN_UNDEF;
3572         }
3573
3574         SvGROW(sv, pathlen + namelen + 1);
3575
3576         if (pathlen) {
3577             /* shift down */
3578             Move(SvPVX(sv), SvPVX(sv) + namelen + 1, pathlen, char);
3579         }
3580
3581         /* prepend current directory to the front */
3582         *SvPVX(sv) = '/';
3583         Move(dp->d_name, SvPVX(sv)+1, namelen, char);
3584         pathlen += (namelen + 1);
3585
3586 #ifdef VOID_CLOSEDIR
3587         PerlDir_close(dir);
3588 #else
3589         if (PerlDir_close(dir) < 0) {
3590             SV_CWD_RETURN_UNDEF;
3591         }
3592 #endif
3593     }
3594
3595     if (pathlen) {
3596         SvCUR_set(sv, pathlen);
3597         *SvEND(sv) = '\0';
3598         SvPOK_only(sv);
3599
3600         if (PerlDir_chdir(SvPVX(sv)) < 0) {
3601             SV_CWD_RETURN_UNDEF;
3602         }
3603     }
3604     if (PerlLIO_stat(".", &statbuf) < 0) {
3605         SV_CWD_RETURN_UNDEF;
3606     }
3607
3608     cdev = statbuf.st_dev;
3609     cino = statbuf.st_ino;
3610
3611     if (cdev != orig_cdev || cino != orig_cino) {
3612         Perl_croak(aTHX_ "Unstable directory path, "
3613                    "current directory changed unexpectedly");
3614     }
3615
3616     return TRUE;
3617 #endif
3618
3619 #else
3620     return FALSE;
3621 #endif
3622 }
3623
3624 /*
3625 =head1 SV Manipulation Functions
3626
3627 =for apidoc scan_vstring
3628
3629 Returns a pointer to the next character after the parsed
3630 vstring, as well as updating the passed in sv.
3631
3632 Function must be called like
3633
3634         sv = NEWSV(92,5);
3635         s = scan_vstring(s,sv);
3636
3637 The sv should already be large enough to store the vstring
3638 passed in, for performance reasons.
3639
3640 =cut
3641 */
3642
3643 char *
3644 Perl_scan_vstring(pTHX_ char *s, SV *sv)
3645 {
3646     char *pos = s;
3647     char *start = s;
3648     if (*pos == 'v') pos++;  /* get past 'v' */
3649     while (isDIGIT(*pos) || *pos == '_')
3650     pos++;
3651     if (!isALPHA(*pos)) {
3652         UV rev;
3653         U8 tmpbuf[UTF8_MAXLEN+1];
3654         U8 *tmpend;
3655
3656         if (*s == 'v') s++;  /* get past 'v' */
3657
3658         sv_setpvn(sv, "", 0);
3659
3660         for (;;) {
3661             rev = 0;
3662             {
3663                 /* this is atoi() that tolerates underscores */
3664                 char *end = pos;
3665                 UV mult = 1;
3666                 while (--end >= s) {
3667                     UV orev;
3668                     if (*end == '_')
3669                         continue;
3670                     orev = rev;
3671                     rev += (*end - '0') * mult;
3672                     mult *= 10;
3673                     if (orev > rev && ckWARN_d(WARN_OVERFLOW))
3674                         Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
3675                                     "Integer overflow in decimal number");
3676                 }
3677             }
3678 #ifdef EBCDIC
3679             if (rev > 0x7FFFFFFF)
3680                  Perl_croak(aTHX "In EBCDIC the v-string components cannot exceed 2147483647");
3681 #endif
3682             /* Append native character for the rev point */
3683             tmpend = uvchr_to_utf8(tmpbuf, rev);
3684             sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
3685             if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(rev)))
3686                  SvUTF8_on(sv);
3687             if (*pos == '.' && isDIGIT(pos[1]))
3688                  s = ++pos;
3689             else {
3690                  s = pos;
3691                  break;
3692             }
3693             while (isDIGIT(*pos) || *pos == '_')
3694                  pos++;
3695         }
3696         SvPOK_on(sv);
3697         sv_magic(sv,NULL,PERL_MAGIC_vstring,(const char*)start, pos-start);
3698         SvRMAGICAL_on(sv);
3699     }
3700     return s;
3701 }
3702
3703 /*
3704 =for apidoc scan_version
3705
3706 Returns a pointer to the next character after the parsed
3707 version string, as well as upgrading the passed in SV to
3708 an RV.
3709
3710 Function must be called with an already existing SV like
3711
3712     sv = NEWSV(92,0);
3713     s = scan_version(s,sv);
3714
3715 Performs some preprocessing to the string to ensure that
3716 it has the correct characteristics of a version.  Flags the
3717 object if it contains an underscore (which denotes this
3718 is a beta version).
3719
3720 =cut
3721 */
3722
3723 char *
3724 Perl_scan_version(pTHX_ char *s, SV *rv)
3725 {
3726     const char *start = s;
3727     char *pos = s;
3728     I32 saw_period = 0;
3729     bool saw_under = 0;
3730     SV* sv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
3731     (void)sv_upgrade(sv, SVt_PVAV); /* needs to be an AV type */
3732
3733     /* pre-scan the imput string to check for decimals */
3734     while ( *pos == '.' || *pos == '_' || isDIGIT(*pos) )
3735     {
3736         if ( *pos == '.' )
3737         {
3738             if ( saw_under )
3739                 Perl_croak(aTHX_ "Invalid version format (underscores before decimal)");
3740             saw_period++ ;
3741         }
3742         else if ( *pos == '_' )
3743         {
3744             if ( saw_under )
3745                 Perl_croak(aTHX_ "Invalid version format (multiple underscores)");
3746             saw_under = 1;
3747         }
3748         pos++;
3749     }
3750     pos = s;
3751
3752     if (*pos == 'v') pos++;  /* get past 'v' */
3753     while (isDIGIT(*pos))
3754         pos++;
3755     if (!isALPHA(*pos)) {
3756         I32 rev;
3757
3758         if (*s == 'v') s++;  /* get past 'v' */
3759
3760         for (;;) {
3761             rev = 0;
3762             {
3763                 /* this is atoi() that delimits on underscores */
3764                 char *end = pos;
3765                 I32 mult = 1;
3766                 if ( s < pos && s > start && *(s-1) == '_' ) {
3767                     if ( *s == '0' && *(s+1) != '0')
3768                         mult = 10;      /* perl-style */
3769                     else
3770                         mult = -1;      /* beta version */
3771                 }
3772                 while (--end >= s) {
3773                     I32 orev;
3774                     orev = rev;
3775                     rev += (*end - '0') * mult;
3776                     mult *= 10;
3777                     if ( abs(orev) > abs(rev) )
3778                         Perl_croak(aTHX_ "Integer overflow in version");
3779                 }
3780             }
3781
3782             /* Append revision */
3783             av_push((AV *)sv, newSViv(rev));
3784             if ( (*pos == '.' || *pos == '_') && isDIGIT(pos[1]))
3785                 s = ++pos;
3786             else if ( isDIGIT(*pos) )
3787                 s = pos;
3788             else {
3789                 s = pos;
3790                 break;
3791             }
3792             while ( isDIGIT(*pos) ) {
3793                 if ( !saw_under && saw_period == 1 && pos-s == 3 )
3794                     break;
3795                 pos++;
3796             }
3797         }
3798     }
3799     return s;
3800 }
3801
3802 /*
3803 =for apidoc new_version
3804
3805 Returns a new version object based on the passed in SV:
3806
3807     SV *sv = new_version(SV *ver);
3808
3809 Does not alter the passed in ver SV.  See "upg_version" if you
3810 want to upgrade the SV.
3811
3812 =cut
3813 */
3814
3815 SV *
3816 Perl_new_version(pTHX_ SV *ver)
3817 {
3818     SV *rv = NEWSV(92,5);
3819     char *version;
3820     if ( SvNOK(ver) ) /* may get too much accuracy */
3821     {
3822         char tbuf[64];
3823         sprintf(tbuf,"%.9"NVgf, SvNVX(ver));
3824         version = savepv(tbuf);
3825     }
3826 #ifdef SvVOK
3827     else if ( SvVOK(ver) ) { /* already a v-string */
3828         MAGIC* mg = mg_find(ver,PERL_MAGIC_vstring);
3829         version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
3830     }
3831 #endif
3832     else
3833     {
3834         version = (char *)SvPV(ver,PL_na);
3835     }
3836     version = scan_version(version,rv);
3837     return rv;
3838 }
3839
3840 /*
3841 =for apidoc upg_version
3842
3843 In-place upgrade of the supplied SV to a version object.
3844
3845     SV *sv = upg_version(SV *sv);
3846
3847 Returns a pointer to the upgraded SV.
3848
3849 =cut
3850 */
3851
3852 SV *
3853 Perl_upg_version(pTHX_ SV *ver)
3854 {
3855     char *version = savepvn(SvPVX(ver),SvCUR(ver));
3856 #ifdef SvVOK
3857     if ( SvVOK(ver) ) { /* already a v-string */
3858         MAGIC* mg = mg_find(ver,PERL_MAGIC_vstring);
3859         version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
3860     }
3861 #endif
3862     version = scan_version(version,ver);
3863     return ver;
3864 }
3865
3866
3867 /*
3868 =for apidoc vnumify
3869
3870 Accepts a version object and returns the normalized floating
3871 point representation.  Call like:
3872
3873     sv = vnumify(rv);
3874
3875 NOTE: you can pass either the object directly or the SV
3876 contained within the RV.
3877
3878 =cut
3879 */
3880
3881 SV *
3882 Perl_vnumify(pTHX_ SV *vs)
3883 {
3884     I32 i, len, digit;
3885     SV *sv = NEWSV(92,0);
3886     if ( SvROK(vs) )
3887         vs = SvRV(vs);
3888     len = av_len((AV *)vs);
3889     if ( len == -1 )
3890     {
3891         Perl_sv_catpv(aTHX_ sv,"0");
3892         return sv;
3893     }
3894     digit = SvIVX(*av_fetch((AV *)vs, 0, 0));
3895     Perl_sv_setpvf(aTHX_ sv,"%d.",abs(digit));
3896     for ( i = 1 ; i <= len ; i++ )
3897     {
3898         digit = SvIVX(*av_fetch((AV *)vs, i, 0));
3899         Perl_sv_catpvf(aTHX_ sv,"%03d",abs(digit));
3900     }
3901     if ( len == 0 )
3902          Perl_sv_catpv(aTHX_ sv,"000");
3903     return sv;
3904 }
3905
3906 /*
3907 =for apidoc vstringify
3908
3909 Accepts a version object and returns the normalized string
3910 representation.  Call like:
3911
3912     sv = vstringify(rv);
3913
3914 NOTE: you can pass either the object directly or the SV
3915 contained within the RV.
3916
3917 =cut
3918 */
3919
3920 SV *
3921 Perl_vstringify(pTHX_ SV *vs)
3922 {
3923     I32 i, len, digit;
3924     SV *sv = NEWSV(92,0);
3925     if ( SvROK(vs) )
3926         vs = SvRV(vs);
3927     len = av_len((AV *)vs);
3928     if ( len == -1 )
3929     {
3930         Perl_sv_catpv(aTHX_ sv,"");
3931         return sv;
3932     }
3933     digit = SvIVX(*av_fetch((AV *)vs, 0, 0));
3934     Perl_sv_setpvf(aTHX_ sv,"%d",digit);
3935     for ( i = 1 ; i <= len ; i++ )
3936     {
3937         digit = SvIVX(*av_fetch((AV *)vs, i, 0));
3938         if ( digit < 0 )
3939             Perl_sv_catpvf(aTHX_ sv,"_%d",-digit);
3940         else
3941             Perl_sv_catpvf(aTHX_ sv,".%d",digit);
3942     }
3943     if ( len == 0 )
3944          Perl_sv_catpv(aTHX_ sv,".0");
3945     return sv;
3946 }
3947
3948 /*
3949 =for apidoc vcmp
3950
3951 Version object aware cmp.  Both operands must already have been
3952 converted into version objects.
3953
3954 =cut
3955 */
3956
3957 int
3958 Perl_vcmp(pTHX_ SV *lsv, SV *rsv)
3959 {
3960     I32 i,l,m,r,retval;
3961     if ( SvROK(lsv) )
3962         lsv = SvRV(lsv);
3963     if ( SvROK(rsv) )
3964         rsv = SvRV(rsv);
3965     l = av_len((AV *)lsv);
3966     r = av_len((AV *)rsv);
3967     m = l < r ? l : r;
3968     retval = 0;
3969     i = 0;
3970     while ( i <= m && retval == 0 )
3971     {
3972         I32 left  = SvIV(*av_fetch((AV *)lsv,i,0));
3973         I32 right = SvIV(*av_fetch((AV *)rsv,i,0));
3974         bool lbeta = left  < 0 ? 1 : 0;
3975         bool rbeta = right < 0 ? 1 : 0;
3976         left  = abs(left);
3977         right = abs(right);
3978         if ( left < right || (left == right && lbeta && !rbeta) )
3979             retval = -1;
3980         if ( left > right || (left == right && rbeta && !lbeta) )
3981             retval = +1;
3982         i++;
3983     }
3984
3985     if ( l != r && retval == 0 )
3986         retval = l < r ? -1 : +1;
3987     return retval;
3988 }
3989
3990 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT)
3991 #   define EMULATE_SOCKETPAIR_UDP
3992 #endif
3993
3994 #ifdef EMULATE_SOCKETPAIR_UDP
3995 static int
3996 S_socketpair_udp (int fd[2]) {
3997     dTHX;
3998     /* Fake a datagram socketpair using UDP to localhost.  */
3999     int sockets[2] = {-1, -1};
4000     struct sockaddr_in addresses[2];
4001     int i;
4002     Sock_size_t size = sizeof(struct sockaddr_in);
4003     unsigned short port;
4004     int got;
4005
4006     memset(&addresses, 0, sizeof(addresses));
4007     i = 1;
4008     do {
4009         sockets[i] = PerlSock_socket(AF_INET, SOCK_DGRAM, PF_INET);
4010         if (sockets[i] == -1)
4011             goto tidy_up_and_fail;
4012
4013         addresses[i].sin_family = AF_INET;
4014         addresses[i].sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4015         addresses[i].sin_port = 0;      /* kernel choses port.  */
4016         if (PerlSock_bind(sockets[i], (struct sockaddr *) &addresses[i],
4017                 sizeof(struct sockaddr_in)) == -1)
4018             goto tidy_up_and_fail;
4019     } while (i--);
4020
4021     /* Now have 2 UDP sockets. Find out which port each is connected to, and
4022        for each connect the other socket to it.  */
4023     i = 1;
4024     do {
4025         if (PerlSock_getsockname(sockets[i], (struct sockaddr *) &addresses[i],
4026                 &size) == -1)
4027             goto tidy_up_and_fail;
4028         if (size != sizeof(struct sockaddr_in))
4029             goto abort_tidy_up_and_fail;
4030         /* !1 is 0, !0 is 1 */
4031         if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i],
4032                 sizeof(struct sockaddr_in)) == -1)
4033             goto tidy_up_and_fail;
4034     } while (i--);
4035
4036     /* Now we have 2 sockets connected to each other. I don't trust some other
4037        process not to have already sent a packet to us (by random) so send
4038        a packet from each to the other.  */
4039     i = 1;
4040     do {
4041         /* I'm going to send my own port number.  As a short.
4042            (Who knows if someone somewhere has sin_port as a bitfield and needs
4043            this routine. (I'm assuming crays have socketpair)) */
4044         port = addresses[i].sin_port;
4045         got = PerlLIO_write(sockets[i], &port, sizeof(port));
4046         if (got != sizeof(port)) {
4047             if (got == -1)
4048                 goto tidy_up_and_fail;
4049             goto abort_tidy_up_and_fail;
4050         }
4051     } while (i--);
4052
4053     /* Packets sent. I don't trust them to have arrived though.
4054        (As I understand it Solaris TCP stack is multithreaded. Non-blocking
4055        connect to localhost will use a second kernel thread. In 2.6 the
4056        first thread running the connect() returns before the second completes,
4057        so EINPROGRESS> In 2.7 the improved stack is faster and connect()
4058        returns 0. Poor programs have tripped up. One poor program's authors'
4059        had a 50-1 reverse stock split. Not sure how connected these were.)
4060        So I don't trust someone not to have an unpredictable UDP stack.
4061     */
4062
4063     {
4064         struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */
4065         int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0];
4066         fd_set rset;
4067
4068         FD_ZERO(&rset);
4069         FD_SET(sockets[0], &rset);
4070         FD_SET(sockets[1], &rset);
4071
4072         got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor);
4073         if (got != 2 || !FD_ISSET(sockets[0], &rset)
4074                 || !FD_ISSET(sockets[1], &rset)) {
4075             /* I hope this is portable and appropriate.  */
4076             if (got == -1)
4077                 goto tidy_up_and_fail;
4078             goto abort_tidy_up_and_fail;
4079         }
4080     }
4081
4082     /* And the paranoia department even now doesn't trust it to have arrive
4083        (hence MSG_DONTWAIT). Or that what arrives was sent by us.  */
4084     {
4085         struct sockaddr_in readfrom;
4086         unsigned short buffer[2];
4087
4088         i = 1;
4089         do {
4090 #ifdef MSG_DONTWAIT
4091             got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4092                     sizeof(buffer), MSG_DONTWAIT,
4093                     (struct sockaddr *) &readfrom, &size);
4094 #else
4095             got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4096                     sizeof(buffer), 0,
4097                     (struct sockaddr *) &readfrom, &size);
4098 #endif
4099
4100             if (got == -1)
4101                 goto tidy_up_and_fail;
4102             if (got != sizeof(port)
4103                     || size != sizeof(struct sockaddr_in)
4104                     /* Check other socket sent us its port.  */
4105                     || buffer[0] != (unsigned short) addresses[!i].sin_port
4106                     /* Check kernel says we got the datagram from that socket */
4107                     || readfrom.sin_family != addresses[!i].sin_family
4108                     || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr
4109                     || readfrom.sin_port != addresses[!i].sin_port)
4110                 goto abort_tidy_up_and_fail;
4111         } while (i--);
4112     }
4113     /* My caller (my_socketpair) has validated that this is non-NULL  */
4114     fd[0] = sockets[0];
4115     fd[1] = sockets[1];
4116     /* I hereby declare this connection open.  May God bless all who cross
4117        her.  */
4118     return 0;
4119
4120   abort_tidy_up_and_fail:
4121     errno = ECONNABORTED;
4122   tidy_up_and_fail:
4123     {
4124         int save_errno = errno;
4125         if (sockets[0] != -1)
4126             PerlLIO_close(sockets[0]);
4127         if (sockets[1] != -1)
4128             PerlLIO_close(sockets[1]);
4129         errno = save_errno;
4130         return -1;
4131     }
4132 }
4133 #endif /*  EMULATE_SOCKETPAIR_UDP */
4134
4135 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET)
4136 int
4137 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4138     /* Stevens says that family must be AF_LOCAL, protocol 0.
4139        I'm going to enforce that, then ignore it, and use TCP (or UDP).  */
4140     dTHX;
4141     int listener = -1;
4142     int connector = -1;
4143     int acceptor = -1;
4144     struct sockaddr_in listen_addr;
4145     struct sockaddr_in connect_addr;
4146     Sock_size_t size;
4147
4148     if (protocol
4149 #ifdef AF_UNIX
4150         || family != AF_UNIX
4151 #endif
4152     ) {
4153         errno = EAFNOSUPPORT;
4154         return -1;
4155     }
4156     if (!fd) {
4157         errno = EINVAL;
4158         return -1;
4159     }
4160
4161 #ifdef EMULATE_SOCKETPAIR_UDP
4162     if (type == SOCK_DGRAM)
4163         return S_socketpair_udp(fd);
4164 #endif
4165
4166     listener = PerlSock_socket(AF_INET, type, 0);
4167     if (listener == -1)
4168         return -1;
4169     memset(&listen_addr, 0, sizeof(listen_addr));
4170     listen_addr.sin_family = AF_INET;
4171     listen_addr.sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4172     listen_addr.sin_port = 0;   /* kernel choses port.  */
4173     if (PerlSock_bind(listener, (struct sockaddr *) &listen_addr,
4174             sizeof(listen_addr)) == -1)
4175         goto tidy_up_and_fail;
4176     if (PerlSock_listen(listener, 1) == -1)
4177         goto tidy_up_and_fail;
4178
4179     connector = PerlSock_socket(AF_INET, type, 0);
4180     if (connector == -1)
4181         goto tidy_up_and_fail;
4182     /* We want to find out the port number to connect to.  */
4183     size = sizeof(connect_addr);
4184     if (PerlSock_getsockname(listener, (struct sockaddr *) &connect_addr,
4185             &size) == -1)
4186         goto tidy_up_and_fail;
4187     if (size != sizeof(connect_addr))
4188         goto abort_tidy_up_and_fail;
4189     if (PerlSock_connect(connector, (struct sockaddr *) &connect_addr,
4190             sizeof(connect_addr)) == -1)
4191         goto tidy_up_and_fail;
4192
4193     size = sizeof(listen_addr);
4194     acceptor = PerlSock_accept(listener, (struct sockaddr *) &listen_addr,
4195             &size);
4196     if (acceptor == -1)
4197         goto tidy_up_and_fail;
4198     if (size != sizeof(listen_addr))
4199         goto abort_tidy_up_and_fail;
4200     PerlLIO_close(listener);
4201     /* Now check we are talking to ourself by matching port and host on the
4202        two sockets.  */
4203     if (PerlSock_getsockname(connector, (struct sockaddr *) &connect_addr,
4204             &size) == -1)
4205         goto tidy_up_and_fail;
4206     if (size != sizeof(connect_addr)
4207             || listen_addr.sin_family != connect_addr.sin_family
4208             || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr
4209             || listen_addr.sin_port != connect_addr.sin_port) {
4210         goto abort_tidy_up_and_fail;
4211     }
4212     fd[0] = connector;
4213     fd[1] = acceptor;
4214     return 0;
4215
4216   abort_tidy_up_and_fail:
4217   errno = ECONNABORTED; /* I hope this is portable and appropriate.  */
4218   tidy_up_and_fail:
4219     {
4220         int save_errno = errno;
4221         if (listener != -1)
4222             PerlLIO_close(listener);
4223         if (connector != -1)
4224             PerlLIO_close(connector);
4225         if (acceptor != -1)
4226             PerlLIO_close(acceptor);
4227         errno = save_errno;
4228         return -1;
4229     }
4230 }
4231 #else
4232 /* In any case have a stub so that there's code corresponding
4233  * to the my_socketpair in global.sym. */
4234 int
4235 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4236 #ifdef HAS_SOCKETPAIR
4237     return socketpair(family, type, protocol, fd);
4238 #else
4239     return -1;
4240 #endif
4241 }
4242 #endif
4243
4244 /*
4245
4246 =for apidoc sv_nosharing
4247
4248 Dummy routine which "shares" an SV when there is no sharing module present.
4249 Exists to avoid test for a NULL function pointer and because it could potentially warn under
4250 some level of strict-ness.
4251
4252 =cut
4253 */
4254
4255 void
4256 Perl_sv_nosharing(pTHX_ SV *sv)
4257 {
4258 }
4259
4260 /*
4261 =for apidoc sv_nolocking
4262
4263 Dummy routine which "locks" an SV when there is no locking module present.
4264 Exists to avoid test for a NULL function pointer and because it could potentially warn under
4265 some level of strict-ness.
4266
4267 =cut
4268 */
4269
4270 void
4271 Perl_sv_nolocking(pTHX_ SV *sv)
4272 {
4273 }
4274
4275
4276 /*
4277 =for apidoc sv_nounlocking
4278
4279 Dummy routine which "unlocks" an SV when there is no locking module present.
4280 Exists to avoid test for a NULL function pointer and because it could potentially warn under
4281 some level of strict-ness.
4282
4283 =cut
4284 */
4285
4286 void
4287 Perl_sv_nounlocking(pTHX_ SV *sv)
4288 {
4289 }
4290