util.c

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