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