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     PERL_ARGS_ASSERT_DIE_NOCONTEXT;
1391     va_start(args, pat);
1392     o = vdie(pat, &args);
1393     va_end(args);
1394     return o;
1395 }
1396 #endif /* PERL_IMPLICIT_CONTEXT */
1397
1398 OP *
1399 Perl_die(pTHX_ const char* pat, ...)
1400 {
1401     OP *o;
1402     va_list args;
1403     va_start(args, pat);
1404     o = vdie(pat, &args);
1405     va_end(args);
1406     return o;
1407 }
1408
1409 void
1410 Perl_vcroak(pTHX_ const char* pat, va_list *args)
1411 {
1412     dVAR;
1413     const char *message;
1414     STRLEN msglen;
1415     I32 utf8 = 0;
1416
1417     message = S_vdie_croak_common(aTHX_ pat, args, &msglen, &utf8);
1418
1419     if (PL_in_eval) {
1420         PL_restartop = die_where(message, msglen);
1421         SvFLAGS(ERRSV) |= utf8;
1422         JMPENV_JUMP(3);
1423     }
1424     else if (!message)
1425         message = SvPVx_const(ERRSV, msglen);
1426
1427     write_to_stderr(message, msglen);
1428     my_failure_exit();
1429 }
1430
1431 #if defined(PERL_IMPLICIT_CONTEXT)
1432 void
1433 Perl_croak_nocontext(const char *pat, ...)
1434 {
1435     dTHX;
1436     va_list args;
1437     va_start(args, pat);
1438     vcroak(pat, &args);
1439     /* NOTREACHED */
1440     va_end(args);
1441 }
1442 #endif /* PERL_IMPLICIT_CONTEXT */
1443
1444 /*
1445 =head1 Warning and Dieing
1446
1447 =for apidoc croak
1448
1449 This is the XSUB-writer's interface to Perl's C<die> function.
1450 Normally call this function the same way you call the C C<printf>
1451 function.  Calling C<croak> returns control directly to Perl,
1452 sidestepping the normal C order of execution. See C<warn>.
1453
1454 If you want to throw an exception object, assign the object to
1455 C<$@> and then pass C<NULL> to croak():
1456
1457    errsv = get_sv("@", GV_ADD);
1458    sv_setsv(errsv, exception_object);
1459    croak(NULL);
1460
1461 =cut
1462 */
1463
1464 void
1465 Perl_croak(pTHX_ const char *pat, ...)
1466 {
1467     va_list args;
1468     va_start(args, pat);
1469     vcroak(pat, &args);
1470     /* NOTREACHED */
1471     va_end(args);
1472 }
1473
1474 void
1475 Perl_vwarn(pTHX_ const char* pat, va_list *args)
1476 {
1477     dVAR;
1478     STRLEN msglen;
1479     SV * const msv = vmess(pat, args);
1480     const I32 utf8 = SvUTF8(msv);
1481     const char * const message = SvPV_const(msv, msglen);
1482
1483     PERL_ARGS_ASSERT_VWARN;
1484
1485     if (PL_warnhook) {
1486         if (vdie_common(message, msglen, utf8, TRUE))
1487             return;
1488     }
1489
1490     write_to_stderr(message, msglen);
1491 }
1492
1493 #if defined(PERL_IMPLICIT_CONTEXT)
1494 void
1495 Perl_warn_nocontext(const char *pat, ...)
1496 {
1497     dTHX;
1498     va_list args;
1499     PERL_ARGS_ASSERT_WARN_NOCONTEXT;
1500     va_start(args, pat);
1501     vwarn(pat, &args);
1502     va_end(args);
1503 }
1504 #endif /* PERL_IMPLICIT_CONTEXT */
1505
1506 /*
1507 =for apidoc warn
1508
1509 This is the XSUB-writer's interface to Perl's C<warn> function.  Call this
1510 function the same way you call the C C<printf> function.  See C<croak>.
1511
1512 =cut
1513 */
1514
1515 void
1516 Perl_warn(pTHX_ const char *pat, ...)
1517 {
1518     va_list args;
1519     PERL_ARGS_ASSERT_WARN;
1520     va_start(args, pat);
1521     vwarn(pat, &args);
1522     va_end(args);
1523 }
1524
1525 #if defined(PERL_IMPLICIT_CONTEXT)
1526 void
1527 Perl_warner_nocontext(U32 err, const char *pat, ...)
1528 {
1529     dTHX;
1530     va_list args;
1531     PERL_ARGS_ASSERT_WARNER_NOCONTEXT;
1532     va_start(args, pat);
1533     vwarner(err, pat, &args);
1534     va_end(args);
1535 }
1536 #endif /* PERL_IMPLICIT_CONTEXT */
1537
1538 void
1539 Perl_warner(pTHX_ U32  err, const char* pat,...)
1540 {
1541     va_list args;
1542     PERL_ARGS_ASSERT_WARNER;
1543     va_start(args, pat);
1544     vwarner(err, pat, &args);
1545     va_end(args);
1546 }
1547
1548 void
1549 Perl_vwarner(pTHX_ U32  err, const char* pat, va_list* args)
1550 {
1551     dVAR;
1552     PERL_ARGS_ASSERT_VWARNER;
1553     if (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) {
1554         SV * const msv = vmess(pat, args);
1555         STRLEN msglen;
1556         const char * const message = SvPV_const(msv, msglen);
1557         const I32 utf8 = SvUTF8(msv);
1558
1559         if (PL_diehook) {
1560             assert(message);
1561             S_vdie_common(aTHX_ message, msglen, utf8, FALSE);
1562         }
1563         if (PL_in_eval) {
1564             PL_restartop = die_where(message, msglen);
1565             SvFLAGS(ERRSV) |= utf8;
1566             JMPENV_JUMP(3);
1567         }
1568         write_to_stderr(message, msglen);
1569         my_failure_exit();
1570     }
1571     else {
1572         Perl_vwarn(aTHX_ pat, args);
1573     }
1574 }
1575
1576 /* implements the ckWARN? macros */
1577
1578 bool
1579 Perl_ckwarn(pTHX_ U32 w)
1580 {
1581     dVAR;
1582     return
1583         (
1584                isLEXWARN_on
1585             && PL_curcop->cop_warnings != pWARN_NONE
1586             && (
1587                    PL_curcop->cop_warnings == pWARN_ALL
1588                 || isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w))
1589                 || (unpackWARN2(w) &&
1590                      isWARN_on(PL_curcop->cop_warnings, unpackWARN2(w)))
1591                 || (unpackWARN3(w) &&
1592                      isWARN_on(PL_curcop->cop_warnings, unpackWARN3(w)))
1593                 || (unpackWARN4(w) &&
1594                      isWARN_on(PL_curcop->cop_warnings, unpackWARN4(w)))
1595                 )
1596         )
1597         ||
1598         (
1599             isLEXWARN_off && PL_dowarn & G_WARN_ON
1600         )
1601         ;
1602 }
1603
1604 /* implements the ckWARN?_d macro */
1605
1606 bool
1607 Perl_ckwarn_d(pTHX_ U32 w)
1608 {
1609     dVAR;
1610     return
1611            isLEXWARN_off
1612         || PL_curcop->cop_warnings == pWARN_ALL
1613         || (
1614               PL_curcop->cop_warnings != pWARN_NONE
1615            && (
1616                    isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w))
1617               || (unpackWARN2(w) &&
1618                    isWARN_on(PL_curcop->cop_warnings, unpackWARN2(w)))
1619               || (unpackWARN3(w) &&
1620                    isWARN_on(PL_curcop->cop_warnings, unpackWARN3(w)))
1621               || (unpackWARN4(w) &&
1622                    isWARN_on(PL_curcop->cop_warnings, unpackWARN4(w)))
1623               )
1624            )
1625         ;
1626 }
1627
1628 /* Set buffer=NULL to get a new one.  */
1629 STRLEN *
1630 Perl_new_warnings_bitfield(pTHX_ STRLEN *buffer, const char *const bits,
1631                            STRLEN size) {
1632     const MEM_SIZE len_wanted = sizeof(STRLEN) + size;
1633     PERL_UNUSED_CONTEXT;
1634     PERL_ARGS_ASSERT_NEW_WARNINGS_BITFIELD;
1635
1636     buffer = (STRLEN*)
1637         (specialWARN(buffer) ?
1638          PerlMemShared_malloc(len_wanted) :
1639          PerlMemShared_realloc(buffer, len_wanted));
1640     buffer[0] = size;
1641     Copy(bits, (buffer + 1), size, char);
1642     return buffer;
1643 }
1644
1645 /* since we've already done strlen() for both nam and val
1646  * we can use that info to make things faster than
1647  * sprintf(s, "%s=%s", nam, val)
1648  */
1649 #define my_setenv_format(s, nam, nlen, val, vlen) \
1650    Copy(nam, s, nlen, char); \
1651    *(s+nlen) = '='; \
1652    Copy(val, s+(nlen+1), vlen, char); \
1653    *(s+(nlen+1+vlen)) = '\0'
1654
1655 #ifdef USE_ENVIRON_ARRAY
1656        /* VMS' my_setenv() is in vms.c */
1657 #if !defined(WIN32) && !defined(NETWARE)
1658 void
1659 Perl_my_setenv(pTHX_ const char *nam, const char *val)
1660 {
1661   dVAR;
1662 #ifdef USE_ITHREADS
1663   /* only parent thread can modify process environment */
1664   if (PL_curinterp == aTHX)
1665 #endif
1666   {
1667 #ifndef PERL_USE_SAFE_PUTENV
1668     if (!PL_use_safe_putenv) {
1669     /* most putenv()s leak, so we manipulate environ directly */
1670     register I32 i;
1671     register const I32 len = strlen(nam);
1672     int nlen, vlen;
1673
1674     /* where does it go? */
1675     for (i = 0; environ[i]; i++) {
1676         if (strnEQ(environ[i],nam,len) && environ[i][len] == '=')
1677             break;
1678     }
1679
1680     if (environ == PL_origenviron) {   /* need we copy environment? */
1681        I32 j;
1682        I32 max;
1683        char **tmpenv;
1684
1685        max = i;
1686        while (environ[max])
1687            max++;
1688        tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*));
1689        for (j=0; j<max; j++) {         /* copy environment */
1690            const int len = strlen(environ[j]);
1691            tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char));
1692            Copy(environ[j], tmpenv[j], len+1, char);
1693        }
1694        tmpenv[max] = NULL;
1695        environ = tmpenv;               /* tell exec where it is now */
1696     }
1697     if (!val) {
1698        safesysfree(environ[i]);
1699        while (environ[i]) {
1700            environ[i] = environ[i+1];
1701            i++;
1702         }
1703        return;
1704     }
1705     if (!environ[i]) {                 /* does not exist yet */
1706        environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
1707        environ[i+1] = NULL;    /* make sure it's null terminated */
1708     }
1709     else
1710        safesysfree(environ[i]);
1711        nlen = strlen(nam);
1712        vlen = strlen(val);
1713
1714        environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char));
1715        /* all that work just for this */
1716        my_setenv_format(environ[i], nam, nlen, val, vlen);
1717     } else {
1718 # endif
1719 #   if defined(__CYGWIN__) || defined(EPOC) || defined(__SYMBIAN32__) || defined(__riscos__)
1720 #       if defined(HAS_UNSETENV)
1721         if (val == NULL) {
1722             (void)unsetenv(nam);
1723         } else {
1724             (void)setenv(nam, val, 1);
1725         }
1726 #       else /* ! HAS_UNSETENV */
1727         (void)setenv(nam, val, 1);
1728 #       endif /* HAS_UNSETENV */
1729 #   else
1730 #       if defined(HAS_UNSETENV)
1731         if (val == NULL) {
1732             (void)unsetenv(nam);
1733         } else {
1734             const int nlen = strlen(nam);
1735             const int vlen = strlen(val);
1736             char * const new_env =
1737                 (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
1738             my_setenv_format(new_env, nam, nlen, val, vlen);
1739             (void)putenv(new_env);
1740         }
1741 #       else /* ! HAS_UNSETENV */
1742         char *new_env;
1743         const int nlen = strlen(nam);
1744         int vlen;
1745         if (!val) {
1746            val = "";
1747         }
1748         vlen = strlen(val);
1749         new_env = (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
1750         /* all that work just for this */
1751         my_setenv_format(new_env, nam, nlen, val, vlen);
1752         (void)putenv(new_env);
1753 #       endif /* HAS_UNSETENV */
1754 #   endif /* __CYGWIN__ */
1755 #ifndef PERL_USE_SAFE_PUTENV
1756     }
1757 #endif
1758   }
1759 }
1760
1761 #else /* WIN32 || NETWARE */
1762
1763 void
1764 Perl_my_setenv(pTHX_ const char *nam, const char *val)
1765 {
1766     dVAR;
1767     register char *envstr;
1768     const int nlen = strlen(nam);
1769     int vlen;
1770
1771     if (!val) {
1772        val = "";
1773     }
1774     vlen = strlen(val);
1775     Newx(envstr, nlen+vlen+2, char);
1776     my_setenv_format(envstr, nam, nlen, val, vlen);
1777     (void)PerlEnv_putenv(envstr);
1778     Safefree(envstr);
1779 }
1780
1781 #endif /* WIN32 || NETWARE */
1782
1783 #endif /* !VMS && !EPOC*/
1784
1785 #ifdef UNLINK_ALL_VERSIONS
1786 I32
1787 Perl_unlnk(pTHX_ const char *f) /* unlink all versions of a file */
1788 {
1789     I32 retries = 0;
1790
1791     PERL_ARGS_ASSERT_UNLNK;
1792
1793     while (PerlLIO_unlink(f) >= 0)
1794         retries++;
1795     return retries ? 0 : -1;
1796 }
1797 #endif
1798
1799 /* this is a drop-in replacement for bcopy() */
1800 #if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY))
1801 char *
1802 Perl_my_bcopy(register const char *from,register char *to,register I32 len)
1803 {
1804     char * const retval = to;
1805
1806     PERL_ARGS_ASSERT_MY_BCOPY;
1807
1808     if (from - to >= 0) {
1809         while (len--)
1810             *to++ = *from++;
1811     }
1812     else {
1813         to += len;
1814         from += len;
1815         while (len--)
1816             *(--to) = *(--from);
1817     }
1818     return retval;
1819 }
1820 #endif
1821
1822 /* this is a drop-in replacement for memset() */
1823 #ifndef HAS_MEMSET
1824 void *
1825 Perl_my_memset(register char *loc, register I32 ch, register I32 len)
1826 {
1827     char * const retval = loc;
1828
1829     PERL_ARGS_ASSERT_MY_MEMSET;
1830
1831     while (len--)
1832         *loc++ = ch;
1833     return retval;
1834 }
1835 #endif
1836
1837 /* this is a drop-in replacement for bzero() */
1838 #if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
1839 char *
1840 Perl_my_bzero(register char *loc, register I32 len)
1841 {
1842     char * const retval = loc;
1843
1844     PERL_ARGS_ASSERT_MY_BZERO;
1845
1846     while (len--)
1847         *loc++ = 0;
1848     return retval;
1849 }
1850 #endif
1851
1852 /* this is a drop-in replacement for memcmp() */
1853 #if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
1854 I32
1855 Perl_my_memcmp(const char *s1, const char *s2, register I32 len)
1856 {
1857     register const U8 *a = (const U8 *)s1;
1858     register const U8 *b = (const U8 *)s2;
1859     register I32 tmp;
1860
1861     PERL_ARGS_ASSERT_MY_MEMCMP;
1862
1863     while (len--) {
1864         if ((tmp = *a++ - *b++))
1865             return tmp;
1866     }
1867     return 0;
1868 }
1869 #endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */
1870
1871 #ifndef HAS_VPRINTF
1872 /* This vsprintf replacement should generally never get used, since
1873    vsprintf was available in both System V and BSD 2.11.  (There may
1874    be some cross-compilation or embedded set-ups where it is needed,
1875    however.)
1876
1877    If you encounter a problem in this function, it's probably a symptom
1878    that Configure failed to detect your system's vprintf() function.
1879    See the section on "item vsprintf" in the INSTALL file.
1880
1881    This version may compile on systems with BSD-ish <stdio.h>,
1882    but probably won't on others.
1883 */
1884
1885 #ifdef USE_CHAR_VSPRINTF
1886 char *
1887 #else
1888 int
1889 #endif
1890 vsprintf(char *dest, const char *pat, void *args)
1891 {
1892     FILE fakebuf;
1893
1894 #if defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE)
1895     FILE_ptr(&fakebuf) = (STDCHAR *) dest;
1896     FILE_cnt(&fakebuf) = 32767;
1897 #else
1898     /* These probably won't compile -- If you really need
1899        this, you'll have to figure out some other method. */
1900     fakebuf._ptr = dest;
1901     fakebuf._cnt = 32767;
1902 #endif
1903 #ifndef _IOSTRG
1904 #define _IOSTRG 0
1905 #endif
1906     fakebuf._flag = _IOWRT|_IOSTRG;
1907     _doprnt(pat, args, &fakebuf);       /* what a kludge */
1908 #if defined(STDIO_PTR_LVALUE)
1909     *(FILE_ptr(&fakebuf)++) = '\0';
1910 #else
1911     /* PerlIO has probably #defined away fputc, but we want it here. */
1912 #  ifdef fputc
1913 #    undef fputc  /* XXX Should really restore it later */
1914 #  endif
1915     (void)fputc('\0', &fakebuf);
1916 #endif
1917 #ifdef USE_CHAR_VSPRINTF
1918     return(dest);
1919 #else
1920     return 0;           /* perl doesn't use return value */
1921 #endif
1922 }
1923
1924 #endif /* HAS_VPRINTF */
1925
1926 #ifdef MYSWAP
1927 #if BYTEORDER != 0x4321
1928 short
1929 Perl_my_swap(pTHX_ short s)
1930 {
1931 #if (BYTEORDER & 1) == 0
1932     short result;
1933
1934     result = ((s & 255) << 8) + ((s >> 8) & 255);
1935     return result;
1936 #else
1937     return s;
1938 #endif
1939 }
1940
1941 long
1942 Perl_my_htonl(pTHX_ long l)
1943 {
1944     union {
1945         long result;
1946         char c[sizeof(long)];
1947     } u;
1948
1949 #if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678
1950 #if BYTEORDER == 0x12345678
1951     u.result = 0;
1952 #endif
1953     u.c[0] = (l >> 24) & 255;
1954     u.c[1] = (l >> 16) & 255;
1955     u.c[2] = (l >> 8) & 255;
1956     u.c[3] = l & 255;
1957     return u.result;
1958 #else
1959 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
1960     Perl_croak(aTHX_ "Unknown BYTEORDER\n");
1961 #else
1962     register I32 o;
1963     register I32 s;
1964
1965     for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
1966         u.c[o & 0xf] = (l >> s) & 255;
1967     }
1968     return u.result;
1969 #endif
1970 #endif
1971 }
1972
1973 long
1974 Perl_my_ntohl(pTHX_ long l)
1975 {
1976     union {
1977         long l;
1978         char c[sizeof(long)];
1979     } u;
1980
1981 #if BYTEORDER == 0x1234
1982     u.c[0] = (l >> 24) & 255;
1983     u.c[1] = (l >> 16) & 255;
1984     u.c[2] = (l >> 8) & 255;
1985     u.c[3] = l & 255;
1986     return u.l;
1987 #else
1988 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
1989     Perl_croak(aTHX_ "Unknown BYTEORDER\n");
1990 #else
1991     register I32 o;
1992     register I32 s;
1993
1994     u.l = l;
1995     l = 0;
1996     for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
1997         l |= (u.c[o & 0xf] & 255) << s;
1998     }
1999     return l;
2000 #endif
2001 #endif
2002 }
2003
2004 #endif /* BYTEORDER != 0x4321 */
2005 #endif /* MYSWAP */
2006
2007 /*
2008  * Little-endian byte order functions - 'v' for 'VAX', or 'reVerse'.
2009  * If these functions are defined,
2010  * the BYTEORDER is neither 0x1234 nor 0x4321.
2011  * However, this is not assumed.
2012  * -DWS
2013  */
2014
2015 #define HTOLE(name,type)                                        \
2016         type                                                    \
2017         name (register type n)                                  \
2018         {                                                       \
2019             union {                                             \
2020                 type value;                                     \
2021                 char c[sizeof(type)];                           \
2022             } u;                                                \
2023             register U32 i;                                     \
2024             register U32 s = 0;                                 \
2025             for (i = 0; i < sizeof(u.c); i++, s += 8) {         \
2026                 u.c[i] = (n >> s) & 0xFF;                       \
2027             }                                                   \
2028             return u.value;                                     \
2029         }
2030
2031 #define LETOH(name,type)                                        \
2032         type                                                    \
2033         name (register type n)                                  \
2034         {                                                       \
2035             union {                                             \
2036                 type value;                                     \
2037                 char c[sizeof(type)];                           \
2038             } u;                                                \
2039             register U32 i;                                     \
2040             register U32 s = 0;                                 \
2041             u.value = n;                                        \
2042             n = 0;                                              \
2043             for (i = 0; i < sizeof(u.c); i++, s += 8) {         \
2044                 n |= ((type)(u.c[i] & 0xFF)) << s;              \
2045             }                                                   \
2046             return n;                                           \
2047         }
2048
2049 /*
2050  * Big-endian byte order functions.
2051  */
2052
2053 #define HTOBE(name,type)                                        \
2054         type                                                    \
2055         name (register type n)                                  \
2056         {                                                       \
2057             union {                                             \
2058                 type value;                                     \
2059                 char c[sizeof(type)];                           \
2060             } u;                                                \
2061             register U32 i;                                     \
2062             register U32 s = 8*(sizeof(u.c)-1);                 \
2063             for (i = 0; i < sizeof(u.c); i++, s -= 8) {         \
2064                 u.c[i] = (n >> s) & 0xFF;                       \
2065             }                                                   \
2066             return u.value;                                     \
2067         }
2068
2069 #define BETOH(name,type)                                        \
2070         type                                                    \
2071         name (register type n)                                  \
2072         {                                                       \
2073             union {                                             \
2074                 type value;                                     \
2075                 char c[sizeof(type)];                           \
2076             } u;                                                \
2077             register U32 i;                                     \
2078             register U32 s = 8*(sizeof(u.c)-1);                 \
2079             u.value = n;                                        \
2080             n = 0;                                              \
2081             for (i = 0; i < sizeof(u.c); i++, s -= 8) {         \
2082                 n |= ((type)(u.c[i] & 0xFF)) << s;              \
2083             }                                                   \
2084             return n;                                           \
2085         }
2086
2087 /*
2088  * If we just can't do it...
2089  */
2090
2091 #define NOT_AVAIL(name,type)                                    \
2092         type                                                    \
2093         name (register type n)                                  \
2094         {                                                       \
2095             Perl_croak_nocontext(#name "() not available");     \
2096             return n; /* not reached */                         \
2097         }
2098
2099
2100 #if defined(HAS_HTOVS) && !defined(htovs)
2101 HTOLE(htovs,short)
2102 #endif
2103 #if defined(HAS_HTOVL) && !defined(htovl)
2104 HTOLE(htovl,long)
2105 #endif
2106 #if defined(HAS_VTOHS) && !defined(vtohs)
2107 LETOH(vtohs,short)
2108 #endif
2109 #if defined(HAS_VTOHL) && !defined(vtohl)
2110 LETOH(vtohl,long)
2111 #endif
2112
2113 #ifdef PERL_NEED_MY_HTOLE16
2114 # if U16SIZE == 2
2115 HTOLE(Perl_my_htole16,U16)
2116 # else
2117 NOT_AVAIL(Perl_my_htole16,U16)
2118 # endif
2119 #endif
2120 #ifdef PERL_NEED_MY_LETOH16
2121 # if U16SIZE == 2
2122 LETOH(Perl_my_letoh16,U16)
2123 # else
2124 NOT_AVAIL(Perl_my_letoh16,U16)
2125 # endif
2126 #endif
2127 #ifdef PERL_NEED_MY_HTOBE16
2128 # if U16SIZE == 2
2129 HTOBE(Perl_my_htobe16,U16)
2130 # else
2131 NOT_AVAIL(Perl_my_htobe16,U16)
2132 # endif
2133 #endif
2134 #ifdef PERL_NEED_MY_BETOH16
2135 # if U16SIZE == 2
2136 BETOH(Perl_my_betoh16,U16)
2137 # else
2138 NOT_AVAIL(Perl_my_betoh16,U16)
2139 # endif
2140 #endif
2141
2142 #ifdef PERL_NEED_MY_HTOLE32
2143 # if U32SIZE == 4
2144 HTOLE(Perl_my_htole32,U32)
2145 # else
2146 NOT_AVAIL(Perl_my_htole32,U32)
2147 # endif
2148 #endif
2149 #ifdef PERL_NEED_MY_LETOH32
2150 # if U32SIZE == 4
2151 LETOH(Perl_my_letoh32,U32)
2152 # else
2153 NOT_AVAIL(Perl_my_letoh32,U32)
2154 # endif
2155 #endif
2156 #ifdef PERL_NEED_MY_HTOBE32
2157 # if U32SIZE == 4
2158 HTOBE(Perl_my_htobe32,U32)
2159 # else
2160 NOT_AVAIL(Perl_my_htobe32,U32)
2161 # endif
2162 #endif
2163 #ifdef PERL_NEED_MY_BETOH32
2164 # if U32SIZE == 4
2165 BETOH(Perl_my_betoh32,U32)
2166 # else
2167 NOT_AVAIL(Perl_my_betoh32,U32)
2168 # endif
2169 #endif
2170
2171 #ifdef PERL_NEED_MY_HTOLE64
2172 # if U64SIZE == 8
2173 HTOLE(Perl_my_htole64,U64)
2174 # else
2175 NOT_AVAIL(Perl_my_htole64,U64)
2176 # endif
2177 #endif
2178 #ifdef PERL_NEED_MY_LETOH64
2179 # if U64SIZE == 8
2180 LETOH(Perl_my_letoh64,U64)
2181 # else
2182 NOT_AVAIL(Perl_my_letoh64,U64)
2183 # endif
2184 #endif
2185 #ifdef PERL_NEED_MY_HTOBE64
2186 # if U64SIZE == 8
2187 HTOBE(Perl_my_htobe64,U64)
2188 # else
2189 NOT_AVAIL(Perl_my_htobe64,U64)
2190 # endif
2191 #endif
2192 #ifdef PERL_NEED_MY_BETOH64
2193 # if U64SIZE == 8
2194 BETOH(Perl_my_betoh64,U64)
2195 # else
2196 NOT_AVAIL(Perl_my_betoh64,U64)
2197 # endif
2198 #endif
2199
2200 #ifdef PERL_NEED_MY_HTOLES
2201 HTOLE(Perl_my_htoles,short)
2202 #endif
2203 #ifdef PERL_NEED_MY_LETOHS
2204 LETOH(Perl_my_letohs,short)
2205 #endif
2206 #ifdef PERL_NEED_MY_HTOBES
2207 HTOBE(Perl_my_htobes,short)
2208 #endif
2209 #ifdef PERL_NEED_MY_BETOHS
2210 BETOH(Perl_my_betohs,short)
2211 #endif
2212
2213 #ifdef PERL_NEED_MY_HTOLEI
2214 HTOLE(Perl_my_htolei,int)
2215 #endif
2216 #ifdef PERL_NEED_MY_LETOHI
2217 LETOH(Perl_my_letohi,int)
2218 #endif
2219 #ifdef PERL_NEED_MY_HTOBEI
2220 HTOBE(Perl_my_htobei,int)
2221 #endif
2222 #ifdef PERL_NEED_MY_BETOHI
2223 BETOH(Perl_my_betohi,int)
2224 #endif
2225
2226 #ifdef PERL_NEED_MY_HTOLEL
2227 HTOLE(Perl_my_htolel,long)
2228 #endif
2229 #ifdef PERL_NEED_MY_LETOHL
2230 LETOH(Perl_my_letohl,long)
2231 #endif
2232 #ifdef PERL_NEED_MY_HTOBEL
2233 HTOBE(Perl_my_htobel,long)
2234 #endif
2235 #ifdef PERL_NEED_MY_BETOHL
2236 BETOH(Perl_my_betohl,long)
2237 #endif
2238
2239 void
2240 Perl_my_swabn(void *ptr, int n)
2241 {
2242     register char *s = (char *)ptr;
2243     register char *e = s + (n-1);
2244     register char tc;
2245
2246     PERL_ARGS_ASSERT_MY_SWABN;
2247
2248     for (n /= 2; n > 0; s++, e--, n--) {
2249       tc = *s;
2250       *s = *e;
2251       *e = tc;
2252     }
2253 }
2254
2255 PerlIO *
2256 Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
2257 {
2258 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(NETWARE) && !defined(__LIBCATAMOUNT__)
2259     dVAR;
2260     int p[2];
2261     register I32 This, that;
2262     register Pid_t pid;
2263     SV *sv;
2264     I32 did_pipes = 0;
2265     int pp[2];
2266
2267     PERL_ARGS_ASSERT_MY_POPEN_LIST;
2268
2269     PERL_FLUSHALL_FOR_CHILD;
2270     This = (*mode == 'w');
2271     that = !This;
2272     if (PL_tainting) {
2273         taint_env();
2274         taint_proper("Insecure %s%s", "EXEC");
2275     }
2276     if (PerlProc_pipe(p) < 0)
2277         return NULL;
2278     /* Try for another pipe pair for error return */
2279     if (PerlProc_pipe(pp) >= 0)
2280         did_pipes = 1;
2281     while ((pid = PerlProc_fork()) < 0) {
2282         if (errno != EAGAIN) {
2283             PerlLIO_close(p[This]);
2284             PerlLIO_close(p[that]);
2285             if (did_pipes) {
2286                 PerlLIO_close(pp[0]);
2287                 PerlLIO_close(pp[1]);
2288             }
2289             return NULL;
2290         }
2291         if (ckWARN(WARN_PIPE))
2292             Perl_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
2293         sleep(5);
2294     }
2295     if (pid == 0) {
2296         /* Child */
2297 #undef THIS
2298 #undef THAT
2299 #define THIS that
2300 #define THAT This
2301         /* Close parent's end of error status pipe (if any) */
2302         if (did_pipes) {
2303             PerlLIO_close(pp[0]);
2304 #if defined(HAS_FCNTL) && defined(F_SETFD)
2305             /* Close error pipe automatically if exec works */
2306             fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2307 #endif
2308         }
2309         /* Now dup our end of _the_ pipe to right position */
2310         if (p[THIS] != (*mode == 'r')) {
2311             PerlLIO_dup2(p[THIS], *mode == 'r');
2312             PerlLIO_close(p[THIS]);
2313             if (p[THAT] != (*mode == 'r'))      /* if dup2() didn't close it */
2314                 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
2315         }
2316         else
2317             PerlLIO_close(p[THAT]);     /* close parent's end of _the_ pipe */
2318 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2319         /* No automatic close - do it by hand */
2320 #  ifndef NOFILE
2321 #  define NOFILE 20
2322 #  endif
2323         {
2324             int fd;
2325
2326             for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) {
2327                 if (fd != pp[1])
2328                     PerlLIO_close(fd);
2329             }
2330         }
2331 #endif
2332         do_aexec5(NULL, args-1, args-1+n, pp[1], did_pipes);
2333         PerlProc__exit(1);
2334 #undef THIS
2335 #undef THAT
2336     }
2337     /* Parent */
2338     do_execfree();      /* free any memory malloced by child on fork */
2339     if (did_pipes)
2340         PerlLIO_close(pp[1]);
2341     /* Keep the lower of the two fd numbers */
2342     if (p[that] < p[This]) {
2343         PerlLIO_dup2(p[This], p[that]);
2344         PerlLIO_close(p[This]);
2345         p[This] = p[that];
2346     }
2347     else
2348         PerlLIO_close(p[that]);         /* close child's end of pipe */
2349
2350     sv = *av_fetch(PL_fdpid,p[This],TRUE);
2351     SvUPGRADE(sv,SVt_IV);
2352     SvIV_set(sv, pid);
2353     PL_forkprocess = pid;
2354     /* If we managed to get status pipe check for exec fail */
2355     if (did_pipes && pid > 0) {
2356         int errkid;
2357         unsigned n = 0;
2358         SSize_t n1;
2359
2360         while (n < sizeof(int)) {
2361             n1 = PerlLIO_read(pp[0],
2362                               (void*)(((char*)&errkid)+n),
2363                               (sizeof(int)) - n);
2364             if (n1 <= 0)
2365                 break;
2366             n += n1;
2367         }
2368         PerlLIO_close(pp[0]);
2369         did_pipes = 0;
2370         if (n) {                        /* Error */
2371             int pid2, status;
2372             PerlLIO_close(p[This]);
2373             if (n != sizeof(int))
2374                 Perl_croak(aTHX_ "panic: kid popen errno read");
2375             do {
2376                 pid2 = wait4pid(pid, &status, 0);
2377             } while (pid2 == -1 && errno == EINTR);
2378             errno = errkid;             /* Propagate errno from kid */
2379             return NULL;
2380         }
2381     }
2382     if (did_pipes)
2383          PerlLIO_close(pp[0]);
2384     return PerlIO_fdopen(p[This], mode);
2385 #else
2386 #  ifdef OS2    /* Same, without fork()ing and all extra overhead... */
2387     return my_syspopen4(aTHX_ NULL, mode, n, args);
2388 #  else
2389     Perl_croak(aTHX_ "List form of piped open not implemented");
2390     return (PerlIO *) NULL;
2391 #  endif
2392 #endif
2393 }
2394
2395     /* VMS' my_popen() is in VMS.c, same with OS/2. */
2396 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(__LIBCATAMOUNT__)
2397 PerlIO *
2398 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2399 {
2400     dVAR;
2401     int p[2];
2402     register I32 This, that;
2403     register Pid_t pid;
2404     SV *sv;
2405     const I32 doexec = !(*cmd == '-' && cmd[1] == '\0');
2406     I32 did_pipes = 0;
2407     int pp[2];
2408
2409     PERL_ARGS_ASSERT_MY_POPEN;
2410
2411     PERL_FLUSHALL_FOR_CHILD;
2412 #ifdef OS2
2413     if (doexec) {
2414         return my_syspopen(aTHX_ cmd,mode);
2415     }
2416 #endif
2417     This = (*mode == 'w');
2418     that = !This;
2419     if (doexec && PL_tainting) {
2420         taint_env();
2421         taint_proper("Insecure %s%s", "EXEC");
2422     }
2423     if (PerlProc_pipe(p) < 0)
2424         return NULL;
2425     if (doexec && PerlProc_pipe(pp) >= 0)
2426         did_pipes = 1;
2427     while ((pid = PerlProc_fork()) < 0) {
2428         if (errno != EAGAIN) {
2429             PerlLIO_close(p[This]);
2430             PerlLIO_close(p[that]);
2431             if (did_pipes) {
2432                 PerlLIO_close(pp[0]);
2433                 PerlLIO_close(pp[1]);
2434             }
2435             if (!doexec)
2436                 Perl_croak(aTHX_ "Can't fork: %s", Strerror(errno));
2437             return NULL;
2438         }
2439         if (ckWARN(WARN_PIPE))
2440             Perl_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
2441         sleep(5);
2442     }
2443     if (pid == 0) {
2444         GV* tmpgv;
2445
2446 #undef THIS
2447 #undef THAT
2448 #define THIS that
2449 #define THAT This
2450         if (did_pipes) {
2451             PerlLIO_close(pp[0]);
2452 #if defined(HAS_FCNTL) && defined(F_SETFD)
2453             fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2454 #endif
2455         }
2456         if (p[THIS] != (*mode == 'r')) {
2457             PerlLIO_dup2(p[THIS], *mode == 'r');
2458             PerlLIO_close(p[THIS]);
2459             if (p[THAT] != (*mode == 'r'))      /* if dup2() didn't close it */
2460                 PerlLIO_close(p[THAT]);
2461         }
2462         else
2463             PerlLIO_close(p[THAT]);
2464 #ifndef OS2
2465         if (doexec) {
2466 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2467 #ifndef NOFILE
2468 #define NOFILE 20
2469 #endif
2470             {
2471                 int fd;
2472
2473                 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
2474                     if (fd != pp[1])
2475                         PerlLIO_close(fd);
2476             }
2477 #endif
2478             /* may or may not use the shell */
2479             do_exec3(cmd, pp[1], did_pipes);
2480             PerlProc__exit(1);
2481         }
2482 #endif  /* defined OS2 */
2483
2484 #ifdef PERLIO_USING_CRLF
2485    /* Since we circumvent IO layers when we manipulate low-level
2486       filedescriptors directly, need to manually switch to the
2487       default, binary, low-level mode; see PerlIOBuf_open(). */
2488    PerlLIO_setmode((*mode == 'r'), O_BINARY);
2489 #endif
2490
2491         if ((tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV))) {
2492             SvREADONLY_off(GvSV(tmpgv));
2493             sv_setiv(GvSV(tmpgv), PerlProc_getpid());
2494             SvREADONLY_on(GvSV(tmpgv));
2495         }
2496 #ifdef THREADS_HAVE_PIDS
2497         PL_ppid = (IV)getppid();
2498 #endif
2499         PL_forkprocess = 0;
2500 #ifdef PERL_USES_PL_PIDSTATUS
2501         hv_clear(PL_pidstatus); /* we have no children */
2502 #endif
2503         return NULL;
2504 #undef THIS
2505 #undef THAT
2506     }
2507     do_execfree();      /* free any memory malloced by child on vfork */
2508     if (did_pipes)
2509         PerlLIO_close(pp[1]);
2510     if (p[that] < p[This]) {
2511         PerlLIO_dup2(p[This], p[that]);
2512         PerlLIO_close(p[This]);
2513         p[This] = p[that];
2514     }
2515     else
2516         PerlLIO_close(p[that]);
2517
2518     sv = *av_fetch(PL_fdpid,p[This],TRUE);
2519     SvUPGRADE(sv,SVt_IV);
2520     SvIV_set(sv, pid);
2521     PL_forkprocess = pid;
2522     if (did_pipes && pid > 0) {
2523         int errkid;
2524         unsigned n = 0;
2525         SSize_t n1;
2526
2527         while (n < sizeof(int)) {
2528             n1 = PerlLIO_read(pp[0],
2529                               (void*)(((char*)&errkid)+n),
2530                               (sizeof(int)) - n);
2531             if (n1 <= 0)
2532                 break;
2533             n += n1;
2534         }
2535         PerlLIO_close(pp[0]);
2536         did_pipes = 0;
2537         if (n) {                        /* Error */
2538             int pid2, status;
2539             PerlLIO_close(p[This]);
2540             if (n != sizeof(int))
2541                 Perl_croak(aTHX_ "panic: kid popen errno read");
2542             do {
2543                 pid2 = wait4pid(pid, &status, 0);
2544             } while (pid2 == -1 && errno == EINTR);
2545             errno = errkid;             /* Propagate errno from kid */
2546             return NULL;
2547         }
2548     }
2549     if (did_pipes)
2550          PerlLIO_close(pp[0]);
2551     return PerlIO_fdopen(p[This], mode);
2552 }
2553 #else
2554 #if defined(atarist) || defined(EPOC)
2555 FILE *popen();
2556 PerlIO *
2557 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2558 {
2559     PERL_ARGS_ASSERT_MY_POPEN;
2560     PERL_FLUSHALL_FOR_CHILD;
2561     /* Call system's popen() to get a FILE *, then import it.
2562        used 0 for 2nd parameter to PerlIO_importFILE;
2563        apparently not used
2564     */
2565     return PerlIO_importFILE(popen(cmd, mode), 0);
2566 }
2567 #else
2568 #if defined(DJGPP)
2569 FILE *djgpp_popen();
2570 PerlIO *
2571 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2572 {
2573     PERL_FLUSHALL_FOR_CHILD;
2574     /* Call system's popen() to get a FILE *, then import it.
2575        used 0 for 2nd parameter to PerlIO_importFILE;
2576        apparently not used
2577     */
2578     return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
2579 }
2580 #else
2581 #if defined(__LIBCATAMOUNT__)
2582 PerlIO *
2583 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2584 {
2585     return NULL;
2586 }
2587 #endif
2588 #endif
2589 #endif
2590
2591 #endif /* !DOSISH */
2592
2593 /* this is called in parent before the fork() */
2594 void
2595 Perl_atfork_lock(void)
2596 {
2597    dVAR;
2598 #if defined(USE_ITHREADS)
2599     /* locks must be held in locking order (if any) */
2600 #  ifdef MYMALLOC
2601     MUTEX_LOCK(&PL_malloc_mutex);
2602 #  endif
2603     OP_REFCNT_LOCK;
2604 #endif
2605 }
2606
2607 /* this is called in both parent and child after the fork() */
2608 void
2609 Perl_atfork_unlock(void)
2610 {
2611     dVAR;
2612 #if defined(USE_ITHREADS)
2613     /* locks must be released in same order as in atfork_lock() */
2614 #  ifdef MYMALLOC
2615     MUTEX_UNLOCK(&PL_malloc_mutex);
2616 #  endif
2617     OP_REFCNT_UNLOCK;
2618 #endif
2619 }
2620
2621 Pid_t
2622 Perl_my_fork(void)
2623 {
2624 #if defined(HAS_FORK)
2625     Pid_t pid;
2626 #if defined(USE_ITHREADS) && !defined(HAS_PTHREAD_ATFORK)
2627     atfork_lock();
2628     pid = fork();
2629     atfork_unlock();
2630 #else
2631     /* atfork_lock() and atfork_unlock() are installed as pthread_atfork()
2632      * handlers elsewhere in the code */
2633     pid = fork();
2634 #endif
2635     return pid;
2636 #else
2637     /* this "canna happen" since nothing should be calling here if !HAS_FORK */
2638     Perl_croak_nocontext("fork() not available");
2639     return 0;
2640 #endif /* HAS_FORK */
2641 }
2642
2643 #ifdef DUMP_FDS
2644 void
2645 Perl_dump_fds(pTHX_ const char *const s)
2646 {
2647     int fd;
2648     Stat_t tmpstatbuf;
2649
2650     PERL_ARGS_ASSERT_DUMP_FDS;
2651
2652     PerlIO_printf(Perl_debug_log,"%s", s);
2653     for (fd = 0; fd < 32; fd++) {
2654         if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0)
2655             PerlIO_printf(Perl_debug_log," %d",fd);
2656     }
2657     PerlIO_printf(Perl_debug_log,"\n");
2658     return;
2659 }
2660 #endif  /* DUMP_FDS */
2661
2662 #ifndef HAS_DUP2
2663 int
2664 dup2(int oldfd, int newfd)
2665 {
2666 #if defined(HAS_FCNTL) && defined(F_DUPFD)
2667     if (oldfd == newfd)
2668         return oldfd;
2669     PerlLIO_close(newfd);
2670     return fcntl(oldfd, F_DUPFD, newfd);
2671 #else
2672 #define DUP2_MAX_FDS 256
2673     int fdtmp[DUP2_MAX_FDS];
2674     I32 fdx = 0;
2675     int fd;
2676
2677     if (oldfd == newfd)
2678         return oldfd;
2679     PerlLIO_close(newfd);
2680     /* good enough for low fd's... */
2681     while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
2682         if (fdx >= DUP2_MAX_FDS) {
2683             PerlLIO_close(fd);
2684             fd = -1;
2685             break;
2686         }
2687         fdtmp[fdx++] = fd;
2688     }
2689     while (fdx > 0)
2690         PerlLIO_close(fdtmp[--fdx]);
2691     return fd;
2692 #endif
2693 }
2694 #endif
2695
2696 #ifndef PERL_MICRO
2697 #ifdef HAS_SIGACTION
2698
2699 Sighandler_t
2700 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2701 {
2702     dVAR;
2703     struct sigaction act, oact;
2704
2705 #ifdef USE_ITHREADS
2706     /* only "parent" interpreter can diddle signals */
2707     if (PL_curinterp != aTHX)
2708         return (Sighandler_t) SIG_ERR;
2709 #endif
2710
2711     act.sa_handler = (void(*)(int))handler;
2712     sigemptyset(&act.sa_mask);
2713     act.sa_flags = 0;
2714 #ifdef SA_RESTART
2715     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2716         act.sa_flags |= SA_RESTART;     /* SVR4, 4.3+BSD */
2717 #endif
2718 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2719     if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
2720         act.sa_flags |= SA_NOCLDWAIT;
2721 #endif
2722     if (sigaction(signo, &act, &oact) == -1)
2723         return (Sighandler_t) SIG_ERR;
2724     else
2725         return (Sighandler_t) oact.sa_handler;
2726 }
2727
2728 Sighandler_t
2729 Perl_rsignal_state(pTHX_ int signo)
2730 {
2731     struct sigaction oact;
2732     PERL_UNUSED_CONTEXT;
2733
2734     if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
2735         return (Sighandler_t) SIG_ERR;
2736     else
2737         return (Sighandler_t) oact.sa_handler;
2738 }
2739
2740 int
2741 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2742 {
2743     dVAR;
2744     struct sigaction act;
2745
2746     PERL_ARGS_ASSERT_RSIGNAL_SAVE;
2747
2748 #ifdef USE_ITHREADS
2749     /* only "parent" interpreter can diddle signals */
2750     if (PL_curinterp != aTHX)
2751         return -1;
2752 #endif
2753
2754     act.sa_handler = (void(*)(int))handler;
2755     sigemptyset(&act.sa_mask);
2756     act.sa_flags = 0;
2757 #ifdef SA_RESTART
2758     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2759         act.sa_flags |= SA_RESTART;     /* SVR4, 4.3+BSD */
2760 #endif
2761 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2762     if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
2763         act.sa_flags |= SA_NOCLDWAIT;
2764 #endif
2765     return sigaction(signo, &act, save);
2766 }
2767
2768 int
2769 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2770 {
2771     dVAR;
2772 #ifdef USE_ITHREADS
2773     /* only "parent" interpreter can diddle signals */
2774     if (PL_curinterp != aTHX)
2775         return -1;
2776 #endif
2777
2778     return sigaction(signo, save, (struct sigaction *)NULL);
2779 }
2780
2781 #else /* !HAS_SIGACTION */
2782
2783 Sighandler_t
2784 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2785 {
2786 #if defined(USE_ITHREADS) && !defined(WIN32)
2787     /* only "parent" interpreter can diddle signals */
2788     if (PL_curinterp != aTHX)
2789         return (Sighandler_t) SIG_ERR;
2790 #endif
2791
2792     return PerlProc_signal(signo, handler);
2793 }
2794
2795 static Signal_t
2796 sig_trap(int signo)
2797 {
2798     dVAR;
2799     PL_sig_trapped++;
2800 }
2801
2802 Sighandler_t
2803 Perl_rsignal_state(pTHX_ int signo)
2804 {
2805     dVAR;
2806     Sighandler_t oldsig;
2807
2808 #if defined(USE_ITHREADS) && !defined(WIN32)
2809     /* only "parent" interpreter can diddle signals */
2810     if (PL_curinterp != aTHX)
2811         return (Sighandler_t) SIG_ERR;
2812 #endif
2813
2814     PL_sig_trapped = 0;
2815     oldsig = PerlProc_signal(signo, sig_trap);
2816     PerlProc_signal(signo, oldsig);
2817     if (PL_sig_trapped)
2818         PerlProc_kill(PerlProc_getpid(), signo);
2819     return oldsig;
2820 }
2821
2822 int
2823 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2824 {
2825 #if defined(USE_ITHREADS) && !defined(WIN32)
2826     /* only "parent" interpreter can diddle signals */
2827     if (PL_curinterp != aTHX)
2828         return -1;
2829 #endif
2830     *save = PerlProc_signal(signo, handler);
2831     return (*save == (Sighandler_t) SIG_ERR) ? -1 : 0;
2832 }
2833
2834 int
2835 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2836 {
2837 #if defined(USE_ITHREADS) && !defined(WIN32)
2838     /* only "parent" interpreter can diddle signals */
2839     if (PL_curinterp != aTHX)
2840         return -1;
2841 #endif
2842     return (PerlProc_signal(signo, *save) == (Sighandler_t) SIG_ERR) ? -1 : 0;
2843 }
2844
2845 #endif /* !HAS_SIGACTION */
2846 #endif /* !PERL_MICRO */
2847
2848     /* VMS' my_pclose() is in VMS.c; same with OS/2 */
2849 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(__LIBCATAMOUNT__)
2850 I32
2851 Perl_my_pclose(pTHX_ PerlIO *ptr)
2852 {
2853     dVAR;
2854     Sigsave_t hstat, istat, qstat;
2855     int status;
2856     SV **svp;
2857     Pid_t pid;
2858     Pid_t pid2;
2859     bool close_failed;
2860     dSAVEDERRNO;
2861
2862     svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE);
2863     pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
2864     SvREFCNT_dec(*svp);
2865     *svp = &PL_sv_undef;
2866 #ifdef OS2
2867     if (pid == -1) {                    /* Opened by popen. */
2868         return my_syspclose(ptr);
2869     }
2870 #endif
2871     close_failed = (PerlIO_close(ptr) == EOF);
2872     SAVE_ERRNO;
2873 #ifdef UTS
2874     if(PerlProc_kill(pid, 0) < 0) { return(pid); }   /* HOM 12/23/91 */
2875 #endif
2876 #ifndef PERL_MICRO
2877     rsignal_save(SIGHUP,  (Sighandler_t) SIG_IGN, &hstat);
2878     rsignal_save(SIGINT,  (Sighandler_t) SIG_IGN, &istat);
2879     rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qstat);
2880 #endif
2881     do {
2882         pid2 = wait4pid(pid, &status, 0);
2883     } while (pid2 == -1 && errno == EINTR);
2884 #ifndef PERL_MICRO
2885     rsignal_restore(SIGHUP, &hstat);
2886     rsignal_restore(SIGINT, &istat);
2887     rsignal_restore(SIGQUIT, &qstat);
2888 #endif
2889     if (close_failed) {
2890         RESTORE_ERRNO;
2891         return -1;
2892     }
2893     return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status));
2894 }
2895 #else
2896 #if defined(__LIBCATAMOUNT__)
2897 I32
2898 Perl_my_pclose(pTHX_ PerlIO *ptr)
2899 {
2900     return -1;
2901 }
2902 #endif
2903 #endif /* !DOSISH */
2904
2905 #if  (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(__LIBCATAMOUNT__)
2906 I32
2907 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
2908 {
2909     dVAR;
2910     I32 result = 0;
2911     PERL_ARGS_ASSERT_WAIT4PID;
2912     if (!pid)
2913         return -1;
2914 #ifdef PERL_USES_PL_PIDSTATUS
2915     {
2916         if (pid > 0) {
2917             /* The keys in PL_pidstatus are now the raw 4 (or 8) bytes of the
2918                pid, rather than a string form.  */
2919             SV * const * const svp = hv_fetch(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),FALSE);
2920             if (svp && *svp != &PL_sv_undef) {
2921                 *statusp = SvIVX(*svp);
2922                 (void)hv_delete(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),
2923                                 G_DISCARD);
2924                 return pid;
2925             }
2926         }
2927         else {
2928             HE *entry;
2929
2930             hv_iterinit(PL_pidstatus);
2931             if ((entry = hv_iternext(PL_pidstatus))) {
2932                 SV * const sv = hv_iterval(PL_pidstatus,entry);
2933                 I32 len;
2934                 const char * const spid = hv_iterkey(entry,&len);
2935
2936                 assert (len == sizeof(Pid_t));
2937                 memcpy((char *)&pid, spid, len);
2938                 *statusp = SvIVX(sv);
2939                 /* The hash iterator is currently on this entry, so simply
2940                    calling hv_delete would trigger the lazy delete, which on
2941                    aggregate does more work, beacuse next call to hv_iterinit()
2942                    would spot the flag, and have to call the delete routine,
2943                    while in the meantime any new entries can't re-use that
2944                    memory.  */
2945                 hv_iterinit(PL_pidstatus);
2946                 (void)hv_delete(PL_pidstatus,spid,len,G_DISCARD);
2947                 return pid;
2948             }
2949         }
2950     }
2951 #endif
2952 #ifdef HAS_WAITPID
2953 #  ifdef HAS_WAITPID_RUNTIME
2954     if (!HAS_WAITPID_RUNTIME)
2955         goto hard_way;
2956 #  endif
2957     result = PerlProc_waitpid(pid,statusp,flags);
2958     goto finish;
2959 #endif
2960 #if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
2961     result = wait4((pid==-1)?0:pid,statusp,flags,NULL);
2962     goto finish;
2963 #endif
2964 #ifdef PERL_USES_PL_PIDSTATUS
2965 #if defined(HAS_WAITPID) && defined(HAS_WAITPID_RUNTIME)
2966   hard_way:
2967 #endif
2968     {
2969         if (flags)
2970             Perl_croak(aTHX_ "Can't do waitpid with flags");
2971         else {
2972             while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
2973                 pidgone(result,*statusp);
2974             if (result < 0)
2975                 *statusp = -1;
2976         }
2977     }
2978 #endif
2979 #if defined(HAS_WAITPID) || defined(HAS_WAIT4)
2980   finish:
2981 #endif
2982     if (result < 0 && errno == EINTR) {
2983         PERL_ASYNC_CHECK();
2984         errno = EINTR; /* reset in case a signal handler changed $! */
2985     }
2986     return result;
2987 }
2988 #endif /* !DOSISH || OS2 || WIN32 || NETWARE */
2989
2990 #ifdef PERL_USES_PL_PIDSTATUS
2991 void
2992 S_pidgone(pTHX_ Pid_t pid, int status)
2993 {
2994     register SV *sv;
2995
2996     sv = *hv_fetch(PL_pidstatus,(const char*)&pid,sizeof(Pid_t),TRUE);
2997     SvUPGRADE(sv,SVt_IV);
2998     SvIV_set(sv, status);
2999     return;
3000 }
3001 #endif
3002
3003 #if defined(atarist) || defined(OS2) || defined(EPOC)
3004 int pclose();
3005 #ifdef HAS_FORK
3006 int                                     /* Cannot prototype with I32
3007                                            in os2ish.h. */
3008 my_syspclose(PerlIO *ptr)
3009 #else
3010 I32
3011 Perl_my_pclose(pTHX_ PerlIO *ptr)
3012 #endif
3013 {
3014     /* Needs work for PerlIO ! */
3015     FILE * const f = PerlIO_findFILE(ptr);
3016     const I32 result = pclose(f);
3017     PerlIO_releaseFILE(ptr,f);
3018     return result;
3019 }
3020 #endif
3021
3022 #if defined(DJGPP)
3023 int djgpp_pclose();
3024 I32
3025 Perl_my_pclose(pTHX_ PerlIO *ptr)
3026 {
3027     /* Needs work for PerlIO ! */
3028     FILE * const f = PerlIO_findFILE(ptr);
3029     I32 result = djgpp_pclose(f);
3030     result = (result << 8) & 0xff00;
3031     PerlIO_releaseFILE(ptr,f);
3032     return result;
3033 }
3034 #endif
3035
3036 void
3037 Perl_repeatcpy(pTHX_ register char *to, register const char *from, I32 len, register I32 count)
3038 {
3039     register I32 todo;
3040     register const char * const frombase = from;
3041     PERL_UNUSED_CONTEXT;
3042
3043     PERL_ARGS_ASSERT_REPEATCPY;
3044
3045     if (len == 1) {
3046         register const char c = *from;
3047         while (count-- > 0)
3048             *to++ = c;
3049         return;
3050     }
3051     while (count-- > 0) {
3052         for (todo = len; todo > 0; todo--) {
3053             *to++ = *from++;
3054         }
3055         from = frombase;
3056     }
3057 }
3058
3059 #ifndef HAS_RENAME
3060 I32
3061 Perl_same_dirent(pTHX_ const char *a, const char *b)
3062 {
3063     char *fa = strrchr(a,'/');
3064     char *fb = strrchr(b,'/');
3065     Stat_t tmpstatbuf1;
3066     Stat_t tmpstatbuf2;
3067     SV * const tmpsv = sv_newmortal();
3068
3069     PERL_ARGS_ASSERT_SAME_DIRENT;
3070
3071     if (fa)
3072         fa++;
3073     else
3074         fa = a;
3075     if (fb)
3076         fb++;
3077     else
3078         fb = b;
3079     if (strNE(a,b))
3080         return FALSE;
3081     if (fa == a)
3082         sv_setpvs(tmpsv, ".");
3083     else
3084         sv_setpvn(tmpsv, a, fa - a);
3085     if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0)
3086         return FALSE;
3087     if (fb == b)
3088         sv_setpvs(tmpsv, ".");
3089     else
3090         sv_setpvn(tmpsv, b, fb - b);
3091     if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0)
3092         return FALSE;
3093     return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
3094            tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
3095 }
3096 #endif /* !HAS_RENAME */
3097
3098 char*
3099 Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
3100                  const char *const *const search_ext, I32 flags)
3101 {
3102     dVAR;
3103     const char *xfound = NULL;
3104     char *xfailed = NULL;
3105     char tmpbuf[MAXPATHLEN];
3106     register char *s;
3107     I32 len = 0;
3108     int retval;
3109     char *bufend;
3110 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
3111 #  define SEARCH_EXTS ".bat", ".cmd", NULL
3112 #  define MAX_EXT_LEN 4
3113 #endif
3114 #ifdef OS2
3115 #  define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
3116 #  define MAX_EXT_LEN 4
3117 #endif
3118 #ifdef VMS
3119 #  define SEARCH_EXTS ".pl", ".com", NULL
3120 #  define MAX_EXT_LEN 4
3121 #endif
3122     /* additional extensions to try in each dir if scriptname not found */
3123 #ifdef SEARCH_EXTS
3124     static const char *const exts[] = { SEARCH_EXTS };
3125     const char *const *const ext = search_ext ? search_ext : exts;
3126     int extidx = 0, i = 0;
3127     const char *curext = NULL;
3128 #else
3129     PERL_UNUSED_ARG(search_ext);
3130 #  define MAX_EXT_LEN 0
3131 #endif
3132
3133     PERL_ARGS_ASSERT_FIND_SCRIPT;
3134
3135     /*
3136      * If dosearch is true and if scriptname does not contain path
3137      * delimiters, search the PATH for scriptname.
3138      *
3139      * If SEARCH_EXTS is also defined, will look for each
3140      * scriptname{SEARCH_EXTS} whenever scriptname is not found
3141      * while searching the PATH.
3142      *
3143      * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
3144      * proceeds as follows:
3145      *   If DOSISH or VMSISH:
3146      *     + look for ./scriptname{,.foo,.bar}
3147      *     + search the PATH for scriptname{,.foo,.bar}
3148      *
3149      *   If !DOSISH:
3150      *     + look *only* in the PATH for scriptname{,.foo,.bar} (note
3151      *       this will not look in '.' if it's not in the PATH)
3152      */
3153     tmpbuf[0] = '\0';
3154
3155 #ifdef VMS
3156 #  ifdef ALWAYS_DEFTYPES
3157     len = strlen(scriptname);
3158     if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
3159         int idx = 0, deftypes = 1;
3160         bool seen_dot = 1;
3161
3162         const int hasdir = !dosearch || (strpbrk(scriptname,":[</") != NULL);
3163 #  else
3164     if (dosearch) {
3165         int idx = 0, deftypes = 1;
3166         bool seen_dot = 1;
3167
3168         const int hasdir = (strpbrk(scriptname,":[</") != NULL);
3169 #  endif
3170         /* The first time through, just add SEARCH_EXTS to whatever we
3171          * already have, so we can check for default file types. */
3172         while (deftypes ||
3173                (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
3174         {
3175             if (deftypes) {
3176                 deftypes = 0;
3177                 *tmpbuf = '\0';
3178             }
3179             if ((strlen(tmpbuf) + strlen(scriptname)
3180                  + MAX_EXT_LEN) >= sizeof tmpbuf)
3181                 continue;       /* don't search dir with too-long name */
3182             my_strlcat(tmpbuf, scriptname, sizeof(tmpbuf));
3183 #else  /* !VMS */
3184
3185 #ifdef DOSISH
3186     if (strEQ(scriptname, "-"))
3187         dosearch = 0;
3188     if (dosearch) {             /* Look in '.' first. */
3189         const char *cur = scriptname;
3190 #ifdef SEARCH_EXTS
3191         if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
3192             while (ext[i])
3193                 if (strEQ(ext[i++],curext)) {
3194                     extidx = -1;                /* already has an ext */
3195                     break;
3196                 }
3197         do {
3198 #endif
3199             DEBUG_p(PerlIO_printf(Perl_debug_log,
3200                                   "Looking for %s\n",cur));
3201             if (PerlLIO_stat(cur,&PL_statbuf) >= 0
3202                 && !S_ISDIR(PL_statbuf.st_mode)) {
3203                 dosearch = 0;
3204                 scriptname = cur;
3205 #ifdef SEARCH_EXTS
3206                 break;
3207 #endif
3208             }
3209 #ifdef SEARCH_EXTS
3210             if (cur == scriptname) {
3211                 len = strlen(scriptname);
3212                 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
3213                     break;
3214                 my_strlcpy(tmpbuf, scriptname, sizeof(tmpbuf));
3215                 cur = tmpbuf;
3216             }
3217         } while (extidx >= 0 && ext[extidx]     /* try an extension? */
3218                  && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len));
3219 #endif
3220     }
3221 #endif
3222
3223     if (dosearch && !strchr(scriptname, '/')
3224 #ifdef DOSISH
3225                  && !strchr(scriptname, '\\')
3226 #endif
3227                  && (s = PerlEnv_getenv("PATH")))
3228     {
3229         bool seen_dot = 0;
3230
3231         bufend = s + strlen(s);
3232         while (s < bufend) {
3233 #if defined(atarist) || defined(DOSISH)
3234             for (len = 0; *s
3235 #  ifdef atarist
3236                     && *s != ','
3237 #  endif
3238                     && *s != ';'; len++, s++) {
3239                 if (len < sizeof tmpbuf)
3240                     tmpbuf[len] = *s;
3241             }
3242             if (len < sizeof tmpbuf)
3243                 tmpbuf[len] = '\0';
3244 #else  /* ! (atarist || DOSISH) */
3245             s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend,
3246                         ':',
3247                         &len);
3248 #endif /* ! (atarist || DOSISH) */
3249             if (s < bufend)
3250                 s++;
3251             if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
3252                 continue;       /* don't search dir with too-long name */
3253             if (len
3254 #  if defined(atarist) || defined(__MINT__) || defined(DOSISH)
3255                 && tmpbuf[len - 1] != '/'
3256                 && tmpbuf[len - 1] != '\\'
3257 #  endif
3258                )
3259                 tmpbuf[len++] = '/';
3260             if (len == 2 && tmpbuf[0] == '.')
3261                 seen_dot = 1;
3262             (void)my_strlcpy(tmpbuf + len, scriptname, sizeof(tmpbuf) - len);
3263 #endif  /* !VMS */
3264
3265 #ifdef SEARCH_EXTS
3266             len = strlen(tmpbuf);
3267             if (extidx > 0)     /* reset after previous loop */
3268                 extidx = 0;
3269             do {
3270 #endif
3271                 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
3272                 retval = PerlLIO_stat(tmpbuf,&PL_statbuf);
3273                 if (S_ISDIR(PL_statbuf.st_mode)) {
3274                     retval = -1;
3275                 }
3276 #ifdef SEARCH_EXTS
3277             } while (  retval < 0               /* not there */
3278                     && extidx>=0 && ext[extidx] /* try an extension? */
3279                     && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len)
3280                 );
3281 #endif
3282             if (retval < 0)
3283                 continue;
3284             if (S_ISREG(PL_statbuf.st_mode)
3285                 && cando(S_IRUSR,TRUE,&PL_statbuf)
3286 #if !defined(DOSISH)
3287                 && cando(S_IXUSR,TRUE,&PL_statbuf)
3288 #endif
3289                 )
3290             {
3291                 xfound = tmpbuf;                /* bingo! */
3292                 break;
3293             }
3294             if (!xfailed)
3295                 xfailed = savepv(tmpbuf);
3296         }
3297 #ifndef DOSISH
3298         if (!xfound && !seen_dot && !xfailed &&
3299             (PerlLIO_stat(scriptname,&PL_statbuf) < 0
3300              || S_ISDIR(PL_statbuf.st_mode)))
3301 #endif
3302             seen_dot = 1;                       /* Disable message. */
3303         if (!xfound) {
3304             if (flags & 1) {                    /* do or die? */
3305                 Perl_croak(aTHX_ "Can't %s %s%s%s",
3306                       (xfailed ? "execute" : "find"),
3307                       (xfailed ? xfailed : scriptname),
3308                       (xfailed ? "" : " on PATH"),
3309                       (xfailed || seen_dot) ? "" : ", '.' not in PATH");
3310             }
3311             scriptname = NULL;
3312         }
3313         Safefree(xfailed);
3314         scriptname = xfound;
3315     }
3316     return (scriptname ? savepv(scriptname) : NULL);
3317 }
3318
3319 #ifndef PERL_GET_CONTEXT_DEFINED
3320
3321 void *
3322 Perl_get_context(void)
3323 {
3324     dVAR;
3325 #if defined(USE_ITHREADS)
3326 #  ifdef OLD_PTHREADS_API
3327     pthread_addr_t t;
3328     if (pthread_getspecific(PL_thr_key, &t))
3329         Perl_croak_nocontext("panic: pthread_getspecific");
3330     return (void*)t;
3331 #  else
3332 #    ifdef I_MACH_CTHREADS
3333     return (void*)cthread_data(cthread_self());
3334 #    else
3335     return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
3336 #    endif
3337 #  endif
3338 #else
3339     return (void*)NULL;
3340 #endif
3341 }
3342
3343 void
3344 Perl_set_context(void *t)
3345 {
3346     dVAR;
3347     PERL_ARGS_ASSERT_SET_CONTEXT;
3348 #if defined(USE_ITHREADS)
3349 #  ifdef I_MACH_CTHREADS
3350     cthread_set_data(cthread_self(), t);
3351 #  else
3352     if (pthread_setspecific(PL_thr_key, t))
3353         Perl_croak_nocontext("panic: pthread_setspecific");
3354 #  endif
3355 #else
3356     PERL_UNUSED_ARG(t);
3357 #endif
3358 }
3359
3360 #endif /* !PERL_GET_CONTEXT_DEFINED */
3361
3362 #if defined(PERL_GLOBAL_STRUCT) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
3363 struct perl_vars *
3364 Perl_GetVars(pTHX)
3365 {
3366  return &PL_Vars;
3367 }
3368 #endif
3369
3370 char **
3371 Perl_get_op_names(pTHX)
3372 {
3373     PERL_UNUSED_CONTEXT;
3374     return (char **)PL_op_name;
3375 }
3376
3377 char **
3378 Perl_get_op_descs(pTHX)
3379 {
3380     PERL_UNUSED_CONTEXT;
3381     return (char **)PL_op_desc;
3382 }
3383
3384 const char *
3385 Perl_get_no_modify(pTHX)
3386 {
3387     PERL_UNUSED_CONTEXT;
3388     return PL_no_modify;
3389 }
3390
3391 U32 *
3392 Perl_get_opargs(pTHX)
3393 {
3394     PERL_UNUSED_CONTEXT;
3395     return (U32 *)PL_opargs;
3396 }
3397
3398 PPADDR_t*
3399 Perl_get_ppaddr(pTHX)
3400 {
3401     dVAR;
3402     PERL_UNUSED_CONTEXT;
3403     return (PPADDR_t*)PL_ppaddr;
3404 }
3405
3406 #ifndef HAS_GETENV_LEN
3407 char *
3408 Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
3409 {
3410     char * const env_trans = PerlEnv_getenv(env_elem);
3411     PERL_UNUSED_CONTEXT;
3412     PERL_ARGS_ASSERT_GETENV_LEN;
3413     if (env_trans)
3414         *len = strlen(env_trans);
3415     return env_trans;
3416 }
3417 #endif
3418
3419
3420 MGVTBL*
3421 Perl_get_vtbl(pTHX_ int vtbl_id)
3422 {
3423     const MGVTBL* result;
3424     PERL_UNUSED_CONTEXT;
3425
3426     switch(vtbl_id) {
3427     case want_vtbl_sv:
3428         result = &PL_vtbl_sv;
3429         break;
3430     case want_vtbl_env:
3431         result = &PL_vtbl_env;
3432         break;
3433     case want_vtbl_envelem:
3434         result = &PL_vtbl_envelem;
3435         break;
3436     case want_vtbl_sig:
3437         result = &PL_vtbl_sig;
3438         break;
3439     case want_vtbl_sigelem:
3440         result = &PL_vtbl_sigelem;
3441         break;
3442     case want_vtbl_pack:
3443         result = &PL_vtbl_pack;
3444         break;
3445     case want_vtbl_packelem:
3446         result = &PL_vtbl_packelem;
3447         break;
3448     case want_vtbl_dbline:
3449         result = &PL_vtbl_dbline;
3450         break;
3451     case want_vtbl_isa:
3452         result = &PL_vtbl_isa;
3453         break;
3454     case want_vtbl_isaelem:
3455         result = &PL_vtbl_isaelem;
3456         break;
3457     case want_vtbl_arylen:
3458         result = &PL_vtbl_arylen;
3459         break;
3460     case want_vtbl_mglob:
3461         result = &PL_vtbl_mglob;
3462         break;
3463     case want_vtbl_nkeys:
3464         result = &PL_vtbl_nkeys;
3465         break;
3466     case want_vtbl_taint:
3467         result = &PL_vtbl_taint;
3468         break;
3469     case want_vtbl_substr:
3470         result = &PL_vtbl_substr;
3471         break;
3472     case want_vtbl_vec:
3473         result = &PL_vtbl_vec;
3474         break;
3475     case want_vtbl_pos:
3476         result = &PL_vtbl_pos;
3477         break;
3478     case want_vtbl_bm:
3479         result = &PL_vtbl_bm;
3480         break;
3481     case want_vtbl_fm:
3482         result = &PL_vtbl_fm;
3483         break;
3484     case want_vtbl_uvar:
3485         result = &PL_vtbl_uvar;
3486         break;
3487     case want_vtbl_defelem:
3488         result = &PL_vtbl_defelem;
3489         break;
3490     case want_vtbl_regexp:
3491         result = &PL_vtbl_regexp;
3492         break;
3493     case want_vtbl_regdata:
3494         result = &PL_vtbl_regdata;
3495         break;
3496     case want_vtbl_regdatum:
3497         result = &PL_vtbl_regdatum;
3498         break;
3499 #ifdef USE_LOCALE_COLLATE
3500     case want_vtbl_collxfrm:
3501         result = &PL_vtbl_collxfrm;
3502         break;
3503 #endif
3504     case want_vtbl_amagic:
3505         result = &PL_vtbl_amagic;
3506         break;
3507     case want_vtbl_amagicelem:
3508         result = &PL_vtbl_amagicelem;
3509         break;
3510     case want_vtbl_backref:
3511         result = &PL_vtbl_backref;
3512         break;
3513     case want_vtbl_utf8:
3514         result = &PL_vtbl_utf8;
3515         break;
3516     default:
3517         result = NULL;
3518         break;
3519     }
3520     return (MGVTBL*)result;
3521 }
3522
3523 I32
3524 Perl_my_fflush_all(pTHX)
3525 {
3526 #if defined(USE_PERLIO) || defined(FFLUSH_NULL) || defined(USE_SFIO)
3527     return PerlIO_flush(NULL);
3528 #else
3529 # if defined(HAS__FWALK)
3530     extern int fflush(FILE *);
3531     /* undocumented, unprototyped, but very useful BSDism */
3532     extern void _fwalk(int (*)(FILE *));
3533     _fwalk(&fflush);
3534     return 0;
3535 # else
3536 #  if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
3537     long open_max = -1;
3538 #   ifdef PERL_FFLUSH_ALL_FOPEN_MAX
3539     open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
3540 #   else
3541 #    if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
3542     open_max = sysconf(_SC_OPEN_MAX);
3543 #     else
3544 #      ifdef FOPEN_MAX
3545     open_max = FOPEN_MAX;
3546 #      else
3547 #       ifdef OPEN_MAX
3548     open_max = OPEN_MAX;
3549 #       else
3550 #        ifdef _NFILE
3551     open_max = _NFILE;
3552 #        endif
3553 #       endif
3554 #      endif
3555 #     endif
3556 #    endif
3557     if (open_max > 0) {
3558       long i;
3559       for (i = 0; i < open_max; i++)
3560             if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
3561                 STDIO_STREAM_ARRAY[i]._file < open_max &&
3562                 STDIO_STREAM_ARRAY[i]._flag)
3563                 PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
3564       return 0;
3565     }
3566 #  endif
3567     SETERRNO(EBADF,RMS_IFI);
3568     return EOF;
3569 # endif
3570 #endif
3571 }
3572
3573 void
3574 Perl_report_evil_fh(pTHX_ const GV *gv, const IO *io, I32 op)
3575 {
3576     const char * const name = gv && isGV(gv) ? GvENAME(gv) : NULL;
3577
3578     if (op == OP_phoney_OUTPUT_ONLY || op == OP_phoney_INPUT_ONLY) {
3579         if (ckWARN(WARN_IO)) {
3580             const char * const direction =
3581                 (const char *)((op == OP_phoney_INPUT_ONLY) ? "in" : "out");
3582             if (name && *name)
3583                 Perl_warner(aTHX_ packWARN(WARN_IO),
3584                             "Filehandle %s opened only for %sput",
3585                             name, direction);
3586             else
3587                 Perl_warner(aTHX_ packWARN(WARN_IO),
3588                             "Filehandle opened only for %sput", direction);
3589         }
3590     }
3591     else {
3592         const char *vile;
3593         I32   warn_type;
3594
3595         if (gv && io && IoTYPE(io) == IoTYPE_CLOSED) {
3596             vile = "closed";
3597             warn_type = WARN_CLOSED;
3598         }
3599         else {
3600             vile = "unopened";
3601             warn_type = WARN_UNOPENED;
3602         }
3603
3604         if (ckWARN(warn_type)) {
3605             const char * const pars =
3606                 (const char *)(OP_IS_FILETEST(op) ? "" : "()");
3607             const char * const func =
3608                 (const char *)
3609                 (op == OP_READLINE   ? "readline"  :    /* "<HANDLE>" not nice */
3610                  op == OP_LEAVEWRITE ? "write" :                /* "write exit" not nice */
3611                  op < 0              ? "" :              /* handle phoney cases */
3612                  PL_op_desc[op]);
3613             const char * const type =
3614                 (const char *)
3615                 (OP_IS_SOCKET(op) ||
3616                  (gv && io && IoTYPE(io) == IoTYPE_SOCKET) ?
3617                  "socket" : "filehandle");
3618             if (name && *name) {
3619                 Perl_warner(aTHX_ packWARN(warn_type),
3620                             "%s%s on %s %s %s", func, pars, vile, type, name);
3621                 if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3622                     Perl_warner(
3623                         aTHX_ packWARN(warn_type),
3624                         "\t(Are you trying to call %s%s on dirhandle %s?)\n",
3625                         func, pars, name
3626                     );
3627             }
3628             else {
3629                 Perl_warner(aTHX_ packWARN(warn_type),
3630                             "%s%s on %s %s", func, pars, vile, type);
3631                 if (gv && io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3632                     Perl_warner(
3633                         aTHX_ packWARN(warn_type),
3634                         "\t(Are you trying to call %s%s on dirhandle?)\n",
3635                         func, pars
3636                     );
3637             }
3638         }
3639     }
3640 }
3641
3642 #ifdef EBCDIC
3643 /* in ASCII order, not that it matters */
3644 static const char controllablechars[] = "?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_";
3645
3646 int
3647 Perl_ebcdic_control(pTHX_ int ch)
3648 {
3649     if (ch > 'a') {
3650         const char *ctlp;
3651
3652         if (islower(ch))
3653             ch = toupper(ch);
3654
3655         if ((ctlp = strchr(controllablechars, ch)) == 0) {
3656             Perl_die(aTHX_ "unrecognised control character '%c'\n", ch);
3657         }
3658
3659         if (ctlp == controllablechars)
3660             return('\177'); /* DEL */
3661         else
3662             return((unsigned char)(ctlp - controllablechars - 1));
3663     } else { /* Want uncontrol */
3664         if (ch == '\177' || ch == -1)
3665             return('?');
3666         else if (ch == '\157')
3667             return('\177');
3668         else if (ch == '\174')
3669             return('\000');
3670         else if (ch == '^')    /* '\137' in 1047, '\260' in 819 */
3671             return('\036');
3672         else if (ch == '\155')
3673             return('\037');
3674         else if (0 < ch && ch < (sizeof(controllablechars) - 1))
3675             return(controllablechars[ch+1]);
3676         else
3677             Perl_die(aTHX_ "invalid control request: '\\%03o'\n", ch & 0xFF);
3678     }
3679 }
3680 #endif
3681
3682 /* To workaround core dumps from the uninitialised tm_zone we get the
3683  * system to give us a reasonable struct to copy.  This fix means that
3684  * strftime uses the tm_zone and tm_gmtoff values returned by
3685  * localtime(time()). That should give the desired result most of the
3686  * time. But probably not always!
3687  *
3688  * This does not address tzname aspects of NETaa14816.
3689  *
3690  */
3691
3692 #ifdef HAS_GNULIBC
3693 # ifndef STRUCT_TM_HASZONE
3694 #    define STRUCT_TM_HASZONE
3695 # endif
3696 #endif
3697
3698 #ifdef STRUCT_TM_HASZONE /* Backward compat */
3699 # ifndef HAS_TM_TM_ZONE
3700 #    define HAS_TM_TM_ZONE
3701 # endif
3702 #endif
3703
3704 void
3705 Perl_init_tm(pTHX_ struct tm *ptm)      /* see mktime, strftime and asctime */
3706 {
3707 #ifdef HAS_TM_TM_ZONE
3708     Time_t now;
3709     const struct tm* my_tm;
3710     PERL_ARGS_ASSERT_INIT_TM;
3711     (void)time(&now);
3712     my_tm = localtime(&now);
3713     if (my_tm)
3714         Copy(my_tm, ptm, 1, struct tm);
3715 #else
3716     PERL_ARGS_ASSERT_INIT_TM;
3717     PERL_UNUSED_ARG(ptm);
3718 #endif
3719 }
3720
3721 /*
3722  * mini_mktime - normalise struct tm values without the localtime()
3723  * semantics (and overhead) of mktime().
3724  */
3725 void
3726 Perl_mini_mktime(pTHX_ struct tm *ptm)
3727 {
3728     int yearday;
3729     int secs;
3730     int month, mday, year, jday;
3731     int odd_cent, odd_year;
3732     PERL_UNUSED_CONTEXT;
3733
3734     PERL_ARGS_ASSERT_MINI_MKTIME;
3735
3736 #define DAYS_PER_YEAR   365
3737 #define DAYS_PER_QYEAR  (4*DAYS_PER_YEAR+1)
3738 #define DAYS_PER_CENT   (25*DAYS_PER_QYEAR-1)
3739 #define DAYS_PER_QCENT  (4*DAYS_PER_CENT+1)
3740 #define SECS_PER_HOUR   (60*60)
3741 #define SECS_PER_DAY    (24*SECS_PER_HOUR)
3742 /* parentheses deliberately absent on these two, otherwise they don't work */
3743 #define MONTH_TO_DAYS   153/5
3744 #define DAYS_TO_MONTH   5/153
3745 /* offset to bias by March (month 4) 1st between month/mday & year finding */
3746 #define YEAR_ADJUST     (4*MONTH_TO_DAYS+1)
3747 /* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */
3748 #define WEEKDAY_BIAS    6       /* (1+6)%7 makes Sunday 0 again */
3749
3750 /*
3751  * Year/day algorithm notes:
3752  *
3753  * With a suitable offset for numeric value of the month, one can find
3754  * an offset into the year by considering months to have 30.6 (153/5) days,
3755  * using integer arithmetic (i.e., with truncation).  To avoid too much
3756  * messing about with leap days, we consider January and February to be
3757  * the 13th and 14th month of the previous year.  After that transformation,
3758  * we need the month index we use to be high by 1 from 'normal human' usage,
3759  * so the month index values we use run from 4 through 15.
3760  *
3761  * Given that, and the rules for the Gregorian calendar (leap years are those
3762  * divisible by 4 unless also divisible by 100, when they must be divisible
3763  * by 400 instead), we can simply calculate the number of days since some
3764  * arbitrary 'beginning of time' by futzing with the (adjusted) year number,
3765  * the days we derive from our month index, and adding in the day of the
3766  * month.  The value used here is not adjusted for the actual origin which
3767  * it normally would use (1 January A.D. 1), since we're not exposing it.
3768  * We're only building the value so we can turn around and get the
3769  * normalised values for the year, month, day-of-month, and day-of-year.
3770  *
3771  * For going backward, we need to bias the value we're using so that we find
3772  * the right year value.  (Basically, we don't want the contribution of
3773  * March 1st to the number to apply while deriving the year).  Having done
3774  * that, we 'count up' the contribution to the year number by accounting for
3775  * full quadracenturies (400-year periods) with their extra leap days, plus
3776  * the contribution from full centuries (to avoid counting in the lost leap
3777  * days), plus the contribution from full quad-years (to count in the normal
3778  * leap days), plus the leftover contribution from any non-leap years.
3779  * At this point, if we were working with an actual leap day, we'll have 0
3780  * days left over.  This is also true for March 1st, however.  So, we have
3781  * to special-case that result, and (earlier) keep track of the 'odd'
3782  * century and year contributions.  If we got 4 extra centuries in a qcent,
3783  * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb.
3784  * Otherwise, we add back in the earlier bias we removed (the 123 from
3785  * figuring in March 1st), find the month index (integer division by 30.6),
3786  * and the remainder is the day-of-month.  We then have to convert back to
3787  * 'real' months (including fixing January and February from being 14/15 in
3788  * the previous year to being in the proper year).  After that, to get
3789  * tm_yday, we work with the normalised year and get a new yearday value for
3790  * January 1st, which we subtract from the yearday value we had earlier,
3791  * representing the date we've re-built.  This is done from January 1
3792  * because tm_yday is 0-origin.
3793  *
3794  * Since POSIX time routines are only guaranteed to work for times since the
3795  * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm
3796  * applies Gregorian calendar rules even to dates before the 16th century
3797  * doesn't bother me.  Besides, you'd need cultural context for a given
3798  * date to know whether it was Julian or Gregorian calendar, and that's
3799  * outside the scope for this routine.  Since we convert back based on the
3800  * same rules we used to build the yearday, you'll only get strange results
3801  * for input which needed normalising, or for the 'odd' century years which
3802  * were leap years in the Julian calander but not in the Gregorian one.
3803  * I can live with that.
3804  *
3805  * This algorithm also fails to handle years before A.D. 1 gracefully, but
3806  * that's still outside the scope for POSIX time manipulation, so I don't
3807  * care.
3808  */
3809
3810     year = 1900 + ptm->tm_year;
3811     month = ptm->tm_mon;
3812     mday = ptm->tm_mday;
3813     /* allow given yday with no month & mday to dominate the result */
3814     if (ptm->tm_yday >= 0 && mday <= 0 && month <= 0) {
3815         month = 0;
3816         mday = 0;
3817         jday = 1 + ptm->tm_yday;
3818     }
3819     else {
3820         jday = 0;
3821     }
3822     if (month >= 2)
3823         month+=2;
3824     else
3825         month+=14, year--;
3826     yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400;
3827     yearday += month*MONTH_TO_DAYS + mday + jday;
3828     /*
3829      * Note that we don't know when leap-seconds were or will be,
3830      * so we have to trust the user if we get something which looks
3831      * like a sensible leap-second.  Wild values for seconds will
3832      * be rationalised, however.
3833      */
3834     if ((unsigned) ptm->tm_sec <= 60) {
3835         secs = 0;
3836     }
3837     else {
3838         secs = ptm->tm_sec;
3839         ptm->tm_sec = 0;
3840     }
3841     secs += 60 * ptm->tm_min;
3842     secs += SECS_PER_HOUR * ptm->tm_hour;
3843     if (secs < 0) {
3844         if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) {
3845             /* got negative remainder, but need positive time */
3846             /* back off an extra day to compensate */
3847             yearday += (secs/SECS_PER_DAY)-1;
3848             secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1);
3849         }
3850         else {
3851             yearday += (secs/SECS_PER_DAY);
3852             secs -= SECS_PER_DAY * (secs/SECS_PER_DAY);
3853         }
3854     }
3855     else if (secs >= SECS_PER_DAY) {
3856         yearday += (secs/SECS_PER_DAY);
3857         secs %= SECS_PER_DAY;
3858     }
3859     ptm->tm_hour = secs/SECS_PER_HOUR;
3860     secs %= SECS_PER_HOUR;
3861     ptm->tm_min = secs/60;
3862     secs %= 60;
3863     ptm->tm_sec += secs;
3864     /* done with time of day effects */
3865     /*
3866      * The algorithm for yearday has (so far) left it high by 428.
3867      * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to
3868      * bias it by 123 while trying to figure out what year it
3869      * really represents.  Even with this tweak, the reverse
3870      * translation fails for years before A.D. 0001.
3871      * It would still fail for Feb 29, but we catch that one below.
3872      */
3873     jday = yearday;     /* save for later fixup vis-a-vis Jan 1 */
3874     yearday -= YEAR_ADJUST;
3875     year = (yearday / DAYS_PER_QCENT) * 400;
3876     yearday %= DAYS_PER_QCENT;
3877     odd_cent = yearday / DAYS_PER_CENT;
3878     year += odd_cent * 100;
3879     yearday %= DAYS_PER_CENT;
3880     year += (yearday / DAYS_PER_QYEAR) * 4;
3881     yearday %= DAYS_PER_QYEAR;
3882     odd_year = yearday / DAYS_PER_YEAR;
3883     year += odd_year;
3884     yearday %= DAYS_PER_YEAR;
3885     if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */
3886         month = 1;
3887         yearday = 29;
3888     }
3889     else {
3890         yearday += YEAR_ADJUST; /* recover March 1st crock */
3891         month = yearday*DAYS_TO_MONTH;
3892         yearday -= month*MONTH_TO_DAYS;
3893         /* recover other leap-year adjustment */
3894         if (month > 13) {
3895             month-=14;
3896             year++;
3897         }
3898         else {
3899             month-=2;
3900         }
3901     }
3902     ptm->tm_year = year - 1900;
3903     if (yearday) {
3904       ptm->tm_mday = yearday;
3905       ptm->tm_mon = month;
3906     }
3907     else {
3908       ptm->tm_mday = 31;
3909       ptm->tm_mon = month - 1;
3910     }
3911     /* re-build yearday based on Jan 1 to get tm_yday */
3912     year--;
3913     yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400;
3914     yearday += 14*MONTH_TO_DAYS + 1;
3915     ptm->tm_yday = jday - yearday;
3916     /* fix tm_wday if not overridden by caller */
3917     if ((unsigned)ptm->tm_wday > 6)
3918         ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
3919 }
3920
3921 char *
3922 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)
3923 {
3924 #ifdef HAS_STRFTIME
3925   char *buf;
3926   int buflen;
3927   struct tm mytm;
3928   int len;
3929
3930   PERL_ARGS_ASSERT_MY_STRFTIME;
3931
3932   init_tm(&mytm);       /* XXX workaround - see init_tm() above */
3933   mytm.tm_sec = sec;
3934   mytm.tm_min = min;
3935   mytm.tm_hour = hour;
3936   mytm.tm_mday = mday;
3937   mytm.tm_mon = mon;
3938   mytm.tm_year = year;
3939   mytm.tm_wday = wday;
3940   mytm.tm_yday = yday;
3941   mytm.tm_isdst = isdst;
3942   mini_mktime(&mytm);
3943   /* use libc to get the values for tm_gmtoff and tm_zone [perl #18238] */
3944 #if defined(HAS_MKTIME) && (defined(HAS_TM_TM_GMTOFF) || defined(HAS_TM_TM_ZONE))
3945   STMT_START {
3946     struct tm mytm2;
3947     mytm2 = mytm;
3948     mktime(&mytm2);
3949 #ifdef HAS_TM_TM_GMTOFF
3950     mytm.tm_gmtoff = mytm2.tm_gmtoff;
3951 #endif
3952 #ifdef HAS_TM_TM_ZONE
3953     mytm.tm_zone = mytm2.tm_zone;
3954 #endif
3955   } STMT_END;
3956 #endif
3957   buflen = 64;
3958   Newx(buf, buflen, char);
3959   len = strftime(buf, buflen, fmt, &mytm);
3960   /*
3961   ** The following is needed to handle to the situation where
3962   ** tmpbuf overflows.  Basically we want to allocate a buffer
3963   ** and try repeatedly.  The reason why it is so complicated
3964   ** is that getting a return value of 0 from strftime can indicate
3965   ** one of the following:
3966   ** 1. buffer overflowed,
3967   ** 2. illegal conversion specifier, or
3968   ** 3. the format string specifies nothing to be returned(not
3969   **      an error).  This could be because format is an empty string
3970   **    or it specifies %p that yields an empty string in some locale.
3971   ** If there is a better way to make it portable, go ahead by
3972   ** all means.
3973   */
3974   if ((len > 0 && len < buflen) || (len == 0 && *fmt == '\0'))
3975     return buf;
3976   else {
3977     /* Possibly buf overflowed - try again with a bigger buf */
3978     const int fmtlen = strlen(fmt);
3979     int bufsize = fmtlen + buflen;
3980
3981     Newx(buf, bufsize, char);
3982     while (buf) {
3983       buflen = strftime(buf, bufsize, fmt, &mytm);
3984       if (buflen > 0 && buflen < bufsize)
3985         break;
3986       /* heuristic to prevent out-of-memory errors */
3987       if (bufsize > 100*fmtlen) {
3988         Safefree(buf);
3989         buf = NULL;
3990         break;
3991       }
3992       bufsize *= 2;
3993       Renew(buf, bufsize, char);
3994     }
3995     return buf;
3996   }
3997 #else
3998   Perl_croak(aTHX_ "panic: no strftime");
3999   return NULL;
4000 #endif
4001 }
4002
4003
4004 #define SV_CWD_RETURN_UNDEF \
4005 sv_setsv(sv, &PL_sv_undef); \
4006 return FALSE
4007
4008 #define SV_CWD_ISDOT(dp) \
4009     (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
4010         (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
4011
4012 /*
4013 =head1 Miscellaneous Functions
4014
4015 =for apidoc getcwd_sv
4016
4017 Fill the sv with current working directory
4018
4019 =cut
4020 */
4021
4022 /* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars.
4023  * rewritten again by dougm, optimized for use with xs TARG, and to prefer
4024  * getcwd(3) if available
4025  * Comments from the orignal:
4026  *     This is a faster version of getcwd.  It's also more dangerous
4027  *     because you might chdir out of a directory that you can't chdir
4028  *     back into. */
4029
4030 int
4031 Perl_getcwd_sv(pTHX_ register SV *sv)
4032 {
4033 #ifndef PERL_MICRO
4034     dVAR;
4035 #ifndef INCOMPLETE_TAINTS
4036     SvTAINTED_on(sv);
4037 #endif
4038
4039     PERL_ARGS_ASSERT_GETCWD_SV;
4040
4041 #ifdef HAS_GETCWD
4042     {
4043         char buf[MAXPATHLEN];
4044
4045         /* Some getcwd()s automatically allocate a buffer of the given
4046          * size from the heap if they are given a NULL buffer pointer.
4047          * The problem is that this behaviour is not portable. */
4048         if (getcwd(buf, sizeof(buf) - 1)) {
4049             sv_setpv(sv, buf);
4050             return TRUE;
4051         }
4052         else {
4053             sv_setsv(sv, &PL_sv_undef);
4054             return FALSE;
4055         }
4056     }
4057
4058 #else
4059
4060     Stat_t statbuf;
4061     int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
4062     int pathlen=0;
4063     Direntry_t *dp;
4064
4065     SvUPGRADE(sv, SVt_PV);
4066
4067     if (PerlLIO_lstat(".", &statbuf) < 0) {
4068         SV_CWD_RETURN_UNDEF;
4069     }
4070
4071     orig_cdev = statbuf.st_dev;
4072     orig_cino = statbuf.st_ino;
4073     cdev = orig_cdev;
4074     cino = orig_cino;
4075
4076     for (;;) {
4077         DIR *dir;
4078         int namelen;
4079         odev = cdev;
4080         oino = cino;
4081
4082         if (PerlDir_chdir("..") < 0) {
4083             SV_CWD_RETURN_UNDEF;
4084         }
4085         if (PerlLIO_stat(".", &statbuf) < 0) {
4086             SV_CWD_RETURN_UNDEF;
4087         }
4088
4089         cdev = statbuf.st_dev;
4090         cino = statbuf.st_ino;
4091
4092         if (odev == cdev && oino == cino) {
4093             break;
4094         }
4095         if (!(dir = PerlDir_open("."))) {
4096             SV_CWD_RETURN_UNDEF;
4097         }
4098
4099         while ((dp = PerlDir_read(dir)) != NULL) {
4100 #ifdef DIRNAMLEN
4101             namelen = dp->d_namlen;
4102 #else
4103             namelen = strlen(dp->d_name);
4104 #endif
4105             /* skip . and .. */
4106             if (SV_CWD_ISDOT(dp)) {
4107                 continue;
4108             }
4109
4110             if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
4111                 SV_CWD_RETURN_UNDEF;
4112             }
4113
4114             tdev = statbuf.st_dev;
4115             tino = statbuf.st_ino;
4116             if (tino == oino && tdev == odev) {
4117                 break;
4118             }
4119         }
4120
4121         if (!dp) {
4122             SV_CWD_RETURN_UNDEF;
4123         }
4124
4125         if (pathlen + namelen + 1 >= MAXPATHLEN) {
4126             SV_CWD_RETURN_UNDEF;
4127         }
4128
4129         SvGROW(sv, pathlen + namelen + 1);
4130
4131         if (pathlen) {
4132             /* shift down */
4133             Move(SvPVX_const(sv), SvPVX(sv) + namelen + 1, pathlen, char);
4134         }
4135
4136         /* prepend current directory to the front */
4137         *SvPVX(sv) = '/';
4138         Move(dp->d_name, SvPVX(sv)+1, namelen, char);
4139         pathlen += (namelen + 1);
4140
4141 #ifdef VOID_CLOSEDIR
4142         PerlDir_close(dir);
4143 #else
4144         if (PerlDir_close(dir) < 0) {
4145             SV_CWD_RETURN_UNDEF;
4146         }
4147 #endif
4148     }
4149
4150     if (pathlen) {
4151         SvCUR_set(sv, pathlen);
4152         *SvEND(sv) = '\0';
4153         SvPOK_only(sv);
4154
4155         if (PerlDir_chdir(SvPVX_const(sv)) < 0) {
4156             SV_CWD_RETURN_UNDEF;
4157         }
4158     }
4159     if (PerlLIO_stat(".", &statbuf) < 0) {
4160         SV_CWD_RETURN_UNDEF;
4161     }
4162
4163     cdev = statbuf.st_dev;
4164     cino = statbuf.st_ino;
4165
4166     if (cdev != orig_cdev || cino != orig_cino) {
4167         Perl_croak(aTHX_ "Unstable directory path, "
4168                    "current directory changed unexpectedly");
4169     }
4170
4171     return TRUE;
4172 #endif
4173
4174 #else
4175     return FALSE;
4176 #endif
4177 }
4178
4179 #define VERSION_MAX 0x7FFFFFFF
4180 /*
4181 =for apidoc scan_version
4182
4183 Returns a pointer to the next character after the parsed
4184 version string, as well as upgrading the passed in SV to
4185 an RV.
4186
4187 Function must be called with an already existing SV like
4188
4189     sv = newSV(0);
4190     s = scan_version(s, SV *sv, bool qv);
4191
4192 Performs some preprocessing to the string to ensure that
4193 it has the correct characteristics of a version.  Flags the
4194 object if it contains an underscore (which denotes this
4195 is an alpha version).  The boolean qv denotes that the version
4196 should be interpreted as if it had multiple decimals, even if
4197 it doesn't.
4198
4199 =cut
4200 */
4201
4202 const char *
4203 Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
4204 {
4205     const char *start;
4206     const char *pos;
4207     const char *last;
4208     int saw_period = 0;
4209     int alpha = 0;
4210     int width = 3;
4211     bool vinf = FALSE;
4212     AV * const av = newAV();
4213     SV * const hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
4214
4215     PERL_ARGS_ASSERT_SCAN_VERSION;
4216
4217     (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
4218
4219     while (isSPACE(*s)) /* leading whitespace is OK */
4220         s++;
4221
4222     start = last = s;
4223
4224     if (*s == 'v') {
4225         s++;  /* get past 'v' */
4226         qv = 1; /* force quoted version processing */
4227     }
4228
4229     pos = s;
4230
4231     /* pre-scan the input string to check for decimals/underbars */
4232     while ( *pos == '.' || *pos == '_' || *pos == ',' || isDIGIT(*pos) )
4233     {
4234         if ( *pos == '.' )
4235         {
4236             if ( alpha )
4237                 Perl_croak(aTHX_ "Invalid version format (underscores before decimal)");
4238             saw_period++ ;
4239             last = pos;
4240         }
4241         else if ( *pos == '_' )
4242         {
4243             if ( alpha )
4244                 Perl_croak(aTHX_ "Invalid version format (multiple underscores)");
4245             alpha = 1;
4246             width = pos - last - 1; /* natural width of sub-version */
4247         }
4248         else if ( *pos == ',' && isDIGIT(pos[1]) )
4249         {
4250             saw_period++ ;
4251             last = pos;
4252         }
4253
4254         pos++;
4255     }
4256
4257     if ( alpha && !saw_period )
4258         Perl_croak(aTHX_ "Invalid version format (alpha without decimal)");
4259
4260     if ( alpha && saw_period && width == 0 )
4261         Perl_croak(aTHX_ "Invalid version format (misplaced _ in number)");
4262
4263     if ( saw_period > 1 )
4264         qv = 1; /* force quoted version processing */
4265
4266     last = pos;
4267     pos = s;
4268
4269     if ( qv )
4270         (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(qv));
4271     if ( alpha )
4272         (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(alpha));
4273     if ( !qv && width < 3 )
4274         (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
4275
4276     while (isDIGIT(*pos))
4277         pos++;
4278     if (!isALPHA(*pos)) {
4279         I32 rev;
4280
4281         for (;;) {
4282             rev = 0;
4283             {
4284                 /* this is atoi() that delimits on underscores */
4285                 const char *end = pos;
4286                 I32 mult = 1;
4287                 I32 orev;
4288
4289                 /* the following if() will only be true after the decimal
4290                  * point of a version originally created with a bare
4291                  * floating point number, i.e. not quoted in any way
4292                  */
4293                 if ( !qv && s > start && saw_period == 1 ) {
4294                     mult *= 100;
4295                     while ( s < end ) {
4296                         orev = rev;
4297                         rev += (*s - '0') * mult;
4298                         mult /= 10;
4299                         if (   (PERL_ABS(orev) > PERL_ABS(rev))
4300                             || (PERL_ABS(rev) > VERSION_MAX )) {
4301                             if(ckWARN(WARN_OVERFLOW))
4302                                 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
4303                                 "Integer overflow in version %d",VERSION_MAX);
4304                             s = end - 1;
4305                             rev = VERSION_MAX;
4306                             vinf = 1;
4307                         }
4308                         s++;
4309                         if ( *s == '_' )
4310                             s++;
4311                     }
4312                 }
4313                 else {
4314                     while (--end >= s) {
4315                         orev = rev;
4316                         rev += (*end - '0') * mult;
4317                         mult *= 10;
4318                         if (   (PERL_ABS(orev) > PERL_ABS(rev))
4319                             || (PERL_ABS(rev) > VERSION_MAX )) {
4320                             if(ckWARN(WARN_OVERFLOW))
4321                                 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
4322                                 "Integer overflow in version");
4323                             end = s - 1;
4324                             rev = VERSION_MAX;
4325                             vinf = 1;
4326                         }
4327                     }
4328                 }
4329             }
4330
4331             /* Append revision */
4332             av_push(av, newSViv(rev));
4333             if ( vinf ) {
4334                 s = last;
4335                 break;
4336             }
4337             else if ( *pos == '.' )
4338                 s = ++pos;
4339             else if ( *pos == '_' && isDIGIT(pos[1]) )
4340                 s = ++pos;
4341             else if ( *pos == ',' && isDIGIT(pos[1]) )
4342                 s = ++pos;
4343             else if ( isDIGIT(*pos) )
4344                 s = pos;
4345             else {
4346                 s = pos;
4347                 break;
4348             }
4349             if ( qv ) {
4350                 while ( isDIGIT(*pos) )
4351                     pos++;
4352             }
4353             else {
4354                 int digits = 0;
4355                 while ( ( isDIGIT(*pos) || *pos == '_' ) && digits < 3 ) {
4356                     if ( *pos != '_' )
4357                         digits++;
4358                     pos++;
4359                 }
4360             }
4361         }
4362     }
4363     if ( qv ) { /* quoted versions always get at least three terms*/
4364         I32 len = av_len(av);
4365         /* This for loop appears to trigger a compiler bug on OS X, as it
4366            loops infinitely. Yes, len is negative. No, it makes no sense.
4367            Compiler in question is:
4368            gcc version 3.3 20030304 (Apple Computer, Inc. build 1640)
4369            for ( len = 2 - len; len > 0; len-- )
4370            av_push(MUTABLE_AV(sv), newSViv(0));
4371         */
4372         len = 2 - len;
4373         while (len-- > 0)
4374             av_push(av, newSViv(0));
4375     }
4376
4377     /* need to save off the current version string for later */
4378     if ( vinf ) {
4379         SV * orig = newSVpvn("v.Inf", sizeof("v.Inf")-1);
4380         (void)hv_stores(MUTABLE_HV(hv), "original", orig);
4381         (void)hv_stores(MUTABLE_HV(hv), "vinf", newSViv(1));
4382     }
4383     else if ( s > start ) {
4384         SV * orig = newSVpvn(start,s-start);
4385         if ( qv && saw_period == 1 && *start != 'v' ) {
4386             /* need to insert a v to be consistent */
4387             sv_insert(orig, 0, 0, "v", 1);
4388         }
4389         (void)hv_stores(MUTABLE_HV(hv), "original", orig);
4390     }
4391     else {
4392         (void)hv_stores(MUTABLE_HV(hv), "original", newSVpvs("0"));
4393         av_push(av, newSViv(0));
4394     }
4395
4396     /* And finally, store the AV in the hash */
4397     (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av)));
4398
4399     /* fix RT#19517 - special case 'undef' as string */
4400     if ( *s == 'u' && strEQ(s,"undef") ) {
4401         s += 5;
4402     }
4403
4404     return s;
4405 }
4406
4407 /*
4408 =for apidoc new_version
4409
4410 Returns a new version object based on the passed in SV:
4411
4412     SV *sv = new_version(SV *ver);
4413
4414 Does not alter the passed in ver SV.  See "upg_version" if you
4415 want to upgrade the SV.
4416
4417 =cut
4418 */
4419
4420 SV *
4421 Perl_new_version(pTHX_ SV *ver)
4422 {
4423     dVAR;
4424     SV * const rv = newSV(0);
4425     PERL_ARGS_ASSERT_NEW_VERSION;
4426     if ( sv_derived_from(ver,"version") ) /* can just copy directly */
4427     {
4428         I32 key;
4429         AV * const av = newAV();
4430         AV *sav;
4431         /* This will get reblessed later if a derived class*/
4432         SV * const hv = newSVrv(rv, "version");
4433         (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
4434
4435         if ( SvROK(ver) )
4436             ver = SvRV(ver);
4437
4438         /* Begin copying all of the elements */
4439         if ( hv_exists(MUTABLE_HV(ver), "qv", 2) )
4440             (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(1));
4441
4442         if ( hv_exists(MUTABLE_HV(ver), "alpha", 5) )
4443             (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(1));
4444
4445         if ( hv_exists(MUTABLE_HV(ver), "width", 5 ) )
4446         {
4447             const I32 width = SvIV(*hv_fetchs(MUTABLE_HV(ver), "width", FALSE));
4448             (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
4449         }
4450
4451         if ( hv_exists(MUTABLE_HV(ver), "original", 8 ) )
4452         {
4453             SV * pv = *hv_fetchs(MUTABLE_HV(ver), "original", FALSE);
4454             (void)hv_stores(MUTABLE_HV(hv), "original", newSVsv(pv));
4455         }
4456
4457         sav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(ver), "version", FALSE)));
4458         /* This will get reblessed later if a derived class*/
4459         for ( key = 0; key <= av_len(sav); key++ )
4460         {
4461             const I32 rev = SvIV(*av_fetch(sav, key, FALSE));
4462             av_push(av, newSViv(rev));
4463         }
4464
4465         (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av)));
4466         return rv;
4467     }
4468 #ifdef SvVOK
4469     {
4470         const MAGIC* const mg = SvVSTRING_mg(ver);
4471         if ( mg ) { /* already a v-string */
4472             const STRLEN len = mg->mg_len;
4473             char * const version = savepvn( (const char*)mg->mg_ptr, len);
4474             sv_setpvn(rv,version,len);
4475             /* this is for consistency with the pure Perl class */
4476             if ( *version != 'v' )
4477                 sv_insert(rv, 0, 0, "v", 1);
4478             Safefree(version);
4479         }
4480         else {
4481 #endif
4482         sv_setsv(rv,ver); /* make a duplicate */
4483 #ifdef SvVOK
4484         }
4485     }
4486 #endif
4487     return upg_version(rv, FALSE);
4488 }
4489
4490 /*
4491 =for apidoc upg_version
4492
4493 In-place upgrade of the supplied SV to a version object.
4494
4495     SV *sv = upg_version(SV *sv, bool qv);
4496
4497 Returns a pointer to the upgraded SV.  Set the boolean qv if you want
4498 to force this SV to be interpreted as an "extended" version.
4499
4500 =cut
4501 */
4502
4503 SV *
4504 Perl_upg_version(pTHX_ SV *ver, bool qv)
4505 {
4506     const char *version, *s;
4507 #ifdef SvVOK
4508     const MAGIC *mg;
4509 #endif
4510
4511     PERL_ARGS_ASSERT_UPG_VERSION;
4512
4513     if ( SvNOK(ver) && !( SvPOK(ver) && sv_len(ver) == 3 ) )
4514     {
4515         /* may get too much accuracy */
4516         char tbuf[64];
4517 #ifdef USE_LOCALE_NUMERIC
4518         char *loc = setlocale(LC_NUMERIC, "C");
4519 #endif
4520         STRLEN len = my_snprintf(tbuf, sizeof(tbuf), "%.9"NVff, SvNVX(ver));
4521 #ifdef USE_LOCALE_NUMERIC
4522         setlocale(LC_NUMERIC, loc);
4523 #endif
4524         while (tbuf[len-1] == '0' && len > 0) len--;
4525         if ( tbuf[len-1] == '.' ) len--; /* eat the trailing decimal */
4526         version = savepvn(tbuf, len);
4527     }
4528 #ifdef SvVOK
4529     else if ( (mg = SvVSTRING_mg(ver)) ) { /* already a v-string */
4530         version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
4531         qv = 1;
4532     }
4533 #endif
4534     else /* must be a string or something like a string */
4535     {
4536         STRLEN len;
4537         version = savepv(SvPV(ver,len));
4538 #ifndef SvVOK
4539 #  if PERL_VERSION > 5
4540         /* This will only be executed for 5.6.0 - 5.8.0 inclusive */
4541         if ( len == 3 && !instr(version,".") && !instr(version,"_") ) {
4542             /* may be a v-string */
4543             SV * const nsv = sv_newmortal();
4544             const char *nver;
4545             const char *pos;
4546             int saw_period = 0;
4547             sv_setpvf(nsv,"v%vd",ver);
4548             pos = nver = savepv(SvPV_nolen(nsv));
4549
4550             /* scan the resulting formatted string */
4551             pos++; /* skip the leading 'v' */
4552             while ( *pos == '.' || isDIGIT(*pos) ) {
4553                 if ( *pos == '.' )
4554                     saw_period++ ;
4555                 pos++;
4556             }
4557
4558             /* is definitely a v-string */
4559             if ( saw_period == 2 ) {
4560                 Safefree(version);
4561                 version = nver;
4562             }
4563         }
4564 #  endif
4565 #endif
4566     }
4567
4568     s = scan_version(version, ver, qv);
4569     if ( *s != '\0' )
4570         if(ckWARN(WARN_MISC))
4571             Perl_warner(aTHX_ packWARN(WARN_MISC),
4572                 "Version string '%s' contains invalid data; "
4573                 "ignoring: '%s'", version, s);
4574     Safefree(version);
4575     return ver;
4576 }
4577
4578 /*
4579 =for apidoc vverify
4580
4581 Validates that the SV contains a valid version object.
4582
4583     bool vverify(SV *vobj);
4584
4585 Note that it only confirms the bare minimum structure (so as not to get
4586 confused by derived classes which may contain additional hash entries):
4587
4588 =over 4
4589
4590 =item * The SV contains a [reference to a] hash
4591
4592 =item * The hash contains a "version" key
4593
4594 =item * The "version" key has [a reference to] an AV as its value
4595
4596 =back
4597
4598 =cut
4599 */
4600
4601 bool
4602 Perl_vverify(pTHX_ SV *vs)
4603 {
4604     SV *sv;
4605
4606     PERL_ARGS_ASSERT_VVERIFY;
4607
4608     if ( SvROK(vs) )
4609         vs = SvRV(vs);
4610
4611     /* see if the appropriate elements exist */
4612     if ( SvTYPE(vs) == SVt_PVHV
4613          && hv_exists(MUTABLE_HV(vs), "version", 7)
4614          && (sv = SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)))
4615          && SvTYPE(sv) == SVt_PVAV )
4616         return TRUE;
4617     else
4618         return FALSE;
4619 }
4620
4621 /*
4622 =for apidoc vnumify
4623
4624 Accepts a version object and returns the normalized floating
4625 point representation.  Call like:
4626
4627     sv = vnumify(rv);
4628
4629 NOTE: you can pass either the object directly or the SV
4630 contained within the RV.
4631
4632 =cut
4633 */
4634
4635 SV *
4636 Perl_vnumify(pTHX_ SV *vs)
4637 {
4638     I32 i, len, digit;
4639     int width;
4640     bool alpha = FALSE;
4641     SV * const sv = newSV(0);
4642     AV *av;
4643
4644     PERL_ARGS_ASSERT_VNUMIFY;
4645
4646     if ( SvROK(vs) )
4647         vs = SvRV(vs);
4648
4649     if ( !vverify(vs) )
4650         Perl_croak(aTHX_ "Invalid version object");
4651
4652     /* see if various flags exist */
4653     if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
4654         alpha = TRUE;
4655     if ( hv_exists(MUTABLE_HV(vs), "width", 5 ) )
4656         width = SvIV(*hv_fetchs(MUTABLE_HV(vs), "width", FALSE));
4657     else
4658         width = 3;
4659
4660
4661     /* attempt to retrieve the version array */
4662     if ( !(av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE))) ) ) {
4663         sv_catpvs(sv,"0");
4664         return sv;
4665     }
4666
4667     len = av_len(av);
4668     if ( len == -1 )
4669     {
4670         sv_catpvs(sv,"0");
4671         return sv;
4672     }
4673
4674     digit = SvIV(*av_fetch(av, 0, 0));
4675     Perl_sv_setpvf(aTHX_ sv, "%d.", (int)PERL_ABS(digit));
4676     for ( i = 1 ; i < len ; i++ )
4677     {
4678         digit = SvIV(*av_fetch(av, i, 0));
4679         if ( width < 3 ) {
4680             const int denom = (width == 2 ? 10 : 100);
4681             const div_t term = div((int)PERL_ABS(digit),denom);
4682             Perl_sv_catpvf(aTHX_ sv, "%0*d_%d", width, term.quot, term.rem);
4683         }
4684         else {
4685             Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
4686         }
4687     }
4688
4689     if ( len > 0 )
4690     {
4691         digit = SvIV(*av_fetch(av, len, 0));
4692         if ( alpha && width == 3 ) /* alpha version */
4693             sv_catpvs(sv,"_");
4694         Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
4695     }
4696     else /* len == 0 */
4697     {
4698         sv_catpvs(sv, "000");
4699     }
4700     return sv;
4701 }
4702
4703 /*
4704 =for apidoc vnormal
4705
4706 Accepts a version object and returns the normalized string
4707 representation.  Call like:
4708
4709     sv = vnormal(rv);
4710
4711 NOTE: you can pass either the object directly or the SV
4712 contained within the RV.
4713
4714 =cut
4715 */
4716
4717 SV *
4718 Perl_vnormal(pTHX_ SV *vs)
4719 {
4720     I32 i, len, digit;
4721     bool alpha = FALSE;
4722     SV * const sv = newSV(0);
4723     AV *av;
4724
4725     PERL_ARGS_ASSERT_VNORMAL;
4726
4727     if ( SvROK(vs) )
4728         vs = SvRV(vs);
4729
4730     if ( !vverify(vs) )
4731         Perl_croak(aTHX_ "Invalid version object");
4732
4733     if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
4734         alpha = TRUE;
4735     av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)));
4736
4737     len = av_len(av);
4738     if ( len == -1 )
4739     {
4740         sv_catpvs(sv,"");
4741         return sv;
4742     }
4743     digit = SvIV(*av_fetch(av, 0, 0));
4744     Perl_sv_setpvf(aTHX_ sv, "v%"IVdf, (IV)digit);
4745     for ( i = 1 ; i < len ; i++ ) {
4746         digit = SvIV(*av_fetch(av, i, 0));
4747         Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
4748     }
4749
4750     if ( len > 0 )
4751     {
4752         /* handle last digit specially */
4753         digit = SvIV(*av_fetch(av, len, 0));
4754         if ( alpha )
4755             Perl_sv_catpvf(aTHX_ sv, "_%"IVdf, (IV)digit);
4756         else
4757             Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
4758     }
4759
4760     if ( len <= 2 ) { /* short version, must be at least three */
4761         for ( len = 2 - len; len != 0; len-- )
4762             sv_catpvs(sv,".0");
4763     }
4764     return sv;
4765 }
4766
4767 /*
4768 =for apidoc vstringify
4769
4770 In order to maintain maximum compatibility with earlier versions
4771 of Perl, this function will return either the floating point
4772 notation or the multiple dotted notation, depending on whether
4773 the original version contained 1 or more dots, respectively
4774
4775 =cut
4776 */
4777
4778 SV *
4779 Perl_vstringify(pTHX_ SV *vs)
4780 {
4781     PERL_ARGS_ASSERT_VSTRINGIFY;
4782
4783     if ( SvROK(vs) )
4784         vs = SvRV(vs);
4785
4786     if ( !vverify(vs) )
4787         Perl_croak(aTHX_ "Invalid version object");
4788
4789     if (hv_exists(MUTABLE_HV(vs), "original",  sizeof("original") - 1)) {
4790         SV *pv;
4791         pv = *hv_fetchs(MUTABLE_HV(vs), "original", FALSE);
4792         if ( SvPOK(pv) )
4793             return newSVsv(pv);
4794         else
4795             return &PL_sv_undef;
4796     }
4797     else {
4798         if ( hv_exists(MUTABLE_HV(vs), "qv", 2) )
4799             return vnormal(vs);
4800         else
4801             return vnumify(vs);
4802     }
4803 }
4804
4805 /*
4806 =for apidoc vcmp
4807
4808 Version object aware cmp.  Both operands must already have been
4809 converted into version objects.
4810
4811 =cut
4812 */
4813
4814 int
4815 Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
4816 {
4817     I32 i,l,m,r,retval;
4818     bool lalpha = FALSE;
4819     bool ralpha = FALSE;
4820     I32 left = 0;
4821     I32 right = 0;
4822     AV *lav, *rav;
4823
4824     PERL_ARGS_ASSERT_VCMP;
4825
4826     if ( SvROK(lhv) )
4827         lhv = SvRV(lhv);
4828     if ( SvROK(rhv) )
4829         rhv = SvRV(rhv);
4830
4831     if ( !vverify(lhv) )
4832         Perl_croak(aTHX_ "Invalid version object");
4833
4834     if ( !vverify(rhv) )
4835         Perl_croak(aTHX_ "Invalid version object");
4836
4837     /* get the left hand term */
4838     lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(lhv), "version", FALSE)));
4839     if ( hv_exists(MUTABLE_HV(lhv), "alpha", 5 ) )
4840         lalpha = TRUE;
4841
4842     /* and the right hand term */
4843     rav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(rhv), "version", FALSE)));
4844     if ( hv_exists(MUTABLE_HV(rhv), "alpha", 5 ) )
4845         ralpha = TRUE;
4846
4847     l = av_len(lav);
4848     r = av_len(rav);
4849     m = l < r ? l : r;
4850     retval = 0;
4851     i = 0;
4852     while ( i <= m && retval == 0 )
4853     {
4854         left  = SvIV(*av_fetch(lav,i,0));
4855         right = SvIV(*av_fetch(rav,i,0));
4856         if ( left < right  )
4857             retval = -1;
4858         if ( left > right )
4859             retval = +1;
4860         i++;
4861     }
4862
4863     /* tiebreaker for alpha with identical terms */
4864     if ( retval == 0 && l == r && left == right && ( lalpha || ralpha ) )
4865     {
4866         if ( lalpha && !ralpha )
4867         {
4868             retval = -1;
4869         }
4870         else if ( ralpha && !lalpha)
4871         {
4872             retval = +1;
4873         }
4874     }
4875
4876     if ( l != r && retval == 0 ) /* possible match except for trailing 0's */
4877     {
4878         if ( l < r )
4879         {
4880             while ( i <= r && retval == 0 )
4881             {
4882                 if ( SvIV(*av_fetch(rav,i,0)) != 0 )
4883                     retval = -1; /* not a match after all */
4884                 i++;
4885             }
4886         }
4887         else
4888         {
4889             while ( i <= l && retval == 0 )
4890             {
4891                 if ( SvIV(*av_fetch(lav,i,0)) != 0 )
4892                     retval = +1; /* not a match after all */
4893                 i++;
4894             }
4895         }
4896     }
4897     return retval;
4898 }
4899
4900 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT)
4901 #   define EMULATE_SOCKETPAIR_UDP
4902 #endif
4903
4904 #ifdef EMULATE_SOCKETPAIR_UDP
4905 static int
4906 S_socketpair_udp (int fd[2]) {
4907     dTHX;
4908     /* Fake a datagram socketpair using UDP to localhost.  */
4909     int sockets[2] = {-1, -1};
4910     struct sockaddr_in addresses[2];
4911     int i;
4912     Sock_size_t size = sizeof(struct sockaddr_in);
4913     unsigned short port;
4914     int got;
4915
4916     memset(&addresses, 0, sizeof(addresses));
4917     i = 1;
4918     do {
4919         sockets[i] = PerlSock_socket(AF_INET, SOCK_DGRAM, PF_INET);
4920         if (sockets[i] == -1)
4921             goto tidy_up_and_fail;
4922
4923         addresses[i].sin_family = AF_INET;
4924         addresses[i].sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4925         addresses[i].sin_port = 0;      /* kernel choses port.  */
4926         if (PerlSock_bind(sockets[i], (struct sockaddr *) &addresses[i],
4927                 sizeof(struct sockaddr_in)) == -1)
4928             goto tidy_up_and_fail;
4929     } while (i--);
4930
4931     /* Now have 2 UDP sockets. Find out which port each is connected to, and
4932        for each connect the other socket to it.  */
4933     i = 1;
4934     do {
4935         if (PerlSock_getsockname(sockets[i], (struct sockaddr *) &addresses[i],
4936                 &size) == -1)
4937             goto tidy_up_and_fail;
4938         if (size != sizeof(struct sockaddr_in))
4939             goto abort_tidy_up_and_fail;
4940         /* !1 is 0, !0 is 1 */
4941         if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i],
4942                 sizeof(struct sockaddr_in)) == -1)
4943             goto tidy_up_and_fail;
4944     } while (i--);
4945
4946     /* Now we have 2 sockets connected to each other. I don't trust some other
4947        process not to have already sent a packet to us (by random) so send
4948        a packet from each to the other.  */
4949     i = 1;
4950     do {
4951         /* I'm going to send my own port number.  As a short.
4952            (Who knows if someone somewhere has sin_port as a bitfield and needs
4953            this routine. (I'm assuming crays have socketpair)) */
4954         port = addresses[i].sin_port;
4955         got = PerlLIO_write(sockets[i], &port, sizeof(port));
4956         if (got != sizeof(port)) {
4957             if (got == -1)
4958                 goto tidy_up_and_fail;
4959             goto abort_tidy_up_and_fail;
4960         }
4961     } while (i--);
4962
4963     /* Packets sent. I don't trust them to have arrived though.
4964        (As I understand it Solaris TCP stack is multithreaded. Non-blocking
4965        connect to localhost will use a second kernel thread. In 2.6 the
4966        first thread running the connect() returns before the second completes,
4967        so EINPROGRESS> In 2.7 the improved stack is faster and connect()
4968        returns 0. Poor programs have tripped up. One poor program's authors'
4969        had a 50-1 reverse stock split. Not sure how connected these were.)
4970        So I don't trust someone not to have an unpredictable UDP stack.
4971     */
4972
4973     {
4974         struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */
4975         int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0];
4976         fd_set rset;
4977
4978         FD_ZERO(&rset);
4979         FD_SET((unsigned int)sockets[0], &rset);
4980         FD_SET((unsigned int)sockets[1], &rset);
4981
4982         got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor);
4983         if (got != 2 || !FD_ISSET(sockets[0], &rset)
4984                 || !FD_ISSET(sockets[1], &rset)) {
4985             /* I hope this is portable and appropriate.  */
4986             if (got == -1)
4987                 goto tidy_up_and_fail;
4988             goto abort_tidy_up_and_fail;
4989         }
4990     }
4991
4992     /* And the paranoia department even now doesn't trust it to have arrive
4993        (hence MSG_DONTWAIT). Or that what arrives was sent by us.  */
4994     {
4995         struct sockaddr_in readfrom;
4996         unsigned short buffer[2];
4997
4998         i = 1;
4999         do {
5000 #ifdef MSG_DONTWAIT
5001             got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
5002                     sizeof(buffer), MSG_DONTWAIT,
5003                     (struct sockaddr *) &readfrom, &size);
5004 #else
5005             got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
5006                     sizeof(buffer), 0,
5007                     (struct sockaddr *) &readfrom, &size);
5008 #endif
5009
5010             if (got == -1)
5011                 goto tidy_up_and_fail;
5012             if (got != sizeof(port)
5013                     || size != sizeof(struct sockaddr_in)
5014                     /* Check other socket sent us its port.  */
5015                     || buffer[0] != (unsigned short) addresses[!i].sin_port
5016                     /* Check kernel says we got the datagram from that socket */
5017                     || readfrom.sin_family != addresses[!i].sin_family
5018                     || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr
5019                     || readfrom.sin_port != addresses[!i].sin_port)
5020                 goto abort_tidy_up_and_fail;
5021         } while (i--);
5022     }
5023     /* My caller (my_socketpair) has validated that this is non-NULL  */
5024     fd[0] = sockets[0];
5025     fd[1] = sockets[1];
5026     /* I hereby declare this connection open.  May God bless all who cross
5027        her.  */
5028     return 0;
5029
5030   abort_tidy_up_and_fail:
5031     errno = ECONNABORTED;
5032   tidy_up_and_fail:
5033     {
5034         dSAVE_ERRNO;
5035         if (sockets[0] != -1)
5036             PerlLIO_close(sockets[0]);
5037         if (sockets[1] != -1)
5038             PerlLIO_close(sockets[1]);
5039         RESTORE_ERRNO;
5040         return -1;
5041     }
5042 }
5043 #endif /*  EMULATE_SOCKETPAIR_UDP */
5044
5045 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET)
5046 int
5047 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
5048     /* Stevens says that family must be AF_LOCAL, protocol 0.
5049        I'm going to enforce that, then ignore it, and use TCP (or UDP).  */
5050     dTHX;
5051     int listener = -1;
5052     int connector = -1;
5053     int acceptor = -1;
5054     struct sockaddr_in listen_addr;
5055     struct sockaddr_in connect_addr;
5056     Sock_size_t size;
5057
5058     if (protocol
5059 #ifdef AF_UNIX
5060         || family != AF_UNIX
5061 #endif
5062     ) {
5063         errno = EAFNOSUPPORT;
5064         return -1;
5065     }
5066     if (!fd) {
5067         errno = EINVAL;
5068         return -1;
5069     }
5070
5071 #ifdef EMULATE_SOCKETPAIR_UDP
5072     if (type == SOCK_DGRAM)
5073         return S_socketpair_udp(fd);
5074 #endif
5075
5076     listener = PerlSock_socket(AF_INET, type, 0);
5077     if (listener == -1)
5078         return -1;
5079     memset(&listen_addr, 0, sizeof(listen_addr));
5080     listen_addr.sin_family = AF_INET;
5081     listen_addr.sin_addr.s_addr = htonl(INADDR_LOOPBACK);
5082     listen_addr.sin_port = 0;   /* kernel choses port.  */
5083     if (PerlSock_bind(listener, (struct sockaddr *) &listen_addr,
5084             sizeof(listen_addr)) == -1)
5085         goto tidy_up_and_fail;
5086     if (PerlSock_listen(listener, 1) == -1)
5087         goto tidy_up_and_fail;
5088
5089     connector = PerlSock_socket(AF_INET, type, 0);
5090     if (connector == -1)
5091         goto tidy_up_and_fail;
5092     /* We want to find out the port number to connect to.  */
5093     size = sizeof(connect_addr);
5094     if (PerlSock_getsockname(listener, (struct sockaddr *) &connect_addr,
5095             &size) == -1)
5096         goto tidy_up_and_fail;
5097     if (size != sizeof(connect_addr))
5098         goto abort_tidy_up_and_fail;
5099     if (PerlSock_connect(connector, (struct sockaddr *) &connect_addr,
5100             sizeof(connect_addr)) == -1)
5101         goto tidy_up_and_fail;
5102
5103     size = sizeof(listen_addr);
5104     acceptor = PerlSock_accept(listener, (struct sockaddr *) &listen_addr,
5105             &size);
5106     if (acceptor == -1)
5107         goto tidy_up_and_fail;
5108     if (size != sizeof(listen_addr))
5109         goto abort_tidy_up_and_fail;
5110     PerlLIO_close(listener);
5111     /* Now check we are talking to ourself by matching port and host on the
5112        two sockets.  */
5113     if (PerlSock_getsockname(connector, (struct sockaddr *) &connect_addr,
5114             &size) == -1)
5115         goto tidy_up_and_fail;
5116     if (size != sizeof(connect_addr)
5117             || listen_addr.sin_family != connect_addr.sin_family
5118             || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr
5119             || listen_addr.sin_port != connect_addr.sin_port) {
5120         goto abort_tidy_up_and_fail;
5121     }
5122     fd[0] = connector;
5123     fd[1] = acceptor;
5124     return 0;
5125
5126   abort_tidy_up_and_fail:
5127 #ifdef ECONNABORTED
5128   errno = ECONNABORTED; /* This would be the standard thing to do. */
5129 #else
5130 #  ifdef ECONNREFUSED
5131   errno = ECONNREFUSED; /* E.g. Symbian does not have ECONNABORTED. */
5132 #  else
5133   errno = ETIMEDOUT;    /* Desperation time. */
5134 #  endif
5135 #endif
5136   tidy_up_and_fail:
5137     {
5138         dSAVE_ERRNO;
5139         if (listener != -1)
5140             PerlLIO_close(listener);
5141         if (connector != -1)
5142             PerlLIO_close(connector);
5143         if (acceptor != -1)
5144             PerlLIO_close(acceptor);
5145         RESTORE_ERRNO;
5146         return -1;
5147     }
5148 }
5149 #else
5150 /* In any case have a stub so that there's code corresponding
5151  * to the my_socketpair in global.sym. */
5152 int
5153 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
5154 #ifdef HAS_SOCKETPAIR
5155     return socketpair(family, type, protocol, fd);
5156 #else
5157     return -1;
5158 #endif
5159 }
5160 #endif
5161
5162 /*
5163
5164 =for apidoc sv_nosharing
5165
5166 Dummy routine which "shares" an SV when there is no sharing module present.
5167 Or "locks" it. Or "unlocks" it. In other words, ignores its single SV argument.
5168 Exists to avoid test for a NULL function pointer and because it could
5169 potentially warn under some level of strict-ness.
5170
5171 =cut
5172 */
5173
5174 void
5175 Perl_sv_nosharing(pTHX_ SV *sv)
5176 {
5177     PERL_UNUSED_CONTEXT;
5178     PERL_UNUSED_ARG(sv);
5179 }
5180
5181 /*
5182
5183 =for apidoc sv_destroyable
5184
5185 Dummy routine which reports that object can be destroyed when there is no
5186 sharing module present.  It ignores its single SV argument, and returns
5187 'true'.  Exists to avoid test for a NULL function pointer and because it
5188 could potentially warn under some level of strict-ness.
5189
5190 =cut
5191 */
5192
5193 bool
5194 Perl_sv_destroyable(pTHX_ SV *sv)
5195 {
5196     PERL_UNUSED_CONTEXT;
5197     PERL_UNUSED_ARG(sv);
5198     return TRUE;
5199 }
5200
5201 U32
5202 Perl_parse_unicode_opts(pTHX_ const char **popt)
5203 {
5204   const char *p = *popt;
5205   U32 opt = 0;
5206
5207   PERL_ARGS_ASSERT_PARSE_UNICODE_OPTS;
5208
5209   if (*p) {
5210        if (isDIGIT(*p)) {
5211             opt = (U32) atoi(p);
5212             while (isDIGIT(*p))
5213                 p++;
5214             if (*p && *p != '\n' && *p != '\r')
5215                  Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
5216        }
5217        else {
5218             for (; *p; p++) {
5219                  switch (*p) {
5220                  case PERL_UNICODE_STDIN:
5221                       opt |= PERL_UNICODE_STDIN_FLAG;   break;
5222                  case PERL_UNICODE_STDOUT:
5223                       opt |= PERL_UNICODE_STDOUT_FLAG;  break;
5224                  case PERL_UNICODE_STDERR:
5225                       opt |= PERL_UNICODE_STDERR_FLAG;  break;
5226                  case PERL_UNICODE_STD:
5227                       opt |= PERL_UNICODE_STD_FLAG;     break;
5228                  case PERL_UNICODE_IN:
5229                       opt |= PERL_UNICODE_IN_FLAG;      break;
5230                  case PERL_UNICODE_OUT:
5231                       opt |= PERL_UNICODE_OUT_FLAG;     break;
5232                  case PERL_UNICODE_INOUT:
5233                       opt |= PERL_UNICODE_INOUT_FLAG;   break;
5234                  case PERL_UNICODE_LOCALE:
5235                       opt |= PERL_UNICODE_LOCALE_FLAG;  break;
5236                  case PERL_UNICODE_ARGV:
5237                       opt |= PERL_UNICODE_ARGV_FLAG;    break;
5238                  case PERL_UNICODE_UTF8CACHEASSERT:
5239                       opt |= PERL_UNICODE_UTF8CACHEASSERT_FLAG; break;
5240                  default:
5241                       if (*p != '\n' && *p != '\r')
5242                           Perl_croak(aTHX_
5243                                      "Unknown Unicode option letter '%c'", *p);
5244                  }
5245             }
5246        }
5247   }
5248   else
5249        opt = PERL_UNICODE_DEFAULT_FLAGS;
5250
5251   if (opt & ~PERL_UNICODE_ALL_FLAGS)
5252        Perl_croak(aTHX_ "Unknown Unicode option value %"UVuf,
5253                   (UV) (opt & ~PERL_UNICODE_ALL_FLAGS));
5254
5255   *popt = p;
5256
5257   return opt;
5258 }
5259
5260 U32
5261 Perl_seed(pTHX)
5262 {
5263     dVAR;
5264     /*
5265      * This is really just a quick hack which grabs various garbage
5266      * values.  It really should be a real hash algorithm which
5267      * spreads the effect of every input bit onto every output bit,
5268      * if someone who knows about such things would bother to write it.
5269      * Might be a good idea to add that function to CORE as well.
5270      * No numbers below come from careful analysis or anything here,
5271      * except they are primes and SEED_C1 > 1E6 to get a full-width
5272      * value from (tv_sec * SEED_C1 + tv_usec).  The multipliers should
5273      * probably be bigger too.
5274      */
5275 #if RANDBITS > 16
5276 #  define SEED_C1       1000003
5277 #define   SEED_C4       73819
5278 #else
5279 #  define SEED_C1       25747
5280 #define   SEED_C4       20639
5281 #endif
5282 #define   SEED_C2       3
5283 #define   SEED_C3       269
5284 #define   SEED_C5       26107
5285
5286 #ifndef PERL_NO_DEV_RANDOM
5287     int fd;
5288 #endif
5289     U32 u;
5290 #ifdef VMS
5291 #  include <starlet.h>
5292     /* when[] = (low 32 bits, high 32 bits) of time since epoch
5293      * in 100-ns units, typically incremented ever 10 ms.        */
5294     unsigned int when[2];
5295 #else
5296 #  ifdef HAS_GETTIMEOFDAY
5297     struct timeval when;
5298 #  else
5299     Time_t when;
5300 #  endif
5301 #endif
5302
5303 /* This test is an escape hatch, this symbol isn't set by Configure. */
5304 #ifndef PERL_NO_DEV_RANDOM
5305 #ifndef PERL_RANDOM_DEVICE
5306    /* /dev/random isn't used by default because reads from it will block
5307     * if there isn't enough entropy available.  You can compile with
5308     * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
5309     * is enough real entropy to fill the seed. */
5310 #  define PERL_RANDOM_DEVICE "/dev/urandom"
5311 #endif
5312     fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
5313     if (fd != -1) {
5314         if (PerlLIO_read(fd, (void*)&u, sizeof u) != sizeof u)
5315             u = 0;
5316         PerlLIO_close(fd);
5317         if (u)
5318             return u;
5319     }
5320 #endif
5321
5322 #ifdef VMS
5323     _ckvmssts(sys$gettim(when));
5324     u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
5325 #else
5326 #  ifdef HAS_GETTIMEOFDAY
5327     PerlProc_gettimeofday(&when,NULL);
5328     u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
5329 #  else
5330     (void)time(&when);
5331     u = (U32)SEED_C1 * when;
5332 #  endif
5333 #endif
5334     u += SEED_C3 * (U32)PerlProc_getpid();
5335     u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
5336 #ifndef PLAN9           /* XXX Plan9 assembler chokes on this; fix needed  */
5337     u += SEED_C5 * (U32)PTR2UV(&when);
5338 #endif
5339     return u;
5340 }
5341
5342 UV
5343 Perl_get_hash_seed(pTHX)
5344 {
5345     dVAR;
5346      const char *s = PerlEnv_getenv("PERL_HASH_SEED");
5347      UV myseed = 0;
5348
5349      if (s)
5350         while (isSPACE(*s))
5351             s++;
5352      if (s && isDIGIT(*s))
5353           myseed = (UV)Atoul(s);
5354      else
5355 #ifdef USE_HASH_SEED_EXPLICIT
5356      if (s)
5357 #endif
5358      {
5359           /* Compute a random seed */
5360           (void)seedDrand01((Rand_seed_t)seed());
5361           myseed = (UV)(Drand01() * (NV)UV_MAX);
5362 #if RANDBITS < (UVSIZE * 8)
5363           /* Since there are not enough randbits to to reach all
5364            * the bits of a UV, the low bits might need extra
5365            * help.  Sum in another random number that will
5366            * fill in the low bits. */
5367           myseed +=
5368                (UV)(Drand01() * (NV)((1 << ((UVSIZE * 8 - RANDBITS))) - 1));
5369 #endif /* RANDBITS < (UVSIZE * 8) */
5370           if (myseed == 0) { /* Superparanoia. */
5371               myseed = (UV)(Drand01() * (NV)UV_MAX); /* One more chance. */
5372               if (myseed == 0)
5373                   Perl_croak(aTHX_ "Your random numbers are not that random");
5374           }
5375      }
5376      PL_rehash_seed_set = TRUE;
5377
5378      return myseed;
5379 }
5380
5381 #ifdef USE_ITHREADS
5382 bool
5383 Perl_stashpv_hvname_match(pTHX_ const COP *c, const HV *hv)
5384 {
5385     const char * const stashpv = CopSTASHPV(c);
5386     const char * const name = HvNAME_get(hv);
5387     PERL_UNUSED_CONTEXT;
5388     PERL_ARGS_ASSERT_STASHPV_HVNAME_MATCH;
5389
5390     if (stashpv == name)
5391         return TRUE;
5392     if (stashpv && name)
5393         if (strEQ(stashpv, name))
5394             return TRUE;
5395     return FALSE;
5396 }
5397 #endif
5398
5399
5400 #ifdef PERL_GLOBAL_STRUCT
5401
5402 #define PERL_GLOBAL_STRUCT_INIT
5403 #include "opcode.h" /* the ppaddr and check */
5404
5405 struct perl_vars *
5406 Perl_init_global_struct(pTHX)
5407 {
5408     struct perl_vars *plvarsp = NULL;
5409 # ifdef PERL_GLOBAL_STRUCT
5410     const IV nppaddr = sizeof(Gppaddr)/sizeof(Perl_ppaddr_t);
5411     const IV ncheck  = sizeof(Gcheck) /sizeof(Perl_check_t);
5412 #  ifdef PERL_GLOBAL_STRUCT_PRIVATE
5413     /* PerlMem_malloc() because can't use even safesysmalloc() this early. */
5414     plvarsp = (struct perl_vars*)PerlMem_malloc(sizeof(struct perl_vars));
5415     if (!plvarsp)
5416         exit(1);
5417 #  else
5418     plvarsp = PL_VarsPtr;
5419 #  endif /* PERL_GLOBAL_STRUCT_PRIVATE */
5420 #  undef PERLVAR
5421 #  undef PERLVARA
5422 #  undef PERLVARI
5423 #  undef PERLVARIC
5424 #  undef PERLVARISC
5425 #  define PERLVAR(var,type) /**/
5426 #  define PERLVARA(var,n,type) /**/
5427 #  define PERLVARI(var,type,init) plvarsp->var = init;
5428 #  define PERLVARIC(var,type,init) plvarsp->var = init;
5429 #  define PERLVARISC(var,init) Copy(init, plvarsp->var, sizeof(init), char);
5430 #  include "perlvars.h"
5431 #  undef PERLVAR
5432 #  undef PERLVARA
5433 #  undef PERLVARI
5434 #  undef PERLVARIC
5435 #  undef PERLVARISC
5436 #  ifdef PERL_GLOBAL_STRUCT
5437     plvarsp->Gppaddr =
5438         (Perl_ppaddr_t*)
5439         PerlMem_malloc(nppaddr * sizeof(Perl_ppaddr_t));
5440     if (!plvarsp->Gppaddr)
5441         exit(1);
5442     plvarsp->Gcheck  =
5443         (Perl_check_t*)
5444         PerlMem_malloc(ncheck  * sizeof(Perl_check_t));
5445     if (!plvarsp->Gcheck)
5446         exit(1);
5447     Copy(Gppaddr, plvarsp->Gppaddr, nppaddr, Perl_ppaddr_t);
5448     Copy(Gcheck,  plvarsp->Gcheck,  ncheck,  Perl_check_t);
5449 #  endif
5450 #  ifdef PERL_SET_VARS
5451     PERL_SET_VARS(plvarsp);
5452 #  endif
5453 # undef PERL_GLOBAL_STRUCT_INIT
5454 # endif
5455     return plvarsp;
5456 }
5457
5458 #endif /* PERL_GLOBAL_STRUCT */
5459
5460 #ifdef PERL_GLOBAL_STRUCT
5461
5462 void
5463 Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp)
5464 {
5465     PERL_ARGS_ASSERT_FREE_GLOBAL_STRUCT;
5466 # ifdef PERL_GLOBAL_STRUCT
5467 #  ifdef PERL_UNSET_VARS
5468     PERL_UNSET_VARS(plvarsp);
5469 #  endif
5470     free(plvarsp->Gppaddr);
5471     free(plvarsp->Gcheck);
5472 #  ifdef PERL_GLOBAL_STRUCT_PRIVATE
5473     free(plvarsp);
5474 #  endif
5475 # endif
5476 }
5477
5478 #endif /* PERL_GLOBAL_STRUCT */
5479
5480 #ifdef PERL_MEM_LOG
5481
5482 /* -DPERL_MEM_LOG: the Perl_mem_log_..() is compiled, including the
5483  * the default implementation, unless -DPERL_MEM_LOG_NOIMPL is also
5484  * given, and you supply your own implementation.
5485  *
5486  * The default implementation reads a single env var, PERL_MEM_LOG,
5487  * expecting one or more of the following:
5488  *
5489  *    \d+ - fd          fd to write to          : must be 1st (atoi)
5490  *    'm' - memlog      was PERL_MEM_LOG=1
5491  *    's' - svlog       was PERL_SV_LOG=1
5492  *    't' - timestamp   was PERL_MEM_LOG_TIMESTAMP=1
5493  *
5494  * This makes the logger controllable enough that it can reasonably be
5495  * added to the system perl.
5496  */
5497
5498 /* -DPERL_MEM_LOG_SPRINTF_BUF_SIZE=X: size of a (stack-allocated) buffer
5499  * the Perl_mem_log_...() will use (either via sprintf or snprintf).
5500  */
5501 #define PERL_MEM_LOG_SPRINTF_BUF_SIZE 128
5502
5503 /* -DPERL_MEM_LOG_FD=N: the file descriptor the Perl_mem_log_...()
5504  * writes to.  In the default logger, this is settable at runtime.
5505  */
5506 #ifndef PERL_MEM_LOG_FD
5507 #  define PERL_MEM_LOG_FD 2 /* If STDERR is too boring for you. */
5508 #endif
5509
5510 #ifndef PERL_MEM_LOG_NOIMPL
5511
5512 # ifdef DEBUG_LEAKING_SCALARS
5513 #   define SV_LOG_SERIAL_FMT        " [%lu]"
5514 #   define _SV_LOG_SERIAL_ARG(sv)   , (unsigned long) (sv)->sv_debug_serial
5515 # else
5516 #   define SV_LOG_SERIAL_FMT
5517 #   define _SV_LOG_SERIAL_ARG(sv)
5518 # endif
5519
5520 static void
5521 S_mem_log_common(enum mem_log_type mlt, const UV n,
5522                  const UV typesize, const char *type_name, const SV *sv,
5523                  Malloc_t oldalloc, Malloc_t newalloc,
5524                  const char *filename, const int linenumber,
5525                  const char *funcname)
5526 {
5527     const char *pmlenv;
5528
5529     PERL_ARGS_ASSERT_MEM_LOG_COMMON;
5530
5531     pmlenv = PerlEnv_getenv("PERL_MEM_LOG");
5532     if (!pmlenv)
5533         return;
5534     if (mlt < MLT_NEW_SV ? strchr(pmlenv,'m') : strchr(pmlenv,'s'))
5535     {
5536         /* We can't use SVs or PerlIO for obvious reasons,
5537          * so we'll use stdio and low-level IO instead. */
5538         char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
5539
5540 #   ifdef HAS_GETTIMEOFDAY
5541 #     define MEM_LOG_TIME_FMT   "%10d.%06d: "
5542 #     define MEM_LOG_TIME_ARG   (int)tv.tv_sec, (int)tv.tv_usec
5543         struct timeval tv;
5544         gettimeofday(&tv, 0);
5545 #   else
5546 #     define MEM_LOG_TIME_FMT   "%10d: "
5547 #     define MEM_LOG_TIME_ARG   (int)when
5548         Time_t when;
5549         (void)time(&when);
5550 #   endif
5551         /* If there are other OS specific ways of hires time than
5552          * gettimeofday() (see ext/Time-HiRes), the easiest way is
5553          * probably that they would be used to fill in the struct
5554          * timeval. */
5555         {
5556             STRLEN len;
5557             int fd = atoi(pmlenv);
5558             if (!fd)
5559                 fd = PERL_MEM_LOG_FD;
5560
5561             if (strchr(pmlenv, 't')) {
5562                 len = my_snprintf(buf, sizeof(buf),
5563                                 MEM_LOG_TIME_FMT, MEM_LOG_TIME_ARG);
5564                 PerlLIO_write(fd, buf, len);
5565             }
5566             switch (mlt) {
5567             case MLT_ALLOC:
5568                 len = my_snprintf(buf, sizeof(buf),
5569                         "alloc: %s:%d:%s: %"IVdf" %"UVuf
5570                         " %s = %"IVdf": %"UVxf"\n",
5571                         filename, linenumber, funcname, n, typesize,
5572                         type_name, n * typesize, PTR2UV(newalloc));
5573                 break;
5574             case MLT_REALLOC:
5575                 len = my_snprintf(buf, sizeof(buf),
5576                         "realloc: %s:%d:%s: %"IVdf" %"UVuf
5577                         " %s = %"IVdf": %"UVxf" -> %"UVxf"\n",
5578                         filename, linenumber, funcname, n, typesize,
5579                         type_name, n * typesize, PTR2UV(oldalloc),
5580                         PTR2UV(newalloc));
5581                 break;
5582             case MLT_FREE:
5583                 len = my_snprintf(buf, sizeof(buf),
5584                         "free: %s:%d:%s: %"UVxf"\n",
5585                         filename, linenumber, funcname,
5586                         PTR2UV(oldalloc));
5587                 break;
5588             case MLT_NEW_SV:
5589             case MLT_DEL_SV:
5590                 len = my_snprintf(buf, sizeof(buf),
5591                         "%s_SV: %s:%d:%s: %"UVxf SV_LOG_SERIAL_FMT "\n",
5592                         mlt == MLT_NEW_SV ? "new" : "del",
5593                         filename, linenumber, funcname,
5594                         PTR2UV(sv) _SV_LOG_SERIAL_ARG(sv));
5595                 break;
5596             default:
5597                 len = 0;
5598             }
5599             PerlLIO_write(fd, buf, len);
5600         }
5601     }
5602 }
5603 #endif /* !PERL_MEM_LOG_NOIMPL */
5604
5605 #ifndef PERL_MEM_LOG_NOIMPL
5606 # define \
5607     mem_log_common_if(alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm) \
5608     mem_log_common   (alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm)
5609 #else
5610 /* this is suboptimal, but bug compatible.  User is providing their
5611    own implemenation, but is getting these functions anyway, and they
5612    do nothing. But _NOIMPL users should be able to cope or fix */
5613 # define \
5614     mem_log_common_if(alty, num, tysz, tynm, u, oal, nal, flnm, ln, fnnm) \
5615     /* mem_log_common_if_PERL_MEM_LOG_NOIMPL */
5616 #endif
5617
5618 Malloc_t
5619 Perl_mem_log_alloc(const UV n, const UV typesize, const char *type_name,
5620                    Malloc_t newalloc,
5621                    const char *filename, const int linenumber,
5622                    const char *funcname)
5623 {
5624     mem_log_common_if(MLT_ALLOC, n, typesize, type_name,
5625                       NULL, NULL, newalloc,
5626                       filename, linenumber, funcname);
5627     return newalloc;
5628 }
5629
5630 Malloc_t
5631 Perl_mem_log_realloc(const UV n, const UV typesize, const char *type_name,
5632                      Malloc_t oldalloc, Malloc_t newalloc,
5633                      const char *filename, const int linenumber,
5634                      const char *funcname)
5635 {
5636     mem_log_common_if(MLT_REALLOC, n, typesize, type_name,
5637                       NULL, oldalloc, newalloc,
5638                       filename, linenumber, funcname);
5639     return newalloc;
5640 }
5641
5642 Malloc_t
5643 Perl_mem_log_free(Malloc_t oldalloc,
5644                   const char *filename, const int linenumber,
5645                   const char *funcname)
5646 {
5647     mem_log_common_if(MLT_FREE, 0, 0, "", NULL, oldalloc, NULL,
5648                       filename, linenumber, funcname);
5649     return oldalloc;
5650 }
5651
5652 void
5653 Perl_mem_log_new_sv(const SV *sv,
5654                     const char *filename, const int linenumber,
5655                     const char *funcname)
5656 {
5657     mem_log_common_if(MLT_NEW_SV, 0, 0, "", sv, NULL, NULL,
5658                       filename, linenumber, funcname);
5659 }
5660
5661 void
5662 Perl_mem_log_del_sv(const SV *sv,
5663                     const char *filename, const int linenumber,
5664                     const char *funcname)
5665 {
5666     mem_log_common_if(MLT_DEL_SV, 0, 0, "", sv, NULL, NULL,
5667                       filename, linenumber, funcname);
5668 }
5669
5670 #endif /* PERL_MEM_LOG */
5671
5672 /*
5673 =for apidoc my_sprintf
5674
5675 The C library C<sprintf>, wrapped if necessary, to ensure that it will return
5676 the length of the string written to the buffer. Only rare pre-ANSI systems
5677 need the wrapper function - usually this is a direct call to C<sprintf>.
5678
5679 =cut
5680 */
5681 #ifndef SPRINTF_RETURNS_STRLEN
5682 int
5683 Perl_my_sprintf(char *buffer, const char* pat, ...)
5684 {
5685     va_list args;
5686     PERL_ARGS_ASSERT_MY_SPRINTF;
5687     va_start(args, pat);
5688     vsprintf(buffer, pat, args);
5689     va_end(args);
5690     return strlen(buffer);
5691 }
5692 #endif
5693
5694 /*
5695 =for apidoc my_snprintf
5696
5697 The C library C<snprintf> functionality, if available and
5698 standards-compliant (uses C<vsnprintf>, actually).  However, if the
5699 C<vsnprintf> is not available, will unfortunately use the unsafe
5700 C<vsprintf> which can overrun the buffer (there is an overrun check,
5701 but that may be too late).  Consider using C<sv_vcatpvf> instead, or
5702 getting C<vsnprintf>.
5703
5704 =cut
5705 */
5706 int
5707 Perl_my_snprintf(char *buffer, const Size_t len, const char *format, ...)
5708 {
5709     dTHX;
5710     int retval;
5711     va_list ap;
5712     PERL_ARGS_ASSERT_MY_SNPRINTF;
5713     va_start(ap, format);
5714 #ifdef HAS_VSNPRINTF
5715     retval = vsnprintf(buffer, len, format, ap);
5716 #else
5717     retval = vsprintf(buffer, format, ap);
5718 #endif
5719     va_end(ap);
5720     /* vsnprintf() shows failure with >= len, vsprintf() with < 0 */
5721     if (retval < 0 || (len > 0 && (Size_t)retval >= len))
5722         Perl_croak(aTHX_ "panic: my_snprintf buffer overflow");
5723     return retval;
5724 }
5725
5726 /*
5727 =for apidoc my_vsnprintf
5728
5729 The C library C<vsnprintf> if available and standards-compliant.
5730 However, if if the C<vsnprintf> is not available, will unfortunately
5731 use the unsafe C<vsprintf> which can overrun the buffer (there is an
5732 overrun check, but that may be too late).  Consider using
5733 C<sv_vcatpvf> instead, or getting C<vsnprintf>.
5734
5735 =cut
5736 */
5737 int
5738 Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap)
5739 {
5740     dTHX;
5741     int retval;
5742 #ifdef NEED_VA_COPY
5743     va_list apc;
5744
5745     PERL_ARGS_ASSERT_MY_VSNPRINTF;
5746
5747     Perl_va_copy(ap, apc);
5748 # ifdef HAS_VSNPRINTF
5749     retval = vsnprintf(buffer, len, format, apc);
5750 # else
5751     retval = vsprintf(buffer, format, apc);
5752 # endif
5753 #else
5754 # ifdef HAS_VSNPRINTF
5755     retval = vsnprintf(buffer, len, format, ap);
5756 # else
5757     retval = vsprintf(buffer, format, ap);
5758 # endif
5759 #endif /* #ifdef NEED_VA_COPY */
5760     /* vsnprintf() shows failure with >= len, vsprintf() with < 0 */
5761     if (retval < 0 || (len > 0 && (Size_t)retval >= len))
5762         Perl_croak(aTHX_ "panic: my_vsnprintf buffer overflow");
5763     return retval;
5764 }
5765
5766 void
5767 Perl_my_clearenv(pTHX)
5768 {
5769     dVAR;
5770 #if ! defined(PERL_MICRO)
5771 #  if defined(PERL_IMPLICIT_SYS) || defined(WIN32)
5772     PerlEnv_clearenv();
5773 #  else /* ! (PERL_IMPLICIT_SYS || WIN32) */
5774 #    if defined(USE_ENVIRON_ARRAY)
5775 #      if defined(USE_ITHREADS)
5776     /* only the parent thread can clobber the process environment */
5777     if (PL_curinterp == aTHX)
5778 #      endif /* USE_ITHREADS */
5779     {
5780 #      if ! defined(PERL_USE_SAFE_PUTENV)
5781     if ( !PL_use_safe_putenv) {
5782       I32 i;
5783       if (environ == PL_origenviron)
5784         environ = (char**)safesysmalloc(sizeof(char*));
5785       else
5786         for (i = 0; environ[i]; i++)
5787           (void)safesysfree(environ[i]);
5788     }
5789     environ[0] = NULL;
5790 #      else /* PERL_USE_SAFE_PUTENV */
5791 #        if defined(HAS_CLEARENV)
5792     (void)clearenv();
5793 #        elif defined(HAS_UNSETENV)
5794     int bsiz = 80; /* Most envvar names will be shorter than this. */
5795     int bufsiz = bsiz * sizeof(char); /* sizeof(char) paranoid? */
5796     char *buf = (char*)safesysmalloc(bufsiz);
5797     while (*environ != NULL) {
5798       char *e = strchr(*environ, '=');
5799       int l = e ? e - *environ : (int)strlen(*environ);
5800       if (bsiz < l + 1) {
5801         (void)safesysfree(buf);
5802         bsiz = l + 1; /* + 1 for the \0. */
5803         buf = (char*)safesysmalloc(bufsiz);
5804       }
5805       memcpy(buf, *environ, l);
5806       buf[l] = '\0';
5807       (void)unsetenv(buf);
5808     }
5809     (void)safesysfree(buf);
5810 #        else /* ! HAS_CLEARENV && ! HAS_UNSETENV */
5811     /* Just null environ and accept the leakage. */
5812     *environ = NULL;
5813 #        endif /* HAS_CLEARENV || HAS_UNSETENV */
5814 #      endif /* ! PERL_USE_SAFE_PUTENV */
5815     }
5816 #    endif /* USE_ENVIRON_ARRAY */
5817 #  endif /* PERL_IMPLICIT_SYS || WIN32 */
5818 #endif /* PERL_MICRO */
5819 }
5820
5821 #ifdef PERL_IMPLICIT_CONTEXT
5822
5823 /* Implements the MY_CXT_INIT macro. The first time a module is loaded,
5824 the global PL_my_cxt_index is incremented, and that value is assigned to
5825 that module's static my_cxt_index (who's address is passed as an arg).
5826 Then, for each interpreter this function is called for, it makes sure a
5827 void* slot is available to hang the static data off, by allocating or
5828 extending the interpreter's PL_my_cxt_list array */
5829
5830 #ifndef PERL_GLOBAL_STRUCT_PRIVATE
5831 void *
5832 Perl_my_cxt_init(pTHX_ int *index, size_t size)
5833 {
5834     dVAR;
5835     void *p;
5836     PERL_ARGS_ASSERT_MY_CXT_INIT;
5837     if (*index == -1) {
5838         /* this module hasn't been allocated an index yet */
5839         MUTEX_LOCK(&PL_my_ctx_mutex);
5840         *index = PL_my_cxt_index++;
5841         MUTEX_UNLOCK(&PL_my_ctx_mutex);
5842     }
5843
5844     /* make sure the array is big enough */
5845     if (PL_my_cxt_size <= *index) {
5846         if (PL_my_cxt_size) {
5847             while (PL_my_cxt_size <= *index)
5848                 PL_my_cxt_size *= 2;
5849             Renew(PL_my_cxt_list, PL_my_cxt_size, void *);
5850         }
5851         else {
5852             PL_my_cxt_size = 16;
5853             Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
5854         }
5855     }
5856     /* newSV() allocates one more than needed */
5857     p = (void*)SvPVX(newSV(size-1));
5858     PL_my_cxt_list[*index] = p;
5859     Zero(p, size, char);
5860     return p;
5861 }
5862
5863 #else /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
5864
5865 int
5866 Perl_my_cxt_index(pTHX_ const char *my_cxt_key)
5867 {
5868     dVAR;
5869     int index;
5870
5871     PERL_ARGS_ASSERT_MY_CXT_INDEX;
5872
5873     for (index = 0; index < PL_my_cxt_index; index++) {
5874         const char *key = PL_my_cxt_keys[index];
5875         /* try direct pointer compare first - there are chances to success,
5876          * and it's much faster.
5877          */
5878         if ((key == my_cxt_key) || strEQ(key, my_cxt_key))
5879             return index;
5880     }
5881     return -1;
5882 }
5883
5884 void *
5885 Perl_my_cxt_init(pTHX_ const char *my_cxt_key, size_t size)
5886 {
5887     dVAR;
5888     void *p;
5889     int index;
5890
5891     PERL_ARGS_ASSERT_MY_CXT_INIT;
5892
5893     index = Perl_my_cxt_index(aTHX_ my_cxt_key);
5894     if (index == -1) {
5895         /* this module hasn't been allocated an index yet */
5896         MUTEX_LOCK(&PL_my_ctx_mutex);
5897         index = PL_my_cxt_index++;
5898         MUTEX_UNLOCK(&PL_my_ctx_mutex);
5899     }
5900
5901     /* make sure the array is big enough */
5902     if (PL_my_cxt_size <= index) {
5903         int old_size = PL_my_cxt_size;
5904         int i;
5905         if (PL_my_cxt_size) {
5906             while (PL_my_cxt_size <= index)
5907                 PL_my_cxt_size *= 2;
5908             Renew(PL_my_cxt_list, PL_my_cxt_size, void *);
5909             Renew(PL_my_cxt_keys, PL_my_cxt_size, const char *);
5910         }
5911         else {
5912             PL_my_cxt_size = 16;
5913             Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
5914             Newx(PL_my_cxt_keys, PL_my_cxt_size, const char *);
5915         }
5916         for (i = old_size; i < PL_my_cxt_size; i++) {
5917             PL_my_cxt_keys[i] = 0;
5918             PL_my_cxt_list[i] = 0;
5919         }
5920     }
5921     PL_my_cxt_keys[index] = my_cxt_key;
5922     /* newSV() allocates one more than needed */
5923     p = (void*)SvPVX(newSV(size-1));
5924     PL_my_cxt_list[index] = p;
5925     Zero(p, size, char);
5926     return p;
5927 }
5928 #endif /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
5929 #endif /* PERL_IMPLICIT_CONTEXT */
5930
5931 #ifndef HAS_STRLCAT
5932 Size_t
5933 Perl_my_strlcat(char *dst, const char *src, Size_t size)
5934 {
5935     Size_t used, length, copy;
5936
5937     used = strlen(dst);
5938     length = strlen(src);
5939     if (size > 0 && used < size - 1) {
5940         copy = (length >= size - used) ? size - used - 1 : length;
5941         memcpy(dst + used, src, copy);
5942         dst[used + copy] = '\0';
5943     }
5944     return used + length;
5945 }
5946 #endif
5947
5948 #ifndef HAS_STRLCPY
5949 Size_t
5950 Perl_my_strlcpy(char *dst, const char *src, Size_t size)
5951 {
5952     Size_t length, copy;
5953
5954     length = strlen(src);
5955     if (size > 0) {
5956         copy = (length >= size) ? size - 1 : length;
5957         memcpy(dst, src, copy);
5958         dst[copy] = '\0';
5959     }
5960     return length;
5961 }
5962 #endif
5963
5964 #if defined(_MSC_VER) && (_MSC_VER >= 1300) && (_MSC_VER < 1400) && (WINVER < 0x0500)
5965 /* VC7 or 7.1, building with pre-VC7 runtime libraries. */
5966 long _ftol( double ); /* Defined by VC6 C libs. */
5967 long _ftol2( double dblSource ) { return _ftol( dblSource ); }
5968 #endif
5969
5970 void
5971 Perl_get_db_sub(pTHX_ SV **svp, CV *cv)
5972 {
5973     dVAR;
5974     SV * const dbsv = GvSVn(PL_DBsub);
5975     /* We do not care about using sv to call CV;
5976      * it's for informational purposes only.
5977      */
5978
5979     PERL_ARGS_ASSERT_GET_DB_SUB;
5980
5981     save_item(dbsv);
5982     if (!PERLDB_SUB_NN) {
5983         GV * const gv = CvGV(cv);
5984
5985         if ( svp && ((CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
5986              || strEQ(GvNAME(gv), "END")
5987              || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
5988                  !( (SvTYPE(*svp) == SVt_PVGV)
5989                     && (GvCV((const GV *)*svp) == cv) )))) {
5990             /* Use GV from the stack as a fallback. */
5991             /* GV is potentially non-unique, or contain different CV. */
5992             SV * const tmp = newRV(MUTABLE_SV(cv));
5993             sv_setsv(dbsv, tmp);
5994             SvREFCNT_dec(tmp);
5995         }
5996         else {
5997             gv_efullname3(dbsv, gv, NULL);
5998         }
5999     }
6000     else {
6001         const int type = SvTYPE(dbsv);
6002         if (type < SVt_PVIV && type != SVt_IV)
6003             sv_upgrade(dbsv, SVt_PVIV);
6004         (void)SvIOK_on(dbsv);
6005         SvIV_set(dbsv, PTR2IV(cv));     /* Do it the quickest way  */
6006     }
6007 }
6008
6009 int
6010 Perl_my_dirfd(pTHX_ DIR * dir) {
6011
6012     /* Most dirfd implementations have problems when passed NULL. */
6013     if(!dir)
6014         return -1;
6015 #ifdef HAS_DIRFD
6016     return dirfd(dir);
6017 #elif defined(HAS_DIR_DD_FD)
6018     return dir->dd_fd;
6019 #else
6020     Perl_die(aTHX_ PL_no_func, "dirfd");
6021    /* NOT REACHED */
6022     return 0;
6023 #endif
6024 }
6025
6026 REGEXP *
6027 Perl_get_re_arg(pTHX_ SV *sv) {
6028     SV    *tmpsv;
6029
6030     if (sv) {
6031         if (SvMAGICAL(sv))
6032             mg_get(sv);
6033         if (SvROK(sv) &&
6034             (tmpsv = MUTABLE_SV(SvRV(sv))) &&            /* assign deliberate */
6035             SvTYPE(tmpsv) == SVt_REGEXP)
6036         {
6037             return (REGEXP*) tmpsv;
6038         }
6039     }
6040
6041     return NULL;
6042 }
6043
6044 /*
6045  * Local variables:
6046  * c-indentation-style: bsd
6047  * c-basic-offset: 4
6048  * indent-tabs-mode: t
6049  * End:
6050  *
6051  * ex: set ts=8 sts=4 sw=4 noet:
6052  */