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