util.c

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