util.c

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