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