util.c

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