util.c

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