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