util.c

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