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