util.c

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