util.c

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