util.c

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