util.c

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