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