util.c

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