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