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