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 WIN32
2525     int saved_win32_errno;
2526 #endif
2527
2528     LOCK_FDPID_MUTEX;
2529     svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE);
2530     UNLOCK_FDPID_MUTEX;
2531     pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
2532     SvREFCNT_dec(*svp);
2533     *svp = &PL_sv_undef;
2534 #ifdef OS2
2535     if (pid == -1) {                    /* Opened by popen. */
2536         return my_syspclose(ptr);
2537     }
2538 #endif
2539     if ((close_failed = (PerlIO_close(ptr) == EOF))) {
2540         saved_errno = errno;
2541 #ifdef WIN32
2542         saved_win32_errno = GetLastError();
2543 #endif
2544     }
2545 #ifdef UTS
2546     if(PerlProc_kill(pid, 0) < 0) { return(pid); }   /* HOM 12/23/91 */
2547 #endif
2548 #ifndef PERL_MICRO
2549     rsignal_save(SIGHUP, SIG_IGN, &hstat);
2550     rsignal_save(SIGINT, SIG_IGN, &istat);
2551     rsignal_save(SIGQUIT, SIG_IGN, &qstat);
2552 #endif
2553     do {
2554         pid2 = wait4pid(pid, &status, 0);
2555     } while (pid2 == -1 && errno == EINTR);
2556 #ifndef PERL_MICRO
2557     rsignal_restore(SIGHUP, &hstat);
2558     rsignal_restore(SIGINT, &istat);
2559     rsignal_restore(SIGQUIT, &qstat);
2560 #endif
2561     if (close_failed) {
2562         SETERRNO(saved_errno, 0);
2563         return -1;
2564     }
2565     return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status));
2566 }
2567 #endif /* !DOSISH */
2568
2569 #if  (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(MACOS_TRADITIONAL)
2570 I32
2571 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
2572 {
2573     I32 result = 0;
2574     if (!pid)
2575         return -1;
2576 #if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME)
2577     {
2578         char spid[TYPE_CHARS(IV)];
2579
2580         if (pid > 0) {
2581             SV** svp;
2582             sprintf(spid, "%"IVdf, (IV)pid);
2583             svp = hv_fetch(PL_pidstatus,spid,strlen(spid),FALSE);
2584             if (svp && *svp != &PL_sv_undef) {
2585                 *statusp = SvIVX(*svp);
2586                 (void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD);
2587                 return pid;
2588             }
2589         }
2590         else {
2591             HE *entry;
2592
2593             hv_iterinit(PL_pidstatus);
2594             if ((entry = hv_iternext(PL_pidstatus))) {
2595                 SV *sv = hv_iterval(PL_pidstatus,entry);
2596
2597                 pid = atoi(hv_iterkey(entry,(I32*)statusp));
2598                 *statusp = SvIVX(sv);
2599                 sprintf(spid, "%"IVdf, (IV)pid);
2600                 (void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD);
2601                 return pid;
2602             }
2603         }
2604     }
2605 #endif
2606 #ifdef HAS_WAITPID
2607 #  ifdef HAS_WAITPID_RUNTIME
2608     if (!HAS_WAITPID_RUNTIME)
2609         goto hard_way;
2610 #  endif
2611     result = PerlProc_waitpid(pid,statusp,flags);
2612     goto finish;
2613 #endif
2614 #if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
2615     result = wait4((pid==-1)?0:pid,statusp,flags,Null(struct rusage *));
2616     goto finish;
2617 #endif
2618 #if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME)
2619 #if defined(HAS_WAITPID) && defined(HAS_WAITPID_RUNTIME)
2620   hard_way:
2621 #endif
2622     {
2623         if (flags)
2624             Perl_croak(aTHX_ "Can't do waitpid with flags");
2625         else {
2626             while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
2627                 pidgone(result,*statusp);
2628             if (result < 0)
2629                 *statusp = -1;
2630         }
2631     }
2632 #endif
2633 #if defined(HAS_WAITPID) || defined(HAS_WAIT4)
2634   finish:
2635 #endif
2636     if (result < 0 && errno == EINTR) {
2637         PERL_ASYNC_CHECK();
2638     }
2639     return result;
2640 }
2641 #endif /* !DOSISH || OS2 || WIN32 || NETWARE */
2642
2643 void
2644 /*SUPPRESS 590*/
2645 Perl_pidgone(pTHX_ Pid_t pid, int status)
2646 {
2647     register SV *sv;
2648     char spid[TYPE_CHARS(IV)];
2649
2650     sprintf(spid, "%"IVdf, (IV)pid);
2651     sv = *hv_fetch(PL_pidstatus,spid,strlen(spid),TRUE);
2652     SvUPGRADE(sv,SVt_IV);
2653     SvIV_set(sv, status);
2654     return;
2655 }
2656
2657 #if defined(atarist) || defined(OS2) || defined(EPOC)
2658 int pclose();
2659 #ifdef HAS_FORK
2660 int                                     /* Cannot prototype with I32
2661                                            in os2ish.h. */
2662 my_syspclose(PerlIO *ptr)
2663 #else
2664 I32
2665 Perl_my_pclose(pTHX_ PerlIO *ptr)
2666 #endif
2667 {
2668     /* Needs work for PerlIO ! */
2669     FILE *f = PerlIO_findFILE(ptr);
2670     I32 result = pclose(f);
2671     PerlIO_releaseFILE(ptr,f);
2672     return result;
2673 }
2674 #endif
2675
2676 #if defined(DJGPP)
2677 int djgpp_pclose();
2678 I32
2679 Perl_my_pclose(pTHX_ PerlIO *ptr)
2680 {
2681     /* Needs work for PerlIO ! */
2682     FILE *f = PerlIO_findFILE(ptr);
2683     I32 result = djgpp_pclose(f);
2684     result = (result << 8) & 0xff00;
2685     PerlIO_releaseFILE(ptr,f);
2686     return result;
2687 }
2688 #endif
2689
2690 void
2691 Perl_repeatcpy(pTHX_ register char *to, register const char *from, I32 len, register I32 count)
2692 {
2693     register I32 todo;
2694     register const char *frombase = from;
2695
2696     if (len == 1) {
2697         register const char c = *from;
2698         while (count-- > 0)
2699             *to++ = c;
2700         return;
2701     }
2702     while (count-- > 0) {
2703         for (todo = len; todo > 0; todo--) {
2704             *to++ = *from++;
2705         }
2706         from = frombase;
2707     }
2708 }
2709
2710 #ifndef HAS_RENAME
2711 I32
2712 Perl_same_dirent(pTHX_ const char *a, const char *b)
2713 {
2714     char *fa = strrchr(a,'/');
2715     char *fb = strrchr(b,'/');
2716     Stat_t tmpstatbuf1;
2717     Stat_t tmpstatbuf2;
2718     SV *tmpsv = sv_newmortal();
2719
2720     if (fa)
2721         fa++;
2722     else
2723         fa = a;
2724     if (fb)
2725         fb++;
2726     else
2727         fb = b;
2728     if (strNE(a,b))
2729         return FALSE;
2730     if (fa == a)
2731         sv_setpvn(tmpsv, ".", 1);
2732     else
2733         sv_setpvn(tmpsv, a, fa - a);
2734     if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0)
2735         return FALSE;
2736     if (fb == b)
2737         sv_setpvn(tmpsv, ".", 1);
2738     else
2739         sv_setpvn(tmpsv, b, fb - b);
2740     if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0)
2741         return FALSE;
2742     return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
2743            tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
2744 }
2745 #endif /* !HAS_RENAME */
2746
2747 char*
2748 Perl_find_script(pTHX_ const char *scriptname, bool dosearch, const char **search_ext, I32 flags)
2749 {
2750     const char *xfound = Nullch;
2751     char *xfailed = Nullch;
2752     char tmpbuf[MAXPATHLEN];
2753     register char *s;
2754     I32 len = 0;
2755     int retval;
2756 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
2757 #  define SEARCH_EXTS ".bat", ".cmd", NULL
2758 #  define MAX_EXT_LEN 4
2759 #endif
2760 #ifdef OS2
2761 #  define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
2762 #  define MAX_EXT_LEN 4
2763 #endif
2764 #ifdef VMS
2765 #  define SEARCH_EXTS ".pl", ".com", NULL
2766 #  define MAX_EXT_LEN 4
2767 #endif
2768     /* additional extensions to try in each dir if scriptname not found */
2769 #ifdef SEARCH_EXTS
2770     const char *exts[] = { SEARCH_EXTS };
2771     const char **ext = search_ext ? search_ext : exts;
2772     int extidx = 0, i = 0;
2773     const char *curext = Nullch;
2774 #else
2775     (void)search_ext;
2776 #  define MAX_EXT_LEN 0
2777 #endif
2778
2779     /*
2780      * If dosearch is true and if scriptname does not contain path
2781      * delimiters, search the PATH for scriptname.
2782      *
2783      * If SEARCH_EXTS is also defined, will look for each
2784      * scriptname{SEARCH_EXTS} whenever scriptname is not found
2785      * while searching the PATH.
2786      *
2787      * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
2788      * proceeds as follows:
2789      *   If DOSISH or VMSISH:
2790      *     + look for ./scriptname{,.foo,.bar}
2791      *     + search the PATH for scriptname{,.foo,.bar}
2792      *
2793      *   If !DOSISH:
2794      *     + look *only* in the PATH for scriptname{,.foo,.bar} (note
2795      *       this will not look in '.' if it's not in the PATH)
2796      */
2797     tmpbuf[0] = '\0';
2798
2799 #ifdef VMS
2800 #  ifdef ALWAYS_DEFTYPES
2801     len = strlen(scriptname);
2802     if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
2803         int hasdir, idx = 0, deftypes = 1;
2804         bool seen_dot = 1;
2805
2806         hasdir = !dosearch || (strpbrk(scriptname,":[</") != Nullch) ;
2807 #  else
2808     if (dosearch) {
2809         int hasdir, idx = 0, deftypes = 1;
2810         bool seen_dot = 1;
2811
2812         hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
2813 #  endif
2814         /* The first time through, just add SEARCH_EXTS to whatever we
2815          * already have, so we can check for default file types. */
2816         while (deftypes ||
2817                (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
2818         {
2819             if (deftypes) {
2820                 deftypes = 0;
2821                 *tmpbuf = '\0';
2822             }
2823             if ((strlen(tmpbuf) + strlen(scriptname)
2824                  + MAX_EXT_LEN) >= sizeof tmpbuf)
2825                 continue;       /* don't search dir with too-long name */
2826             strcat(tmpbuf, scriptname);
2827 #else  /* !VMS */
2828
2829 #ifdef DOSISH
2830     if (strEQ(scriptname, "-"))
2831         dosearch = 0;
2832     if (dosearch) {             /* Look in '.' first. */
2833         const char *cur = scriptname;
2834 #ifdef SEARCH_EXTS
2835         if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
2836             while (ext[i])
2837                 if (strEQ(ext[i++],curext)) {
2838                     extidx = -1;                /* already has an ext */
2839                     break;
2840                 }
2841         do {
2842 #endif
2843             DEBUG_p(PerlIO_printf(Perl_debug_log,
2844                                   "Looking for %s\n",cur));
2845             if (PerlLIO_stat(cur,&PL_statbuf) >= 0
2846                 && !S_ISDIR(PL_statbuf.st_mode)) {
2847                 dosearch = 0;
2848                 scriptname = cur;
2849 #ifdef SEARCH_EXTS
2850                 break;
2851 #endif
2852             }
2853 #ifdef SEARCH_EXTS
2854             if (cur == scriptname) {
2855                 len = strlen(scriptname);
2856                 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
2857                     break;
2858                 cur = strcpy(tmpbuf, scriptname);
2859             }
2860         } while (extidx >= 0 && ext[extidx]     /* try an extension? */
2861                  && strcpy(tmpbuf+len, ext[extidx++]));
2862 #endif
2863     }
2864 #endif
2865
2866 #ifdef MACOS_TRADITIONAL
2867     if (dosearch && !strchr(scriptname, ':') &&
2868         (s = PerlEnv_getenv("Commands")))
2869 #else
2870     if (dosearch && !strchr(scriptname, '/')
2871 #ifdef DOSISH
2872                  && !strchr(scriptname, '\\')
2873 #endif
2874                  && (s = PerlEnv_getenv("PATH")))
2875 #endif
2876     {
2877         bool seen_dot = 0;
2878
2879         PL_bufend = s + strlen(s);
2880         while (s < PL_bufend) {
2881 #ifdef MACOS_TRADITIONAL
2882             s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
2883                         ',',
2884                         &len);
2885 #else
2886 #if defined(atarist) || defined(DOSISH)
2887             for (len = 0; *s
2888 #  ifdef atarist
2889                     && *s != ','
2890 #  endif
2891                     && *s != ';'; len++, s++) {
2892                 if (len < sizeof tmpbuf)
2893                     tmpbuf[len] = *s;
2894             }
2895             if (len < sizeof tmpbuf)
2896                 tmpbuf[len] = '\0';
2897 #else  /* ! (atarist || DOSISH) */
2898             s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
2899                         ':',
2900                         &len);
2901 #endif /* ! (atarist || DOSISH) */
2902 #endif /* MACOS_TRADITIONAL */
2903             if (s < PL_bufend)
2904                 s++;
2905             if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
2906                 continue;       /* don't search dir with too-long name */
2907 #ifdef MACOS_TRADITIONAL
2908             if (len && tmpbuf[len - 1] != ':')
2909                 tmpbuf[len++] = ':';
2910 #else
2911             if (len
2912 #if defined(atarist) || defined(__MINT__) || defined(DOSISH)
2913                 && tmpbuf[len - 1] != '/'
2914                 && tmpbuf[len - 1] != '\\'
2915 #endif
2916                )
2917                 tmpbuf[len++] = '/';
2918             if (len == 2 && tmpbuf[0] == '.')
2919                 seen_dot = 1;
2920 #endif
2921             (void)strcpy(tmpbuf + len, scriptname);
2922 #endif  /* !VMS */
2923
2924 #ifdef SEARCH_EXTS
2925             len = strlen(tmpbuf);
2926             if (extidx > 0)     /* reset after previous loop */
2927                 extidx = 0;
2928             do {
2929 #endif
2930                 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
2931                 retval = PerlLIO_stat(tmpbuf,&PL_statbuf);
2932                 if (S_ISDIR(PL_statbuf.st_mode)) {
2933                     retval = -1;
2934                 }
2935 #ifdef SEARCH_EXTS
2936             } while (  retval < 0               /* not there */
2937                     && extidx>=0 && ext[extidx] /* try an extension? */
2938                     && strcpy(tmpbuf+len, ext[extidx++])
2939                 );
2940 #endif
2941             if (retval < 0)
2942                 continue;
2943             if (S_ISREG(PL_statbuf.st_mode)
2944                 && cando(S_IRUSR,TRUE,&PL_statbuf)
2945 #if !defined(DOSISH) && !defined(MACOS_TRADITIONAL)
2946                 && cando(S_IXUSR,TRUE,&PL_statbuf)
2947 #endif
2948                 )
2949             {
2950                 xfound = tmpbuf;                /* bingo! */
2951                 break;
2952             }
2953             if (!xfailed)
2954                 xfailed = savepv(tmpbuf);
2955         }
2956 #ifndef DOSISH
2957         if (!xfound && !seen_dot && !xfailed &&
2958             (PerlLIO_stat(scriptname,&PL_statbuf) < 0
2959              || S_ISDIR(PL_statbuf.st_mode)))
2960 #endif
2961             seen_dot = 1;                       /* Disable message. */
2962         if (!xfound) {
2963             if (flags & 1) {                    /* do or die? */
2964                 Perl_croak(aTHX_ "Can't %s %s%s%s",
2965                       (xfailed ? "execute" : "find"),
2966                       (xfailed ? xfailed : scriptname),
2967                       (xfailed ? "" : " on PATH"),
2968                       (xfailed || seen_dot) ? "" : ", '.' not in PATH");
2969             }
2970             scriptname = Nullch;
2971         }
2972         if (xfailed)
2973             Safefree(xfailed);
2974         scriptname = xfound;
2975     }
2976     return (scriptname ? savepv(scriptname) : Nullch);
2977 }
2978
2979 #ifndef PERL_GET_CONTEXT_DEFINED
2980
2981 void *
2982 Perl_get_context(void)
2983 {
2984     dVAR;
2985 #if defined(USE_ITHREADS)
2986 #  ifdef OLD_PTHREADS_API
2987     pthread_addr_t t;
2988     if (pthread_getspecific(PL_thr_key, &t))
2989         Perl_croak_nocontext("panic: pthread_getspecific");
2990     return (void*)t;
2991 #  else
2992 #    ifdef I_MACH_CTHREADS
2993     return (void*)cthread_data(cthread_self());
2994 #    else
2995     return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
2996 #    endif
2997 #  endif
2998 #else
2999     return (void*)NULL;
3000 #endif
3001 }
3002
3003 void
3004 Perl_set_context(void *t)
3005 {
3006    dVAR;
3007 #if defined(USE_ITHREADS)
3008 #  ifdef I_MACH_CTHREADS
3009     cthread_set_data(cthread_self(), t);
3010 #  else
3011     if (pthread_setspecific(PL_thr_key, t))
3012         Perl_croak_nocontext("panic: pthread_setspecific");
3013 #  endif
3014 #else
3015     (void)t;
3016 #endif
3017 }
3018
3019 #endif /* !PERL_GET_CONTEXT_DEFINED */
3020
3021 #if defined(PERL_GLOBAL_STRUCT) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
3022 struct perl_vars *
3023 Perl_GetVars(pTHX)
3024 {
3025  return &PL_Vars;
3026 }
3027 #endif
3028
3029 char **
3030 Perl_get_op_names(pTHX)
3031 {
3032  return (char **)PL_op_name;
3033 }
3034
3035 char **
3036 Perl_get_op_descs(pTHX)
3037 {
3038  return (char **)PL_op_desc;
3039 }
3040
3041 const char *
3042 Perl_get_no_modify(pTHX)
3043 {
3044  return PL_no_modify;
3045 }
3046
3047 U32 *
3048 Perl_get_opargs(pTHX)
3049 {
3050  return (U32 *)PL_opargs;
3051 }
3052
3053 PPADDR_t*
3054 Perl_get_ppaddr(pTHX)
3055 {
3056  dVAR;
3057  return (PPADDR_t*)PL_ppaddr;
3058 }
3059
3060 #ifndef HAS_GETENV_LEN
3061 char *
3062 Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
3063 {
3064     char *env_trans = PerlEnv_getenv(env_elem);
3065     if (env_trans)
3066         *len = strlen(env_trans);
3067     return env_trans;
3068 }
3069 #endif
3070
3071
3072 MGVTBL*
3073 Perl_get_vtbl(pTHX_ int vtbl_id)
3074 {
3075     const MGVTBL* result = Null(MGVTBL*);
3076
3077     switch(vtbl_id) {
3078     case want_vtbl_sv:
3079         result = &PL_vtbl_sv;
3080         break;
3081     case want_vtbl_env:
3082         result = &PL_vtbl_env;
3083         break;
3084     case want_vtbl_envelem:
3085         result = &PL_vtbl_envelem;
3086         break;
3087     case want_vtbl_sig:
3088         result = &PL_vtbl_sig;
3089         break;
3090     case want_vtbl_sigelem:
3091         result = &PL_vtbl_sigelem;
3092         break;
3093     case want_vtbl_pack:
3094         result = &PL_vtbl_pack;
3095         break;
3096     case want_vtbl_packelem:
3097         result = &PL_vtbl_packelem;
3098         break;
3099     case want_vtbl_dbline:
3100         result = &PL_vtbl_dbline;
3101         break;
3102     case want_vtbl_isa:
3103         result = &PL_vtbl_isa;
3104         break;
3105     case want_vtbl_isaelem:
3106         result = &PL_vtbl_isaelem;
3107         break;
3108     case want_vtbl_arylen:
3109         result = &PL_vtbl_arylen;
3110         break;
3111     case want_vtbl_glob:
3112         result = &PL_vtbl_glob;
3113         break;
3114     case want_vtbl_mglob:
3115         result = &PL_vtbl_mglob;
3116         break;
3117     case want_vtbl_nkeys:
3118         result = &PL_vtbl_nkeys;
3119         break;
3120     case want_vtbl_taint:
3121         result = &PL_vtbl_taint;
3122         break;
3123     case want_vtbl_substr:
3124         result = &PL_vtbl_substr;
3125         break;
3126     case want_vtbl_vec:
3127         result = &PL_vtbl_vec;
3128         break;
3129     case want_vtbl_pos:
3130         result = &PL_vtbl_pos;
3131         break;
3132     case want_vtbl_bm:
3133         result = &PL_vtbl_bm;
3134         break;
3135     case want_vtbl_fm:
3136         result = &PL_vtbl_fm;
3137         break;
3138     case want_vtbl_uvar:
3139         result = &PL_vtbl_uvar;
3140         break;
3141     case want_vtbl_defelem:
3142         result = &PL_vtbl_defelem;
3143         break;
3144     case want_vtbl_regexp:
3145         result = &PL_vtbl_regexp;
3146         break;
3147     case want_vtbl_regdata:
3148         result = &PL_vtbl_regdata;
3149         break;
3150     case want_vtbl_regdatum:
3151         result = &PL_vtbl_regdatum;
3152         break;
3153 #ifdef USE_LOCALE_COLLATE
3154     case want_vtbl_collxfrm:
3155         result = &PL_vtbl_collxfrm;
3156         break;
3157 #endif
3158     case want_vtbl_amagic:
3159         result = &PL_vtbl_amagic;
3160         break;
3161     case want_vtbl_amagicelem:
3162         result = &PL_vtbl_amagicelem;
3163         break;
3164     case want_vtbl_backref:
3165         result = &PL_vtbl_backref;
3166         break;
3167     case want_vtbl_utf8:
3168         result = &PL_vtbl_utf8;
3169         break;
3170     }
3171     return (MGVTBL*)result;
3172 }
3173
3174 I32
3175 Perl_my_fflush_all(pTHX)
3176 {
3177 #if defined(USE_PERLIO) || defined(FFLUSH_NULL) || defined(USE_SFIO)
3178     return PerlIO_flush(NULL);
3179 #else
3180 # if defined(HAS__FWALK)
3181     extern int fflush(FILE *);
3182     /* undocumented, unprototyped, but very useful BSDism */
3183     extern void _fwalk(int (*)(FILE *));
3184     _fwalk(&fflush);
3185     return 0;
3186 # else
3187 #  if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
3188     long open_max = -1;
3189 #   ifdef PERL_FFLUSH_ALL_FOPEN_MAX
3190     open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
3191 #   else
3192 #    if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
3193     open_max = sysconf(_SC_OPEN_MAX);
3194 #     else
3195 #      ifdef FOPEN_MAX
3196     open_max = FOPEN_MAX;
3197 #      else
3198 #       ifdef OPEN_MAX
3199     open_max = OPEN_MAX;
3200 #       else
3201 #        ifdef _NFILE
3202     open_max = _NFILE;
3203 #        endif
3204 #       endif
3205 #      endif
3206 #     endif
3207 #    endif
3208     if (open_max > 0) {
3209       long i;
3210       for (i = 0; i < open_max; i++)
3211             if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
3212                 STDIO_STREAM_ARRAY[i]._file < open_max &&
3213                 STDIO_STREAM_ARRAY[i]._flag)
3214                 PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
3215       return 0;
3216     }
3217 #  endif
3218     SETERRNO(EBADF,RMS_IFI);
3219     return EOF;
3220 # endif
3221 #endif
3222 }
3223
3224 void
3225 Perl_report_evil_fh(pTHX_ const GV *gv, const IO *io, I32 op)
3226 {
3227     const char *func =
3228         op == OP_READLINE   ? "readline"  :     /* "<HANDLE>" not nice */
3229         op == OP_LEAVEWRITE ? "write" :         /* "write exit" not nice */
3230         PL_op_desc[op];
3231     const char *pars = OP_IS_FILETEST(op) ? "" : "()";
3232     const char *type = OP_IS_SOCKET(op)
3233             || (gv && io && IoTYPE(io) == IoTYPE_SOCKET)
3234                 ?  "socket" : "filehandle";
3235     const char *name = NULL;
3236
3237     if (gv && isGV(gv)) {
3238         name = GvENAME(gv);
3239     }
3240
3241     if (op == OP_phoney_OUTPUT_ONLY || op == OP_phoney_INPUT_ONLY) {
3242         if (ckWARN(WARN_IO)) {
3243             const char *direction = (op == OP_phoney_INPUT_ONLY) ? "in" : "out";
3244             if (name && *name)
3245                 Perl_warner(aTHX_ packWARN(WARN_IO),
3246                             "Filehandle %s opened only for %sput",
3247                             name, direction);
3248             else
3249                 Perl_warner(aTHX_ packWARN(WARN_IO),
3250                             "Filehandle opened only for %sput", direction);
3251         }
3252     }
3253     else {
3254         const char *vile;
3255         I32   warn_type;
3256
3257         if (gv && io && IoTYPE(io) == IoTYPE_CLOSED) {
3258             vile = "closed";
3259             warn_type = WARN_CLOSED;
3260         }
3261         else {
3262             vile = "unopened";
3263             warn_type = WARN_UNOPENED;
3264         }
3265
3266         if (ckWARN(warn_type)) {
3267             if (name && *name) {
3268                 Perl_warner(aTHX_ packWARN(warn_type),
3269                             "%s%s on %s %s %s", func, pars, vile, type, name);
3270                 if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3271                     Perl_warner(
3272                         aTHX_ packWARN(warn_type),
3273                         "\t(Are you trying to call %s%s on dirhandle %s?)\n",
3274                         func, pars, name
3275                     );
3276             }
3277             else {
3278                 Perl_warner(aTHX_ packWARN(warn_type),
3279                             "%s%s on %s %s", func, pars, vile, type);
3280                 if (gv && io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3281                     Perl_warner(
3282                         aTHX_ packWARN(warn_type),
3283                         "\t(Are you trying to call %s%s on dirhandle?)\n",
3284                         func, pars
3285                     );
3286             }
3287         }
3288     }
3289 }
3290
3291 #ifdef EBCDIC
3292 /* in ASCII order, not that it matters */
3293 static const char controllablechars[] = "?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_";
3294
3295 int
3296 Perl_ebcdic_control(pTHX_ int ch)
3297 {
3298     if (ch > 'a') {
3299         const char *ctlp;
3300
3301         if (islower(ch))
3302             ch = toupper(ch);
3303
3304         if ((ctlp = strchr(controllablechars, ch)) == 0) {
3305             Perl_die(aTHX_ "unrecognised control character '%c'\n", ch);
3306         }
3307
3308         if (ctlp == controllablechars)
3309             return('\177'); /* DEL */
3310         else
3311             return((unsigned char)(ctlp - controllablechars - 1));
3312     } else { /* Want uncontrol */
3313         if (ch == '\177' || ch == -1)
3314             return('?');
3315         else if (ch == '\157')
3316             return('\177');
3317         else if (ch == '\174')
3318             return('\000');
3319         else if (ch == '^')    /* '\137' in 1047, '\260' in 819 */
3320             return('\036');
3321         else if (ch == '\155')
3322             return('\037');
3323         else if (0 < ch && ch < (sizeof(controllablechars) - 1))
3324             return(controllablechars[ch+1]);
3325         else
3326             Perl_die(aTHX_ "invalid control request: '\\%03o'\n", ch & 0xFF);
3327     }
3328 }
3329 #endif
3330
3331 /* To workaround core dumps from the uninitialised tm_zone we get the
3332  * system to give us a reasonable struct to copy.  This fix means that
3333  * strftime uses the tm_zone and tm_gmtoff values returned by
3334  * localtime(time()). That should give the desired result most of the
3335  * time. But probably not always!
3336  *
3337  * This does not address tzname aspects of NETaa14816.
3338  *
3339  */
3340
3341 #ifdef HAS_GNULIBC
3342 # ifndef STRUCT_TM_HASZONE
3343 #    define STRUCT_TM_HASZONE
3344 # endif
3345 #endif
3346
3347 #ifdef STRUCT_TM_HASZONE /* Backward compat */
3348 # ifndef HAS_TM_TM_ZONE
3349 #    define HAS_TM_TM_ZONE
3350 # endif
3351 #endif
3352
3353 void
3354 Perl_init_tm(pTHX_ struct tm *ptm)      /* see mktime, strftime and asctime */
3355 {
3356 #ifdef HAS_TM_TM_ZONE
3357     Time_t now;
3358     struct tm* my_tm;
3359     (void)time(&now);
3360     my_tm = localtime(&now);
3361     if (my_tm)
3362         Copy(my_tm, ptm, 1, struct tm);
3363 #endif
3364 }
3365
3366 /*
3367  * mini_mktime - normalise struct tm values without the localtime()
3368  * semantics (and overhead) of mktime().
3369  */
3370 void
3371 Perl_mini_mktime(pTHX_ struct tm *ptm)
3372 {
3373     int yearday;
3374     int secs;
3375     int month, mday, year, jday;
3376     int odd_cent, odd_year;
3377
3378 #define DAYS_PER_YEAR   365
3379 #define DAYS_PER_QYEAR  (4*DAYS_PER_YEAR+1)
3380 #define DAYS_PER_CENT   (25*DAYS_PER_QYEAR-1)
3381 #define DAYS_PER_QCENT  (4*DAYS_PER_CENT+1)
3382 #define SECS_PER_HOUR   (60*60)
3383 #define SECS_PER_DAY    (24*SECS_PER_HOUR)
3384 /* parentheses deliberately absent on these two, otherwise they don't work */
3385 #define MONTH_TO_DAYS   153/5
3386 #define DAYS_TO_MONTH   5/153
3387 /* offset to bias by March (month 4) 1st between month/mday & year finding */
3388 #define YEAR_ADJUST     (4*MONTH_TO_DAYS+1)
3389 /* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */
3390 #define WEEKDAY_BIAS    6       /* (1+6)%7 makes Sunday 0 again */
3391
3392 /*
3393  * Year/day algorithm notes:
3394  *
3395  * With a suitable offset for numeric value of the month, one can find
3396  * an offset into the year by considering months to have 30.6 (153/5) days,
3397  * using integer arithmetic (i.e., with truncation).  To avoid too much
3398  * messing about with leap days, we consider January and February to be
3399  * the 13th and 14th month of the previous year.  After that transformation,
3400  * we need the month index we use to be high by 1 from 'normal human' usage,
3401  * so the month index values we use run from 4 through 15.
3402  *
3403  * Given that, and the rules for the Gregorian calendar (leap years are those
3404  * divisible by 4 unless also divisible by 100, when they must be divisible
3405  * by 400 instead), we can simply calculate the number of days since some
3406  * arbitrary 'beginning of time' by futzing with the (adjusted) year number,
3407  * the days we derive from our month index, and adding in the day of the
3408  * month.  The value used here is not adjusted for the actual origin which
3409  * it normally would use (1 January A.D. 1), since we're not exposing it.
3410  * We're only building the value so we can turn around and get the
3411  * normalised values for the year, month, day-of-month, and day-of-year.
3412  *
3413  * For going backward, we need to bias the value we're using so that we find
3414  * the right year value.  (Basically, we don't want the contribution of
3415  * March 1st to the number to apply while deriving the year).  Having done
3416  * that, we 'count up' the contribution to the year number by accounting for
3417  * full quadracenturies (400-year periods) with their extra leap days, plus
3418  * the contribution from full centuries (to avoid counting in the lost leap
3419  * days), plus the contribution from full quad-years (to count in the normal
3420  * leap days), plus the leftover contribution from any non-leap years.
3421  * At this point, if we were working with an actual leap day, we'll have 0
3422  * days left over.  This is also true for March 1st, however.  So, we have
3423  * to special-case that result, and (earlier) keep track of the 'odd'
3424  * century and year contributions.  If we got 4 extra centuries in a qcent,
3425  * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb.
3426  * Otherwise, we add back in the earlier bias we removed (the 123 from
3427  * figuring in March 1st), find the month index (integer division by 30.6),
3428  * and the remainder is the day-of-month.  We then have to convert back to
3429  * 'real' months (including fixing January and February from being 14/15 in
3430  * the previous year to being in the proper year).  After that, to get
3431  * tm_yday, we work with the normalised year and get a new yearday value for
3432  * January 1st, which we subtract from the yearday value we had earlier,
3433  * representing the date we've re-built.  This is done from January 1
3434  * because tm_yday is 0-origin.
3435  *
3436  * Since POSIX time routines are only guaranteed to work for times since the
3437  * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm
3438  * applies Gregorian calendar rules even to dates before the 16th century
3439  * doesn't bother me.  Besides, you'd need cultural context for a given
3440  * date to know whether it was Julian or Gregorian calendar, and that's
3441  * outside the scope for this routine.  Since we convert back based on the
3442  * same rules we used to build the yearday, you'll only get strange results
3443  * for input which needed normalising, or for the 'odd' century years which
3444  * were leap years in the Julian calander but not in the Gregorian one.
3445  * I can live with that.
3446  *
3447  * This algorithm also fails to handle years before A.D. 1 gracefully, but
3448  * that's still outside the scope for POSIX time manipulation, so I don't
3449  * care.
3450  */
3451
3452     year = 1900 + ptm->tm_year;
3453     month = ptm->tm_mon;
3454     mday = ptm->tm_mday;
3455     /* allow given yday with no month & mday to dominate the result */
3456     if (ptm->tm_yday >= 0 && mday <= 0 && month <= 0) {
3457         month = 0;
3458         mday = 0;
3459         jday = 1 + ptm->tm_yday;
3460     }
3461     else {
3462         jday = 0;
3463     }
3464     if (month >= 2)
3465         month+=2;
3466     else
3467         month+=14, year--;
3468     yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400;
3469     yearday += month*MONTH_TO_DAYS + mday + jday;
3470     /*
3471      * Note that we don't know when leap-seconds were or will be,
3472      * so we have to trust the user if we get something which looks
3473      * like a sensible leap-second.  Wild values for seconds will
3474      * be rationalised, however.
3475      */
3476     if ((unsigned) ptm->tm_sec <= 60) {
3477         secs = 0;
3478     }
3479     else {
3480         secs = ptm->tm_sec;
3481         ptm->tm_sec = 0;
3482     }
3483     secs += 60 * ptm->tm_min;
3484     secs += SECS_PER_HOUR * ptm->tm_hour;
3485     if (secs < 0) {
3486         if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) {
3487             /* got negative remainder, but need positive time */
3488             /* back off an extra day to compensate */
3489             yearday += (secs/SECS_PER_DAY)-1;
3490             secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1);
3491         }
3492         else {
3493             yearday += (secs/SECS_PER_DAY);
3494             secs -= SECS_PER_DAY * (secs/SECS_PER_DAY);
3495         }
3496     }
3497     else if (secs >= SECS_PER_DAY) {
3498         yearday += (secs/SECS_PER_DAY);
3499         secs %= SECS_PER_DAY;
3500     }
3501     ptm->tm_hour = secs/SECS_PER_HOUR;
3502     secs %= SECS_PER_HOUR;
3503     ptm->tm_min = secs/60;
3504     secs %= 60;
3505     ptm->tm_sec += secs;
3506     /* done with time of day effects */
3507     /*
3508      * The algorithm for yearday has (so far) left it high by 428.
3509      * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to
3510      * bias it by 123 while trying to figure out what year it
3511      * really represents.  Even with this tweak, the reverse
3512      * translation fails for years before A.D. 0001.
3513      * It would still fail for Feb 29, but we catch that one below.
3514      */
3515     jday = yearday;     /* save for later fixup vis-a-vis Jan 1 */
3516     yearday -= YEAR_ADJUST;
3517     year = (yearday / DAYS_PER_QCENT) * 400;
3518     yearday %= DAYS_PER_QCENT;
3519     odd_cent = yearday / DAYS_PER_CENT;
3520     year += odd_cent * 100;
3521     yearday %= DAYS_PER_CENT;
3522     year += (yearday / DAYS_PER_QYEAR) * 4;
3523     yearday %= DAYS_PER_QYEAR;
3524     odd_year = yearday / DAYS_PER_YEAR;
3525     year += odd_year;
3526     yearday %= DAYS_PER_YEAR;
3527     if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */
3528         month = 1;
3529         yearday = 29;
3530     }
3531     else {
3532         yearday += YEAR_ADJUST; /* recover March 1st crock */
3533         month = yearday*DAYS_TO_MONTH;
3534         yearday -= month*MONTH_TO_DAYS;
3535         /* recover other leap-year adjustment */
3536         if (month > 13) {
3537             month-=14;
3538             year++;
3539         }
3540         else {
3541             month-=2;
3542         }
3543     }
3544     ptm->tm_year = year - 1900;
3545     if (yearday) {
3546       ptm->tm_mday = yearday;
3547       ptm->tm_mon = month;
3548     }
3549     else {
3550       ptm->tm_mday = 31;
3551       ptm->tm_mon = month - 1;
3552     }
3553     /* re-build yearday based on Jan 1 to get tm_yday */
3554     year--;
3555     yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400;
3556     yearday += 14*MONTH_TO_DAYS + 1;
3557     ptm->tm_yday = jday - yearday;
3558     /* fix tm_wday if not overridden by caller */
3559     if ((unsigned)ptm->tm_wday > 6)
3560         ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
3561 }
3562
3563 char *
3564 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)
3565 {
3566 #ifdef HAS_STRFTIME
3567   char *buf;
3568   int buflen;
3569   struct tm mytm;
3570   int len;
3571
3572   init_tm(&mytm);       /* XXX workaround - see init_tm() above */
3573   mytm.tm_sec = sec;
3574   mytm.tm_min = min;
3575   mytm.tm_hour = hour;
3576   mytm.tm_mday = mday;
3577   mytm.tm_mon = mon;
3578   mytm.tm_year = year;
3579   mytm.tm_wday = wday;
3580   mytm.tm_yday = yday;
3581   mytm.tm_isdst = isdst;
3582   mini_mktime(&mytm);
3583   /* use libc to get the values for tm_gmtoff and tm_zone [perl #18238] */
3584 #if defined(HAS_MKTIME) && (defined(HAS_TM_TM_GMTOFF) || defined(HAS_TM_TM_ZONE))
3585   STMT_START {
3586     struct tm mytm2;
3587     mytm2 = mytm;
3588     mktime(&mytm2);
3589 #ifdef HAS_TM_TM_GMTOFF
3590     mytm.tm_gmtoff = mytm2.tm_gmtoff;
3591 #endif
3592 #ifdef HAS_TM_TM_ZONE
3593     mytm.tm_zone = mytm2.tm_zone;
3594 #endif
3595   } STMT_END;
3596 #endif
3597   buflen = 64;
3598   New(0, buf, buflen, char);
3599   len = strftime(buf, buflen, fmt, &mytm);
3600   /*
3601   ** The following is needed to handle to the situation where
3602   ** tmpbuf overflows.  Basically we want to allocate a buffer
3603   ** and try repeatedly.  The reason why it is so complicated
3604   ** is that getting a return value of 0 from strftime can indicate
3605   ** one of the following:
3606   ** 1. buffer overflowed,
3607   ** 2. illegal conversion specifier, or
3608   ** 3. the format string specifies nothing to be returned(not
3609   **      an error).  This could be because format is an empty string
3610   **    or it specifies %p that yields an empty string in some locale.
3611   ** If there is a better way to make it portable, go ahead by
3612   ** all means.
3613   */
3614   if ((len > 0 && len < buflen) || (len == 0 && *fmt == '\0'))
3615     return buf;
3616   else {
3617     /* Possibly buf overflowed - try again with a bigger buf */
3618     const int fmtlen = strlen(fmt);
3619     const int bufsize = fmtlen + buflen;
3620
3621     New(0, buf, bufsize, char);
3622     while (buf) {
3623       buflen = strftime(buf, bufsize, fmt, &mytm);
3624       if (buflen > 0 && buflen < bufsize)
3625         break;
3626       /* heuristic to prevent out-of-memory errors */
3627       if (bufsize > 100*fmtlen) {
3628         Safefree(buf);
3629         buf = NULL;
3630         break;
3631       }
3632       Renew(buf, bufsize*2, char);
3633     }
3634     return buf;
3635   }
3636 #else
3637   Perl_croak(aTHX_ "panic: no strftime");
3638   return NULL;
3639 #endif
3640 }
3641
3642
3643 #define SV_CWD_RETURN_UNDEF \
3644 sv_setsv(sv, &PL_sv_undef); \
3645 return FALSE
3646
3647 #define SV_CWD_ISDOT(dp) \
3648     (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
3649         (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
3650
3651 /*
3652 =head1 Miscellaneous Functions
3653
3654 =for apidoc getcwd_sv
3655
3656 Fill the sv with current working directory
3657
3658 =cut
3659 */
3660
3661 /* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars.
3662  * rewritten again by dougm, optimized for use with xs TARG, and to prefer
3663  * getcwd(3) if available
3664  * Comments from the orignal:
3665  *     This is a faster version of getcwd.  It's also more dangerous
3666  *     because you might chdir out of a directory that you can't chdir
3667  *     back into. */
3668
3669 int
3670 Perl_getcwd_sv(pTHX_ register SV *sv)
3671 {
3672 #ifndef PERL_MICRO
3673
3674 #ifndef INCOMPLETE_TAINTS
3675     SvTAINTED_on(sv);
3676 #endif
3677
3678 #ifdef HAS_GETCWD
3679     {
3680         char buf[MAXPATHLEN];
3681
3682         /* Some getcwd()s automatically allocate a buffer of the given
3683          * size from the heap if they are given a NULL buffer pointer.
3684          * The problem is that this behaviour is not portable. */
3685         if (getcwd(buf, sizeof(buf) - 1)) {
3686             sv_setpvn(sv, buf, strlen(buf));
3687             return TRUE;
3688         }
3689         else {
3690             sv_setsv(sv, &PL_sv_undef);
3691             return FALSE;
3692         }
3693     }
3694
3695 #else
3696
3697     Stat_t statbuf;
3698     int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
3699     int pathlen=0;
3700     Direntry_t *dp;
3701
3702     SvUPGRADE(sv, SVt_PV);
3703
3704     if (PerlLIO_lstat(".", &statbuf) < 0) {
3705         SV_CWD_RETURN_UNDEF;
3706     }
3707
3708     orig_cdev = statbuf.st_dev;
3709     orig_cino = statbuf.st_ino;
3710     cdev = orig_cdev;
3711     cino = orig_cino;
3712
3713     for (;;) {
3714         DIR *dir;
3715         odev = cdev;
3716         oino = cino;
3717
3718         if (PerlDir_chdir("..") < 0) {
3719             SV_CWD_RETURN_UNDEF;
3720         }
3721         if (PerlLIO_stat(".", &statbuf) < 0) {
3722             SV_CWD_RETURN_UNDEF;
3723         }
3724
3725         cdev = statbuf.st_dev;
3726         cino = statbuf.st_ino;
3727
3728         if (odev == cdev && oino == cino) {
3729             break;
3730         }
3731         if (!(dir = PerlDir_open("."))) {
3732             SV_CWD_RETURN_UNDEF;
3733         }
3734
3735         while ((dp = PerlDir_read(dir)) != NULL) {
3736 #ifdef DIRNAMLEN
3737             const int namelen = dp->d_namlen;
3738 #else
3739             const int namelen = strlen(dp->d_name);
3740 #endif
3741             /* skip . and .. */
3742             if (SV_CWD_ISDOT(dp)) {
3743                 continue;
3744             }
3745
3746             if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
3747                 SV_CWD_RETURN_UNDEF;
3748             }
3749
3750             tdev = statbuf.st_dev;
3751             tino = statbuf.st_ino;
3752             if (tino == oino && tdev == odev) {
3753                 break;
3754             }
3755         }
3756
3757         if (!dp) {
3758             SV_CWD_RETURN_UNDEF;
3759         }
3760
3761         if (pathlen + namelen + 1 >= MAXPATHLEN) {
3762             SV_CWD_RETURN_UNDEF;
3763         }
3764
3765         SvGROW(sv, pathlen + namelen + 1);
3766
3767         if (pathlen) {
3768             /* shift down */
3769             Move(SvPVX_const(sv), SvPVX(sv) + namelen + 1, pathlen, char);
3770         }
3771
3772         /* prepend current directory to the front */
3773         *SvPVX(sv) = '/';
3774         Move(dp->d_name, SvPVX(sv)+1, namelen, char);
3775         pathlen += (namelen + 1);
3776
3777 #ifdef VOID_CLOSEDIR
3778         PerlDir_close(dir);
3779 #else
3780         if (PerlDir_close(dir) < 0) {
3781             SV_CWD_RETURN_UNDEF;
3782         }
3783 #endif
3784     }
3785
3786     if (pathlen) {
3787         SvCUR_set(sv, pathlen);
3788         *SvEND(sv) = '\0';
3789         SvPOK_only(sv);
3790
3791         if (PerlDir_chdir(SvPVX_const(sv)) < 0) {
3792             SV_CWD_RETURN_UNDEF;
3793         }
3794     }
3795     if (PerlLIO_stat(".", &statbuf) < 0) {
3796         SV_CWD_RETURN_UNDEF;
3797     }
3798
3799     cdev = statbuf.st_dev;
3800     cino = statbuf.st_ino;
3801
3802     if (cdev != orig_cdev || cino != orig_cino) {
3803         Perl_croak(aTHX_ "Unstable directory path, "
3804                    "current directory changed unexpectedly");
3805     }
3806
3807     return TRUE;
3808 #endif
3809
3810 #else
3811     return FALSE;
3812 #endif
3813 }
3814
3815 /*
3816 =for apidoc scan_version
3817
3818 Returns a pointer to the next character after the parsed
3819 version string, as well as upgrading the passed in SV to
3820 an RV.
3821
3822 Function must be called with an already existing SV like
3823
3824     sv = newSV(0);
3825     s = scan_version(s,SV *sv, bool qv);
3826
3827 Performs some preprocessing to the string to ensure that
3828 it has the correct characteristics of a version.  Flags the
3829 object if it contains an underscore (which denotes this
3830 is a alpha version).  The boolean qv denotes that the version
3831 should be interpreted as if it had multiple decimals, even if
3832 it doesn't.
3833
3834 =cut
3835 */
3836
3837 char *
3838 Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
3839 {
3840     const char *start = s;
3841     const char *pos = s;
3842     I32 saw_period = 0;
3843     bool saw_under = 0;
3844     SV* sv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
3845     (void)sv_upgrade(sv, SVt_PVAV); /* needs to be an AV type */
3846     AvREAL_on((AV*)sv);
3847
3848     /* pre-scan the imput string to check for decimals */
3849     while ( *pos == '.' || *pos == '_' || isDIGIT(*pos) )
3850     {
3851         if ( *pos == '.' )
3852         {
3853             if ( saw_under )
3854                 Perl_croak(aTHX_ "Invalid version format (underscores before decimal)");
3855             saw_period++ ;
3856         }
3857         else if ( *pos == '_' )
3858         {
3859             if ( saw_under )
3860                 Perl_croak(aTHX_ "Invalid version format (multiple underscores)");
3861             saw_under = 1;
3862         }
3863         pos++;
3864     }
3865     pos = s;
3866
3867     if (*pos == 'v') {
3868         pos++;  /* get past 'v' */
3869         qv = 1; /* force quoted version processing */
3870     }
3871     while (isDIGIT(*pos))
3872         pos++;
3873     if (!isALPHA(*pos)) {
3874         I32 rev;
3875
3876         if (*s == 'v') s++;  /* get past 'v' */
3877
3878         for (;;) {
3879             rev = 0;
3880             {
3881                 /* this is atoi() that delimits on underscores */
3882                 const char *end = pos;
3883                 I32 mult = 1;
3884                 I32 orev;
3885                 if ( s < pos && s > start && *(s-1) == '_' ) {
3886                         mult *= -1;     /* alpha version */
3887                 }
3888                 /* the following if() will only be true after the decimal
3889                  * point of a version originally created with a bare
3890                  * floating point number, i.e. not quoted in any way
3891                  */
3892                 if ( !qv && s > start+1 && saw_period == 1 ) {
3893                     mult *= 100;
3894                     while ( s < end ) {
3895                         orev = rev;
3896                         rev += (*s - '0') * mult;
3897                         mult /= 10;
3898                         if ( PERL_ABS(orev) > PERL_ABS(rev) )
3899                             Perl_croak(aTHX_ "Integer overflow in version");
3900                         s++;
3901                     }
3902                 }
3903                 else {
3904                     while (--end >= s) {
3905                         orev = rev;
3906                         rev += (*end - '0') * mult;
3907                         mult *= 10;
3908                         if ( PERL_ABS(orev) > PERL_ABS(rev) )
3909                             Perl_croak(aTHX_ "Integer overflow in version");
3910                     }
3911                 }
3912             }
3913
3914             /* Append revision */
3915             av_push((AV *)sv, newSViv(rev));
3916             if ( (*pos == '.' || *pos == '_') && isDIGIT(pos[1]))
3917                 s = ++pos;
3918             else if ( isDIGIT(*pos) )
3919                 s = pos;
3920             else {
3921                 s = pos;
3922                 break;
3923             }
3924             while ( isDIGIT(*pos) ) {
3925                 if ( saw_period == 1 && pos-s == 3 )
3926                     break;
3927                 pos++;
3928             }
3929         }
3930     }
3931     if ( qv ) { /* quoted versions always become full version objects */
3932         I32 len = av_len((AV *)sv);
3933         /* This for loop appears to trigger a compiler bug on OS X, as it
3934            loops infinitely. Yes, len is negative. No, it makes no sense.
3935            Compiler in question is:
3936            gcc version 3.3 20030304 (Apple Computer, Inc. build 1640)
3937            for ( len = 2 - len; len > 0; len-- )
3938            av_push((AV *)sv, newSViv(0));
3939         */
3940         len = 2 - len;
3941         while (len-- > 0)
3942             av_push((AV *)sv, newSViv(0));
3943     }
3944     return (char *)s;
3945 }
3946
3947 /*
3948 =for apidoc new_version
3949
3950 Returns a new version object based on the passed in SV:
3951
3952     SV *sv = new_version(SV *ver);
3953
3954 Does not alter the passed in ver SV.  See "upg_version" if you
3955 want to upgrade the SV.
3956
3957 =cut
3958 */
3959
3960 SV *
3961 Perl_new_version(pTHX_ SV *ver)
3962 {
3963     SV *rv = newSV(0);
3964     if ( sv_derived_from(ver,"version") ) /* can just copy directly */
3965     {
3966         I32 key;
3967         AV *av = (AV *)SvRV(ver);
3968         SV* sv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
3969         (void)sv_upgrade(sv, SVt_PVAV); /* needs to be an AV type */
3970         AvREAL_on((AV*)sv);
3971         for ( key = 0; key <= av_len(av); key++ )
3972         {
3973             const I32 rev = SvIV(*av_fetch(av, key, FALSE));
3974             av_push((AV *)sv, newSViv(rev));
3975         }
3976         return rv;
3977     }
3978 #ifdef SvVOK
3979     if ( SvVOK(ver) ) { /* already a v-string */
3980         char *version;
3981         MAGIC* mg = mg_find(ver,PERL_MAGIC_vstring);
3982         version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
3983         sv_setpv(rv,version);
3984         Safefree(version);
3985     }
3986     else {
3987 #endif
3988     sv_setsv(rv,ver); /* make a duplicate */
3989 #ifdef SvVOK
3990     }
3991 #endif
3992     upg_version(rv);
3993     return rv;
3994 }
3995
3996 /*
3997 =for apidoc upg_version
3998
3999 In-place upgrade of the supplied SV to a version object.
4000
4001     SV *sv = upg_version(SV *sv);
4002
4003 Returns a pointer to the upgraded SV.
4004
4005 =cut
4006 */
4007
4008 SV *
4009 Perl_upg_version(pTHX_ SV *ver)
4010 {
4011     char *version;
4012     bool qv = 0;
4013
4014     if ( SvNOK(ver) ) /* may get too much accuracy */
4015     {
4016         char tbuf[64];
4017         sprintf(tbuf,"%.9"NVgf, SvNVX(ver));
4018         version = savepv(tbuf);
4019     }
4020 #ifdef SvVOK
4021     else if ( SvVOK(ver) ) { /* already a v-string */
4022         MAGIC* mg = mg_find(ver,PERL_MAGIC_vstring);
4023         version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
4024         qv = 1;
4025     }
4026 #endif
4027     else /* must be a string or something like a string */
4028     {
4029         version = savesvpv(ver);
4030     }
4031     (void)scan_version(version, ver, qv);
4032     Safefree(version);
4033     return ver;
4034 }
4035
4036
4037 /*
4038 =for apidoc vnumify
4039
4040 Accepts a version object and returns the normalized floating
4041 point representation.  Call like:
4042
4043     sv = vnumify(rv);
4044
4045 NOTE: you can pass either the object directly or the SV
4046 contained within the RV.
4047
4048 =cut
4049 */
4050
4051 SV *
4052 Perl_vnumify(pTHX_ SV *vs)
4053 {
4054     I32 i, len, digit;
4055     SV *sv = newSV(0);
4056     if ( SvROK(vs) )
4057         vs = SvRV(vs);
4058     len = av_len((AV *)vs);
4059     if ( len == -1 )
4060     {
4061         Perl_sv_catpv(aTHX_ sv,"0");
4062         return sv;
4063     }
4064     digit = SvIVX(*av_fetch((AV *)vs, 0, 0));
4065     Perl_sv_setpvf(aTHX_ sv,"%d.", (int)PERL_ABS(digit));
4066     for ( i = 1 ; i < len ; i++ )
4067     {
4068         digit = SvIVX(*av_fetch((AV *)vs, i, 0));
4069         Perl_sv_catpvf(aTHX_ sv,"%03d", (int)PERL_ABS(digit));
4070     }
4071
4072     if ( len > 0 )
4073     {
4074         digit = SvIVX(*av_fetch((AV *)vs, len, 0));
4075         if ( (int)PERL_ABS(digit) != 0 || len == 1 )
4076         {
4077             if ( digit < 0 ) /* alpha version */
4078                 Perl_sv_catpv(aTHX_ sv,"_");
4079             /* Don't display additional trailing zeros */
4080             Perl_sv_catpvf(aTHX_ sv,"%03d", (int)PERL_ABS(digit));
4081         }
4082     }
4083     else /* len == 0 */
4084     {
4085          Perl_sv_catpv(aTHX_ sv,"000");
4086     }
4087     return sv;
4088 }
4089
4090 /*
4091 =for apidoc vnormal
4092
4093 Accepts a version object and returns the normalized string
4094 representation.  Call like:
4095
4096     sv = vnormal(rv);
4097
4098 NOTE: you can pass either the object directly or the SV
4099 contained within the RV.
4100
4101 =cut
4102 */
4103
4104 SV *
4105 Perl_vnormal(pTHX_ SV *vs)
4106 {
4107     I32 i, len, digit;
4108     SV *sv = newSV(0);
4109     if ( SvROK(vs) )
4110         vs = SvRV(vs);
4111     len = av_len((AV *)vs);
4112     if ( len == -1 )
4113     {
4114         Perl_sv_catpv(aTHX_ sv,"");
4115         return sv;
4116     }
4117     digit = SvIVX(*av_fetch((AV *)vs, 0, 0));
4118     Perl_sv_setpvf(aTHX_ sv,"%"IVdf,(IV)digit);
4119     for ( i = 1 ; i <= len ; i++ )
4120     {
4121         digit = SvIVX(*av_fetch((AV *)vs, i, 0));
4122         if ( digit < 0 )
4123             Perl_sv_catpvf(aTHX_ sv,"_%"IVdf,(IV)-digit);
4124         else
4125             Perl_sv_catpvf(aTHX_ sv,".%"IVdf,(IV)digit);
4126     }
4127
4128     if ( len <= 2 ) { /* short version, must be at least three */
4129         for ( len = 2 - len; len != 0; len-- )
4130             Perl_sv_catpv(aTHX_ sv,".0");
4131     }
4132
4133     return sv;
4134 }
4135
4136 /*
4137 =for apidoc vstringify
4138
4139 In order to maintain maximum compatibility with earlier versions
4140 of Perl, this function will return either the floating point
4141 notation or the multiple dotted notation, depending on whether
4142 the original version contained 1 or more dots, respectively
4143
4144 =cut
4145 */
4146
4147 SV *
4148 Perl_vstringify(pTHX_ SV *vs)
4149 {
4150     I32 len, digit;
4151     if ( SvROK(vs) )
4152         vs = SvRV(vs);
4153     len = av_len((AV *)vs);
4154     digit = SvIVX(*av_fetch((AV *)vs, len, 0));
4155
4156     if ( len < 2 || ( len == 2 && digit < 0 ) )
4157         return vnumify(vs);
4158     else
4159         return vnormal(vs);
4160 }
4161
4162 /*
4163 =for apidoc vcmp
4164
4165 Version object aware cmp.  Both operands must already have been
4166 converted into version objects.
4167
4168 =cut
4169 */
4170
4171 int
4172 Perl_vcmp(pTHX_ SV *lsv, SV *rsv)
4173 {
4174     I32 i,l,m,r,retval;
4175     if ( SvROK(lsv) )
4176         lsv = SvRV(lsv);
4177     if ( SvROK(rsv) )
4178         rsv = SvRV(rsv);
4179     l = av_len((AV *)lsv);
4180     r = av_len((AV *)rsv);
4181     m = l < r ? l : r;
4182     retval = 0;
4183     i = 0;
4184     while ( i <= m && retval == 0 )
4185     {
4186         I32 left  = SvIV(*av_fetch((AV *)lsv,i,0));
4187         I32 right = SvIV(*av_fetch((AV *)rsv,i,0));
4188         bool lalpha = left  < 0 ? 1 : 0;
4189         bool ralpha = right < 0 ? 1 : 0;
4190         left  = abs(left);
4191         right = abs(right);
4192         if ( left < right || (left == right && lalpha && !ralpha) )
4193             retval = -1;
4194         if ( left > right || (left == right && ralpha && !lalpha) )
4195             retval = +1;
4196         i++;
4197     }
4198
4199     if ( l != r && retval == 0 ) /* possible match except for trailing 0's */
4200     {
4201         if ( l < r )
4202         {
4203             while ( i <= r && retval == 0 )
4204             {
4205                 if ( SvIV(*av_fetch((AV *)rsv,i,0)) != 0 )
4206                     retval = -1; /* not a match after all */
4207                 i++;
4208             }
4209         }
4210         else
4211         {
4212             while ( i <= l && retval == 0 )
4213             {
4214                 if ( SvIV(*av_fetch((AV *)lsv,i,0)) != 0 )
4215                     retval = +1; /* not a match after all */
4216                 i++;
4217             }
4218         }
4219     }
4220     return retval;
4221 }
4222
4223 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT)
4224 #   define EMULATE_SOCKETPAIR_UDP
4225 #endif
4226
4227 #ifdef EMULATE_SOCKETPAIR_UDP
4228 static int
4229 S_socketpair_udp (int fd[2]) {
4230     dTHX;
4231     /* Fake a datagram socketpair using UDP to localhost.  */
4232     int sockets[2] = {-1, -1};
4233     struct sockaddr_in addresses[2];
4234     int i;
4235     Sock_size_t size = sizeof(struct sockaddr_in);
4236     unsigned short port;
4237     int got;
4238
4239     memset(&addresses, 0, sizeof(addresses));
4240     i = 1;
4241     do {
4242         sockets[i] = PerlSock_socket(AF_INET, SOCK_DGRAM, PF_INET);
4243         if (sockets[i] == -1)
4244             goto tidy_up_and_fail;
4245
4246         addresses[i].sin_family = AF_INET;
4247         addresses[i].sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4248         addresses[i].sin_port = 0;      /* kernel choses port.  */
4249         if (PerlSock_bind(sockets[i], (struct sockaddr *) &addresses[i],
4250                 sizeof(struct sockaddr_in)) == -1)
4251             goto tidy_up_and_fail;
4252     } while (i--);
4253
4254     /* Now have 2 UDP sockets. Find out which port each is connected to, and
4255        for each connect the other socket to it.  */
4256     i = 1;
4257     do {
4258         if (PerlSock_getsockname(sockets[i], (struct sockaddr *) &addresses[i],
4259                 &size) == -1)
4260             goto tidy_up_and_fail;
4261         if (size != sizeof(struct sockaddr_in))
4262             goto abort_tidy_up_and_fail;
4263         /* !1 is 0, !0 is 1 */
4264         if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i],
4265                 sizeof(struct sockaddr_in)) == -1)
4266             goto tidy_up_and_fail;
4267     } while (i--);
4268
4269     /* Now we have 2 sockets connected to each other. I don't trust some other
4270        process not to have already sent a packet to us (by random) so send
4271        a packet from each to the other.  */
4272     i = 1;
4273     do {
4274         /* I'm going to send my own port number.  As a short.
4275            (Who knows if someone somewhere has sin_port as a bitfield and needs
4276            this routine. (I'm assuming crays have socketpair)) */
4277         port = addresses[i].sin_port;
4278         got = PerlLIO_write(sockets[i], &port, sizeof(port));
4279         if (got != sizeof(port)) {
4280             if (got == -1)
4281                 goto tidy_up_and_fail;
4282             goto abort_tidy_up_and_fail;
4283         }
4284     } while (i--);
4285
4286     /* Packets sent. I don't trust them to have arrived though.
4287        (As I understand it Solaris TCP stack is multithreaded. Non-blocking
4288        connect to localhost will use a second kernel thread. In 2.6 the
4289        first thread running the connect() returns before the second completes,
4290        so EINPROGRESS> In 2.7 the improved stack is faster and connect()
4291        returns 0. Poor programs have tripped up. One poor program's authors'
4292        had a 50-1 reverse stock split. Not sure how connected these were.)
4293        So I don't trust someone not to have an unpredictable UDP stack.
4294     */
4295
4296     {
4297         struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */
4298         int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0];
4299         fd_set rset;
4300
4301         FD_ZERO(&rset);
4302         FD_SET(sockets[0], &rset);
4303         FD_SET(sockets[1], &rset);
4304
4305         got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor);
4306         if (got != 2 || !FD_ISSET(sockets[0], &rset)
4307                 || !FD_ISSET(sockets[1], &rset)) {
4308             /* I hope this is portable and appropriate.  */
4309             if (got == -1)
4310                 goto tidy_up_and_fail;
4311             goto abort_tidy_up_and_fail;
4312         }
4313     }
4314
4315     /* And the paranoia department even now doesn't trust it to have arrive
4316        (hence MSG_DONTWAIT). Or that what arrives was sent by us.  */
4317     {
4318         struct sockaddr_in readfrom;
4319         unsigned short buffer[2];
4320
4321         i = 1;
4322         do {
4323 #ifdef MSG_DONTWAIT
4324             got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4325                     sizeof(buffer), MSG_DONTWAIT,
4326                     (struct sockaddr *) &readfrom, &size);
4327 #else
4328             got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4329                     sizeof(buffer), 0,
4330                     (struct sockaddr *) &readfrom, &size);
4331 #endif
4332
4333             if (got == -1)
4334                 goto tidy_up_and_fail;
4335             if (got != sizeof(port)
4336                     || size != sizeof(struct sockaddr_in)
4337                     /* Check other socket sent us its port.  */
4338                     || buffer[0] != (unsigned short) addresses[!i].sin_port
4339                     /* Check kernel says we got the datagram from that socket */
4340                     || readfrom.sin_family != addresses[!i].sin_family
4341                     || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr
4342                     || readfrom.sin_port != addresses[!i].sin_port)
4343                 goto abort_tidy_up_and_fail;
4344         } while (i--);
4345     }
4346     /* My caller (my_socketpair) has validated that this is non-NULL  */
4347     fd[0] = sockets[0];
4348     fd[1] = sockets[1];
4349     /* I hereby declare this connection open.  May God bless all who cross
4350        her.  */
4351     return 0;
4352
4353   abort_tidy_up_and_fail:
4354     errno = ECONNABORTED;
4355   tidy_up_and_fail:
4356     {
4357         const int save_errno = errno;
4358         if (sockets[0] != -1)
4359             PerlLIO_close(sockets[0]);
4360         if (sockets[1] != -1)
4361             PerlLIO_close(sockets[1]);
4362         errno = save_errno;
4363         return -1;
4364     }
4365 }
4366 #endif /*  EMULATE_SOCKETPAIR_UDP */
4367
4368 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET)
4369 int
4370 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4371     /* Stevens says that family must be AF_LOCAL, protocol 0.
4372        I'm going to enforce that, then ignore it, and use TCP (or UDP).  */
4373     dTHX;
4374     int listener = -1;
4375     int connector = -1;
4376     int acceptor = -1;
4377     struct sockaddr_in listen_addr;
4378     struct sockaddr_in connect_addr;
4379     Sock_size_t size;
4380
4381     if (protocol
4382 #ifdef AF_UNIX
4383         || family != AF_UNIX
4384 #endif
4385     ) {
4386         errno = EAFNOSUPPORT;
4387         return -1;
4388     }
4389     if (!fd) {
4390         errno = EINVAL;
4391         return -1;
4392     }
4393
4394 #ifdef EMULATE_SOCKETPAIR_UDP
4395     if (type == SOCK_DGRAM)
4396         return S_socketpair_udp(fd);
4397 #endif
4398
4399     listener = PerlSock_socket(AF_INET, type, 0);
4400     if (listener == -1)
4401         return -1;
4402     memset(&listen_addr, 0, sizeof(listen_addr));
4403     listen_addr.sin_family = AF_INET;
4404     listen_addr.sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4405     listen_addr.sin_port = 0;   /* kernel choses port.  */
4406     if (PerlSock_bind(listener, (struct sockaddr *) &listen_addr,
4407             sizeof(listen_addr)) == -1)
4408         goto tidy_up_and_fail;
4409     if (PerlSock_listen(listener, 1) == -1)
4410         goto tidy_up_and_fail;
4411
4412     connector = PerlSock_socket(AF_INET, type, 0);
4413     if (connector == -1)
4414         goto tidy_up_and_fail;
4415     /* We want to find out the port number to connect to.  */
4416     size = sizeof(connect_addr);
4417     if (PerlSock_getsockname(listener, (struct sockaddr *) &connect_addr,
4418             &size) == -1)
4419         goto tidy_up_and_fail;
4420     if (size != sizeof(connect_addr))
4421         goto abort_tidy_up_and_fail;
4422     if (PerlSock_connect(connector, (struct sockaddr *) &connect_addr,
4423             sizeof(connect_addr)) == -1)
4424         goto tidy_up_and_fail;
4425
4426     size = sizeof(listen_addr);
4427     acceptor = PerlSock_accept(listener, (struct sockaddr *) &listen_addr,
4428             &size);
4429     if (acceptor == -1)
4430         goto tidy_up_and_fail;
4431     if (size != sizeof(listen_addr))
4432         goto abort_tidy_up_and_fail;
4433     PerlLIO_close(listener);
4434     /* Now check we are talking to ourself by matching port and host on the
4435        two sockets.  */
4436     if (PerlSock_getsockname(connector, (struct sockaddr *) &connect_addr,
4437             &size) == -1)
4438         goto tidy_up_and_fail;
4439     if (size != sizeof(connect_addr)
4440             || listen_addr.sin_family != connect_addr.sin_family
4441             || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr
4442             || listen_addr.sin_port != connect_addr.sin_port) {
4443         goto abort_tidy_up_and_fail;
4444     }
4445     fd[0] = connector;
4446     fd[1] = acceptor;
4447     return 0;
4448
4449   abort_tidy_up_and_fail:
4450 #ifdef ECONNABORTED
4451   errno = ECONNABORTED; /* This would be the standard thing to do. */
4452 #else
4453 #  ifdef ECONNREFUSED
4454   errno = ECONNREFUSED; /* E.g. Symbian does not have ECONNABORTED. */
4455 #  else
4456   errno = ETIMEDOUT;    /* Desperation time. */
4457 #  endif
4458 #endif
4459   tidy_up_and_fail:
4460     {
4461         int save_errno = errno;
4462         if (listener != -1)
4463             PerlLIO_close(listener);
4464         if (connector != -1)
4465             PerlLIO_close(connector);
4466         if (acceptor != -1)
4467             PerlLIO_close(acceptor);
4468         errno = save_errno;
4469         return -1;
4470     }
4471 }
4472 #else
4473 /* In any case have a stub so that there's code corresponding
4474  * to the my_socketpair in global.sym. */
4475 int
4476 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4477 #ifdef HAS_SOCKETPAIR
4478     return socketpair(family, type, protocol, fd);
4479 #else
4480     return -1;
4481 #endif
4482 }
4483 #endif
4484
4485 /*
4486
4487 =for apidoc sv_nosharing
4488
4489 Dummy routine which "shares" an SV when there is no sharing module present.
4490 Exists to avoid test for a NULL function pointer and because it could potentially warn under
4491 some level of strict-ness.
4492
4493 =cut
4494 */
4495
4496 void
4497 Perl_sv_nosharing(pTHX_ SV *sv)
4498 {
4499     (void)sv;
4500 }
4501
4502 /*
4503 =for apidoc sv_nolocking
4504
4505 Dummy routine which "locks" an SV when there is no locking module present.
4506 Exists to avoid test for a NULL function pointer and because it could potentially warn under
4507 some level of strict-ness.
4508
4509 =cut
4510 */
4511
4512 void
4513 Perl_sv_nolocking(pTHX_ SV *sv)
4514 {
4515     (void)sv;
4516 }
4517
4518
4519 /*
4520 =for apidoc sv_nounlocking
4521
4522 Dummy routine which "unlocks" an SV when there is no locking module present.
4523 Exists to avoid test for a NULL function pointer and because it could potentially warn under
4524 some level of strict-ness.
4525
4526 =cut
4527 */
4528
4529 void
4530 Perl_sv_nounlocking(pTHX_ SV *sv)
4531 {
4532     (void)sv;
4533 }
4534
4535 U32
4536 Perl_parse_unicode_opts(pTHX_ const char **popt)
4537 {
4538   const char *p = *popt;
4539   U32 opt = 0;
4540
4541   if (*p) {
4542        if (isDIGIT(*p)) {
4543             opt = (U32) atoi(p);
4544             while (isDIGIT(*p)) p++;
4545             if (*p && *p != '\n' && *p != '\r')
4546                  Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
4547        }
4548        else {
4549             for (; *p; p++) {
4550                  switch (*p) {
4551                  case PERL_UNICODE_STDIN:
4552                       opt |= PERL_UNICODE_STDIN_FLAG;   break;
4553                  case PERL_UNICODE_STDOUT:
4554                       opt |= PERL_UNICODE_STDOUT_FLAG;  break;
4555                  case PERL_UNICODE_STDERR:
4556                       opt |= PERL_UNICODE_STDERR_FLAG;  break;
4557                  case PERL_UNICODE_STD:
4558                       opt |= PERL_UNICODE_STD_FLAG;     break;
4559                  case PERL_UNICODE_IN:
4560                       opt |= PERL_UNICODE_IN_FLAG;      break;
4561                  case PERL_UNICODE_OUT:
4562                       opt |= PERL_UNICODE_OUT_FLAG;     break;
4563                  case PERL_UNICODE_INOUT:
4564                       opt |= PERL_UNICODE_INOUT_FLAG;   break;
4565                  case PERL_UNICODE_LOCALE:
4566                       opt |= PERL_UNICODE_LOCALE_FLAG;  break;
4567                  case PERL_UNICODE_ARGV:
4568                       opt |= PERL_UNICODE_ARGV_FLAG;    break;
4569                  default:
4570                       if (*p != '\n' && *p != '\r')
4571                           Perl_croak(aTHX_
4572                                      "Unknown Unicode option letter '%c'", *p);
4573                  }
4574             }
4575        }
4576   }
4577   else
4578        opt = PERL_UNICODE_DEFAULT_FLAGS;
4579
4580   if (opt & ~PERL_UNICODE_ALL_FLAGS)
4581        Perl_croak(aTHX_ "Unknown Unicode option value %"UVuf,
4582                   (UV) (opt & ~PERL_UNICODE_ALL_FLAGS));
4583
4584   *popt = p;
4585
4586   return opt;
4587 }
4588
4589 U32
4590 Perl_seed(pTHX)
4591 {
4592     /*
4593      * This is really just a quick hack which grabs various garbage
4594      * values.  It really should be a real hash algorithm which
4595      * spreads the effect of every input bit onto every output bit,
4596      * if someone who knows about such things would bother to write it.
4597      * Might be a good idea to add that function to CORE as well.
4598      * No numbers below come from careful analysis or anything here,
4599      * except they are primes and SEED_C1 > 1E6 to get a full-width
4600      * value from (tv_sec * SEED_C1 + tv_usec).  The multipliers should
4601      * probably be bigger too.
4602      */
4603 #if RANDBITS > 16
4604 #  define SEED_C1       1000003
4605 #define   SEED_C4       73819
4606 #else
4607 #  define SEED_C1       25747
4608 #define   SEED_C4       20639
4609 #endif
4610 #define   SEED_C2       3
4611 #define   SEED_C3       269
4612 #define   SEED_C5       26107
4613
4614 #ifndef PERL_NO_DEV_RANDOM
4615     int fd;
4616 #endif
4617     U32 u;
4618 #ifdef VMS
4619 #  include <starlet.h>
4620     /* when[] = (low 32 bits, high 32 bits) of time since epoch
4621      * in 100-ns units, typically incremented ever 10 ms.        */
4622     unsigned int when[2];
4623 #else
4624 #  ifdef HAS_GETTIMEOFDAY
4625     struct timeval when;
4626 #  else
4627     Time_t when;
4628 #  endif
4629 #endif
4630
4631 /* This test is an escape hatch, this symbol isn't set by Configure. */
4632 #ifndef PERL_NO_DEV_RANDOM
4633 #ifndef PERL_RANDOM_DEVICE
4634    /* /dev/random isn't used by default because reads from it will block
4635     * if there isn't enough entropy available.  You can compile with
4636     * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
4637     * is enough real entropy to fill the seed. */
4638 #  define PERL_RANDOM_DEVICE "/dev/urandom"
4639 #endif
4640     fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
4641     if (fd != -1) {
4642         if (PerlLIO_read(fd, (void*)&u, sizeof u) != sizeof u)
4643             u = 0;
4644         PerlLIO_close(fd);
4645         if (u)
4646             return u;
4647     }
4648 #endif
4649
4650 #ifdef VMS
4651     _ckvmssts(sys$gettim(when));
4652     u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
4653 #else
4654 #  ifdef HAS_GETTIMEOFDAY
4655     PerlProc_gettimeofday(&when,NULL);
4656     u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
4657 #  else
4658     (void)time(&when);
4659     u = (U32)SEED_C1 * when;
4660 #  endif
4661 #endif
4662     u += SEED_C3 * (U32)PerlProc_getpid();
4663     u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
4664 #ifndef PLAN9           /* XXX Plan9 assembler chokes on this; fix needed  */
4665     u += SEED_C5 * (U32)PTR2UV(&when);
4666 #endif
4667     return u;
4668 }
4669
4670 UV
4671 Perl_get_hash_seed(pTHX)
4672 {
4673      const char *s = PerlEnv_getenv("PERL_HASH_SEED");
4674      UV myseed = 0;
4675
4676      if (s)
4677           while (isSPACE(*s)) s++;
4678      if (s && isDIGIT(*s))
4679           myseed = (UV)Atoul(s);
4680      else
4681 #ifdef USE_HASH_SEED_EXPLICIT
4682      if (s)
4683 #endif
4684      {
4685           /* Compute a random seed */
4686           (void)seedDrand01((Rand_seed_t)seed());
4687           myseed = (UV)(Drand01() * (NV)UV_MAX);
4688 #if RANDBITS < (UVSIZE * 8)
4689           /* Since there are not enough randbits to to reach all
4690            * the bits of a UV, the low bits might need extra
4691            * help.  Sum in another random number that will
4692            * fill in the low bits. */
4693           myseed +=
4694                (UV)(Drand01() * (NV)((1 << ((UVSIZE * 8 - RANDBITS))) - 1));
4695 #endif /* RANDBITS < (UVSIZE * 8) */
4696           if (myseed == 0) { /* Superparanoia. */
4697               myseed = (UV)(Drand01() * (NV)UV_MAX); /* One more chance. */
4698               if (myseed == 0)
4699                   Perl_croak(aTHX_ "Your random numbers are not that random");
4700           }
4701      }
4702      PL_rehash_seed_set = TRUE;
4703
4704      return myseed;
4705 }
4706
4707 #ifdef PERL_GLOBAL_STRUCT
4708
4709 struct perl_vars *
4710 Perl_init_global_struct(pTHX)
4711 {
4712     struct perl_vars *plvarsp = NULL;
4713 #ifdef PERL_GLOBAL_STRUCT
4714 #  define PERL_GLOBAL_STRUCT_INIT
4715 #  include "opcode.h" /* the ppaddr and check */
4716     IV nppaddr = sizeof(Gppaddr)/sizeof(Perl_ppaddr_t);
4717     IV ncheck  = sizeof(Gcheck) /sizeof(Perl_check_t);
4718 #  ifdef PERL_GLOBAL_STRUCT_PRIVATE
4719     /* PerlMem_malloc() because can't use even safesysmalloc() this early. */
4720     plvarsp = (struct perl_vars*)PerlMem_malloc(sizeof(struct perl_vars));
4721     if (!plvarsp)
4722         exit(1);
4723 #  else
4724     plvarsp = PL_VarsPtr;
4725 #  endif /* PERL_GLOBAL_STRUCT_PRIVATE */
4726 #  undef PERLVAR
4727 #  undef PERLVARA
4728 #  undef PERLVARI
4729 #  undef PERLVARIC
4730 #  undef PERLVARISC
4731 #  define PERLVAR(var,type) /**/
4732 #  define PERLVARA(var,n,type) /**/
4733 #  define PERLVARI(var,type,init) plvarsp->var = init;
4734 #  define PERLVARIC(var,type,init) plvarsp->var = init;
4735 #  define PERLVARISC(var,init) Copy(init, plvarsp->var, sizeof(init), char);
4736 #  include "perlvars.h"
4737 #  undef PERLVAR
4738 #  undef PERLVARA
4739 #  undef PERLVARI
4740 #  undef PERLVARIC
4741 #  undef PERLVARISC
4742 #  ifdef PERL_GLOBAL_STRUCT
4743     plvarsp->Gppaddr = PerlMem_malloc(nppaddr * sizeof(Perl_ppaddr_t));
4744     if (!plvarsp->Gppaddr)
4745         exit(1);
4746     plvarsp->Gcheck  = PerlMem_malloc(ncheck  * sizeof(Perl_check_t));
4747     if (!plvarsp->Gcheck)
4748         exit(1);
4749     Copy(Gppaddr, plvarsp->Gppaddr, nppaddr, Perl_ppaddr_t);
4750     Copy(Gcheck,  plvarsp->Gcheck,  ncheck,  Perl_check_t);
4751 #  endif
4752 #  ifdef PERL_SET_VARS
4753     PERL_SET_VARS(plvarsp);
4754 #  endif
4755 #  undef PERL_GLOBAL_STRUCT_INIT
4756 #endif
4757     return plvarsp;
4758 }
4759
4760 #endif /* PERL_GLOBAL_STRUCT */
4761
4762 #ifdef PERL_GLOBAL_STRUCT
4763
4764 void
4765 Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp)
4766 {
4767 #ifdef PERL_GLOBAL_STRUCT
4768 #  ifdef PERL_UNSET_VARS
4769     PERL_UNSET_VARS(plvarsp);
4770 #  endif
4771     free(plvarsp->Gppaddr);
4772     free(plvarsp->Gcheck);
4773 #    ifdef PERL_GLOBAL_STRUCT_PRIVATE
4774     free(plvarsp);
4775 #    endif
4776 #endif
4777 }
4778
4779 #endif /* PERL_GLOBAL_STRUCT */
4780
4781 /*
4782  * Local variables:
4783  * c-indentation-style: bsd
4784  * c-basic-offset: 4
4785  * indent-tabs-mode: t
4786  * End:
4787  *
4788  * ex: set ts=8 sts=4 sw=4 noet:
4789  */