util.c

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