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