util.c

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