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