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