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