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