util.c

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