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