util.c

   1 /*    util.c
   2  *
   3  *    Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
   4  *    2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
   5  *
   6  *    You may distribute under the terms of either the GNU General Public
   7  *    License or the Artistic License, as specified in the README file.
   8  *
   9  */
  10
  11 /*
  12  * "Very useful, no doubt, that was to Saruman; yet it seems that he was
  13  * not content."  --Gandalf
  14  */
  15
  16 /* This file contains assorted utility routines.
  17  * Which is a polite way of saying any stuff that people couldn't think of
  18  * a better place for. Amongst other things, it includes the warning and
  19  * dieing stuff, plus wrappers for malloc code.
  20  */
  21
  22 #include "EXTERN.h"
  23 #define PERL_IN_UTIL_C
  24 #include "perl.h"
  25
  26 #ifndef PERL_MICRO
  27 #include <signal.h>
  28 #ifndef SIG_ERR
  29 # define SIG_ERR ((Sighandler_t) -1)
  30 #endif
  31 #endif
  32
  33 #ifdef __Lynx__
  34 /* Missing protos on LynxOS */
  35 int putenv(char *);
  36 #endif
  37
  38 #ifdef I_SYS_WAIT
  39 #  include <sys/wait.h>
  40 #endif
  41
  42 #ifdef HAS_SELECT
  43 # ifdef I_SYS_SELECT
  44 #  include <sys/select.h>
  45 # endif
  46 #endif
  47
  48 #define FLUSH
  49
  50 #if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC)
  51 #  define FD_CLOEXEC 1                  /* NeXT needs this */
  52 #endif
  53
  54 /* NOTE:  Do not call the next three routines directly.  Use the macros
  55  * in handy.h, so that we can easily redefine everything to do tracking of
  56  * allocated hunks back to the original New to track down any memory leaks.
  57  * XXX This advice seems to be widely ignored :-(   --AD  August 1996.
  58  */
  59
  60 /* paranoid version of system's malloc() */
  61
  62 Malloc_t
  63 Perl_safesysmalloc(MEM_SIZE size)
  64 {
  65     dTHX;
  66     Malloc_t ptr;
  67 #ifdef HAS_64K_LIMIT
  68         if (size > 0xffff) {
  69             PerlIO_printf(Perl_error_log,
  70                           "Allocation too large: %lx\n", size) FLUSH;
  71             my_exit(1);
  72         }
  73 #endif /* HAS_64K_LIMIT */
  74 #ifdef DEBUGGING
  75     if ((long)size < 0)
  76         Perl_croak_nocontext("panic: malloc");
  77 #endif
  78     ptr = (Malloc_t)PerlMem_malloc(size?size:1);        /* malloc(0) is NASTY on our system */
  79     PERL_ALLOC_CHECK(ptr);
  80     DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
  81     if (ptr != Nullch)
  82         return ptr;
  83     else if (PL_nomemok)
  84         return Nullch;
  85     else {
  86         /* Can't use PerlIO to write as it allocates memory */
  87         PerlLIO_write(PerlIO_fileno(Perl_error_log),
  88                       PL_no_mem, strlen(PL_no_mem));
  89         my_exit(1);
  90         return Nullch;
  91     }
  92     /*NOTREACHED*/
  93 }
  94
  95 /* paranoid version of system's realloc() */
  96
  97 Malloc_t
  98 Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
  99 {
 100     dTHX;
 101     Malloc_t ptr;
 102 #if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) && !defined(PERL_MICRO)
 103     Malloc_t PerlMem_realloc();
 104 #endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */
 105
 106 #ifdef HAS_64K_LIMIT
 107     if (size > 0xffff) {
 108         PerlIO_printf(Perl_error_log,
 109                       "Reallocation too large: %lx\n", size) FLUSH;
 110         my_exit(1);
 111     }
 112 #endif /* HAS_64K_LIMIT */
 113     if (!size) {
 114         safesysfree(where);
 115         return NULL;
 116     }
 117
 118     if (!where)
 119         return safesysmalloc(size);
 120 #ifdef DEBUGGING
 121     if ((long)size < 0)
 122         Perl_croak_nocontext("panic: realloc");
 123 #endif
 124     ptr = (Malloc_t)PerlMem_realloc(where,size);
 125     PERL_ALLOC_CHECK(ptr);
 126
 127     DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++));
 128     DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
 129
 130     if (ptr != Nullch)
 131         return ptr;
 132     else if (PL_nomemok)
 133         return Nullch;
 134     else {
 135         /* Can't use PerlIO to write as it allocates memory */
 136         PerlLIO_write(PerlIO_fileno(Perl_error_log),
 137                       PL_no_mem, strlen(PL_no_mem));
 138         my_exit(1);
 139         return Nullch;
 140     }
 141     /*NOTREACHED*/
 142 }
 143
 144 /* safe version of system's free() */
 145
 146 Free_t
 147 Perl_safesysfree(Malloc_t where)
 148 {
 149     dVAR;
 150 #ifdef PERL_IMPLICIT_SYS
 151     dTHX;
 152 #endif
 153     DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) free\n",PTR2UV(where),(long)PL_an++));
 154     if (where) {
 155         PerlMem_free(where);
 156     }
 157 }
 158
 159 /* safe version of system's calloc() */
 160
 161 Malloc_t
 162 Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
 163 {
 164     dTHX;
 165     Malloc_t ptr;
 166
 167 #ifdef HAS_64K_LIMIT
 168     if (size * count > 0xffff) {
 169         PerlIO_printf(Perl_error_log,
 170                       "Allocation too large: %lx\n", size * count) FLUSH;
 171         my_exit(1);
 172     }
 173 #endif /* HAS_64K_LIMIT */
 174 #ifdef DEBUGGING
 175     if ((long)size < 0 || (long)count < 0)
 176         Perl_croak_nocontext("panic: calloc");
 177 #endif
 178     size *= count;
 179     ptr = (Malloc_t)PerlMem_malloc(size?size:1);        /* malloc(0) is NASTY on our system */
 180     PERL_ALLOC_CHECK(ptr);
 181     DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) calloc %ld x %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)count,(long)size));
 182     if (ptr != Nullch) {
 183         memset((void*)ptr, 0, size);
 184         return ptr;
 185     }
 186     else if (PL_nomemok)
 187         return Nullch;
 188     else {
 189         /* Can't use PerlIO to write as it allocates memory */
 190         PerlLIO_write(PerlIO_fileno(Perl_error_log),
 191                       PL_no_mem, strlen(PL_no_mem));
 192         my_exit(1);
 193         return Nullch;
 194     }
 195     /*NOTREACHED*/
 196 }
 197
 198 /* These must be defined when not using Perl's malloc for binary
 199  * compatibility */
 200
 201 #ifndef MYMALLOC
 202
 203 Malloc_t Perl_malloc (MEM_SIZE nbytes)
 204 {
 205     dTHXs;
 206     return (Malloc_t)PerlMem_malloc(nbytes);
 207 }
 208
 209 Malloc_t Perl_calloc (MEM_SIZE elements, MEM_SIZE size)
 210 {
 211     dTHXs;
 212     return (Malloc_t)PerlMem_calloc(elements, size);
 213 }
 214
 215 Malloc_t Perl_realloc (Malloc_t where, MEM_SIZE nbytes)
 216 {
 217     dTHXs;
 218     return (Malloc_t)PerlMem_realloc(where, nbytes);
 219 }
 220
 221 Free_t   Perl_mfree (Malloc_t where)
 222 {
 223     dTHXs;
 224     PerlMem_free(where);
 225 }
 226
 227 #endif
 228
 229 /* copy a string up to some (non-backslashed) delimiter, if any */
 230
 231 char *
 232 Perl_delimcpy(pTHX_ register char *to, register const char *toend, register const char *from, register const char *fromend, register int delim, I32 *retlen)
 233 {
 234     register I32 tolen;
 235     for (tolen = 0; from < fromend; from++, tolen++) {
 236         if (*from == '\\') {
 237             if (from[1] == delim)
 238                 from++;
 239             else {
 240                 if (to < toend)
 241                     *to++ = *from;
 242                 tolen++;
 243                 from++;
 244             }
 245         }
 246         else if (*from == delim)
 247             break;
 248         if (to < toend)
 249             *to++ = *from;
 250     }
 251     if (to < toend)
 252         *to = '\0';
 253     *retlen = tolen;
 254     return (char *)from;
 255 }
 256
 257 /* return ptr to little string in big string, NULL if not found */
 258 /* This routine was donated by Corey Satten. */
 259
 260 char *
 261 Perl_instr(pTHX_ register const char *big, register const char *little)
 262 {
 263     register I32 first;
 264
 265     if (!little)
 266         return (char*)big;
 267     first = *little++;
 268     if (!first)
 269         return (char*)big;
 270     while (*big) {
 271         register const char *s, *x;
 272         if (*big++ != first)
 273             continue;
 274         for (x=big,s=little; *s; /**/ ) {
 275             if (!*x)
 276                 return Nullch;
 277             if (*s++ != *x++) {
 278                 s--;
 279                 break;
 280             }
 281         }
 282         if (!*s)
 283             return (char*)(big-1);
 284     }
 285     return Nullch;
 286 }
 287
 288 /* same as instr but allow embedded nulls */
 289
 290 char *
 291 Perl_ninstr(pTHX_ register const char *big, register const char *bigend, const char *little, const char *lend)
 292 {
 293     register const I32 first = *little;
 294     register const char *littleend = lend;
 295
 296     if (!first && little >= littleend)
 297         return (char*)big;
 298     if (bigend - big < littleend - little)
 299         return Nullch;
 300     bigend -= littleend - little++;
 301     while (big <= bigend) {
 302         register const char *s, *x;
 303         if (*big++ != first)
 304             continue;
 305         for (x=big,s=little; s < littleend; /**/ ) {
 306             if (*s++ != *x++) {
 307                 s--;
 308                 break;
 309             }
 310         }
 311         if (s >= littleend)
 312             return (char*)(big-1);
 313     }
 314     return Nullch;
 315 }
 316
 317 /* reverse of the above--find last substring */
 318
 319 char *
 320 Perl_rninstr(pTHX_ register const char *big, const char *bigend, const char *little, const char *lend)
 321 {
 322     register const char *bigbeg;
 323     register const I32 first = *little;
 324     register const char *littleend = lend;
 325
 326     if (!first && little >= littleend)
 327         return (char*)bigend;
 328     bigbeg = big;
 329     big = bigend - (littleend - little++);
 330     while (big >= bigbeg) {
 331         register const char *s, *x;
 332         if (*big-- != first)
 333             continue;
 334         for (x=big+2,s=little; s < littleend; /**/ ) {
 335             if (*s++ != *x++) {
 336                 s--;
 337                 break;
 338             }
 339         }
 340         if (s >= littleend)
 341             return (char*)(big+1);
 342     }
 343     return Nullch;
 344 }
 345
 346 #define FBM_TABLE_OFFSET 2      /* Number of bytes between EOS and table*/
 347
 348 /* As a space optimization, we do not compile tables for strings of length
 349    0 and 1, and for strings of length 2 unless FBMcf_TAIL.  These are
 350    special-cased in fbm_instr().
 351
 352    If FBMcf_TAIL, the table is created as if the string has a trailing \n. */
 353
 354 /*
 355 =head1 Miscellaneous Functions
 356
 357 =for apidoc fbm_compile
 358
 359 Analyses the string in order to make fast searches on it using fbm_instr()
 360 -- the Boyer-Moore algorithm.
 361
 362 =cut
 363 */
 364
 365 void
 366 Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
 367 {
 368     const register U8 *s;
 369     register U8 *table;
 370     register U32 i;
 371     STRLEN len;
 372     I32 rarest = 0;
 373     U32 frequency = 256;
 374
 375     if (flags & FBMcf_TAIL) {
 376         MAGIC *mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
 377         sv_catpvn(sv, "\n", 1);         /* Taken into account in fbm_instr() */
 378         if (mg && mg->mg_len >= 0)
 379             mg->mg_len++;
 380     }
 381     s = (U8*)SvPV_force_mutable(sv, len);
 382     SvUPGRADE(sv, SVt_PVBM);
 383     if (len == 0)               /* TAIL might be on a zero-length string. */
 384         return;
 385     if (len > 2) {
 386         const unsigned char *sb;
 387         const U8 mlen = (len>255) ? 255 : (U8)len;
 388
 389         Sv_Grow(sv, len + 256 + FBM_TABLE_OFFSET);
 390         table = (unsigned char*)(SvPVX_mutable(sv) + len + FBM_TABLE_OFFSET);
 391         s = table - 1 - FBM_TABLE_OFFSET;       /* last char */
 392         memset((void*)table, mlen, 256);
 393         table[-1] = (U8)flags;
 394         i = 0;
 395         sb = s - mlen + 1;                      /* first char (maybe) */
 396         while (s >= sb) {
 397             if (table[*s] == mlen)
 398                 table[*s] = (U8)i;
 399             s--, i++;
 400         }
 401     }
 402     sv_magic(sv, Nullsv, PERL_MAGIC_bm, Nullch, 0);     /* deep magic */
 403     SvVALID_on(sv);
 404
 405     s = (const unsigned char*)(SvPVX_const(sv));        /* deeper magic */
 406     for (i = 0; i < len; i++) {
 407         if (PL_freq[s[i]] < frequency) {
 408             rarest = i;
 409             frequency = PL_freq[s[i]];
 410         }
 411     }
 412     BmRARE(sv) = s[rarest];
 413     BmPREVIOUS(sv) = (U16)rarest;
 414     BmUSEFUL(sv) = 100;                 /* Initial value */
 415     if (flags & FBMcf_TAIL)
 416         SvTAIL_on(sv);
 417     DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %d\n",
 418                           BmRARE(sv),BmPREVIOUS(sv)));
 419 }
 420
 421 /* If SvTAIL(littlestr), it has a fake '\n' at end. */
 422 /* If SvTAIL is actually due to \Z or \z, this gives false positives
 423    if multiline */
 424
 425 /*
 426 =for apidoc fbm_instr
 427
 428 Returns the location of the SV in the string delimited by C<str> and
 429 C<strend>.  It returns C<Nullch> if the string can't be found.  The C<sv>
 430 does not have to be fbm_compiled, but the search will not be as fast
 431 then.
 432
 433 =cut
 434 */
 435
 436 char *
 437 Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *littlestr, U32 flags)
 438 {
 439     register unsigned char *s;
 440     STRLEN l;
 441     register const unsigned char *little
 442         = (const unsigned char *)SvPV_const(littlestr,l);
 443     register STRLEN littlelen = l;
 444     register const I32 multiline = flags & FBMrf_MULTILINE;
 445
 446     if ((STRLEN)(bigend - big) < littlelen) {
 447         if ( SvTAIL(littlestr)
 448              && ((STRLEN)(bigend - big) == littlelen - 1)
 449              && (littlelen == 1
 450                  || (*big == *little &&
 451                      memEQ((char *)big, (char *)little, littlelen - 1))))
 452             return (char*)big;
 453         return Nullch;
 454     }
 455
 456     if (littlelen <= 2) {               /* Special-cased */
 457
 458         if (littlelen == 1) {
 459             if (SvTAIL(littlestr) && !multiline) { /* Anchor only! */
 460                 /* Know that bigend != big.  */
 461                 if (bigend[-1] == '\n')
 462                     return (char *)(bigend - 1);
 463                 return (char *) bigend;
 464             }
 465             s = big;
 466             while (s < bigend) {
 467                 if (*s == *little)
 468                     return (char *)s;
 469                 s++;
 470             }
 471             if (SvTAIL(littlestr))
 472                 return (char *) bigend;
 473             return Nullch;
 474         }
 475         if (!littlelen)
 476             return (char*)big;          /* Cannot be SvTAIL! */
 477
 478         /* littlelen is 2 */
 479         if (SvTAIL(littlestr) && !multiline) {
 480             if (bigend[-1] == '\n' && bigend[-2] == *little)
 481                 return (char*)bigend - 2;
 482             if (bigend[-1] == *little)
 483                 return (char*)bigend - 1;
 484             return Nullch;
 485         }
 486         {
 487             /* This should be better than FBM if c1 == c2, and almost
 488                as good otherwise: maybe better since we do less indirection.
 489                And we save a lot of memory by caching no table. */
 490             const unsigned char c1 = little[0];
 491             const unsigned char c2 = little[1];
 492
 493             s = big + 1;
 494             bigend--;
 495             if (c1 != c2) {
 496                 while (s <= bigend) {
 497                     if (s[0] == c2) {
 498                         if (s[-1] == c1)
 499                             return (char*)s - 1;
 500                         s += 2;
 501                         continue;
 502                     }
 503                   next_chars:
 504                     if (s[0] == c1) {
 505                         if (s == bigend)
 506                             goto check_1char_anchor;
 507                         if (s[1] == c2)
 508                             return (char*)s;
 509                         else {
 510                             s++;
 511                             goto next_chars;
 512                         }
 513                     }
 514                     else
 515                         s += 2;
 516                 }
 517                 goto check_1char_anchor;
 518             }
 519             /* Now c1 == c2 */
 520             while (s <= bigend) {
 521                 if (s[0] == c1) {
 522                     if (s[-1] == c1)
 523                         return (char*)s - 1;
 524                     if (s == bigend)
 525                         goto check_1char_anchor;
 526                     if (s[1] == c1)
 527                         return (char*)s;
 528                     s += 3;
 529                 }
 530                 else
 531                     s += 2;
 532             }
 533         }
 534       check_1char_anchor:               /* One char and anchor! */
 535         if (SvTAIL(littlestr) && (*bigend == *little))
 536             return (char *)bigend;      /* bigend is already decremented. */
 537         return Nullch;
 538     }
 539     if (SvTAIL(littlestr) && !multiline) {      /* tail anchored? */
 540         s = bigend - littlelen;
 541         if (s >= big && bigend[-1] == '\n' && *s == *little
 542             /* Automatically of length > 2 */
 543             && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
 544         {
 545             return (char*)s;            /* how sweet it is */
 546         }
 547         if (s[1] == *little
 548             && memEQ((char*)s + 2, (char*)little + 1, littlelen - 2))
 549         {
 550             return (char*)s + 1;        /* how sweet it is */
 551         }
 552         return Nullch;
 553     }
 554     if (SvTYPE(littlestr) != SVt_PVBM || !SvVALID(littlestr)) {
 555         char *b = ninstr((char*)big,(char*)bigend,
 556                          (char*)little, (char*)little + littlelen);
 557
 558         if (!b && SvTAIL(littlestr)) {  /* Automatically multiline!  */
 559             /* Chop \n from littlestr: */
 560             s = bigend - littlelen + 1;
 561             if (*s == *little
 562                 && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
 563             {
 564                 return (char*)s;
 565             }
 566             return Nullch;
 567         }
 568         return b;
 569     }
 570
 571     {   /* Do actual FBM.  */
 572         register const unsigned char *table = little + littlelen + FBM_TABLE_OFFSET;
 573         const register unsigned char *oldlittle;
 574
 575         if (littlelen > (STRLEN)(bigend - big))
 576             return Nullch;
 577         --littlelen;                    /* Last char found by table lookup */
 578
 579         s = big + littlelen;
 580         little += littlelen;            /* last char */
 581         oldlittle = little;
 582         if (s < bigend) {
 583             register I32 tmp;
 584
 585           top2:
 586             if ((tmp = table[*s])) {
 587                 if ((s += tmp) < bigend)
 588                     goto top2;
 589                 goto check_end;
 590             }
 591             else {              /* less expensive than calling strncmp() */
 592                 register unsigned char * const olds = s;
 593
 594                 tmp = littlelen;
 595
 596                 while (tmp--) {
 597                     if (*--s == *--little)
 598                         continue;
 599                     s = olds + 1;       /* here we pay the price for failure */
 600                     little = oldlittle;
 601                     if (s < bigend)     /* fake up continue to outer loop */
 602                         goto top2;
 603                     goto check_end;
 604                 }
 605                 return (char *)s;
 606             }
 607         }
 608       check_end:
 609         if ( s == bigend && (table[-1] & FBMcf_TAIL)
 610              && memEQ((char *)(bigend - littlelen),
 611                       (char *)(oldlittle - littlelen), littlelen) )
 612             return (char*)bigend - littlelen;
 613         return Nullch;
 614     }
 615 }
 616
 617 /* start_shift, end_shift are positive quantities which give offsets
 618    of ends of some substring of bigstr.
 619    If "last" we want the last occurrence.
 620    old_posp is the way of communication between consequent calls if
 621    the next call needs to find the .
 622    The initial *old_posp should be -1.
 623
 624    Note that we take into account SvTAIL, so one can get extra
 625    optimizations if _ALL flag is set.
 626  */
 627
 628 /* If SvTAIL is actually due to \Z or \z, this gives false positives
 629    if PL_multiline.  In fact if !PL_multiline the authoritative answer
 630    is not supported yet. */
 631
 632 char *
 633 Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last)
 634 {
 635     const register unsigned char *big;
 636     register I32 pos;
 637     register I32 previous;
 638     register I32 first;
 639     const register unsigned char *little;
 640     register I32 stop_pos;
 641     const register unsigned char *littleend;
 642     I32 found = 0;
 643
 644     if (*old_posp == -1
 645         ? (pos = PL_screamfirst[BmRARE(littlestr)]) < 0
 646         : (((pos = *old_posp), pos += PL_screamnext[pos]) == 0)) {
 647       cant_find:
 648         if ( BmRARE(littlestr) == '\n'
 649              && BmPREVIOUS(littlestr) == SvCUR(littlestr) - 1) {
 650             little = (const unsigned char *)(SvPVX_const(littlestr));
 651             littleend = little + SvCUR(littlestr);
 652             first = *little++;
 653             goto check_tail;
 654         }
 655         return Nullch;
 656     }
 657
 658     little = (const unsigned char *)(SvPVX_const(littlestr));
 659     littleend = little + SvCUR(littlestr);
 660     first = *little++;
 661     /* The value of pos we can start at: */
 662     previous = BmPREVIOUS(littlestr);
 663     big = (const unsigned char *)(SvPVX_const(bigstr));
 664     /* The value of pos we can stop at: */
 665     stop_pos = SvCUR(bigstr) - end_shift - (SvCUR(littlestr) - 1 - previous);
 666     if (previous + start_shift > stop_pos) {
 667 /*
 668   stop_pos does not include SvTAIL in the count, so this check is incorrect
 669   (I think) - see [ID 20010618.006] and t/op/study.t. HVDS 2001/06/19
 670 */
 671 #if 0
 672         if (previous + start_shift == stop_pos + 1) /* A fake '\n'? */
 673             goto check_tail;
 674 #endif
 675         return Nullch;
 676     }
 677     while (pos < previous + start_shift) {
 678         if (!(pos += PL_screamnext[pos]))
 679             goto cant_find;
 680     }
 681     big -= previous;
 682     do {
 683         const register unsigned char *s, *x;
 684         if (pos >= stop_pos) break;
 685         if (big[pos] != first)
 686             continue;
 687         for (x=big+pos+1,s=little; s < littleend; /**/ ) {
 688             if (*s++ != *x++) {
 689                 s--;
 690                 break;
 691             }
 692         }
 693         if (s == littleend) {
 694             *old_posp = pos;
 695             if (!last) return (char *)(big+pos);
 696             found = 1;
 697         }
 698     } while ( pos += PL_screamnext[pos] );
 699     if (last && found)
 700         return (char *)(big+(*old_posp));
 701   check_tail:
 702     if (!SvTAIL(littlestr) || (end_shift > 0))
 703         return Nullch;
 704     /* Ignore the trailing "\n".  This code is not microoptimized */
 705     big = (const unsigned char *)(SvPVX_const(bigstr) + SvCUR(bigstr));
 706     stop_pos = littleend - little;      /* Actual littlestr len */
 707     if (stop_pos == 0)
 708         return (char*)big;
 709     big -= stop_pos;
 710     if (*big == first
 711         && ((stop_pos == 1) ||
 712             memEQ((char *)(big + 1), (char *)little, stop_pos - 1)))
 713         return (char*)big;
 714     return Nullch;
 715 }
 716
 717 I32
 718 Perl_ibcmp(pTHX_ const char *s1, const char *s2, register I32 len)
 719 {
 720     register const U8 *a = (const U8 *)s1;
 721     register const U8 *b = (const U8 *)s2;
 722     while (len--) {
 723         if (*a != *b && *a != PL_fold[*b])
 724             return 1;
 725         a++,b++;
 726     }
 727     return 0;
 728 }
 729
 730 I32
 731 Perl_ibcmp_locale(pTHX_ const char *s1, const char *s2, register I32 len)
 732 {
 733     dVAR;
 734     register const U8 *a = (const U8 *)s1;
 735     register const U8 *b = (const U8 *)s2;
 736     while (len--) {
 737         if (*a != *b && *a != PL_fold_locale[*b])
 738             return 1;
 739         a++,b++;
 740     }
 741     return 0;
 742 }
 743
 744 /* copy a string to a safe spot */
 745
 746 /*
 747 =head1 Memory Management
 748
 749 =for apidoc savepv
 750
 751 Perl's version of C<strdup()>. Returns a pointer to a newly allocated
 752 string which is a duplicate of C<pv>. The size of the string is
 753 determined by C<strlen()>. The memory allocated for the new string can
 754 be freed with the C<Safefree()> function.
 755
 756 =cut
 757 */
 758
 759 char *
 760 Perl_savepv(pTHX_ const char *pv)
 761 {
 762     if (!pv)
 763         return Nullch;
 764     else {
 765         char *newaddr;
 766         const STRLEN pvlen = strlen(pv)+1;
 767         New(902,newaddr,pvlen,char);
 768         return memcpy(newaddr,pv,pvlen);
 769     }
 770
 771 }
 772
 773 /* same thing but with a known length */
 774
 775 /*
 776 =for apidoc savepvn
 777
 778 Perl's version of what C<strndup()> would be if it existed. Returns a
 779 pointer to a newly allocated string which is a duplicate of the first
 780 C<len> bytes from C<pv>. The memory allocated for the new string can be
 781 freed with the C<Safefree()> function.
 782
 783 =cut
 784 */
 785
 786 char *
 787 Perl_savepvn(pTHX_ const char *pv, register I32 len)
 788 {
 789     register char *newaddr;
 790
 791     New(903,newaddr,len+1,char);
 792     /* Give a meaning to NULL pointer mainly for the use in sv_magic() */
 793     if (pv) {
 794         /* might not be null terminated */
 795         newaddr[len] = '\0';
 796         return (char *) CopyD(pv,newaddr,len,char);
 797     }
 798     else {
 799         return (char *) ZeroD(newaddr,len+1,char);
 800     }
 801 }
 802
 803 /*
 804 =for apidoc savesharedpv
 805
 806 A version of C<savepv()> which allocates the duplicate string in memory
 807 which is shared between threads.
 808
 809 =cut
 810 */
 811 char *
 812 Perl_savesharedpv(pTHX_ const char *pv)
 813 {
 814     register char *newaddr;
 815     STRLEN pvlen;
 816     if (!pv)
 817         return Nullch;
 818
 819     pvlen = strlen(pv)+1;
 820     newaddr = (char*)PerlMemShared_malloc(pvlen);
 821     if (!newaddr) {
 822         PerlLIO_write(PerlIO_fileno(Perl_error_log),
 823                       PL_no_mem, strlen(PL_no_mem));
 824         my_exit(1);
 825     }
 826     return memcpy(newaddr,pv,pvlen);
 827 }
 828
 829 /*
 830 =for apidoc savesvpv
 831
 832 A version of C<savepv()>/C<savepvn()> which gets the string to duplicate from
 833 the passed in SV using C<SvPV()>
 834
 835 =cut
 836 */
 837
 838 char *
 839 Perl_savesvpv(pTHX_ SV *sv)
 840 {
 841     STRLEN len;
 842     const char *pv = SvPV_const(sv, len);
 843     register char *newaddr;
 844
 845     ++len;
 846     New(903,newaddr,len,char);
 847     return (char *) CopyD(pv,newaddr,len,char);
 848 }
 849
 850
 851 /* the SV for Perl_form() and mess() is not kept in an arena */
 852
 853 STATIC SV *
 854 S_mess_alloc(pTHX)
 855 {
 856     SV *sv;
 857     XPVMG *any;
 858
 859     if (!PL_dirty)
 860         return sv_2mortal(newSVpvn("",0));
 861
 862     if (PL_mess_sv)
 863         return PL_mess_sv;
 864
 865     /* Create as PVMG now, to avoid any upgrading later */
 866     New(905, sv, 1, SV);
 867     Newz(905, any, 1, XPVMG);
 868     SvFLAGS(sv) = SVt_PVMG;
 869     SvANY(sv) = (void*)any;
 870     SvPV_set(sv, 0);
 871     SvREFCNT(sv) = 1 << 30; /* practically infinite */
 872     PL_mess_sv = sv;
 873     return sv;
 874 }
 875
 876 #if defined(PERL_IMPLICIT_CONTEXT)
 877 char *
 878 Perl_form_nocontext(const char* pat, ...)
 879 {
 880     dTHX;
 881     char *retval;
 882     va_list args;
 883     va_start(args, pat);
 884     retval = vform(pat, &args);
 885     va_end(args);
 886     return retval;
 887 }
 888 #endif /* PERL_IMPLICIT_CONTEXT */
 889
 890 /*
 891 =head1 Miscellaneous Functions
 892 =for apidoc form
 893
 894 Takes a sprintf-style format pattern and conventional
 895 (non-SV) arguments and returns the formatted string.
 896
 897     (char *) Perl_form(pTHX_ const char* pat, ...)
 898
 899 can be used any place a string (char *) is required:
 900
 901     char * s = Perl_form("%d.%d",major,minor);
 902
 903 Uses a single private buffer so if you want to format several strings you
 904 must explicitly copy the earlier strings away (and free the copies when you
 905 are done).
 906
 907 =cut
 908 */
 909
 910 char *
 911 Perl_form(pTHX_ const char* pat, ...)
 912 {
 913     char *retval;
 914     va_list args;
 915     va_start(args, pat);
 916     retval = vform(pat, &args);
 917     va_end(args);
 918     return retval;
 919 }
 920
 921 char *
 922 Perl_vform(pTHX_ const char *pat, va_list *args)
 923 {
 924     SV *sv = mess_alloc();
 925     sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
 926     return SvPVX(sv);
 927 }
 928
 929 #if defined(PERL_IMPLICIT_CONTEXT)
 930 SV *
 931 Perl_mess_nocontext(const char *pat, ...)
 932 {
 933     dTHX;
 934     SV *retval;
 935     va_list args;
 936     va_start(args, pat);
 937     retval = vmess(pat, &args);
 938     va_end(args);
 939     return retval;
 940 }
 941 #endif /* PERL_IMPLICIT_CONTEXT */
 942
 943 SV *
 944 Perl_mess(pTHX_ const char *pat, ...)
 945 {
 946     SV *retval;
 947     va_list args;
 948     va_start(args, pat);
 949     retval = vmess(pat, &args);
 950     va_end(args);
 951     return retval;
 952 }
 953
 954 STATIC COP*
 955 S_closest_cop(pTHX_ COP *cop, const OP *o)
 956 {
 957     /* Look for PL_op starting from o.  cop is the last COP we've seen. */
 958
 959     if (!o || o == PL_op) return cop;
 960
 961     if (o->op_flags & OPf_KIDS) {
 962         OP *kid;
 963         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
 964         {
 965             COP *new_cop;
 966
 967             /* If the OP_NEXTSTATE has been optimised away we can still use it
 968              * the get the file and line number. */
 969
 970             if (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE)
 971                 cop = (COP *)kid;
 972
 973             /* Keep searching, and return when we've found something. */
 974
 975             new_cop = closest_cop(cop, kid);
 976             if (new_cop) return new_cop;
 977         }
 978     }
 979
 980     /* Nothing found. */
 981
 982     return Null(COP *);
 983 }
 984
 985 SV *
 986 Perl_vmess(pTHX_ const char *pat, va_list *args)
 987 {
 988     SV *sv = mess_alloc();
 989     static const char dgd[] = " during global destruction.\n";
 990
 991     sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
 992     if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
 993
 994         /*
 995          * Try and find the file and line for PL_op.  This will usually be
 996          * PL_curcop, but it might be a cop that has been optimised away.  We
 997          * can try to find such a cop by searching through the optree starting
 998          * from the sibling of PL_curcop.
 999          */
1000
1001         const COP *cop = closest_cop(PL_curcop, PL_curcop->op_sibling);
1002         if (!cop) cop = PL_curcop;
1003
1004         if (CopLINE(cop))
1005             Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf,
1006             OutCopFILE(cop), (IV)CopLINE(cop));
1007         if (GvIO(PL_last_in_gv) && IoLINES(GvIOp(PL_last_in_gv))) {
1008             const bool line_mode = (RsSIMPLE(PL_rs) &&
1009                               SvCUR(PL_rs) == 1 && *SvPVX_const(PL_rs) == '\n');
1010             Perl_sv_catpvf(aTHX_ sv, ", <%s> %s %"IVdf,
1011                            PL_last_in_gv == PL_argvgv ?
1012                            "" : GvNAME(PL_last_in_gv),
1013                            line_mode ? "line" : "chunk",
1014                            (IV)IoLINES(GvIOp(PL_last_in_gv)));
1015         }
1016         sv_catpv(sv, PL_dirty ? dgd : ".\n");
1017     }
1018     return sv;
1019 }
1020
1021 void
1022 Perl_write_to_stderr(pTHX_ const char* message, int msglen)
1023 {
1024     dVAR;
1025     IO *io;
1026     MAGIC *mg;
1027
1028     if (PL_stderrgv && SvREFCNT(PL_stderrgv)
1029         && (io = GvIO(PL_stderrgv))
1030         && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
1031     {
1032         dSP;
1033         ENTER;
1034         SAVETMPS;
1035
1036         save_re_context();
1037         SAVESPTR(PL_stderrgv);
1038         PL_stderrgv = Nullgv;
1039
1040         PUSHSTACKi(PERLSI_MAGIC);
1041
1042         PUSHMARK(SP);
1043         EXTEND(SP,2);
1044         PUSHs(SvTIED_obj((SV*)io, mg));
1045         PUSHs(sv_2mortal(newSVpvn(message, msglen)));
1046         PUTBACK;
1047         call_method("PRINT", G_SCALAR);
1048
1049         POPSTACK;
1050         FREETMPS;
1051         LEAVE;
1052     }
1053     else {
1054 #ifdef USE_SFIO
1055         /* SFIO can really mess with your errno */
1056         const int e = errno;
1057 #endif
1058         PerlIO * const serr = Perl_error_log;
1059
1060         PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
1061         (void)PerlIO_flush(serr);
1062 #ifdef USE_SFIO
1063         errno = e;
1064 #endif
1065     }
1066 }
1067
1068 /* Common code used by vcroak, vdie and vwarner  */
1069
1070 STATIC void
1071 S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8)
1072 {
1073     HV *stash;
1074     GV *gv;
1075     CV *cv;
1076     /* sv_2cv might call Perl_croak() */
1077     SV *olddiehook = PL_diehook;
1078
1079     assert(PL_diehook);
1080     ENTER;
1081     SAVESPTR(PL_diehook);
1082     PL_diehook = Nullsv;
1083     cv = sv_2cv(olddiehook, &stash, &gv, 0);
1084     LEAVE;
1085     if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1086         dSP;
1087         SV *msg;
1088
1089         ENTER;
1090         save_re_context();
1091         if (message) {
1092             msg = newSVpvn(message, msglen);
1093             SvFLAGS(msg) |= utf8;
1094             SvREADONLY_on(msg);
1095             SAVEFREESV(msg);
1096         }
1097         else {
1098             msg = ERRSV;
1099         }
1100
1101         PUSHSTACKi(PERLSI_DIEHOOK);
1102         PUSHMARK(SP);
1103         XPUSHs(msg);
1104         PUTBACK;
1105         call_sv((SV*)cv, G_DISCARD);
1106         POPSTACK;
1107         LEAVE;
1108     }
1109 }
1110
1111 STATIC const char *
1112 S_vdie_croak_common(pTHX_ const char* pat, va_list* args, STRLEN* msglen,
1113                     I32* utf8)
1114 {
1115     dVAR;
1116     const char *message;
1117
1118     if (pat) {
1119         SV *msv = vmess(pat, args);
1120         if (PL_errors && SvCUR(PL_errors)) {
1121             sv_catsv(PL_errors, msv);
1122             message = SvPV_const(PL_errors, *msglen);
1123             SvCUR_set(PL_errors, 0);
1124         }
1125         else
1126             message = SvPV_const(msv,*msglen);
1127         *utf8 = SvUTF8(msv);
1128     }
1129     else {
1130         message = Nullch;
1131     }
1132
1133     DEBUG_S(PerlIO_printf(Perl_debug_log,
1134                           "%p: die/croak: message = %s\ndiehook = %p\n",
1135                           thr, message, PL_diehook));
1136     if (PL_diehook) {
1137         S_vdie_common(aTHX_ message, *msglen, *utf8);
1138     }
1139     return message;
1140 }
1141
1142 OP *
1143 Perl_vdie(pTHX_ const char* pat, va_list *args)
1144 {
1145     const char *message;
1146     const int was_in_eval = PL_in_eval;
1147     STRLEN msglen;
1148     I32 utf8 = 0;
1149
1150     DEBUG_S(PerlIO_printf(Perl_debug_log,
1151                           "%p: die: curstack = %p, mainstack = %p\n",
1152                           thr, PL_curstack, PL_mainstack));
1153
1154     message = S_vdie_croak_common(aTHX_ pat, args, &msglen, &utf8);
1155
1156     PL_restartop = die_where(message, msglen);
1157     SvFLAGS(ERRSV) |= utf8;
1158     DEBUG_S(PerlIO_printf(Perl_debug_log,
1159           "%p: die: restartop = %p, was_in_eval = %d, top_env = %p\n",
1160           thr, PL_restartop, was_in_eval, PL_top_env));
1161     if ((!PL_restartop && was_in_eval) || PL_top_env->je_prev)
1162         JMPENV_JUMP(3);
1163     return PL_restartop;
1164 }
1165
1166 #if defined(PERL_IMPLICIT_CONTEXT)
1167 OP *
1168 Perl_die_nocontext(const char* pat, ...)
1169 {
1170     dTHX;
1171     OP *o;
1172     va_list args;
1173     va_start(args, pat);
1174     o = vdie(pat, &args);
1175     va_end(args);
1176     return o;
1177 }
1178 #endif /* PERL_IMPLICIT_CONTEXT */
1179
1180 OP *
1181 Perl_die(pTHX_ const char* pat, ...)
1182 {
1183     OP *o;
1184     va_list args;
1185     va_start(args, pat);
1186     o = vdie(pat, &args);
1187     va_end(args);
1188     return o;
1189 }
1190
1191 void
1192 Perl_vcroak(pTHX_ const char* pat, va_list *args)
1193 {
1194     const char *message;
1195     STRLEN msglen;
1196     I32 utf8 = 0;
1197
1198     message = S_vdie_croak_common(aTHX_ pat, args, &msglen, &utf8);
1199
1200     if (PL_in_eval) {
1201         PL_restartop = die_where(message, msglen);
1202         SvFLAGS(ERRSV) |= utf8;
1203         JMPENV_JUMP(3);
1204     }
1205     else if (!message)
1206         message = SvPVx_const(ERRSV, msglen);
1207
1208     write_to_stderr(message, msglen);
1209     my_failure_exit();
1210 }
1211
1212 #if defined(PERL_IMPLICIT_CONTEXT)
1213 void
1214 Perl_croak_nocontext(const char *pat, ...)
1215 {
1216     dTHX;
1217     va_list args;
1218     va_start(args, pat);
1219     vcroak(pat, &args);
1220     /* NOTREACHED */
1221     va_end(args);
1222 }
1223 #endif /* PERL_IMPLICIT_CONTEXT */
1224
1225 /*
1226 =head1 Warning and Dieing
1227
1228 =for apidoc croak
1229
1230 This is the XSUB-writer's interface to Perl's C<die> function.
1231 Normally call this function the same way you call the C C<printf>
1232 function.  Calling C<croak> returns control directly to Perl,
1233 sidestepping the normal C order of execution. See C<warn>.
1234
1235 If you want to throw an exception object, assign the object to
1236 C<$@> and then pass C<Nullch> to croak():
1237
1238    errsv = get_sv("@", TRUE);
1239    sv_setsv(errsv, exception_object);
1240    croak(Nullch);
1241
1242 =cut
1243 */
1244
1245 void
1246 Perl_croak(pTHX_ const char *pat, ...)
1247 {
1248     va_list args;
1249     va_start(args, pat);
1250     vcroak(pat, &args);
1251     /* NOTREACHED */
1252     va_end(args);
1253 }
1254
1255 void
1256 Perl_vwarn(pTHX_ const char* pat, va_list *args)
1257 {
1258     dVAR;
1259     STRLEN msglen;
1260     SV * const msv = vmess(pat, args);
1261     const I32 utf8 = SvUTF8(msv);
1262     const char * const message = SvPV_const(msv, msglen);
1263
1264     if (PL_warnhook) {
1265         /* sv_2cv might call Perl_warn() */
1266         SV * const oldwarnhook = PL_warnhook;
1267         CV * cv;
1268         HV * stash;
1269         GV * gv;
1270
1271         ENTER;
1272         SAVESPTR(PL_warnhook);
1273         PL_warnhook = Nullsv;
1274         cv = sv_2cv(oldwarnhook, &stash, &gv, 0);
1275         LEAVE;
1276         if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1277             dSP;
1278             SV *msg;
1279
1280             ENTER;
1281             save_re_context();
1282             msg = newSVpvn(message, msglen);
1283             SvFLAGS(msg) |= utf8;
1284             SvREADONLY_on(msg);
1285             SAVEFREESV(msg);
1286
1287             PUSHSTACKi(PERLSI_WARNHOOK);
1288             PUSHMARK(SP);
1289             XPUSHs(msg);
1290             PUTBACK;
1291             call_sv((SV*)cv, G_DISCARD);
1292             POPSTACK;
1293             LEAVE;
1294             return;
1295         }
1296     }
1297
1298     write_to_stderr(message, msglen);
1299 }
1300
1301 #if defined(PERL_IMPLICIT_CONTEXT)
1302 void
1303 Perl_warn_nocontext(const char *pat, ...)
1304 {
1305     dTHX;
1306     va_list args;
1307     va_start(args, pat);
1308     vwarn(pat, &args);
1309     va_end(args);
1310 }
1311 #endif /* PERL_IMPLICIT_CONTEXT */
1312
1313 /*
1314 =for apidoc warn
1315
1316 This is the XSUB-writer's interface to Perl's C<warn> function.  Call this
1317 function the same way you call the C C<printf> function.  See C<croak>.
1318
1319 =cut
1320 */
1321
1322 void
1323 Perl_warn(pTHX_ const char *pat, ...)
1324 {
1325     va_list args;
1326     va_start(args, pat);
1327     vwarn(pat, &args);
1328     va_end(args);
1329 }
1330
1331 #if defined(PERL_IMPLICIT_CONTEXT)
1332 void
1333 Perl_warner_nocontext(U32 err, const char *pat, ...)
1334 {
1335     dTHX;
1336     va_list args;
1337     va_start(args, pat);
1338     vwarner(err, pat, &args);
1339     va_end(args);
1340 }
1341 #endif /* PERL_IMPLICIT_CONTEXT */
1342
1343 void
1344 Perl_warner(pTHX_ U32  err, const char* pat,...)
1345 {
1346     va_list args;
1347     va_start(args, pat);
1348     vwarner(err, pat, &args);
1349     va_end(args);
1350 }
1351
1352 void
1353 Perl_vwarner(pTHX_ U32  err, const char* pat, va_list* args)
1354 {
1355     dVAR;
1356     if (ckDEAD(err)) {
1357         SV * const msv = vmess(pat, args);
1358         STRLEN msglen;
1359         const char *message = SvPV_const(msv, msglen);
1360         const I32 utf8 = SvUTF8(msv);
1361
1362         if (PL_diehook) {
1363             assert(message);
1364             S_vdie_common(aTHX_ message, msglen, utf8);
1365         }
1366         if (PL_in_eval) {
1367             PL_restartop = die_where(message, msglen);
1368             SvFLAGS(ERRSV) |= utf8;
1369             JMPENV_JUMP(3);
1370         }
1371         write_to_stderr(message, msglen);
1372         my_failure_exit();
1373     }
1374     else {
1375         Perl_vwarn(aTHX_ pat, args);
1376     }
1377 }
1378
1379 /* 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     New(904, 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 *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 *pars = OP_IS_FILETEST(op) ? "" : "()";
3273     const char *type = OP_IS_SOCKET(op)
3274             || (gv && io && IoTYPE(io) == IoTYPE_SOCKET)
3275                 ?  "socket" : "filehandle";
3276     const char *name = NULL;
3277
3278     if (gv && isGV(gv)) {
3279         name = GvENAME(gv);
3280     }
3281
3282     if (op == OP_phoney_OUTPUT_ONLY || op == OP_phoney_INPUT_ONLY) {
3283         if (ckWARN(WARN_IO)) {
3284             const char *direction = (op == OP_phoney_INPUT_ONLY) ? "in" : "out";
3285             if (name && *name)
3286                 Perl_warner(aTHX_ packWARN(WARN_IO),
3287                             "Filehandle %s opened only for %sput",
3288                             name, direction);
3289             else
3290                 Perl_warner(aTHX_ packWARN(WARN_IO),
3291                             "Filehandle opened only for %sput", direction);
3292         }
3293     }
3294     else {
3295         const char *vile;
3296         I32   warn_type;
3297
3298         if (gv && io && IoTYPE(io) == IoTYPE_CLOSED) {
3299             vile = "closed";
3300             warn_type = WARN_CLOSED;
3301         }
3302         else {
3303             vile = "unopened";
3304             warn_type = WARN_UNOPENED;
3305         }
3306
3307         if (ckWARN(warn_type)) {
3308             if (name && *name) {
3309                 Perl_warner(aTHX_ packWARN(warn_type),
3310                             "%s%s on %s %s %s", func, pars, vile, type, name);
3311                 if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3312                     Perl_warner(
3313                         aTHX_ packWARN(warn_type),
3314                         "\t(Are you trying to call %s%s on dirhandle %s?)\n",
3315                         func, pars, name
3316                     );
3317             }
3318             else {
3319                 Perl_warner(aTHX_ packWARN(warn_type),
3320                             "%s%s on %s %s", func, pars, vile, type);
3321                 if (gv && io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3322                     Perl_warner(
3323                         aTHX_ packWARN(warn_type),
3324                         "\t(Are you trying to call %s%s on dirhandle?)\n",
3325                         func, pars
3326                     );
3327             }
3328         }
3329     }
3330 }
3331
3332 #ifdef EBCDIC
3333 /* in ASCII order, not that it matters */
3334 static const char controllablechars[] = "?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_";
3335
3336 int
3337 Perl_ebcdic_control(pTHX_ int ch)
3338 {
3339     if (ch > 'a') {
3340         const char *ctlp;
3341
3342         if (islower(ch))
3343             ch = toupper(ch);
3344
3345         if ((ctlp = strchr(controllablechars, ch)) == 0) {
3346             Perl_die(aTHX_ "unrecognised control character '%c'\n", ch);
3347         }
3348
3349         if (ctlp == controllablechars)
3350             return('\177'); /* DEL */
3351         else
3352             return((unsigned char)(ctlp - controllablechars - 1));
3353     } else { /* Want uncontrol */
3354         if (ch == '\177' || ch == -1)
3355             return('?');
3356         else if (ch == '\157')
3357             return('\177');
3358         else if (ch == '\174')
3359             return('\000');
3360         else if (ch == '^')    /* '\137' in 1047, '\260' in 819 */
3361             return('\036');
3362         else if (ch == '\155')
3363             return('\037');
3364         else if (0 < ch && ch < (sizeof(controllablechars) - 1))
3365             return(controllablechars[ch+1]);
3366         else
3367             Perl_die(aTHX_ "invalid control request: '\\%03o'\n", ch & 0xFF);
3368     }
3369 }
3370 #endif
3371
3372 /* To workaround core dumps from the uninitialised tm_zone we get the
3373  * system to give us a reasonable struct to copy.  This fix means that
3374  * strftime uses the tm_zone and tm_gmtoff values returned by
3375  * localtime(time()). That should give the desired result most of the
3376  * time. But probably not always!
3377  *
3378  * This does not address tzname aspects of NETaa14816.
3379  *
3380  */
3381
3382 #ifdef HAS_GNULIBC
3383 # ifndef STRUCT_TM_HASZONE
3384 #    define STRUCT_TM_HASZONE
3385 # endif
3386 #endif
3387
3388 #ifdef STRUCT_TM_HASZONE /* Backward compat */
3389 # ifndef HAS_TM_TM_ZONE
3390 #    define HAS_TM_TM_ZONE
3391 # endif
3392 #endif
3393
3394 void
3395 Perl_init_tm(pTHX_ struct tm *ptm)      /* see mktime, strftime and asctime */
3396 {
3397 #ifdef HAS_TM_TM_ZONE
3398     Time_t now;
3399     const struct tm* my_tm;
3400     (void)time(&now);
3401     my_tm = localtime(&now);
3402     if (my_tm)
3403         Copy(my_tm, ptm, 1, struct tm);
3404 #else
3405     PERL_UNUSED_ARG(ptm);
3406 #endif
3407 }
3408
3409 /*
3410  * mini_mktime - normalise struct tm values without the localtime()
3411  * semantics (and overhead) of mktime().
3412  */
3413 void
3414 Perl_mini_mktime(pTHX_ struct tm *ptm)
3415 {
3416     int yearday;
3417     int secs;
3418     int month, mday, year, jday;
3419     int odd_cent, odd_year;
3420
3421 #define DAYS_PER_YEAR   365
3422 #define DAYS_PER_QYEAR  (4*DAYS_PER_YEAR+1)
3423 #define DAYS_PER_CENT   (25*DAYS_PER_QYEAR-1)
3424 #define DAYS_PER_QCENT  (4*DAYS_PER_CENT+1)
3425 #define SECS_PER_HOUR   (60*60)
3426 #define SECS_PER_DAY    (24*SECS_PER_HOUR)
3427 /* parentheses deliberately absent on these two, otherwise they don't work */
3428 #define MONTH_TO_DAYS   153/5
3429 #define DAYS_TO_MONTH   5/153
3430 /* offset to bias by March (month 4) 1st between month/mday & year finding */
3431 #define YEAR_ADJUST     (4*MONTH_TO_DAYS+1)
3432 /* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */
3433 #define WEEKDAY_BIAS    6       /* (1+6)%7 makes Sunday 0 again */
3434
3435 /*
3436  * Year/day algorithm notes:
3437  *
3438  * With a suitable offset for numeric value of the month, one can find
3439  * an offset into the year by considering months to have 30.6 (153/5) days,
3440  * using integer arithmetic (i.e., with truncation).  To avoid too much
3441  * messing about with leap days, we consider January and February to be
3442  * the 13th and 14th month of the previous year.  After that transformation,
3443  * we need the month index we use to be high by 1 from 'normal human' usage,
3444  * so the month index values we use run from 4 through 15.
3445  *
3446  * Given that, and the rules for the Gregorian calendar (leap years are those
3447  * divisible by 4 unless also divisible by 100, when they must be divisible
3448  * by 400 instead), we can simply calculate the number of days since some
3449  * arbitrary 'beginning of time' by futzing with the (adjusted) year number,
3450  * the days we derive from our month index, and adding in the day of the
3451  * month.  The value used here is not adjusted for the actual origin which
3452  * it normally would use (1 January A.D. 1), since we're not exposing it.
3453  * We're only building the value so we can turn around and get the
3454  * normalised values for the year, month, day-of-month, and day-of-year.
3455  *
3456  * For going backward, we need to bias the value we're using so that we find
3457  * the right year value.  (Basically, we don't want the contribution of
3458  * March 1st to the number to apply while deriving the year).  Having done
3459  * that, we 'count up' the contribution to the year number by accounting for
3460  * full quadracenturies (400-year periods) with their extra leap days, plus
3461  * the contribution from full centuries (to avoid counting in the lost leap
3462  * days), plus the contribution from full quad-years (to count in the normal
3463  * leap days), plus the leftover contribution from any non-leap years.
3464  * At this point, if we were working with an actual leap day, we'll have 0
3465  * days left over.  This is also true for March 1st, however.  So, we have
3466  * to special-case that result, and (earlier) keep track of the 'odd'
3467  * century and year contributions.  If we got 4 extra centuries in a qcent,
3468  * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb.
3469  * Otherwise, we add back in the earlier bias we removed (the 123 from
3470  * figuring in March 1st), find the month index (integer division by 30.6),
3471  * and the remainder is the day-of-month.  We then have to convert back to
3472  * 'real' months (including fixing January and February from being 14/15 in
3473  * the previous year to being in the proper year).  After that, to get
3474  * tm_yday, we work with the normalised year and get a new yearday value for
3475  * January 1st, which we subtract from the yearday value we had earlier,
3476  * representing the date we've re-built.  This is done from January 1
3477  * because tm_yday is 0-origin.
3478  *
3479  * Since POSIX time routines are only guaranteed to work for times since the
3480  * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm
3481  * applies Gregorian calendar rules even to dates before the 16th century
3482  * doesn't bother me.  Besides, you'd need cultural context for a given
3483  * date to know whether it was Julian or Gregorian calendar, and that's
3484  * outside the scope for this routine.  Since we convert back based on the
3485  * same rules we used to build the yearday, you'll only get strange results
3486  * for input which needed normalising, or for the 'odd' century years which
3487  * were leap years in the Julian calander but not in the Gregorian one.
3488  * I can live with that.
3489  *
3490  * This algorithm also fails to handle years before A.D. 1 gracefully, but
3491  * that's still outside the scope for POSIX time manipulation, so I don't
3492  * care.
3493  */
3494
3495     year = 1900 + ptm->tm_year;
3496     month = ptm->tm_mon;
3497     mday = ptm->tm_mday;
3498     /* allow given yday with no month & mday to dominate the result */
3499     if (ptm->tm_yday >= 0 && mday <= 0 && month <= 0) {
3500         month = 0;
3501         mday = 0;
3502         jday = 1 + ptm->tm_yday;
3503     }
3504     else {
3505         jday = 0;
3506     }
3507     if (month >= 2)
3508         month+=2;
3509     else
3510         month+=14, year--;
3511     yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400;
3512     yearday += month*MONTH_TO_DAYS + mday + jday;
3513     /*
3514      * Note that we don't know when leap-seconds were or will be,
3515      * so we have to trust the user if we get something which looks
3516      * like a sensible leap-second.  Wild values for seconds will
3517      * be rationalised, however.
3518      */
3519     if ((unsigned) ptm->tm_sec <= 60) {
3520         secs = 0;
3521     }
3522     else {
3523         secs = ptm->tm_sec;
3524         ptm->tm_sec = 0;
3525     }
3526     secs += 60 * ptm->tm_min;
3527     secs += SECS_PER_HOUR * ptm->tm_hour;
3528     if (secs < 0) {
3529         if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) {
3530             /* got negative remainder, but need positive time */
3531             /* back off an extra day to compensate */
3532             yearday += (secs/SECS_PER_DAY)-1;
3533             secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1);
3534         }
3535         else {
3536             yearday += (secs/SECS_PER_DAY);
3537             secs -= SECS_PER_DAY * (secs/SECS_PER_DAY);
3538         }
3539     }
3540     else if (secs >= SECS_PER_DAY) {
3541         yearday += (secs/SECS_PER_DAY);
3542         secs %= SECS_PER_DAY;
3543     }
3544     ptm->tm_hour = secs/SECS_PER_HOUR;
3545     secs %= SECS_PER_HOUR;
3546     ptm->tm_min = secs/60;
3547     secs %= 60;
3548     ptm->tm_sec += secs;
3549     /* done with time of day effects */
3550     /*
3551      * The algorithm for yearday has (so far) left it high by 428.
3552      * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to
3553      * bias it by 123 while trying to figure out what year it
3554      * really represents.  Even with this tweak, the reverse
3555      * translation fails for years before A.D. 0001.
3556      * It would still fail for Feb 29, but we catch that one below.
3557      */
3558     jday = yearday;     /* save for later fixup vis-a-vis Jan 1 */
3559     yearday -= YEAR_ADJUST;
3560     year = (yearday / DAYS_PER_QCENT) * 400;
3561     yearday %= DAYS_PER_QCENT;
3562     odd_cent = yearday / DAYS_PER_CENT;
3563     year += odd_cent * 100;
3564     yearday %= DAYS_PER_CENT;
3565     year += (yearday / DAYS_PER_QYEAR) * 4;
3566     yearday %= DAYS_PER_QYEAR;
3567     odd_year = yearday / DAYS_PER_YEAR;
3568     year += odd_year;
3569     yearday %= DAYS_PER_YEAR;
3570     if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */
3571         month = 1;
3572         yearday = 29;
3573     }
3574     else {
3575         yearday += YEAR_ADJUST; /* recover March 1st crock */
3576         month = yearday*DAYS_TO_MONTH;
3577         yearday -= month*MONTH_TO_DAYS;
3578         /* recover other leap-year adjustment */
3579         if (month > 13) {
3580             month-=14;
3581             year++;
3582         }
3583         else {
3584             month-=2;
3585         }
3586     }
3587     ptm->tm_year = year - 1900;
3588     if (yearday) {
3589       ptm->tm_mday = yearday;
3590       ptm->tm_mon = month;
3591     }
3592     else {
3593       ptm->tm_mday = 31;
3594       ptm->tm_mon = month - 1;
3595     }
3596     /* re-build yearday based on Jan 1 to get tm_yday */
3597     year--;
3598     yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400;
3599     yearday += 14*MONTH_TO_DAYS + 1;
3600     ptm->tm_yday = jday - yearday;
3601     /* fix tm_wday if not overridden by caller */
3602     if ((unsigned)ptm->tm_wday > 6)
3603         ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
3604 }
3605
3606 char *
3607 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)
3608 {
3609 #ifdef HAS_STRFTIME
3610   char *buf;
3611   int buflen;
3612   struct tm mytm;
3613   int len;
3614
3615   init_tm(&mytm);       /* XXX workaround - see init_tm() above */
3616   mytm.tm_sec = sec;
3617   mytm.tm_min = min;
3618   mytm.tm_hour = hour;
3619   mytm.tm_mday = mday;
3620   mytm.tm_mon = mon;
3621   mytm.tm_year = year;
3622   mytm.tm_wday = wday;
3623   mytm.tm_yday = yday;
3624   mytm.tm_isdst = isdst;
3625   mini_mktime(&mytm);
3626   /* use libc to get the values for tm_gmtoff and tm_zone [perl #18238] */
3627 #if defined(HAS_MKTIME) && (defined(HAS_TM_TM_GMTOFF) || defined(HAS_TM_TM_ZONE))
3628   STMT_START {
3629     struct tm mytm2;
3630     mytm2 = mytm;
3631     mktime(&mytm2);
3632 #ifdef HAS_TM_TM_GMTOFF
3633     mytm.tm_gmtoff = mytm2.tm_gmtoff;
3634 #endif
3635 #ifdef HAS_TM_TM_ZONE
3636     mytm.tm_zone = mytm2.tm_zone;
3637 #endif
3638   } STMT_END;
3639 #endif
3640   buflen = 64;
3641   New(0, buf, buflen, char);
3642   len = strftime(buf, buflen, fmt, &mytm);
3643   /*
3644   ** The following is needed to handle to the situation where
3645   ** tmpbuf overflows.  Basically we want to allocate a buffer
3646   ** and try repeatedly.  The reason why it is so complicated
3647   ** is that getting a return value of 0 from strftime can indicate
3648   ** one of the following:
3649   ** 1. buffer overflowed,
3650   ** 2. illegal conversion specifier, or
3651   ** 3. the format string specifies nothing to be returned(not
3652   **      an error).  This could be because format is an empty string
3653   **    or it specifies %p that yields an empty string in some locale.
3654   ** If there is a better way to make it portable, go ahead by
3655   ** all means.
3656   */
3657   if ((len > 0 && len < buflen) || (len == 0 && *fmt == '\0'))
3658     return buf;
3659   else {
3660     /* Possibly buf overflowed - try again with a bigger buf */
3661     const int fmtlen = strlen(fmt);
3662     const int bufsize = fmtlen + buflen;
3663
3664     New(0, buf, bufsize, char);
3665     while (buf) {
3666       buflen = strftime(buf, bufsize, fmt, &mytm);
3667       if (buflen > 0 && buflen < bufsize)
3668         break;
3669       /* heuristic to prevent out-of-memory errors */
3670       if (bufsize > 100*fmtlen) {
3671         Safefree(buf);
3672         buf = NULL;
3673         break;
3674       }
3675       Renew(buf, bufsize*2, char);
3676     }
3677     return buf;
3678   }
3679 #else
3680   Perl_croak(aTHX_ "panic: no strftime");
3681   return NULL;
3682 #endif
3683 }
3684
3685
3686 #define SV_CWD_RETURN_UNDEF \
3687 sv_setsv(sv, &PL_sv_undef); \
3688 return FALSE
3689
3690 #define SV_CWD_ISDOT(dp) \
3691     (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
3692         (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
3693
3694 /*
3695 =head1 Miscellaneous Functions
3696
3697 =for apidoc getcwd_sv
3698
3699 Fill the sv with current working directory
3700
3701 =cut
3702 */
3703
3704 /* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars.
3705  * rewritten again by dougm, optimized for use with xs TARG, and to prefer
3706  * getcwd(3) if available
3707  * Comments from the orignal:
3708  *     This is a faster version of getcwd.  It's also more dangerous
3709  *     because you might chdir out of a directory that you can't chdir
3710  *     back into. */
3711
3712 int
3713 Perl_getcwd_sv(pTHX_ register SV *sv)
3714 {
3715 #ifndef PERL_MICRO
3716
3717 #ifndef INCOMPLETE_TAINTS
3718     SvTAINTED_on(sv);
3719 #endif
3720
3721 #ifdef HAS_GETCWD
3722     {
3723         char buf[MAXPATHLEN];
3724
3725         /* Some getcwd()s automatically allocate a buffer of the given
3726          * size from the heap if they are given a NULL buffer pointer.
3727          * The problem is that this behaviour is not portable. */
3728         if (getcwd(buf, sizeof(buf) - 1)) {
3729             sv_setpvn(sv, buf, strlen(buf));
3730             return TRUE;
3731         }
3732         else {
3733             sv_setsv(sv, &PL_sv_undef);
3734             return FALSE;
3735         }
3736     }
3737
3738 #else
3739
3740     Stat_t statbuf;
3741     int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
3742     int pathlen=0;
3743     Direntry_t *dp;
3744
3745     SvUPGRADE(sv, SVt_PV);
3746
3747     if (PerlLIO_lstat(".", &statbuf) < 0) {
3748         SV_CWD_RETURN_UNDEF;
3749     }
3750
3751     orig_cdev = statbuf.st_dev;
3752     orig_cino = statbuf.st_ino;
3753     cdev = orig_cdev;
3754     cino = orig_cino;
3755
3756     for (;;) {
3757         DIR *dir;
3758         odev = cdev;
3759         oino = cino;
3760
3761         if (PerlDir_chdir("..") < 0) {
3762             SV_CWD_RETURN_UNDEF;
3763         }
3764         if (PerlLIO_stat(".", &statbuf) < 0) {
3765             SV_CWD_RETURN_UNDEF;
3766         }
3767
3768         cdev = statbuf.st_dev;
3769         cino = statbuf.st_ino;
3770
3771         if (odev == cdev && oino == cino) {
3772             break;
3773         }
3774         if (!(dir = PerlDir_open("."))) {
3775             SV_CWD_RETURN_UNDEF;
3776         }
3777
3778         while ((dp = PerlDir_read(dir)) != NULL) {
3779 #ifdef DIRNAMLEN
3780             const int namelen = dp->d_namlen;
3781 #else
3782             const int namelen = strlen(dp->d_name);
3783 #endif
3784             /* skip . and .. */
3785             if (SV_CWD_ISDOT(dp)) {
3786                 continue;
3787             }
3788
3789             if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
3790                 SV_CWD_RETURN_UNDEF;
3791             }
3792
3793             tdev = statbuf.st_dev;
3794             tino = statbuf.st_ino;
3795             if (tino == oino && tdev == odev) {
3796                 break;
3797             }
3798         }
3799
3800         if (!dp) {
3801             SV_CWD_RETURN_UNDEF;
3802         }
3803
3804         if (pathlen + namelen + 1 >= MAXPATHLEN) {
3805             SV_CWD_RETURN_UNDEF;
3806         }
3807
3808         SvGROW(sv, pathlen + namelen + 1);
3809
3810         if (pathlen) {
3811             /* shift down */
3812             Move(SvPVX_const(sv), SvPVX(sv) + namelen + 1, pathlen, char);
3813         }
3814
3815         /* prepend current directory to the front */
3816         *SvPVX(sv) = '/';
3817         Move(dp->d_name, SvPVX(sv)+1, namelen, char);
3818         pathlen += (namelen + 1);
3819
3820 #ifdef VOID_CLOSEDIR
3821         PerlDir_close(dir);
3822 #else
3823         if (PerlDir_close(dir) < 0) {
3824             SV_CWD_RETURN_UNDEF;
3825         }
3826 #endif
3827     }
3828
3829     if (pathlen) {
3830         SvCUR_set(sv, pathlen);
3831         *SvEND(sv) = '\0';
3832         SvPOK_only(sv);
3833
3834         if (PerlDir_chdir(SvPVX_const(sv)) < 0) {
3835             SV_CWD_RETURN_UNDEF;
3836         }
3837     }
3838     if (PerlLIO_stat(".", &statbuf) < 0) {
3839         SV_CWD_RETURN_UNDEF;
3840     }
3841
3842     cdev = statbuf.st_dev;
3843     cino = statbuf.st_ino;
3844
3845     if (cdev != orig_cdev || cino != orig_cino) {
3846         Perl_croak(aTHX_ "Unstable directory path, "
3847                    "current directory changed unexpectedly");
3848     }
3849
3850     return TRUE;
3851 #endif
3852
3853 #else
3854     return FALSE;
3855 #endif
3856 }
3857
3858 /*
3859 =for apidoc scan_version
3860
3861 Returns a pointer to the next character after the parsed
3862 version string, as well as upgrading the passed in SV to
3863 an RV.
3864
3865 Function must be called with an already existing SV like
3866
3867     sv = newSV(0);
3868     s = scan_version(s,SV *sv, bool qv);
3869
3870 Performs some preprocessing to the string to ensure that
3871 it has the correct characteristics of a version.  Flags the
3872 object if it contains an underscore (which denotes this
3873 is a alpha version).  The boolean qv denotes that the version
3874 should be interpreted as if it had multiple decimals, even if
3875 it doesn't.
3876
3877 =cut
3878 */
3879
3880 const char *
3881 Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
3882 {
3883     const char *start = s;
3884     const char *pos;
3885     const char *last;
3886     int saw_period = 0;
3887     int saw_under = 0;
3888     int width = 3;
3889     AV *av = newAV();
3890     SV* hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
3891     (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
3892 #ifndef NODEFAULT_SHAREKEYS
3893     HvSHAREKEYS_on(hv);         /* key-sharing on by default */
3894 #endif
3895
3896     if (*s == 'v') {
3897         s++;  /* get past 'v' */
3898         qv = 1; /* force quoted version processing */
3899     }
3900
3901     last = pos = s;
3902
3903     /* pre-scan the input string to check for decimals/underbars */
3904     while ( *pos == '.' || *pos == '_' || isDIGIT(*pos) )
3905     {
3906         if ( *pos == '.' )
3907         {
3908             if ( saw_under )
3909                 Perl_croak(aTHX_ "Invalid version format (underscores before decimal)");
3910             saw_period++ ;
3911             last = pos;
3912         }
3913         else if ( *pos == '_' )
3914         {
3915             if ( saw_under )
3916                 Perl_croak(aTHX_ "Invalid version format (multiple underscores)");
3917             saw_under = 1;
3918             width = pos - last - 1; /* natural width of sub-version */
3919         }
3920         pos++;
3921     }
3922
3923     if ( saw_period > 1 ) {
3924         qv = 1; /* force quoted version processing */
3925     }
3926
3927     pos = s;
3928
3929     if ( qv )
3930         hv_store((HV *)hv, "qv", 2, &PL_sv_yes, 0);
3931     if ( saw_under ) {
3932         hv_store((HV *)hv, "alpha", 5, &PL_sv_yes, 0);
3933     }
3934     if ( !qv && width < 3 )
3935         hv_store((HV *)hv, "width", 5, newSViv(width), 0);
3936
3937     while (isDIGIT(*pos))
3938         pos++;
3939     if (!isALPHA(*pos)) {
3940         I32 rev;
3941
3942         for (;;) {
3943             rev = 0;
3944             {
3945                 /* this is atoi() that delimits on underscores */
3946                 const char *end = pos;
3947                 I32 mult = 1;
3948                 I32 orev;
3949
3950                 /* the following if() will only be true after the decimal
3951                  * point of a version originally created with a bare
3952                  * floating point number, i.e. not quoted in any way
3953                  */
3954                 if ( !qv && s > start+1 && saw_period == 1 ) {
3955                     mult *= 100;
3956                     while ( s < end ) {
3957                         orev = rev;
3958                         rev += (*s - '0') * mult;
3959                         mult /= 10;
3960                         if ( PERL_ABS(orev) > PERL_ABS(rev) )
3961                             Perl_croak(aTHX_ "Integer overflow in version");
3962                         s++;
3963                         if ( *s == '_' )
3964                             s++;
3965                     }
3966                 }
3967                 else {
3968                     while (--end >= s) {
3969                         orev = rev;
3970                         rev += (*end - '0') * mult;
3971                         mult *= 10;
3972                         if ( PERL_ABS(orev) > PERL_ABS(rev) )
3973                             Perl_croak(aTHX_ "Integer overflow in version");
3974                     }
3975                 }
3976             }
3977
3978             /* Append revision */
3979             av_push(av, newSViv(rev));
3980             if ( *pos == '.' && isDIGIT(pos[1]) )
3981                 s = ++pos;
3982             else if ( *pos == '_' && isDIGIT(pos[1]) )
3983                 s = ++pos;
3984             else if ( isDIGIT(*pos) )
3985                 s = pos;
3986             else {
3987                 s = pos;
3988                 break;
3989             }
3990             if ( qv ) {
3991                 while ( isDIGIT(*pos) )
3992                     pos++;
3993             }
3994             else {
3995                 int digits = 0;
3996                 while ( ( isDIGIT(*pos) || *pos == '_' ) && digits < 3 ) {
3997                     if ( *pos != '_' )
3998                         digits++;
3999                     pos++;
4000                 }
4001             }
4002         }
4003     }
4004     if ( qv ) { /* quoted versions always get at least three terms*/
4005         I32 len = av_len(av);
4006         /* This for loop appears to trigger a compiler bug on OS X, as it
4007            loops infinitely. Yes, len is negative. No, it makes no sense.
4008            Compiler in question is:
4009            gcc version 3.3 20030304 (Apple Computer, Inc. build 1640)
4010            for ( len = 2 - len; len > 0; len-- )
4011            av_push((AV *)sv, newSViv(0));
4012         */
4013         len = 2 - len;
4014         while (len-- > 0)
4015             av_push(av, newSViv(0));
4016     }
4017
4018     if ( av_len(av) == -1 ) /* oops, someone forgot to pass a value */
4019         av_push(av, newSViv(0));
4020
4021     /* And finally, store the AV in the hash */
4022     hv_store((HV *)hv, "version", 7, (SV *)av, 0);
4023     return s;
4024 }
4025
4026 /*
4027 =for apidoc new_version
4028
4029 Returns a new version object based on the passed in SV:
4030
4031     SV *sv = new_version(SV *ver);
4032
4033 Does not alter the passed in ver SV.  See "upg_version" if you
4034 want to upgrade the SV.
4035
4036 =cut
4037 */
4038
4039 SV *
4040 Perl_new_version(pTHX_ SV *ver)
4041 {
4042     SV *rv = newSV(0);
4043     if ( sv_derived_from(ver,"version") ) /* can just copy directly */
4044     {
4045         I32 key;
4046         AV * const av = newAV();
4047         AV *sav;
4048         /* This will get reblessed later if a derived class*/
4049         SV*  const hv = newSVrv(rv, "version");
4050         (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
4051 #ifndef NODEFAULT_SHAREKEYS
4052         HvSHAREKEYS_on(hv);         /* key-sharing on by default */
4053 #endif
4054
4055         if ( SvROK(ver) )
4056             ver = SvRV(ver);
4057
4058         /* Begin copying all of the elements */
4059         if ( hv_exists((HV *)ver, "qv", 2) )
4060             hv_store((HV *)hv, "qv", 2, &PL_sv_yes, 0);
4061
4062         if ( hv_exists((HV *)ver, "alpha", 5) )
4063             hv_store((HV *)hv, "alpha", 5, &PL_sv_yes, 0);
4064
4065         if ( hv_exists((HV*)ver, "width", 5 ) )
4066         {
4067             const I32 width = SvIV(*hv_fetch((HV*)ver, "width", 5, FALSE));
4068             hv_store((HV *)hv, "width", 5, newSViv(width), 0);
4069         }
4070
4071         sav = (AV *)*hv_fetch((HV*)ver, "version", 7, FALSE);
4072         /* This will get reblessed later if a derived class*/
4073         for ( key = 0; key <= av_len(sav); key++ )
4074         {
4075             const I32 rev = SvIV(*av_fetch(sav, key, FALSE));
4076             av_push(av, newSViv(rev));
4077         }
4078
4079         hv_store((HV *)hv, "version", 7, (SV *)av, 0);
4080         return rv;
4081     }
4082 #ifdef SvVOK
4083     if ( SvVOK(ver) ) { /* already a v-string */
4084         char *version;
4085         MAGIC* mg = mg_find(ver,PERL_MAGIC_vstring);
4086         const STRLEN len = mg->mg_len;
4087         version = savepvn( (const char*)mg->mg_ptr, len);
4088         sv_setpvn(rv,version,len);
4089         Safefree(version);
4090     }
4091     else {
4092 #endif
4093     sv_setsv(rv,ver); /* make a duplicate */
4094 #ifdef SvVOK
4095     }
4096 #endif
4097     upg_version(rv);
4098     return rv;
4099 }
4100
4101 /*
4102 =for apidoc upg_version
4103
4104 In-place upgrade of the supplied SV to a version object.
4105
4106     SV *sv = upg_version(SV *sv);
4107
4108 Returns a pointer to the upgraded SV.
4109
4110 =cut
4111 */
4112
4113 SV *
4114 Perl_upg_version(pTHX_ SV *ver)
4115 {
4116     char *version;
4117     bool qv = 0;
4118
4119     if ( SvNOK(ver) ) /* may get too much accuracy */
4120     {
4121         char tbuf[64];
4122         sprintf(tbuf,"%.9"NVgf, SvNVX(ver));
4123         version = savepv(tbuf);
4124     }
4125 #ifdef SvVOK
4126     else if ( SvVOK(ver) ) { /* already a v-string */
4127         MAGIC* mg = mg_find(ver,PERL_MAGIC_vstring);
4128         version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
4129         qv = 1;
4130     }
4131 #endif
4132     else /* must be a string or something like a string */
4133     {
4134         version = savepv(SvPV_nolen(ver));
4135     }
4136     (void)scan_version(version, ver, qv);
4137     Safefree(version);
4138     return ver;
4139 }
4140
4141
4142 /*
4143 =for apidoc vnumify
4144
4145 Accepts a version object and returns the normalized floating
4146 point representation.  Call like:
4147
4148     sv = vnumify(rv);
4149
4150 NOTE: you can pass either the object directly or the SV
4151 contained within the RV.
4152
4153 =cut
4154 */
4155
4156 SV *
4157 Perl_vnumify(pTHX_ SV *vs)
4158 {
4159     I32 i, len, digit;
4160     int width;
4161     bool alpha = FALSE;
4162     SV * const sv = newSV(0);
4163     AV *av;
4164     if ( SvROK(vs) )
4165         vs = SvRV(vs);
4166
4167     /* see if various flags exist */
4168     if ( hv_exists((HV*)vs, "alpha", 5 ) )
4169         alpha = TRUE;
4170     if ( hv_exists((HV*)vs, "width", 5 ) )
4171         width = SvIV(*hv_fetch((HV*)vs, "width", 5, FALSE));
4172     else
4173         width = 3;
4174
4175
4176     /* attempt to retrieve the version array */
4177     if ( !(av = (AV *)*hv_fetch((HV*)vs, "version", 7, FALSE) ) ) {
4178         sv_catpvn(sv,"0",1);
4179         return sv;
4180     }
4181
4182     len = av_len(av);
4183     if ( len == -1 )
4184     {
4185         sv_catpvn(sv,"0",1);
4186         return sv;
4187     }
4188
4189     digit = SvIV(*av_fetch(av, 0, 0));
4190     Perl_sv_setpvf(aTHX_ sv,"%d.", (int)PERL_ABS(digit));
4191     for ( i = 1 ; i < len ; i++ )
4192     {
4193         digit = SvIV(*av_fetch(av, i, 0));
4194         if ( width < 3 ) {
4195             const int denom = (int)pow(10,(3-width));
4196             const div_t term = div((int)PERL_ABS(digit),denom);
4197             Perl_sv_catpvf(aTHX_ sv,"%0*d_%d", width, term.quot, term.rem);
4198         }
4199         else {
4200             Perl_sv_catpvf(aTHX_ sv,"%0*d", width, (int)digit);
4201         }
4202     }
4203
4204     if ( len > 0 )
4205     {
4206         digit = SvIV(*av_fetch(av, len, 0));
4207         if ( alpha && width == 3 ) /* alpha version */
4208             Perl_sv_catpv(aTHX_ sv,"_");
4209         /* Don't display additional trailing zeros */
4210         if ( digit > 0 )
4211             Perl_sv_catpvf(aTHX_ sv,"%0*d", width, (int)digit);
4212     }
4213     else /* len == 1 */
4214     {
4215          sv_catpvn(sv,"000",3);
4216     }
4217     return sv;
4218 }
4219
4220 /*
4221 =for apidoc vnormal
4222
4223 Accepts a version object and returns the normalized string
4224 representation.  Call like:
4225
4226     sv = vnormal(rv);
4227
4228 NOTE: you can pass either the object directly or the SV
4229 contained within the RV.
4230
4231 =cut
4232 */
4233
4234 SV *
4235 Perl_vnormal(pTHX_ SV *vs)
4236 {
4237     I32 i, len, digit;
4238     bool alpha = FALSE;
4239     SV *sv = newSV(0);
4240     AV *av;
4241     if ( SvROK(vs) )
4242         vs = SvRV(vs);
4243
4244     if ( hv_exists((HV*)vs, "alpha", 5 ) )
4245         alpha = TRUE;
4246     av = (AV *)*hv_fetch((HV*)vs, "version", 7, FALSE);
4247
4248     len = av_len(av);
4249     if ( len == -1 ) {
4250         sv_catpvn(sv,"",0);
4251         return sv;
4252     }
4253     digit = SvIV(*av_fetch(av, 0, 0));
4254     Perl_sv_setpvf(aTHX_ sv,"v%"IVdf,(IV)digit);
4255     for ( i = 1 ; i <= len-1 ; i++ ) {
4256         digit = SvIV(*av_fetch(av, i, 0));
4257         Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
4258     }
4259
4260     if ( len > 0 ) {
4261         /* handle last digit specially */
4262         digit = SvIV(*av_fetch(av, len, 0));
4263         if ( alpha )
4264             Perl_sv_catpvf(aTHX_ sv, "_%"IVdf, (IV)digit);
4265         else
4266             Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
4267     }
4268
4269     if ( len <= 2 ) { /* short version, must be at least three */
4270         for ( len = 2 - len; len != 0; len-- )
4271             sv_catpvn(sv,".0",2);
4272     }
4273
4274     return sv;
4275 }
4276
4277 /*
4278 =for apidoc vstringify
4279
4280 In order to maintain maximum compatibility with earlier versions
4281 of Perl, this function will return either the floating point
4282 notation or the multiple dotted notation, depending on whether
4283 the original version contained 1 or more dots, respectively
4284
4285 =cut
4286 */
4287
4288 SV *
4289 Perl_vstringify(pTHX_ SV *vs)
4290 {
4291     I32 qv = 0;
4292     if ( SvROK(vs) )
4293         vs = SvRV(vs);
4294
4295     if ( hv_exists((HV *)vs, "qv", 2) )
4296         qv = 1;
4297
4298     if ( qv )
4299         return vnormal(vs);
4300     else
4301         return vnumify(vs);
4302 }
4303
4304 /*
4305 =for apidoc vcmp
4306
4307 Version object aware cmp.  Both operands must already have been
4308 converted into version objects.
4309
4310 =cut
4311 */
4312
4313 int
4314 Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
4315 {
4316     I32 i,l,m,r,retval;
4317     bool lalpha = FALSE;
4318     bool ralpha = FALSE;
4319     I32 left = 0;
4320     I32 right = 0;
4321     AV *lav, *rav;
4322     if ( SvROK(lhv) )
4323         lhv = SvRV(lhv);
4324     if ( SvROK(rhv) )
4325         rhv = SvRV(rhv);
4326
4327     /* get the left hand term */
4328     lav = (AV *)*hv_fetch((HV*)lhv, "version", 7, FALSE);
4329     if ( hv_exists((HV*)lhv, "alpha", 5 ) )
4330         lalpha = TRUE;
4331
4332     /* and the right hand term */
4333     rav = (AV *)*hv_fetch((HV*)rhv, "version", 7, FALSE);
4334     if ( hv_exists((HV*)rhv, "alpha", 5 ) )
4335         ralpha = TRUE;
4336
4337     l = av_len(lav);
4338     r = av_len(rav);
4339     m = l < r ? l : r;
4340     retval = 0;
4341     i = 0;
4342     while ( i <= m && retval == 0 )
4343     {
4344         left  = SvIV(*av_fetch(lav,i,0));
4345         right = SvIV(*av_fetch(rav,i,0));
4346         if ( left < right  )
4347             retval = -1;
4348         if ( left > right )
4349             retval = +1;
4350         i++;
4351     }
4352
4353     /* tiebreaker for alpha with identical terms */
4354     if ( retval == 0 && l == r && left == right && ( lalpha || ralpha ) )
4355     {
4356         if ( lalpha && !ralpha )
4357         {
4358             retval = -1;
4359         }
4360         else if ( ralpha && !lalpha)
4361         {
4362             retval = +1;
4363         }
4364     }
4365
4366     if ( l != r && retval == 0 ) /* possible match except for trailing 0's */
4367     {
4368         if ( l < r )
4369         {
4370             while ( i <= r && retval == 0 )
4371             {
4372                 if ( SvIV(*av_fetch(rav,i,0)) != 0 )
4373                     retval = -1; /* not a match after all */
4374                 i++;
4375             }
4376         }
4377         else
4378         {
4379             while ( i <= l && retval == 0 )
4380             {
4381                 if ( SvIV(*av_fetch(lav,i,0)) != 0 )
4382                     retval = +1; /* not a match after all */
4383                 i++;
4384             }
4385         }
4386     }
4387     return retval;
4388 }
4389
4390 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT)
4391 #   define EMULATE_SOCKETPAIR_UDP
4392 #endif
4393
4394 #ifdef EMULATE_SOCKETPAIR_UDP
4395 static int
4396 S_socketpair_udp (int fd[2]) {
4397     dTHX;
4398     /* Fake a datagram socketpair using UDP to localhost.  */
4399     int sockets[2] = {-1, -1};
4400     struct sockaddr_in addresses[2];
4401     int i;
4402     Sock_size_t size = sizeof(struct sockaddr_in);
4403     unsigned short port;
4404     int got;
4405
4406     memset(&addresses, 0, sizeof(addresses));
4407     i = 1;
4408     do {
4409         sockets[i] = PerlSock_socket(AF_INET, SOCK_DGRAM, PF_INET);
4410         if (sockets[i] == -1)
4411             goto tidy_up_and_fail;
4412
4413         addresses[i].sin_family = AF_INET;
4414         addresses[i].sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4415         addresses[i].sin_port = 0;      /* kernel choses port.  */
4416         if (PerlSock_bind(sockets[i], (struct sockaddr *) &addresses[i],
4417                 sizeof(struct sockaddr_in)) == -1)
4418             goto tidy_up_and_fail;
4419     } while (i--);
4420
4421     /* Now have 2 UDP sockets. Find out which port each is connected to, and
4422        for each connect the other socket to it.  */
4423     i = 1;
4424     do {
4425         if (PerlSock_getsockname(sockets[i], (struct sockaddr *) &addresses[i],
4426                 &size) == -1)
4427             goto tidy_up_and_fail;
4428         if (size != sizeof(struct sockaddr_in))
4429             goto abort_tidy_up_and_fail;
4430         /* !1 is 0, !0 is 1 */
4431         if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i],
4432                 sizeof(struct sockaddr_in)) == -1)
4433             goto tidy_up_and_fail;
4434     } while (i--);
4435
4436     /* Now we have 2 sockets connected to each other. I don't trust some other
4437        process not to have already sent a packet to us (by random) so send
4438        a packet from each to the other.  */
4439     i = 1;
4440     do {
4441         /* I'm going to send my own port number.  As a short.
4442            (Who knows if someone somewhere has sin_port as a bitfield and needs
4443            this routine. (I'm assuming crays have socketpair)) */
4444         port = addresses[i].sin_port;
4445         got = PerlLIO_write(sockets[i], &port, sizeof(port));
4446         if (got != sizeof(port)) {
4447             if (got == -1)
4448                 goto tidy_up_and_fail;
4449             goto abort_tidy_up_and_fail;
4450         }
4451     } while (i--);
4452
4453     /* Packets sent. I don't trust them to have arrived though.
4454        (As I understand it Solaris TCP stack is multithreaded. Non-blocking
4455        connect to localhost will use a second kernel thread. In 2.6 the
4456        first thread running the connect() returns before the second completes,
4457        so EINPROGRESS> In 2.7 the improved stack is faster and connect()
4458        returns 0. Poor programs have tripped up. One poor program's authors'
4459        had a 50-1 reverse stock split. Not sure how connected these were.)
4460        So I don't trust someone not to have an unpredictable UDP stack.
4461     */
4462
4463     {
4464         struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */
4465         int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0];
4466         fd_set rset;
4467
4468         FD_ZERO(&rset);
4469         FD_SET(sockets[0], &rset);
4470         FD_SET(sockets[1], &rset);
4471
4472         got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor);
4473         if (got != 2 || !FD_ISSET(sockets[0], &rset)
4474                 || !FD_ISSET(sockets[1], &rset)) {
4475             /* I hope this is portable and appropriate.  */
4476             if (got == -1)
4477                 goto tidy_up_and_fail;
4478             goto abort_tidy_up_and_fail;
4479         }
4480     }
4481
4482     /* And the paranoia department even now doesn't trust it to have arrive
4483        (hence MSG_DONTWAIT). Or that what arrives was sent by us.  */
4484     {
4485         struct sockaddr_in readfrom;
4486         unsigned short buffer[2];
4487
4488         i = 1;
4489         do {
4490 #ifdef MSG_DONTWAIT
4491             got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4492                     sizeof(buffer), MSG_DONTWAIT,
4493                     (struct sockaddr *) &readfrom, &size);
4494 #else
4495             got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4496                     sizeof(buffer), 0,
4497                     (struct sockaddr *) &readfrom, &size);
4498 #endif
4499
4500             if (got == -1)
4501                 goto tidy_up_and_fail;
4502             if (got != sizeof(port)
4503                     || size != sizeof(struct sockaddr_in)
4504                     /* Check other socket sent us its port.  */
4505                     || buffer[0] != (unsigned short) addresses[!i].sin_port
4506                     /* Check kernel says we got the datagram from that socket */
4507                     || readfrom.sin_family != addresses[!i].sin_family
4508                     || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr
4509                     || readfrom.sin_port != addresses[!i].sin_port)
4510                 goto abort_tidy_up_and_fail;
4511         } while (i--);
4512     }
4513     /* My caller (my_socketpair) has validated that this is non-NULL  */
4514     fd[0] = sockets[0];
4515     fd[1] = sockets[1];
4516     /* I hereby declare this connection open.  May God bless all who cross
4517        her.  */
4518     return 0;
4519
4520   abort_tidy_up_and_fail:
4521     errno = ECONNABORTED;
4522   tidy_up_and_fail:
4523     {
4524         const int save_errno = errno;
4525         if (sockets[0] != -1)
4526             PerlLIO_close(sockets[0]);
4527         if (sockets[1] != -1)
4528             PerlLIO_close(sockets[1]);
4529         errno = save_errno;
4530         return -1;
4531     }
4532 }
4533 #endif /*  EMULATE_SOCKETPAIR_UDP */
4534
4535 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET)
4536 int
4537 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4538     /* Stevens says that family must be AF_LOCAL, protocol 0.
4539        I'm going to enforce that, then ignore it, and use TCP (or UDP).  */
4540     dTHX;
4541     int listener = -1;
4542     int connector = -1;
4543     int acceptor = -1;
4544     struct sockaddr_in listen_addr;
4545     struct sockaddr_in connect_addr;
4546     Sock_size_t size;
4547
4548     if (protocol
4549 #ifdef AF_UNIX
4550         || family != AF_UNIX
4551 #endif
4552     ) {
4553         errno = EAFNOSUPPORT;
4554         return -1;
4555     }
4556     if (!fd) {
4557         errno = EINVAL;
4558         return -1;
4559     }
4560
4561 #ifdef EMULATE_SOCKETPAIR_UDP
4562     if (type == SOCK_DGRAM)
4563         return S_socketpair_udp(fd);
4564 #endif
4565
4566     listener = PerlSock_socket(AF_INET, type, 0);
4567     if (listener == -1)
4568         return -1;
4569     memset(&listen_addr, 0, sizeof(listen_addr));
4570     listen_addr.sin_family = AF_INET;
4571     listen_addr.sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4572     listen_addr.sin_port = 0;   /* kernel choses port.  */
4573     if (PerlSock_bind(listener, (struct sockaddr *) &listen_addr,
4574             sizeof(listen_addr)) == -1)
4575         goto tidy_up_and_fail;
4576     if (PerlSock_listen(listener, 1) == -1)
4577         goto tidy_up_and_fail;
4578
4579     connector = PerlSock_socket(AF_INET, type, 0);
4580     if (connector == -1)
4581         goto tidy_up_and_fail;
4582     /* We want to find out the port number to connect to.  */
4583     size = sizeof(connect_addr);
4584     if (PerlSock_getsockname(listener, (struct sockaddr *) &connect_addr,
4585             &size) == -1)
4586         goto tidy_up_and_fail;
4587     if (size != sizeof(connect_addr))
4588         goto abort_tidy_up_and_fail;
4589     if (PerlSock_connect(connector, (struct sockaddr *) &connect_addr,
4590             sizeof(connect_addr)) == -1)
4591         goto tidy_up_and_fail;
4592
4593     size = sizeof(listen_addr);
4594     acceptor = PerlSock_accept(listener, (struct sockaddr *) &listen_addr,
4595             &size);
4596     if (acceptor == -1)
4597         goto tidy_up_and_fail;
4598     if (size != sizeof(listen_addr))
4599         goto abort_tidy_up_and_fail;
4600     PerlLIO_close(listener);
4601     /* Now check we are talking to ourself by matching port and host on the
4602        two sockets.  */
4603     if (PerlSock_getsockname(connector, (struct sockaddr *) &connect_addr,
4604             &size) == -1)
4605         goto tidy_up_and_fail;
4606     if (size != sizeof(connect_addr)
4607             || listen_addr.sin_family != connect_addr.sin_family
4608             || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr
4609             || listen_addr.sin_port != connect_addr.sin_port) {
4610         goto abort_tidy_up_and_fail;
4611     }
4612     fd[0] = connector;
4613     fd[1] = acceptor;
4614     return 0;
4615
4616   abort_tidy_up_and_fail:
4617 #ifdef ECONNABORTED
4618   errno = ECONNABORTED; /* This would be the standard thing to do. */
4619 #else
4620 #  ifdef ECONNREFUSED
4621   errno = ECONNREFUSED; /* E.g. Symbian does not have ECONNABORTED. */
4622 #  else
4623   errno = ETIMEDOUT;    /* Desperation time. */
4624 #  endif
4625 #endif
4626   tidy_up_and_fail:
4627     {
4628         int save_errno = errno;
4629         if (listener != -1)
4630             PerlLIO_close(listener);
4631         if (connector != -1)
4632             PerlLIO_close(connector);
4633         if (acceptor != -1)
4634             PerlLIO_close(acceptor);
4635         errno = save_errno;
4636         return -1;
4637     }
4638 }
4639 #else
4640 /* In any case have a stub so that there's code corresponding
4641  * to the my_socketpair in global.sym. */
4642 int
4643 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4644 #ifdef HAS_SOCKETPAIR
4645     return socketpair(family, type, protocol, fd);
4646 #else
4647     return -1;
4648 #endif
4649 }
4650 #endif
4651
4652 /*
4653
4654 =for apidoc sv_nosharing
4655
4656 Dummy routine which "shares" an SV when there is no sharing module present.
4657 Exists to avoid test for a NULL function pointer and because it could potentially warn under
4658 some level of strict-ness.
4659
4660 =cut
4661 */
4662
4663 void
4664 Perl_sv_nosharing(pTHX_ SV *sv)
4665 {
4666     PERL_UNUSED_ARG(sv);
4667 }
4668
4669 /*
4670 =for apidoc sv_nolocking
4671
4672 Dummy routine which "locks" an SV when there is no locking module present.
4673 Exists to avoid test for a NULL function pointer and because it could potentially warn under
4674 some level of strict-ness.
4675
4676 =cut
4677 */
4678
4679 void
4680 Perl_sv_nolocking(pTHX_ SV *sv)
4681 {
4682     PERL_UNUSED_ARG(sv);
4683 }
4684
4685
4686 /*
4687 =for apidoc sv_nounlocking
4688
4689 Dummy routine which "unlocks" an SV when there is no locking module present.
4690 Exists to avoid test for a NULL function pointer and because it could potentially warn under
4691 some level of strict-ness.
4692
4693 =cut
4694 */
4695
4696 void
4697 Perl_sv_nounlocking(pTHX_ SV *sv)
4698 {
4699     PERL_UNUSED_ARG(sv);
4700 }
4701
4702 U32
4703 Perl_parse_unicode_opts(pTHX_ const char **popt)
4704 {
4705   const char *p = *popt;
4706   U32 opt = 0;
4707
4708   if (*p) {
4709        if (isDIGIT(*p)) {
4710             opt = (U32) atoi(p);
4711             while (isDIGIT(*p)) p++;
4712             if (*p && *p != '\n' && *p != '\r')
4713                  Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
4714        }
4715        else {
4716             for (; *p; p++) {
4717                  switch (*p) {
4718                  case PERL_UNICODE_STDIN:
4719                       opt |= PERL_UNICODE_STDIN_FLAG;   break;
4720                  case PERL_UNICODE_STDOUT:
4721                       opt |= PERL_UNICODE_STDOUT_FLAG;  break;
4722                  case PERL_UNICODE_STDERR:
4723                       opt |= PERL_UNICODE_STDERR_FLAG;  break;
4724                  case PERL_UNICODE_STD:
4725                       opt |= PERL_UNICODE_STD_FLAG;     break;
4726                  case PERL_UNICODE_IN:
4727                       opt |= PERL_UNICODE_IN_FLAG;      break;
4728                  case PERL_UNICODE_OUT:
4729                       opt |= PERL_UNICODE_OUT_FLAG;     break;
4730                  case PERL_UNICODE_INOUT:
4731                       opt |= PERL_UNICODE_INOUT_FLAG;   break;
4732                  case PERL_UNICODE_LOCALE:
4733                       opt |= PERL_UNICODE_LOCALE_FLAG;  break;
4734                  case PERL_UNICODE_ARGV:
4735                       opt |= PERL_UNICODE_ARGV_FLAG;    break;
4736                  default:
4737                       if (*p != '\n' && *p != '\r')
4738                           Perl_croak(aTHX_
4739                                      "Unknown Unicode option letter '%c'", *p);
4740                  }
4741             }
4742        }
4743   }
4744   else
4745        opt = PERL_UNICODE_DEFAULT_FLAGS;
4746
4747   if (opt & ~PERL_UNICODE_ALL_FLAGS)
4748        Perl_croak(aTHX_ "Unknown Unicode option value %"UVuf,
4749                   (UV) (opt & ~PERL_UNICODE_ALL_FLAGS));
4750
4751   *popt = p;
4752
4753   return opt;
4754 }
4755
4756 U32
4757 Perl_seed(pTHX)
4758 {
4759     /*
4760      * This is really just a quick hack which grabs various garbage
4761      * values.  It really should be a real hash algorithm which
4762      * spreads the effect of every input bit onto every output bit,
4763      * if someone who knows about such things would bother to write it.
4764      * Might be a good idea to add that function to CORE as well.
4765      * No numbers below come from careful analysis or anything here,
4766      * except they are primes and SEED_C1 > 1E6 to get a full-width
4767      * value from (tv_sec * SEED_C1 + tv_usec).  The multipliers should
4768      * probably be bigger too.
4769      */
4770 #if RANDBITS > 16
4771 #  define SEED_C1       1000003
4772 #define   SEED_C4       73819
4773 #else
4774 #  define SEED_C1       25747
4775 #define   SEED_C4       20639
4776 #endif
4777 #define   SEED_C2       3
4778 #define   SEED_C3       269
4779 #define   SEED_C5       26107
4780
4781 #ifndef PERL_NO_DEV_RANDOM
4782     int fd;
4783 #endif
4784     U32 u;
4785 #ifdef VMS
4786 #  include <starlet.h>
4787     /* when[] = (low 32 bits, high 32 bits) of time since epoch
4788      * in 100-ns units, typically incremented ever 10 ms.        */
4789     unsigned int when[2];
4790 #else
4791 #  ifdef HAS_GETTIMEOFDAY
4792     struct timeval when;
4793 #  else
4794     Time_t when;
4795 #  endif
4796 #endif
4797
4798 /* This test is an escape hatch, this symbol isn't set by Configure. */
4799 #ifndef PERL_NO_DEV_RANDOM
4800 #ifndef PERL_RANDOM_DEVICE
4801    /* /dev/random isn't used by default because reads from it will block
4802     * if there isn't enough entropy available.  You can compile with
4803     * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
4804     * is enough real entropy to fill the seed. */
4805 #  define PERL_RANDOM_DEVICE "/dev/urandom"
4806 #endif
4807     fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
4808     if (fd != -1) {
4809         if (PerlLIO_read(fd, (void*)&u, sizeof u) != sizeof u)
4810             u = 0;
4811         PerlLIO_close(fd);
4812         if (u)
4813             return u;
4814     }
4815 #endif
4816
4817 #ifdef VMS
4818     _ckvmssts(sys$gettim(when));
4819     u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
4820 #else
4821 #  ifdef HAS_GETTIMEOFDAY
4822     PerlProc_gettimeofday(&when,NULL);
4823     u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
4824 #  else
4825     (void)time(&when);
4826     u = (U32)SEED_C1 * when;
4827 #  endif
4828 #endif
4829     u += SEED_C3 * (U32)PerlProc_getpid();
4830     u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
4831 #ifndef PLAN9           /* XXX Plan9 assembler chokes on this; fix needed  */
4832     u += SEED_C5 * (U32)PTR2UV(&when);
4833 #endif
4834     return u;
4835 }
4836
4837 UV
4838 Perl_get_hash_seed(pTHX)
4839 {
4840      const char *s = PerlEnv_getenv("PERL_HASH_SEED");
4841      UV myseed = 0;
4842
4843      if (s)
4844           while (isSPACE(*s)) s++;
4845      if (s && isDIGIT(*s))
4846           myseed = (UV)Atoul(s);
4847      else
4848 #ifdef USE_HASH_SEED_EXPLICIT
4849      if (s)
4850 #endif
4851      {
4852           /* Compute a random seed */
4853           (void)seedDrand01((Rand_seed_t)seed());
4854           myseed = (UV)(Drand01() * (NV)UV_MAX);
4855 #if RANDBITS < (UVSIZE * 8)
4856           /* Since there are not enough randbits to to reach all
4857            * the bits of a UV, the low bits might need extra
4858            * help.  Sum in another random number that will
4859            * fill in the low bits. */
4860           myseed +=
4861                (UV)(Drand01() * (NV)((1 << ((UVSIZE * 8 - RANDBITS))) - 1));
4862 #endif /* RANDBITS < (UVSIZE * 8) */
4863           if (myseed == 0) { /* Superparanoia. */
4864               myseed = (UV)(Drand01() * (NV)UV_MAX); /* One more chance. */
4865               if (myseed == 0)
4866                   Perl_croak(aTHX_ "Your random numbers are not that random");
4867           }
4868      }
4869      PL_rehash_seed_set = TRUE;
4870
4871      return myseed;
4872 }
4873
4874 #ifdef USE_ITHREADS
4875 bool
4876 Perl_stashpv_hvname_match(pTHX_ const COP *c, const HV *hv)
4877 {
4878     const char * const stashpv = CopSTASHPV(c);
4879     const char * const name = HvNAME_get(hv);
4880
4881     if (stashpv == name)
4882         return TRUE;
4883     if (stashpv && name)
4884         if (strEQ(stashpv, name))
4885             return TRUE;
4886     return FALSE;
4887 }
4888 #endif
4889
4890
4891 #ifdef PERL_GLOBAL_STRUCT
4892
4893 struct perl_vars *
4894 Perl_init_global_struct(pTHX)
4895 {
4896     struct perl_vars *plvarsp = NULL;
4897 #ifdef PERL_GLOBAL_STRUCT
4898 #  define PERL_GLOBAL_STRUCT_INIT
4899 #  include "opcode.h" /* the ppaddr and check */
4900     IV nppaddr = sizeof(Gppaddr)/sizeof(Perl_ppaddr_t);
4901     IV ncheck  = sizeof(Gcheck) /sizeof(Perl_check_t);
4902 #  ifdef PERL_GLOBAL_STRUCT_PRIVATE
4903     /* PerlMem_malloc() because can't use even safesysmalloc() this early. */
4904     plvarsp = (struct perl_vars*)PerlMem_malloc(sizeof(struct perl_vars));
4905     if (!plvarsp)
4906         exit(1);
4907 #  else
4908     plvarsp = PL_VarsPtr;
4909 #  endif /* PERL_GLOBAL_STRUCT_PRIVATE */
4910 #  undef PERLVAR
4911 #  undef PERLVARA
4912 #  undef PERLVARI
4913 #  undef PERLVARIC
4914 #  undef PERLVARISC
4915 #  define PERLVAR(var,type) /**/
4916 #  define PERLVARA(var,n,type) /**/
4917 #  define PERLVARI(var,type,init) plvarsp->var = init;
4918 #  define PERLVARIC(var,type,init) plvarsp->var = init;
4919 #  define PERLVARISC(var,init) Copy(init, plvarsp->var, sizeof(init), char);
4920 #  include "perlvars.h"
4921 #  undef PERLVAR
4922 #  undef PERLVARA
4923 #  undef PERLVARI
4924 #  undef PERLVARIC
4925 #  undef PERLVARISC
4926 #  ifdef PERL_GLOBAL_STRUCT
4927     plvarsp->Gppaddr = PerlMem_malloc(nppaddr * sizeof(Perl_ppaddr_t));
4928     if (!plvarsp->Gppaddr)
4929         exit(1);
4930     plvarsp->Gcheck  = PerlMem_malloc(ncheck  * sizeof(Perl_check_t));
4931     if (!plvarsp->Gcheck)
4932         exit(1);
4933     Copy(Gppaddr, plvarsp->Gppaddr, nppaddr, Perl_ppaddr_t);
4934     Copy(Gcheck,  plvarsp->Gcheck,  ncheck,  Perl_check_t);
4935 #  endif
4936 #  ifdef PERL_SET_VARS
4937     PERL_SET_VARS(plvarsp);
4938 #  endif
4939 #  undef PERL_GLOBAL_STRUCT_INIT
4940 #endif
4941     return plvarsp;
4942 }
4943
4944 #endif /* PERL_GLOBAL_STRUCT */
4945
4946 #ifdef PERL_GLOBAL_STRUCT
4947
4948 void
4949 Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp)
4950 {
4951 #ifdef PERL_GLOBAL_STRUCT
4952 #  ifdef PERL_UNSET_VARS
4953     PERL_UNSET_VARS(plvarsp);
4954 #  endif
4955     free(plvarsp->Gppaddr);
4956     free(plvarsp->Gcheck);
4957 #    ifdef PERL_GLOBAL_STRUCT_PRIVATE
4958     free(plvarsp);
4959 #    endif
4960 #endif
4961 }
4962
4963 #endif /* PERL_GLOBAL_STRUCT */
4964
4965 /*
4966  * Local variables:
4967  * c-indentation-style: bsd
4968  * c-basic-offset: 4
4969  * indent-tabs-mode: t
4970  * End:
4971  *
4972  * ex: set ts=8 sts=4 sw=4 noet:
4973  */