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