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