util.c

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