util.c

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