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