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