util.c

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