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