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