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