util.c

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