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