util.c

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