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