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 ( saw_period > 1 )
4145         qv = 1; /* force quoted version processing */
4146
4147     pos = s;
4148
4149     if ( qv )
4150         hv_store((HV *)hv, "qv", 2, newSViv(qv), 0);
4151     if ( alpha )
4152         hv_store((HV *)hv, "alpha", 5, newSViv(alpha), 0);
4153     if ( !qv && width < 3 )
4154         hv_store((HV *)hv, "width", 5, newSViv(width), 0);
4155
4156     while (isDIGIT(*pos))
4157         pos++;
4158     if (!isALPHA(*pos)) {
4159         I32 rev;
4160
4161         for (;;) {
4162             rev = 0;
4163             {
4164                 /* this is atoi() that delimits on underscores */
4165                 const char *end = pos;
4166                 I32 mult = 1;
4167                 I32 orev;
4168
4169                 /* the following if() will only be true after the decimal
4170                  * point of a version originally created with a bare
4171                  * floating point number, i.e. not quoted in any way
4172                  */
4173                 if ( !qv && s > start && saw_period == 1 ) {
4174                     mult *= 100;
4175                     while ( s < end ) {
4176                         orev = rev;
4177                         rev += (*s - '0') * mult;
4178                         mult /= 10;
4179                         if ( PERL_ABS(orev) > PERL_ABS(rev) )
4180                             Perl_croak(aTHX_ "Integer overflow in version");
4181                         s++;
4182                         if ( *s == '_' )
4183                             s++;
4184                     }
4185                 }
4186                 else {
4187                     while (--end >= s) {
4188                         orev = rev;
4189                         rev += (*end - '0') * mult;
4190                         mult *= 10;
4191                         if ( PERL_ABS(orev) > PERL_ABS(rev) )
4192                             Perl_croak(aTHX_ "Integer overflow in version");
4193                     }
4194                 }
4195             }
4196
4197             /* Append revision */
4198             av_push(av, newSViv(rev));
4199             if ( *pos == '.' )
4200                 s = ++pos;
4201             else if ( *pos == '_' && isDIGIT(pos[1]) )
4202                 s = ++pos;
4203             else if ( isDIGIT(*pos) )
4204                 s = pos;
4205             else {
4206                 s = pos;
4207                 break;
4208             }
4209             if ( qv ) {
4210                 while ( isDIGIT(*pos) )
4211                     pos++;
4212             }
4213             else {
4214                 int digits = 0;
4215                 while ( ( isDIGIT(*pos) || *pos == '_' ) && digits < 3 ) {
4216                     if ( *pos != '_' )
4217                         digits++;
4218                     pos++;
4219                 }
4220             }
4221         }
4222     }
4223     if ( qv ) { /* quoted versions always get at least three terms*/
4224         I32 len = av_len(av);
4225         /* This for loop appears to trigger a compiler bug on OS X, as it
4226            loops infinitely. Yes, len is negative. No, it makes no sense.
4227            Compiler in question is:
4228            gcc version 3.3 20030304 (Apple Computer, Inc. build 1640)
4229            for ( len = 2 - len; len > 0; len-- )
4230            av_push((AV *)sv, newSViv(0));
4231         */
4232         len = 2 - len;
4233         while (len-- > 0)
4234             av_push(av, newSViv(0));
4235     }
4236
4237     if ( av_len(av) == -1 ) /* oops, someone forgot to pass a value */
4238         av_push(av, newSViv(0));
4239
4240     /* fix RT#19517 - special case 'undef' as string */
4241     if ( *s == 'u' && strEQ(s,"undef") ) {
4242         s += 5;
4243     }
4244
4245     /* And finally, store the AV in the hash */
4246     hv_store((HV *)hv, "version", 7, newRV_noinc((SV *)av), 0);
4247     return s;
4248 }
4249
4250 /*
4251 =for apidoc new_version
4252
4253 Returns a new version object based on the passed in SV:
4254
4255     SV *sv = new_version(SV *ver);
4256
4257 Does not alter the passed in ver SV.  See "upg_version" if you
4258 want to upgrade the SV.
4259
4260 =cut
4261 */
4262
4263 SV *
4264 Perl_new_version(pTHX_ SV *ver)
4265 {
4266     dVAR;
4267     SV * const rv = newSV(0);
4268     if ( sv_derived_from(ver,"version") ) /* can just copy directly */
4269     {
4270         I32 key;
4271         AV * const av = newAV();
4272         AV *sav;
4273         /* This will get reblessed later if a derived class*/
4274         SV * const hv = newSVrv(rv, "version");
4275         (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
4276 #ifndef NODEFAULT_SHAREKEYS
4277         HvSHAREKEYS_on(hv);         /* key-sharing on by default */
4278 #endif
4279
4280         if ( SvROK(ver) )
4281             ver = SvRV(ver);
4282
4283         /* Begin copying all of the elements */
4284         if ( hv_exists((HV *)ver, "qv", 2) )
4285             hv_store((HV *)hv, "qv", 2, &PL_sv_yes, 0);
4286
4287         if ( hv_exists((HV *)ver, "alpha", 5) )
4288             hv_store((HV *)hv, "alpha", 5, &PL_sv_yes, 0);
4289
4290         if ( hv_exists((HV*)ver, "width", 5 ) )
4291         {
4292             const I32 width = SvIV(*hv_fetchs((HV*)ver, "width", FALSE));
4293             hv_store((HV *)hv, "width", 5, newSViv(width), 0);
4294         }
4295
4296         sav = (AV *)SvRV(*hv_fetchs((HV*)ver, "version", FALSE));
4297         /* This will get reblessed later if a derived class*/
4298         for ( key = 0; key <= av_len(sav); key++ )
4299         {
4300             const I32 rev = SvIV(*av_fetch(sav, key, FALSE));
4301             av_push(av, newSViv(rev));
4302         }
4303
4304         hv_store((HV *)hv, "version", 7, newRV_noinc((SV *)av), 0);
4305         return rv;
4306     }
4307 #ifdef SvVOK
4308     {
4309         const MAGIC* const mg = SvVSTRING_mg(ver);
4310         if ( mg ) { /* already a v-string */
4311             const STRLEN len = mg->mg_len;
4312             char * const version = savepvn( (const char*)mg->mg_ptr, len);
4313             sv_setpvn(rv,version,len);
4314             Safefree(version);
4315         }
4316         else {
4317 #endif
4318         sv_setsv(rv,ver); /* make a duplicate */
4319 #ifdef SvVOK
4320         }
4321     }
4322 #endif
4323     return upg_version(rv);
4324 }
4325
4326 /*
4327 =for apidoc upg_version
4328
4329 In-place upgrade of the supplied SV to a version object.
4330
4331     SV *sv = upg_version(SV *sv);
4332
4333 Returns a pointer to the upgraded SV.
4334
4335 =cut
4336 */
4337
4338 SV *
4339 Perl_upg_version(pTHX_ SV *ver)
4340 {
4341     const char *version, *s;
4342     bool qv = 0;
4343 #ifdef SvVOK
4344     const MAGIC *mg;
4345 #endif
4346
4347     if ( SvNOK(ver) ) /* may get too much accuracy */
4348     {
4349         char tbuf[64];
4350 #ifdef USE_LOCALE_NUMERIC
4351         char *loc = setlocale(LC_NUMERIC, "C");
4352 #endif
4353         STRLEN len = my_snprintf(tbuf, sizeof(tbuf), "%.9"NVff, SvNVX(ver));
4354 #ifdef USE_LOCALE_NUMERIC
4355         setlocale(LC_NUMERIC, loc);
4356 #endif
4357         while (tbuf[len-1] == '0' && len > 0) len--;
4358         version = savepvn(tbuf, len);
4359     }
4360 #ifdef SvVOK
4361     else if ( (mg = SvVSTRING_mg(ver)) ) { /* already a v-string */
4362         version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
4363         qv = 1;
4364     }
4365 #endif
4366     else /* must be a string or something like a string */
4367     {
4368         version = savepv(SvPV_nolen(ver));
4369     }
4370
4371     s = scan_version(version, ver, qv);
4372     if ( *s != '\0' )
4373         if(ckWARN(WARN_MISC))
4374             Perl_warner(aTHX_ packWARN(WARN_MISC),
4375                 "Version string '%s' contains invalid data; "
4376                 "ignoring: '%s'", version, s);
4377     Safefree(version);
4378     return ver;
4379 }
4380
4381 /*
4382 =for apidoc vverify
4383
4384 Validates that the SV contains a valid version object.
4385
4386     bool vverify(SV *vobj);
4387
4388 Note that it only confirms the bare minimum structure (so as not to get
4389 confused by derived classes which may contain additional hash entries):
4390
4391 =over 4
4392
4393 =item * The SV contains a [reference to a] hash
4394
4395 =item * The hash contains a "version" key
4396
4397 =item * The "version" key has [a reference to] an AV as its value
4398
4399 =back
4400
4401 =cut
4402 */
4403
4404 bool
4405 Perl_vverify(pTHX_ SV *vs)
4406 {
4407     SV *sv;
4408     if ( SvROK(vs) )
4409         vs = SvRV(vs);
4410
4411     /* see if the appropriate elements exist */
4412     if ( SvTYPE(vs) == SVt_PVHV
4413          && hv_exists((HV*)vs, "version", 7)
4414          && (sv = SvRV(*hv_fetchs((HV*)vs, "version", FALSE)))
4415          && SvTYPE(sv) == SVt_PVAV )
4416         return TRUE;
4417     else
4418         return FALSE;
4419 }
4420
4421 /*
4422 =for apidoc vnumify
4423
4424 Accepts a version object and returns the normalized floating
4425 point representation.  Call like:
4426
4427     sv = vnumify(rv);
4428
4429 NOTE: you can pass either the object directly or the SV
4430 contained within the RV.
4431
4432 =cut
4433 */
4434
4435 SV *
4436 Perl_vnumify(pTHX_ SV *vs)
4437 {
4438     I32 i, len, digit;
4439     int width;
4440     bool alpha = FALSE;
4441     SV * const sv = newSV(0);
4442     AV *av;
4443     if ( SvROK(vs) )
4444         vs = SvRV(vs);
4445
4446     if ( !vverify(vs) )
4447         Perl_croak(aTHX_ "Invalid version object");
4448
4449     /* see if various flags exist */
4450     if ( hv_exists((HV*)vs, "alpha", 5 ) )
4451         alpha = TRUE;
4452     if ( hv_exists((HV*)vs, "width", 5 ) )
4453         width = SvIV(*hv_fetchs((HV*)vs, "width", FALSE));
4454     else
4455         width = 3;
4456
4457
4458     /* attempt to retrieve the version array */
4459     if ( !(av = (AV *)SvRV(*hv_fetchs((HV*)vs, "version", FALSE)) ) ) {
4460         sv_catpvs(sv,"0");
4461         return sv;
4462     }
4463
4464     len = av_len(av);
4465     if ( len == -1 )
4466     {
4467         sv_catpvs(sv,"0");
4468         return sv;
4469     }
4470
4471     digit = SvIV(*av_fetch(av, 0, 0));
4472     Perl_sv_setpvf(aTHX_ sv, "%d.", (int)PERL_ABS(digit));
4473     for ( i = 1 ; i < len ; i++ )
4474     {
4475         digit = SvIV(*av_fetch(av, i, 0));
4476         if ( width < 3 ) {
4477             const int denom = (width == 2 ? 10 : 100);
4478             const div_t term = div((int)PERL_ABS(digit),denom);
4479             Perl_sv_catpvf(aTHX_ sv, "%0*d_%d", width, term.quot, term.rem);
4480         }
4481         else {
4482             Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
4483         }
4484     }
4485
4486     if ( len > 0 )
4487     {
4488         digit = SvIV(*av_fetch(av, len, 0));
4489         if ( alpha && width == 3 ) /* alpha version */
4490             sv_catpvs(sv,"_");
4491         Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
4492     }
4493     else /* len == 0 */
4494     {
4495         sv_catpvs(sv, "000");
4496     }
4497     return sv;
4498 }
4499
4500 /*
4501 =for apidoc vnormal
4502
4503 Accepts a version object and returns the normalized string
4504 representation.  Call like:
4505
4506     sv = vnormal(rv);
4507
4508 NOTE: you can pass either the object directly or the SV
4509 contained within the RV.
4510
4511 =cut
4512 */
4513
4514 SV *
4515 Perl_vnormal(pTHX_ SV *vs)
4516 {
4517     I32 i, len, digit;
4518     bool alpha = FALSE;
4519     SV * const sv = newSV(0);
4520     AV *av;
4521     if ( SvROK(vs) )
4522         vs = SvRV(vs);
4523
4524     if ( !vverify(vs) )
4525         Perl_croak(aTHX_ "Invalid version object");
4526
4527     if ( hv_exists((HV*)vs, "alpha", 5 ) )
4528         alpha = TRUE;
4529     av = (AV *)SvRV(*hv_fetchs((HV*)vs, "version", FALSE));
4530
4531     len = av_len(av);
4532     if ( len == -1 )
4533     {
4534         sv_catpvs(sv,"");
4535         return sv;
4536     }
4537     digit = SvIV(*av_fetch(av, 0, 0));
4538     Perl_sv_setpvf(aTHX_ sv, "v%"IVdf, (IV)digit);
4539     for ( i = 1 ; i < len ; i++ ) {
4540         digit = SvIV(*av_fetch(av, i, 0));
4541         Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
4542     }
4543
4544     if ( len > 0 )
4545     {
4546         /* handle last digit specially */
4547         digit = SvIV(*av_fetch(av, len, 0));
4548         if ( alpha )
4549             Perl_sv_catpvf(aTHX_ sv, "_%"IVdf, (IV)digit);
4550         else
4551             Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
4552     }
4553
4554     if ( len <= 2 ) { /* short version, must be at least three */
4555         for ( len = 2 - len; len != 0; len-- )
4556             sv_catpvs(sv,".0");
4557     }
4558     return sv;
4559 }
4560
4561 /*
4562 =for apidoc vstringify
4563
4564 In order to maintain maximum compatibility with earlier versions
4565 of Perl, this function will return either the floating point
4566 notation or the multiple dotted notation, depending on whether
4567 the original version contained 1 or more dots, respectively
4568
4569 =cut
4570 */
4571
4572 SV *
4573 Perl_vstringify(pTHX_ SV *vs)
4574 {
4575     if ( SvROK(vs) )
4576         vs = SvRV(vs);
4577
4578     if ( !vverify(vs) )
4579         Perl_croak(aTHX_ "Invalid version object");
4580
4581     if ( hv_exists((HV *)vs, "qv", 2) )
4582         return vnormal(vs);
4583     else
4584         return vnumify(vs);
4585 }
4586
4587 /*
4588 =for apidoc vcmp
4589
4590 Version object aware cmp.  Both operands must already have been
4591 converted into version objects.
4592
4593 =cut
4594 */
4595
4596 int
4597 Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
4598 {
4599     I32 i,l,m,r,retval;
4600     bool lalpha = FALSE;
4601     bool ralpha = FALSE;
4602     I32 left = 0;
4603     I32 right = 0;
4604     AV *lav, *rav;
4605     if ( SvROK(lhv) )
4606         lhv = SvRV(lhv);
4607     if ( SvROK(rhv) )
4608         rhv = SvRV(rhv);
4609
4610     if ( !vverify(lhv) )
4611         Perl_croak(aTHX_ "Invalid version object");
4612
4613     if ( !vverify(rhv) )
4614         Perl_croak(aTHX_ "Invalid version object");
4615
4616     /* get the left hand term */
4617     lav = (AV *)SvRV(*hv_fetchs((HV*)lhv, "version", FALSE));
4618     if ( hv_exists((HV*)lhv, "alpha", 5 ) )
4619         lalpha = TRUE;
4620
4621     /* and the right hand term */
4622     rav = (AV *)SvRV(*hv_fetchs((HV*)rhv, "version", FALSE));
4623     if ( hv_exists((HV*)rhv, "alpha", 5 ) )
4624         ralpha = TRUE;
4625
4626     l = av_len(lav);
4627     r = av_len(rav);
4628     m = l < r ? l : r;
4629     retval = 0;
4630     i = 0;
4631     while ( i <= m && retval == 0 )
4632     {
4633         left  = SvIV(*av_fetch(lav,i,0));
4634         right = SvIV(*av_fetch(rav,i,0));
4635         if ( left < right  )
4636             retval = -1;
4637         if ( left > right )
4638             retval = +1;
4639         i++;
4640     }
4641
4642     /* tiebreaker for alpha with identical terms */
4643     if ( retval == 0 && l == r && left == right && ( lalpha || ralpha ) )
4644     {
4645         if ( lalpha && !ralpha )
4646         {
4647             retval = -1;
4648         }
4649         else if ( ralpha && !lalpha)
4650         {
4651             retval = +1;
4652         }
4653     }
4654
4655     if ( l != r && retval == 0 ) /* possible match except for trailing 0's */
4656     {
4657         if ( l < r )
4658         {
4659             while ( i <= r && retval == 0 )
4660             {
4661                 if ( SvIV(*av_fetch(rav,i,0)) != 0 )
4662                     retval = -1; /* not a match after all */
4663                 i++;
4664             }
4665         }
4666         else
4667         {
4668             while ( i <= l && retval == 0 )
4669             {
4670                 if ( SvIV(*av_fetch(lav,i,0)) != 0 )
4671                     retval = +1; /* not a match after all */
4672                 i++;
4673             }
4674         }
4675     }
4676     return retval;
4677 }
4678
4679 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT)
4680 #   define EMULATE_SOCKETPAIR_UDP
4681 #endif
4682
4683 #ifdef EMULATE_SOCKETPAIR_UDP
4684 static int
4685 S_socketpair_udp (int fd[2]) {
4686     dTHX;
4687     /* Fake a datagram socketpair using UDP to localhost.  */
4688     int sockets[2] = {-1, -1};
4689     struct sockaddr_in addresses[2];
4690     int i;
4691     Sock_size_t size = sizeof(struct sockaddr_in);
4692     unsigned short port;
4693     int got;
4694
4695     memset(&addresses, 0, sizeof(addresses));
4696     i = 1;
4697     do {
4698         sockets[i] = PerlSock_socket(AF_INET, SOCK_DGRAM, PF_INET);
4699         if (sockets[i] == -1)
4700             goto tidy_up_and_fail;
4701
4702         addresses[i].sin_family = AF_INET;
4703         addresses[i].sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4704         addresses[i].sin_port = 0;      /* kernel choses port.  */
4705         if (PerlSock_bind(sockets[i], (struct sockaddr *) &addresses[i],
4706                 sizeof(struct sockaddr_in)) == -1)
4707             goto tidy_up_and_fail;
4708     } while (i--);
4709
4710     /* Now have 2 UDP sockets. Find out which port each is connected to, and
4711        for each connect the other socket to it.  */
4712     i = 1;
4713     do {
4714         if (PerlSock_getsockname(sockets[i], (struct sockaddr *) &addresses[i],
4715                 &size) == -1)
4716             goto tidy_up_and_fail;
4717         if (size != sizeof(struct sockaddr_in))
4718             goto abort_tidy_up_and_fail;
4719         /* !1 is 0, !0 is 1 */
4720         if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i],
4721                 sizeof(struct sockaddr_in)) == -1)
4722             goto tidy_up_and_fail;
4723     } while (i--);
4724
4725     /* Now we have 2 sockets connected to each other. I don't trust some other
4726        process not to have already sent a packet to us (by random) so send
4727        a packet from each to the other.  */
4728     i = 1;
4729     do {
4730         /* I'm going to send my own port number.  As a short.
4731            (Who knows if someone somewhere has sin_port as a bitfield and needs
4732            this routine. (I'm assuming crays have socketpair)) */
4733         port = addresses[i].sin_port;
4734         got = PerlLIO_write(sockets[i], &port, sizeof(port));
4735         if (got != sizeof(port)) {
4736             if (got == -1)
4737                 goto tidy_up_and_fail;
4738             goto abort_tidy_up_and_fail;
4739         }
4740     } while (i--);
4741
4742     /* Packets sent. I don't trust them to have arrived though.
4743        (As I understand it Solaris TCP stack is multithreaded. Non-blocking
4744        connect to localhost will use a second kernel thread. In 2.6 the
4745        first thread running the connect() returns before the second completes,
4746        so EINPROGRESS> In 2.7 the improved stack is faster and connect()
4747        returns 0. Poor programs have tripped up. One poor program's authors'
4748        had a 50-1 reverse stock split. Not sure how connected these were.)
4749        So I don't trust someone not to have an unpredictable UDP stack.
4750     */
4751
4752     {
4753         struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */
4754         int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0];
4755         fd_set rset;
4756
4757         FD_ZERO(&rset);
4758         FD_SET((unsigned int)sockets[0], &rset);
4759         FD_SET((unsigned int)sockets[1], &rset);
4760
4761         got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor);
4762         if (got != 2 || !FD_ISSET(sockets[0], &rset)
4763                 || !FD_ISSET(sockets[1], &rset)) {
4764             /* I hope this is portable and appropriate.  */
4765             if (got == -1)
4766                 goto tidy_up_and_fail;
4767             goto abort_tidy_up_and_fail;
4768         }
4769     }
4770
4771     /* And the paranoia department even now doesn't trust it to have arrive
4772        (hence MSG_DONTWAIT). Or that what arrives was sent by us.  */
4773     {
4774         struct sockaddr_in readfrom;
4775         unsigned short buffer[2];
4776
4777         i = 1;
4778         do {
4779 #ifdef MSG_DONTWAIT
4780             got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4781                     sizeof(buffer), MSG_DONTWAIT,
4782                     (struct sockaddr *) &readfrom, &size);
4783 #else
4784             got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4785                     sizeof(buffer), 0,
4786                     (struct sockaddr *) &readfrom, &size);
4787 #endif
4788
4789             if (got == -1)
4790                 goto tidy_up_and_fail;
4791             if (got != sizeof(port)
4792                     || size != sizeof(struct sockaddr_in)
4793                     /* Check other socket sent us its port.  */
4794                     || buffer[0] != (unsigned short) addresses[!i].sin_port
4795                     /* Check kernel says we got the datagram from that socket */
4796                     || readfrom.sin_family != addresses[!i].sin_family
4797                     || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr
4798                     || readfrom.sin_port != addresses[!i].sin_port)
4799                 goto abort_tidy_up_and_fail;
4800         } while (i--);
4801     }
4802     /* My caller (my_socketpair) has validated that this is non-NULL  */
4803     fd[0] = sockets[0];
4804     fd[1] = sockets[1];
4805     /* I hereby declare this connection open.  May God bless all who cross
4806        her.  */
4807     return 0;
4808
4809   abort_tidy_up_and_fail:
4810     errno = ECONNABORTED;
4811   tidy_up_and_fail:
4812     {
4813         const int save_errno = errno;
4814         if (sockets[0] != -1)
4815             PerlLIO_close(sockets[0]);
4816         if (sockets[1] != -1)
4817             PerlLIO_close(sockets[1]);
4818         errno = save_errno;
4819         return -1;
4820     }
4821 }
4822 #endif /*  EMULATE_SOCKETPAIR_UDP */
4823
4824 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET)
4825 int
4826 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4827     /* Stevens says that family must be AF_LOCAL, protocol 0.
4828        I'm going to enforce that, then ignore it, and use TCP (or UDP).  */
4829     dTHX;
4830     int listener = -1;
4831     int connector = -1;
4832     int acceptor = -1;
4833     struct sockaddr_in listen_addr;
4834     struct sockaddr_in connect_addr;
4835     Sock_size_t size;
4836
4837     if (protocol
4838 #ifdef AF_UNIX
4839         || family != AF_UNIX
4840 #endif
4841     ) {
4842         errno = EAFNOSUPPORT;
4843         return -1;
4844     }
4845     if (!fd) {
4846         errno = EINVAL;
4847         return -1;
4848     }
4849
4850 #ifdef EMULATE_SOCKETPAIR_UDP
4851     if (type == SOCK_DGRAM)
4852         return S_socketpair_udp(fd);
4853 #endif
4854
4855     listener = PerlSock_socket(AF_INET, type, 0);
4856     if (listener == -1)
4857         return -1;
4858     memset(&listen_addr, 0, sizeof(listen_addr));
4859     listen_addr.sin_family = AF_INET;
4860     listen_addr.sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4861     listen_addr.sin_port = 0;   /* kernel choses port.  */
4862     if (PerlSock_bind(listener, (struct sockaddr *) &listen_addr,
4863             sizeof(listen_addr)) == -1)
4864         goto tidy_up_and_fail;
4865     if (PerlSock_listen(listener, 1) == -1)
4866         goto tidy_up_and_fail;
4867
4868     connector = PerlSock_socket(AF_INET, type, 0);
4869     if (connector == -1)
4870         goto tidy_up_and_fail;
4871     /* We want to find out the port number to connect to.  */
4872     size = sizeof(connect_addr);
4873     if (PerlSock_getsockname(listener, (struct sockaddr *) &connect_addr,
4874             &size) == -1)
4875         goto tidy_up_and_fail;
4876     if (size != sizeof(connect_addr))
4877         goto abort_tidy_up_and_fail;
4878     if (PerlSock_connect(connector, (struct sockaddr *) &connect_addr,
4879             sizeof(connect_addr)) == -1)
4880         goto tidy_up_and_fail;
4881
4882     size = sizeof(listen_addr);
4883     acceptor = PerlSock_accept(listener, (struct sockaddr *) &listen_addr,
4884             &size);
4885     if (acceptor == -1)
4886         goto tidy_up_and_fail;
4887     if (size != sizeof(listen_addr))
4888         goto abort_tidy_up_and_fail;
4889     PerlLIO_close(listener);
4890     /* Now check we are talking to ourself by matching port and host on the
4891        two sockets.  */
4892     if (PerlSock_getsockname(connector, (struct sockaddr *) &connect_addr,
4893             &size) == -1)
4894         goto tidy_up_and_fail;
4895     if (size != sizeof(connect_addr)
4896             || listen_addr.sin_family != connect_addr.sin_family
4897             || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr
4898             || listen_addr.sin_port != connect_addr.sin_port) {
4899         goto abort_tidy_up_and_fail;
4900     }
4901     fd[0] = connector;
4902     fd[1] = acceptor;
4903     return 0;
4904
4905   abort_tidy_up_and_fail:
4906 #ifdef ECONNABORTED
4907   errno = ECONNABORTED; /* This would be the standard thing to do. */
4908 #else
4909 #  ifdef ECONNREFUSED
4910   errno = ECONNREFUSED; /* E.g. Symbian does not have ECONNABORTED. */
4911 #  else
4912   errno = ETIMEDOUT;    /* Desperation time. */
4913 #  endif
4914 #endif
4915   tidy_up_and_fail:
4916     {
4917         const int save_errno = errno;
4918         if (listener != -1)
4919             PerlLIO_close(listener);
4920         if (connector != -1)
4921             PerlLIO_close(connector);
4922         if (acceptor != -1)
4923             PerlLIO_close(acceptor);
4924         errno = save_errno;
4925         return -1;
4926     }
4927 }
4928 #else
4929 /* In any case have a stub so that there's code corresponding
4930  * to the my_socketpair in global.sym. */
4931 int
4932 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4933 #ifdef HAS_SOCKETPAIR
4934     return socketpair(family, type, protocol, fd);
4935 #else
4936     return -1;
4937 #endif
4938 }
4939 #endif
4940
4941 /*
4942
4943 =for apidoc sv_nosharing
4944
4945 Dummy routine which "shares" an SV when there is no sharing module present.
4946 Or "locks" it. Or "unlocks" it. In other words, ignores its single SV argument.
4947 Exists to avoid test for a NULL function pointer and because it could
4948 potentially warn under some level of strict-ness.
4949
4950 =cut
4951 */
4952
4953 void
4954 Perl_sv_nosharing(pTHX_ SV *sv)
4955 {
4956     PERL_UNUSED_CONTEXT;
4957     PERL_UNUSED_ARG(sv);
4958 }
4959
4960 U32
4961 Perl_parse_unicode_opts(pTHX_ const char **popt)
4962 {
4963   const char *p = *popt;
4964   U32 opt = 0;
4965
4966   if (*p) {
4967        if (isDIGIT(*p)) {
4968             opt = (U32) atoi(p);
4969             while (isDIGIT(*p))
4970                 p++;
4971             if (*p && *p != '\n' && *p != '\r')
4972                  Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
4973        }
4974        else {
4975             for (; *p; p++) {
4976                  switch (*p) {
4977                  case PERL_UNICODE_STDIN:
4978                       opt |= PERL_UNICODE_STDIN_FLAG;   break;
4979                  case PERL_UNICODE_STDOUT:
4980                       opt |= PERL_UNICODE_STDOUT_FLAG;  break;
4981                  case PERL_UNICODE_STDERR:
4982                       opt |= PERL_UNICODE_STDERR_FLAG;  break;
4983                  case PERL_UNICODE_STD:
4984                       opt |= PERL_UNICODE_STD_FLAG;     break;
4985                  case PERL_UNICODE_IN:
4986                       opt |= PERL_UNICODE_IN_FLAG;      break;
4987                  case PERL_UNICODE_OUT:
4988                       opt |= PERL_UNICODE_OUT_FLAG;     break;
4989                  case PERL_UNICODE_INOUT:
4990                       opt |= PERL_UNICODE_INOUT_FLAG;   break;
4991                  case PERL_UNICODE_LOCALE:
4992                       opt |= PERL_UNICODE_LOCALE_FLAG;  break;
4993                  case PERL_UNICODE_ARGV:
4994                       opt |= PERL_UNICODE_ARGV_FLAG;    break;
4995                  case PERL_UNICODE_UTF8CACHEASSERT:
4996                       opt |= PERL_UNICODE_UTF8CACHEASSERT_FLAG; break;
4997                  default:
4998                       if (*p != '\n' && *p != '\r')
4999                           Perl_croak(aTHX_
5000                                      "Unknown Unicode option letter '%c'", *p);
5001                  }
5002             }
5003        }
5004   }
5005   else
5006        opt = PERL_UNICODE_DEFAULT_FLAGS;
5007
5008   if (opt & ~PERL_UNICODE_ALL_FLAGS)
5009        Perl_croak(aTHX_ "Unknown Unicode option value %"UVuf,
5010                   (UV) (opt & ~PERL_UNICODE_ALL_FLAGS));
5011
5012   *popt = p;
5013
5014   return opt;
5015 }
5016
5017 U32
5018 Perl_seed(pTHX)
5019 {
5020     dVAR;
5021     /*
5022      * This is really just a quick hack which grabs various garbage
5023      * values.  It really should be a real hash algorithm which
5024      * spreads the effect of every input bit onto every output bit,
5025      * if someone who knows about such things would bother to write it.
5026      * Might be a good idea to add that function to CORE as well.
5027      * No numbers below come from careful analysis or anything here,
5028      * except they are primes and SEED_C1 > 1E6 to get a full-width
5029      * value from (tv_sec * SEED_C1 + tv_usec).  The multipliers should
5030      * probably be bigger too.
5031      */
5032 #if RANDBITS > 16
5033 #  define SEED_C1       1000003
5034 #define   SEED_C4       73819
5035 #else
5036 #  define SEED_C1       25747
5037 #define   SEED_C4       20639
5038 #endif
5039 #define   SEED_C2       3
5040 #define   SEED_C3       269
5041 #define   SEED_C5       26107
5042
5043 #ifndef PERL_NO_DEV_RANDOM
5044     int fd;
5045 #endif
5046     U32 u;
5047 #ifdef VMS
5048 #  include <starlet.h>
5049     /* when[] = (low 32 bits, high 32 bits) of time since epoch
5050      * in 100-ns units, typically incremented ever 10 ms.        */
5051     unsigned int when[2];
5052 #else
5053 #  ifdef HAS_GETTIMEOFDAY
5054     struct timeval when;
5055 #  else
5056     Time_t when;
5057 #  endif
5058 #endif
5059
5060 /* This test is an escape hatch, this symbol isn't set by Configure. */
5061 #ifndef PERL_NO_DEV_RANDOM
5062 #ifndef PERL_RANDOM_DEVICE
5063    /* /dev/random isn't used by default because reads from it will block
5064     * if there isn't enough entropy available.  You can compile with
5065     * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
5066     * is enough real entropy to fill the seed. */
5067 #  define PERL_RANDOM_DEVICE "/dev/urandom"
5068 #endif
5069     fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
5070     if (fd != -1) {
5071         if (PerlLIO_read(fd, (void*)&u, sizeof u) != sizeof u)
5072             u = 0;
5073         PerlLIO_close(fd);
5074         if (u)
5075             return u;
5076     }
5077 #endif
5078
5079 #ifdef VMS
5080     _ckvmssts(sys$gettim(when));
5081     u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
5082 #else
5083 #  ifdef HAS_GETTIMEOFDAY
5084     PerlProc_gettimeofday(&when,NULL);
5085     u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
5086 #  else
5087     (void)time(&when);
5088     u = (U32)SEED_C1 * when;
5089 #  endif
5090 #endif
5091     u += SEED_C3 * (U32)PerlProc_getpid();
5092     u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
5093 #ifndef PLAN9           /* XXX Plan9 assembler chokes on this; fix needed  */
5094     u += SEED_C5 * (U32)PTR2UV(&when);
5095 #endif
5096     return u;
5097 }
5098
5099 UV
5100 Perl_get_hash_seed(pTHX)
5101 {
5102     dVAR;
5103      const char *s = PerlEnv_getenv("PERL_HASH_SEED");
5104      UV myseed = 0;
5105
5106      if (s)
5107         while (isSPACE(*s))
5108             s++;
5109      if (s && isDIGIT(*s))
5110           myseed = (UV)Atoul(s);
5111      else
5112 #ifdef USE_HASH_SEED_EXPLICIT
5113      if (s)
5114 #endif
5115      {
5116           /* Compute a random seed */
5117           (void)seedDrand01((Rand_seed_t)seed());
5118           myseed = (UV)(Drand01() * (NV)UV_MAX);
5119 #if RANDBITS < (UVSIZE * 8)
5120           /* Since there are not enough randbits to to reach all
5121            * the bits of a UV, the low bits might need extra
5122            * help.  Sum in another random number that will
5123            * fill in the low bits. */
5124           myseed +=
5125                (UV)(Drand01() * (NV)((1 << ((UVSIZE * 8 - RANDBITS))) - 1));
5126 #endif /* RANDBITS < (UVSIZE * 8) */
5127           if (myseed == 0) { /* Superparanoia. */
5128               myseed = (UV)(Drand01() * (NV)UV_MAX); /* One more chance. */
5129               if (myseed == 0)
5130                   Perl_croak(aTHX_ "Your random numbers are not that random");
5131           }
5132      }
5133      PL_rehash_seed_set = TRUE;
5134
5135      return myseed;
5136 }
5137
5138 #ifdef USE_ITHREADS
5139 bool
5140 Perl_stashpv_hvname_match(pTHX_ const COP *c, const HV *hv)
5141 {
5142     const char * const stashpv = CopSTASHPV(c);
5143     const char * const name = HvNAME_get(hv);
5144     PERL_UNUSED_CONTEXT;
5145
5146     if (stashpv == name)
5147         return TRUE;
5148     if (stashpv && name)
5149         if (strEQ(stashpv, name))
5150             return TRUE;
5151     return FALSE;
5152 }
5153 #endif
5154
5155
5156 #ifdef PERL_GLOBAL_STRUCT
5157
5158 struct perl_vars *
5159 Perl_init_global_struct(pTHX)
5160 {
5161     struct perl_vars *plvarsp = NULL;
5162 #ifdef PERL_GLOBAL_STRUCT
5163 #  define PERL_GLOBAL_STRUCT_INIT
5164 #  include "opcode.h" /* the ppaddr and check */
5165     const IV nppaddr = sizeof(Gppaddr)/sizeof(Perl_ppaddr_t);
5166     const IV ncheck  = sizeof(Gcheck) /sizeof(Perl_check_t);
5167 #  ifdef PERL_GLOBAL_STRUCT_PRIVATE
5168     /* PerlMem_malloc() because can't use even safesysmalloc() this early. */
5169     plvarsp = (struct perl_vars*)PerlMem_malloc(sizeof(struct perl_vars));
5170     if (!plvarsp)
5171         exit(1);
5172 #  else
5173     plvarsp = PL_VarsPtr;
5174 #  endif /* PERL_GLOBAL_STRUCT_PRIVATE */
5175 #  undef PERLVAR
5176 #  undef PERLVARA
5177 #  undef PERLVARI
5178 #  undef PERLVARIC
5179 #  undef PERLVARISC
5180 #  define PERLVAR(var,type) /**/
5181 #  define PERLVARA(var,n,type) /**/
5182 #  define PERLVARI(var,type,init) plvarsp->var = init;
5183 #  define PERLVARIC(var,type,init) plvarsp->var = init;
5184 #  define PERLVARISC(var,init) Copy(init, plvarsp->var, sizeof(init), char);
5185 #  include "perlvars.h"
5186 #  undef PERLVAR
5187 #  undef PERLVARA
5188 #  undef PERLVARI
5189 #  undef PERLVARIC
5190 #  undef PERLVARISC
5191 #  ifdef PERL_GLOBAL_STRUCT
5192     plvarsp->Gppaddr = PerlMem_malloc(nppaddr * sizeof(Perl_ppaddr_t));
5193     if (!plvarsp->Gppaddr)
5194         exit(1);
5195     plvarsp->Gcheck  = PerlMem_malloc(ncheck  * sizeof(Perl_check_t));
5196     if (!plvarsp->Gcheck)
5197         exit(1);
5198     Copy(Gppaddr, plvarsp->Gppaddr, nppaddr, Perl_ppaddr_t);
5199     Copy(Gcheck,  plvarsp->Gcheck,  ncheck,  Perl_check_t);
5200 #  endif
5201 #  ifdef PERL_SET_VARS
5202     PERL_SET_VARS(plvarsp);
5203 #  endif
5204 #  undef PERL_GLOBAL_STRUCT_INIT
5205 #endif
5206     return plvarsp;
5207 }
5208
5209 #endif /* PERL_GLOBAL_STRUCT */
5210
5211 #ifdef PERL_GLOBAL_STRUCT
5212
5213 void
5214 Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp)
5215 {
5216 #ifdef PERL_GLOBAL_STRUCT
5217 #  ifdef PERL_UNSET_VARS
5218     PERL_UNSET_VARS(plvarsp);
5219 #  endif
5220     free(plvarsp->Gppaddr);
5221     free(plvarsp->Gcheck);
5222 #    ifdef PERL_GLOBAL_STRUCT_PRIVATE
5223     free(plvarsp);
5224 #    endif
5225 #endif
5226 }
5227
5228 #endif /* PERL_GLOBAL_STRUCT */
5229
5230 #ifdef PERL_MEM_LOG
5231
5232 /*
5233  * PERL_MEM_LOG: the Perl_mem_log_..() will be compiled.
5234  *
5235  * PERL_MEM_LOG_ENV: if defined, during run time the environment
5236  * variable PERL_MEM_LOG will be consulted, and if the integer value
5237  * of that is true, the logging will happen.  (The default is to
5238  * always log if the PERL_MEM_LOG define was in effect.)
5239  */
5240
5241 /*
5242  * PERL_MEM_LOG_SPRINTF_BUF_SIZE: size of a (stack-allocated) buffer
5243  * the Perl_mem_log_...() will use (either via sprintf or snprintf).
5244  */
5245 #define PERL_MEM_LOG_SPRINTF_BUF_SIZE 128
5246
5247 /*
5248  * PERL_MEM_LOG_FD: the file descriptor the Perl_mem_log_...() will
5249  * log to.  You can also define in compile time PERL_MEM_LOG_ENV_FD,
5250  * in which case the environment variable PERL_MEM_LOG_FD will be
5251  * consulted for the file descriptor number to use.
5252  */
5253 #ifndef PERL_MEM_LOG_FD
5254 #  define PERL_MEM_LOG_FD 2 /* If STDERR is too boring for you. */
5255 #endif
5256
5257 Malloc_t
5258 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)
5259 {
5260 #ifdef PERL_MEM_LOG_STDERR
5261 # if defined(PERL_MEM_LOG_ENV) || defined(PERL_MEM_LOG_ENV_FD)
5262     char *s;
5263 # endif
5264 # ifdef PERL_MEM_LOG_ENV
5265     s = getenv("PERL_MEM_LOG");
5266     if (s ? atoi(s) : 0)
5267 # endif
5268     {
5269         /* We can't use SVs or PerlIO for obvious reasons,
5270          * so we'll use stdio and low-level IO instead. */
5271         char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
5272 # ifdef PERL_MEM_LOG_TIMESTAMP
5273         struct timeval tv;
5274 #   ifdef HAS_GETTIMEOFDAY
5275         gettimeofday(&tv, 0);
5276 #   endif
5277         /* If there are other OS specific ways of hires time than
5278          * gettimeofday() (see ext/Time/HiRes), the easiest way is
5279          * probably that they would be used to fill in the struct
5280          * timeval. */
5281 # endif
5282         {
5283             const STRLEN len =
5284                 my_snprintf(buf,
5285                             sizeof(buf),
5286 #  ifdef PERL_MEM_LOG_TIMESTAMP
5287                             "%10d.%06d: "
5288 # endif
5289                             "alloc: %s:%d:%s: %"IVdf" %"UVuf
5290                             " %s = %"IVdf": %"UVxf"\n",
5291 #  ifdef PERL_MEM_LOG_TIMESTAMP
5292                             (int)tv.tv_sec, (int)tv.tv_usec,
5293 # endif
5294                             filename, linenumber, funcname, n, typesize,
5295                             typename, n * typesize, PTR2UV(newalloc));
5296 # ifdef PERL_MEM_LOG_ENV_FD
5297             s = PerlEnv_getenv("PERL_MEM_LOG_FD");
5298             PerlLIO_write(s ? atoi(s) : PERL_MEM_LOG_FD, buf, len);
5299 # else
5300             PerlLIO_write(PERL_MEM_LOG_FD, buf, len);
5301 #endif
5302         }
5303     }
5304 #endif
5305     return newalloc;
5306 }
5307
5308 Malloc_t
5309 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)
5310 {
5311 #ifdef PERL_MEM_LOG_STDERR
5312 # if defined(PERL_MEM_LOG_ENV) || defined(PERL_MEM_LOG_ENV_FD)
5313     char *s;
5314 # endif
5315 # ifdef PERL_MEM_LOG_ENV
5316     s = PerlEnv_getenv("PERL_MEM_LOG");
5317     if (s ? atoi(s) : 0)
5318 # endif
5319     {
5320         /* We can't use SVs or PerlIO for obvious reasons,
5321          * so we'll use stdio and low-level IO instead. */
5322         char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
5323 #  ifdef PERL_MEM_LOG_TIMESTAMP
5324         struct timeval tv;
5325         gettimeofday(&tv, 0);
5326 # endif
5327         {
5328             const STRLEN len =
5329                 my_snprintf(buf,
5330                             sizeof(buf),
5331 #  ifdef PERL_MEM_LOG_TIMESTAMP
5332                             "%10d.%06d: "
5333 # endif
5334                             "realloc: %s:%d:%s: %"IVdf" %"UVuf
5335                             " %s = %"IVdf": %"UVxf" -> %"UVxf"\n",
5336 #  ifdef PERL_MEM_LOG_TIMESTAMP
5337                             (int)tv.tv_sec, (int)tv.tv_usec,
5338 # endif
5339                             filename, linenumber, funcname, n, typesize,
5340                             typename, n * typesize, PTR2UV(oldalloc),
5341                             PTR2UV(newalloc));
5342 # ifdef PERL_MEM_LOG_ENV_FD
5343             s = PerlEnv_getenv("PERL_MEM_LOG_FD");
5344             PerlLIO_write(s ? atoi(s) : PERL_MEM_LOG_FD, buf, len);
5345 # else
5346             PerlLIO_write(PERL_MEM_LOG_FD, buf, len);
5347 # endif
5348         }
5349     }
5350 #endif
5351     return newalloc;
5352 }
5353
5354 Malloc_t
5355 Perl_mem_log_free(Malloc_t oldalloc, const char *filename, const int linenumber, const char *funcname)
5356 {
5357 #ifdef PERL_MEM_LOG_STDERR
5358 # if defined(PERL_MEM_LOG_ENV) || defined(PERL_MEM_LOG_ENV_FD)
5359     char *s;
5360 # endif
5361 # ifdef PERL_MEM_LOG_ENV
5362     s = PerlEnv_getenv("PERL_MEM_LOG");
5363     if (s ? atoi(s) : 0)
5364 # endif
5365     {
5366         /* We can't use SVs or PerlIO for obvious reasons,
5367          * so we'll use stdio and low-level IO instead. */
5368         char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
5369 #  ifdef PERL_MEM_LOG_TIMESTAMP
5370         struct timeval tv;
5371         gettimeofday(&tv, 0);
5372 # endif
5373         {
5374             const STRLEN len =
5375                 my_snprintf(buf,
5376                             sizeof(buf),
5377 #  ifdef PERL_MEM_LOG_TIMESTAMP
5378                             "%10d.%06d: "
5379 # endif
5380                             "free: %s:%d:%s: %"UVxf"\n",
5381 #  ifdef PERL_MEM_LOG_TIMESTAMP
5382                             (int)tv.tv_sec, (int)tv.tv_usec,
5383 # endif
5384                             filename, linenumber, funcname,
5385                             PTR2UV(oldalloc));
5386 # ifdef PERL_MEM_LOG_ENV_FD
5387             s = PerlEnv_getenv("PERL_MEM_LOG_FD");
5388             PerlLIO_write(s ? atoi(s) : PERL_MEM_LOG_FD, buf, len);
5389 # else
5390             PerlLIO_write(PERL_MEM_LOG_FD, buf, len);
5391 # endif
5392         }
5393     }
5394 #endif
5395     return oldalloc;
5396 }
5397
5398 #endif /* PERL_MEM_LOG */
5399
5400 /*
5401 =for apidoc my_sprintf
5402
5403 The C library C<sprintf>, wrapped if necessary, to ensure that it will return
5404 the length of the string written to the buffer. Only rare pre-ANSI systems
5405 need the wrapper function - usually this is a direct call to C<sprintf>.
5406
5407 =cut
5408 */
5409 #ifndef SPRINTF_RETURNS_STRLEN
5410 int
5411 Perl_my_sprintf(char *buffer, const char* pat, ...)
5412 {
5413     va_list args;
5414     va_start(args, pat);
5415     vsprintf(buffer, pat, args);
5416     va_end(args);
5417     return strlen(buffer);
5418 }
5419 #endif
5420
5421 /*
5422 =for apidoc my_snprintf
5423
5424 The C library C<snprintf> functionality, if available and
5425 standards-compliant (uses C<vsnprintf>, actually).  However, if the
5426 C<vsnprintf> is not available, will unfortunately use the unsafe
5427 C<vsprintf> which can overrun the buffer (there is an overrun check,
5428 but that may be too late).  Consider using C<sv_vcatpvf> instead, or
5429 getting C<vsnprintf>.
5430
5431 =cut
5432 */
5433 int
5434 Perl_my_snprintf(char *buffer, const Size_t len, const char *format, ...)
5435 {
5436     dTHX;
5437     int retval;
5438     va_list ap;
5439     va_start(ap, format);
5440 #ifdef HAS_VSNPRINTF
5441     retval = vsnprintf(buffer, len, format, ap);
5442 #else
5443     retval = vsprintf(buffer, format, ap);
5444 #endif
5445     va_end(ap);
5446     /* vsnprintf() shows failure with >= len, vsprintf() with < 0 */
5447     if (retval < 0 || (len > 0 && (Size_t)retval >= len))
5448         Perl_croak(aTHX_ "panic: my_snprintf buffer overflow");
5449     return retval;
5450 }
5451
5452 /*
5453 =for apidoc my_vsnprintf
5454
5455 The C library C<vsnprintf> if available and standards-compliant.
5456 However, if if the C<vsnprintf> is not available, will unfortunately
5457 use the unsafe C<vsprintf> which can overrun the buffer (there is an
5458 overrun check, but that may be too late).  Consider using
5459 C<sv_vcatpvf> instead, or getting C<vsnprintf>.
5460
5461 =cut
5462 */
5463 int
5464 Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap)
5465 {
5466     dTHX;
5467     int retval;
5468 #ifdef NEED_VA_COPY
5469     va_list apc;
5470     Perl_va_copy(ap, apc);
5471 # ifdef HAS_VSNPRINTF
5472     retval = vsnprintf(buffer, len, format, apc);
5473 # else
5474     retval = vsprintf(buffer, format, apc);
5475 # endif
5476 #else
5477 # ifdef HAS_VSNPRINTF
5478     retval = vsnprintf(buffer, len, format, ap);
5479 # else
5480     retval = vsprintf(buffer, format, ap);
5481 # endif
5482 #endif /* #ifdef NEED_VA_COPY */
5483     /* vsnprintf() shows failure with >= len, vsprintf() with < 0 */
5484     if (retval < 0 || (len > 0 && (Size_t)retval >= len))
5485         Perl_croak(aTHX_ "panic: my_vsnprintf buffer overflow");
5486     return retval;
5487 }
5488
5489 void
5490 Perl_my_clearenv(pTHX)
5491 {
5492     dVAR;
5493 #if ! defined(PERL_MICRO)
5494 #  if defined(PERL_IMPLICIT_SYS) || defined(WIN32)
5495     PerlEnv_clearenv();
5496 #  else /* ! (PERL_IMPLICIT_SYS || WIN32) */
5497 #    if defined(USE_ENVIRON_ARRAY)
5498 #      if defined(USE_ITHREADS)
5499     /* only the parent thread can clobber the process environment */
5500     if (PL_curinterp == aTHX)
5501 #      endif /* USE_ITHREADS */
5502     {
5503 #      if ! defined(PERL_USE_SAFE_PUTENV)
5504     if ( !PL_use_safe_putenv) {
5505       I32 i;
5506       if (environ == PL_origenviron)
5507         environ = (char**)safesysmalloc(sizeof(char*));
5508       else
5509         for (i = 0; environ[i]; i++)
5510           (void)safesysfree(environ[i]);
5511     }
5512     environ[0] = NULL;
5513 #      else /* PERL_USE_SAFE_PUTENV */
5514 #        if defined(HAS_CLEARENV)
5515     (void)clearenv();
5516 #        elif defined(HAS_UNSETENV)
5517     int bsiz = 80; /* Most envvar names will be shorter than this. */
5518     int bufsiz = bsiz * sizeof(char); /* sizeof(char) paranoid? */
5519     char *buf = (char*)safesysmalloc(bufsiz);
5520     while (*environ != NULL) {
5521       char *e = strchr(*environ, '=');
5522       int l = e ? e - *environ : (int)strlen(*environ);
5523       if (bsiz < l + 1) {
5524         (void)safesysfree(buf);
5525         bsiz = l + 1; /* + 1 for the \0. */
5526         buf = (char*)safesysmalloc(bufsiz);
5527       }
5528       my_strlcpy(buf, *environ, l + 1);
5529       (void)unsetenv(buf);
5530     }
5531     (void)safesysfree(buf);
5532 #        else /* ! HAS_CLEARENV && ! HAS_UNSETENV */
5533     /* Just null environ and accept the leakage. */
5534     *environ = NULL;
5535 #        endif /* HAS_CLEARENV || HAS_UNSETENV */
5536 #      endif /* ! PERL_USE_SAFE_PUTENV */
5537     }
5538 #    endif /* USE_ENVIRON_ARRAY */
5539 #  endif /* PERL_IMPLICIT_SYS || WIN32 */
5540 #endif /* PERL_MICRO */
5541 }
5542
5543 #ifdef PERL_IMPLICIT_CONTEXT
5544
5545 /* Implements the MY_CXT_INIT macro. The first time a module is loaded,
5546 the global PL_my_cxt_index is incremented, and that value is assigned to
5547 that module's static my_cxt_index (who's address is passed as an arg).
5548 Then, for each interpreter this function is called for, it makes sure a
5549 void* slot is available to hang the static data off, by allocating or
5550 extending the interpreter's PL_my_cxt_list array */
5551
5552 #ifndef PERL_GLOBAL_STRUCT_PRIVATE
5553 void *
5554 Perl_my_cxt_init(pTHX_ int *index, size_t size)
5555 {
5556     dVAR;
5557     void *p;
5558     if (*index == -1) {
5559         /* this module hasn't been allocated an index yet */
5560         MUTEX_LOCK(&PL_my_ctx_mutex);
5561         *index = PL_my_cxt_index++;
5562         MUTEX_UNLOCK(&PL_my_ctx_mutex);
5563     }
5564
5565     /* make sure the array is big enough */
5566     if (PL_my_cxt_size <= *index) {
5567         if (PL_my_cxt_size) {
5568             while (PL_my_cxt_size <= *index)
5569                 PL_my_cxt_size *= 2;
5570             Renew(PL_my_cxt_list, PL_my_cxt_size, void *);
5571         }
5572         else {
5573             PL_my_cxt_size = 16;
5574             Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
5575         }
5576     }
5577     /* newSV() allocates one more than needed */
5578     p = (void*)SvPVX(newSV(size-1));
5579     PL_my_cxt_list[*index] = p;
5580     Zero(p, size, char);
5581     return p;
5582 }
5583
5584 #else /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
5585
5586 int
5587 Perl_my_cxt_index(pTHX_ const char *my_cxt_key)
5588 {
5589     dVAR;
5590     int index;
5591
5592     for (index = 0; index < PL_my_cxt_index; index++) {
5593         const char *key = PL_my_cxt_keys[index];
5594         /* try direct pointer compare first - there are chances to success,
5595          * and it's much faster.
5596          */
5597         if ((key == my_cxt_key) || strEQ(key, my_cxt_key))
5598             return index;
5599     }
5600     return -1;
5601 }
5602
5603 void *
5604 Perl_my_cxt_init(pTHX_ const char *my_cxt_key, size_t size)
5605 {
5606     dVAR;
5607     void *p;
5608     int index;
5609
5610     index = Perl_my_cxt_index(aTHX_ my_cxt_key);
5611     if (index == -1) {
5612         /* this module hasn't been allocated an index yet */
5613         MUTEX_LOCK(&PL_my_ctx_mutex);
5614         index = PL_my_cxt_index++;
5615         MUTEX_UNLOCK(&PL_my_ctx_mutex);
5616     }
5617
5618     /* make sure the array is big enough */
5619     if (PL_my_cxt_size <= index) {
5620         int old_size = PL_my_cxt_size;
5621         int i;
5622         if (PL_my_cxt_size) {
5623             while (PL_my_cxt_size <= index)
5624                 PL_my_cxt_size *= 2;
5625             Renew(PL_my_cxt_list, PL_my_cxt_size, void *);
5626             Renew(PL_my_cxt_keys, PL_my_cxt_size, const char *);
5627         }
5628         else {
5629             PL_my_cxt_size = 16;
5630             Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
5631             Newx(PL_my_cxt_keys, PL_my_cxt_size, const char *);
5632         }
5633         for (i = old_size; i < PL_my_cxt_size; i++) {
5634             PL_my_cxt_keys[i] = 0;
5635             PL_my_cxt_list[i] = 0;
5636         }
5637     }
5638     PL_my_cxt_keys[index] = my_cxt_key;
5639     /* newSV() allocates one more than needed */
5640     p = (void*)SvPVX(newSV(size-1));
5641     PL_my_cxt_list[index] = p;
5642     Zero(p, size, char);
5643     return p;
5644 }
5645 #endif /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
5646 #endif /* PERL_IMPLICIT_CONTEXT */
5647
5648 #ifndef HAS_STRLCAT
5649 Size_t
5650 Perl_my_strlcat(char *dst, const char *src, Size_t size)
5651 {
5652     Size_t used, length, copy;
5653
5654     used = strlen(dst);
5655     length = strlen(src);
5656     if (size > 0 && used < size - 1) {
5657         copy = (length >= size - used) ? size - used - 1 : length;
5658         memcpy(dst + used, src, copy);
5659         dst[used + copy] = '\0';
5660     }
5661     return used + length;
5662 }
5663 #endif
5664
5665 #ifndef HAS_STRLCPY
5666 Size_t
5667 Perl_my_strlcpy(char *dst, const char *src, Size_t size)
5668 {
5669     Size_t length, copy;
5670
5671     length = strlen(src);
5672     if (size > 0) {
5673         copy = (length >= size) ? size - 1 : length;
5674         memcpy(dst, src, copy);
5675         dst[copy] = '\0';
5676     }
5677     return length;
5678 }
5679 #endif
5680
5681 #if defined(_MSC_VER) && (_MSC_VER >= 1300) && (_MSC_VER < 1400) && (WINVER < 0x0500)
5682 /* VC7 or 7.1, building with pre-VC7 runtime libraries. */
5683 long _ftol( double ); /* Defined by VC6 C libs. */
5684 long _ftol2( double dblSource ) { return _ftol( dblSource ); }
5685 #endif
5686
5687 void
5688 Perl_get_db_sub(pTHX_ SV **svp, CV *cv)
5689 {
5690     dVAR;
5691     SV * const dbsv = GvSVn(PL_DBsub);
5692     /* We do not care about using sv to call CV;
5693      * it's for informational purposes only.
5694      */
5695
5696     save_item(dbsv);
5697     if (!PERLDB_SUB_NN) {
5698         GV * const gv = CvGV(cv);
5699
5700         if ( svp && ((CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
5701              || strEQ(GvNAME(gv), "END")
5702              || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
5703                  !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv) )))) {
5704             /* Use GV from the stack as a fallback. */
5705             /* GV is potentially non-unique, or contain different CV. */
5706             SV * const tmp = newRV((SV*)cv);
5707             sv_setsv(dbsv, tmp);
5708             SvREFCNT_dec(tmp);
5709         }
5710         else {
5711             gv_efullname3(dbsv, gv, NULL);
5712         }
5713     }
5714     else {
5715         const int type = SvTYPE(dbsv);
5716         if (type < SVt_PVIV && type != SVt_IV)
5717             sv_upgrade(dbsv, SVt_PVIV);
5718         (void)SvIOK_on(dbsv);
5719         SvIV_set(dbsv, PTR2IV(cv));     /* Do it the quickest way  */
5720     }
5721 }
5722
5723 /*
5724  * Local variables:
5725  * c-indentation-style: bsd
5726  * c-basic-offset: 4
5727  * indent-tabs-mode: t
5728  * End:
5729  *
5730  * ex: set ts=8 sts=4 sw=4 noet:
5731  */