util.c

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