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