util.c

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