util.c

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