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