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