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