util.c

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