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