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