util.c

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