util.c

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