util.c

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