util.c

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