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