This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Eliminate Perl_my_swabn(), as it is now unused.
[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 /*
2164  * Little-endian byte order functions - 'v' for 'VAX', or 'reVerse'.
2165  * If these functions are defined,
2166  * the BYTEORDER is neither 0x1234 nor 0x4321.
2167  * However, this is not assumed.
2168  * -DWS
2169  */
2170
2171 #define HTOLE(name,type)                                        \
2172         type                                                    \
2173         name (type n)                                           \
2174         {                                                       \
2175             union {                                             \
2176                 type value;                                     \
2177                 char c[sizeof(type)];                           \
2178             } u;                                                \
2179             U32 i;                                              \
2180             U32 s = 0;                                          \
2181             for (i = 0; i < sizeof(u.c); i++, s += 8) {         \
2182                 u.c[i] = (n >> s) & 0xFF;                       \
2183             }                                                   \
2184             return u.value;                                     \
2185         }
2186
2187 #define LETOH(name,type)                                        \
2188         type                                                    \
2189         name (type n)                                           \
2190         {                                                       \
2191             union {                                             \
2192                 type value;                                     \
2193                 char c[sizeof(type)];                           \
2194             } u;                                                \
2195             U32 i;                                              \
2196             U32 s = 0;                                          \
2197             u.value = n;                                        \
2198             n = 0;                                              \
2199             for (i = 0; i < sizeof(u.c); i++, s += 8) {         \
2200                 n |= ((type)(u.c[i] & 0xFF)) << s;              \
2201             }                                                   \
2202             return n;                                           \
2203         }
2204
2205 /*
2206  * Big-endian byte order functions.
2207  */
2208
2209 #define HTOBE(name,type)                                        \
2210         type                                                    \
2211         name (type n)                                           \
2212         {                                                       \
2213             union {                                             \
2214                 type value;                                     \
2215                 char c[sizeof(type)];                           \
2216             } u;                                                \
2217             U32 i;                                              \
2218             U32 s = 8*(sizeof(u.c)-1);                          \
2219             for (i = 0; i < sizeof(u.c); i++, s -= 8) {         \
2220                 u.c[i] = (n >> s) & 0xFF;                       \
2221             }                                                   \
2222             return u.value;                                     \
2223         }
2224
2225 #define BETOH(name,type)                                        \
2226         type                                                    \
2227         name (type n)                                           \
2228         {                                                       \
2229             union {                                             \
2230                 type value;                                     \
2231                 char c[sizeof(type)];                           \
2232             } u;                                                \
2233             U32 i;                                              \
2234             U32 s = 8*(sizeof(u.c)-1);                          \
2235             u.value = n;                                        \
2236             n = 0;                                              \
2237             for (i = 0; i < sizeof(u.c); i++, s -= 8) {         \
2238                 n |= ((type)(u.c[i] & 0xFF)) << s;              \
2239             }                                                   \
2240             return n;                                           \
2241         }
2242
2243 #if !defined(htovs)
2244 HTOLE(htovs,short)
2245 #endif
2246 #if !defined(htovl)
2247 HTOLE(htovl,long)
2248 #endif
2249 #if !defined(vtohs)
2250 LETOH(vtohs,short)
2251 #endif
2252 #if !defined(vtohl)
2253 LETOH(vtohl,long)
2254 #endif
2255
2256 PerlIO *
2257 Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
2258 {
2259 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(NETWARE) && !defined(__LIBCATAMOUNT__)
2260     dVAR;
2261     int p[2];
2262     I32 This, that;
2263     Pid_t pid;
2264     SV *sv;
2265     I32 did_pipes = 0;
2266     int pp[2];
2267
2268     PERL_ARGS_ASSERT_MY_POPEN_LIST;
2269
2270     PERL_FLUSHALL_FOR_CHILD;
2271     This = (*mode == 'w');
2272     that = !This;
2273     if (TAINTING_get) {
2274         taint_env();
2275         taint_proper("Insecure %s%s", "EXEC");
2276     }
2277     if (PerlProc_pipe(p) < 0)
2278         return NULL;
2279     /* Try for another pipe pair for error return */
2280     if (PerlProc_pipe(pp) >= 0)
2281         did_pipes = 1;
2282     while ((pid = PerlProc_fork()) < 0) {
2283         if (errno != EAGAIN) {
2284             PerlLIO_close(p[This]);
2285             PerlLIO_close(p[that]);
2286             if (did_pipes) {
2287                 PerlLIO_close(pp[0]);
2288                 PerlLIO_close(pp[1]);
2289             }
2290             return NULL;
2291         }
2292         Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
2293         sleep(5);
2294     }
2295     if (pid == 0) {
2296         /* Child */
2297 #undef THIS
2298 #undef THAT
2299 #define THIS that
2300 #define THAT This
2301         /* Close parent's end of error status pipe (if any) */
2302         if (did_pipes) {
2303             PerlLIO_close(pp[0]);
2304 #if defined(HAS_FCNTL) && defined(F_SETFD)
2305             /* Close error pipe automatically if exec works */
2306             fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2307 #endif
2308         }
2309         /* Now dup our end of _the_ pipe to right position */
2310         if (p[THIS] != (*mode == 'r')) {
2311             PerlLIO_dup2(p[THIS], *mode == 'r');
2312             PerlLIO_close(p[THIS]);
2313             if (p[THAT] != (*mode == 'r'))      /* if dup2() didn't close it */
2314                 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
2315         }
2316         else
2317             PerlLIO_close(p[THAT]);     /* close parent's end of _the_ pipe */
2318 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2319         /* No automatic close - do it by hand */
2320 #  ifndef NOFILE
2321 #  define NOFILE 20
2322 #  endif
2323         {
2324             int fd;
2325
2326             for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) {
2327                 if (fd != pp[1])
2328                     PerlLIO_close(fd);
2329             }
2330         }
2331 #endif
2332         do_aexec5(NULL, args-1, args-1+n, pp[1], did_pipes);
2333         PerlProc__exit(1);
2334 #undef THIS
2335 #undef THAT
2336     }
2337     /* Parent */
2338     do_execfree();      /* free any memory malloced by child on fork */
2339     if (did_pipes)
2340         PerlLIO_close(pp[1]);
2341     /* Keep the lower of the two fd numbers */
2342     if (p[that] < p[This]) {
2343         PerlLIO_dup2(p[This], p[that]);
2344         PerlLIO_close(p[This]);
2345         p[This] = p[that];
2346     }
2347     else
2348         PerlLIO_close(p[that]);         /* close child's end of pipe */
2349
2350     sv = *av_fetch(PL_fdpid,p[This],TRUE);
2351     SvUPGRADE(sv,SVt_IV);
2352     SvIV_set(sv, pid);
2353     PL_forkprocess = pid;
2354     /* If we managed to get status pipe check for exec fail */
2355     if (did_pipes && pid > 0) {
2356         int errkid;
2357         unsigned n = 0;
2358         SSize_t n1;
2359
2360         while (n < sizeof(int)) {
2361             n1 = PerlLIO_read(pp[0],
2362                               (void*)(((char*)&errkid)+n),
2363                               (sizeof(int)) - n);
2364             if (n1 <= 0)
2365                 break;
2366             n += n1;
2367         }
2368         PerlLIO_close(pp[0]);
2369         did_pipes = 0;
2370         if (n) {                        /* Error */
2371             int pid2, status;
2372             PerlLIO_close(p[This]);
2373             if (n != sizeof(int))
2374                 Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", n);
2375             do {
2376                 pid2 = wait4pid(pid, &status, 0);
2377             } while (pid2 == -1 && errno == EINTR);
2378             errno = errkid;             /* Propagate errno from kid */
2379             return NULL;
2380         }
2381     }
2382     if (did_pipes)
2383          PerlLIO_close(pp[0]);
2384     return PerlIO_fdopen(p[This], mode);
2385 #else
2386 #  ifdef OS2    /* Same, without fork()ing and all extra overhead... */
2387     return my_syspopen4(aTHX_ NULL, mode, n, args);
2388 #  else
2389     Perl_croak(aTHX_ "List form of piped open not implemented");
2390     return (PerlIO *) NULL;
2391 #  endif
2392 #endif
2393 }
2394
2395     /* VMS' my_popen() is in VMS.c, same with OS/2. */
2396 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__LIBCATAMOUNT__)
2397 PerlIO *
2398 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2399 {
2400     dVAR;
2401     int p[2];
2402     I32 This, that;
2403     Pid_t pid;
2404     SV *sv;
2405     const I32 doexec = !(*cmd == '-' && cmd[1] == '\0');
2406     I32 did_pipes = 0;
2407     int pp[2];
2408
2409     PERL_ARGS_ASSERT_MY_POPEN;
2410
2411     PERL_FLUSHALL_FOR_CHILD;
2412 #ifdef OS2
2413     if (doexec) {
2414         return my_syspopen(aTHX_ cmd,mode);
2415     }
2416 #endif
2417     This = (*mode == 'w');
2418     that = !This;
2419     if (doexec && TAINTING_get) {
2420         taint_env();
2421         taint_proper("Insecure %s%s", "EXEC");
2422     }
2423     if (PerlProc_pipe(p) < 0)
2424         return NULL;
2425     if (doexec && PerlProc_pipe(pp) >= 0)
2426         did_pipes = 1;
2427     while ((pid = PerlProc_fork()) < 0) {
2428         if (errno != EAGAIN) {
2429             PerlLIO_close(p[This]);
2430             PerlLIO_close(p[that]);
2431             if (did_pipes) {
2432                 PerlLIO_close(pp[0]);
2433                 PerlLIO_close(pp[1]);
2434             }
2435             if (!doexec)
2436                 Perl_croak(aTHX_ "Can't fork: %s", Strerror(errno));
2437             return NULL;
2438         }
2439         Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
2440         sleep(5);
2441     }
2442     if (pid == 0) {
2443
2444 #undef THIS
2445 #undef THAT
2446 #define THIS that
2447 #define THAT This
2448         if (did_pipes) {
2449             PerlLIO_close(pp[0]);
2450 #if defined(HAS_FCNTL) && defined(F_SETFD)
2451             fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2452 #endif
2453         }
2454         if (p[THIS] != (*mode == 'r')) {
2455             PerlLIO_dup2(p[THIS], *mode == 'r');
2456             PerlLIO_close(p[THIS]);
2457             if (p[THAT] != (*mode == 'r'))      /* if dup2() didn't close it */
2458                 PerlLIO_close(p[THAT]);
2459         }
2460         else
2461             PerlLIO_close(p[THAT]);
2462 #ifndef OS2
2463         if (doexec) {
2464 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2465 #ifndef NOFILE
2466 #define NOFILE 20
2467 #endif
2468             {
2469                 int fd;
2470
2471                 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
2472                     if (fd != pp[1])
2473                         PerlLIO_close(fd);
2474             }
2475 #endif
2476             /* may or may not use the shell */
2477             do_exec3(cmd, pp[1], did_pipes);
2478             PerlProc__exit(1);
2479         }
2480 #endif  /* defined OS2 */
2481
2482 #ifdef PERLIO_USING_CRLF
2483    /* Since we circumvent IO layers when we manipulate low-level
2484       filedescriptors directly, need to manually switch to the
2485       default, binary, low-level mode; see PerlIOBuf_open(). */
2486    PerlLIO_setmode((*mode == 'r'), O_BINARY);
2487 #endif 
2488         PL_forkprocess = 0;
2489 #ifdef PERL_USES_PL_PIDSTATUS
2490         hv_clear(PL_pidstatus); /* we have no children */
2491 #endif
2492         return NULL;
2493 #undef THIS
2494 #undef THAT
2495     }
2496     do_execfree();      /* free any memory malloced by child on vfork */
2497     if (did_pipes)
2498         PerlLIO_close(pp[1]);
2499     if (p[that] < p[This]) {
2500         PerlLIO_dup2(p[This], p[that]);
2501         PerlLIO_close(p[This]);
2502         p[This] = p[that];
2503     }
2504     else
2505         PerlLIO_close(p[that]);
2506
2507     sv = *av_fetch(PL_fdpid,p[This],TRUE);
2508     SvUPGRADE(sv,SVt_IV);
2509     SvIV_set(sv, pid);
2510     PL_forkprocess = pid;
2511     if (did_pipes && pid > 0) {
2512         int errkid;
2513         unsigned n = 0;
2514         SSize_t n1;
2515
2516         while (n < sizeof(int)) {
2517             n1 = PerlLIO_read(pp[0],
2518                               (void*)(((char*)&errkid)+n),
2519                               (sizeof(int)) - n);
2520             if (n1 <= 0)
2521                 break;
2522             n += n1;
2523         }
2524         PerlLIO_close(pp[0]);
2525         did_pipes = 0;
2526         if (n) {                        /* Error */
2527             int pid2, status;
2528             PerlLIO_close(p[This]);
2529             if (n != sizeof(int))
2530                 Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", n);
2531             do {
2532                 pid2 = wait4pid(pid, &status, 0);
2533             } while (pid2 == -1 && errno == EINTR);
2534             errno = errkid;             /* Propagate errno from kid */
2535             return NULL;
2536         }
2537     }
2538     if (did_pipes)
2539          PerlLIO_close(pp[0]);
2540     return PerlIO_fdopen(p[This], mode);
2541 }
2542 #else
2543 #if defined(DJGPP)
2544 FILE *djgpp_popen();
2545 PerlIO *
2546 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2547 {
2548     PERL_FLUSHALL_FOR_CHILD;
2549     /* Call system's popen() to get a FILE *, then import it.
2550        used 0 for 2nd parameter to PerlIO_importFILE;
2551        apparently not used
2552     */
2553     return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
2554 }
2555 #else
2556 #if defined(__LIBCATAMOUNT__)
2557 PerlIO *
2558 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2559 {
2560     return NULL;
2561 }
2562 #endif
2563 #endif
2564
2565 #endif /* !DOSISH */
2566
2567 /* this is called in parent before the fork() */
2568 void
2569 Perl_atfork_lock(void)
2570 {
2571    dVAR;
2572 #if defined(USE_ITHREADS)
2573     /* locks must be held in locking order (if any) */
2574 #  ifdef USE_PERLIO
2575     MUTEX_LOCK(&PL_perlio_mutex);
2576 #  endif
2577 #  ifdef MYMALLOC
2578     MUTEX_LOCK(&PL_malloc_mutex);
2579 #  endif
2580     OP_REFCNT_LOCK;
2581 #endif
2582 }
2583
2584 /* this is called in both parent and child after the fork() */
2585 void
2586 Perl_atfork_unlock(void)
2587 {
2588     dVAR;
2589 #if defined(USE_ITHREADS)
2590     /* locks must be released in same order as in atfork_lock() */
2591 #  ifdef USE_PERLIO
2592     MUTEX_UNLOCK(&PL_perlio_mutex);
2593 #  endif
2594 #  ifdef MYMALLOC
2595     MUTEX_UNLOCK(&PL_malloc_mutex);
2596 #  endif
2597     OP_REFCNT_UNLOCK;
2598 #endif
2599 }
2600
2601 Pid_t
2602 Perl_my_fork(void)
2603 {
2604 #if defined(HAS_FORK)
2605     Pid_t pid;
2606 #if defined(USE_ITHREADS) && !defined(HAS_PTHREAD_ATFORK)
2607     atfork_lock();
2608     pid = fork();
2609     atfork_unlock();
2610 #else
2611     /* atfork_lock() and atfork_unlock() are installed as pthread_atfork()
2612      * handlers elsewhere in the code */
2613     pid = fork();
2614 #endif
2615     return pid;
2616 #else
2617     /* this "canna happen" since nothing should be calling here if !HAS_FORK */
2618     Perl_croak_nocontext("fork() not available");
2619     return 0;
2620 #endif /* HAS_FORK */
2621 }
2622
2623 #ifdef DUMP_FDS
2624 void
2625 Perl_dump_fds(pTHX_ const char *const s)
2626 {
2627     int fd;
2628     Stat_t tmpstatbuf;
2629
2630     PERL_ARGS_ASSERT_DUMP_FDS;
2631
2632     PerlIO_printf(Perl_debug_log,"%s", s);
2633     for (fd = 0; fd < 32; fd++) {
2634         if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0)
2635             PerlIO_printf(Perl_debug_log," %d",fd);
2636     }
2637     PerlIO_printf(Perl_debug_log,"\n");
2638     return;
2639 }
2640 #endif  /* DUMP_FDS */
2641
2642 #ifndef HAS_DUP2
2643 int
2644 dup2(int oldfd, int newfd)
2645 {
2646 #if defined(HAS_FCNTL) && defined(F_DUPFD)
2647     if (oldfd == newfd)
2648         return oldfd;
2649     PerlLIO_close(newfd);
2650     return fcntl(oldfd, F_DUPFD, newfd);
2651 #else
2652 #define DUP2_MAX_FDS 256
2653     int fdtmp[DUP2_MAX_FDS];
2654     I32 fdx = 0;
2655     int fd;
2656
2657     if (oldfd == newfd)
2658         return oldfd;
2659     PerlLIO_close(newfd);
2660     /* good enough for low fd's... */
2661     while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
2662         if (fdx >= DUP2_MAX_FDS) {
2663             PerlLIO_close(fd);
2664             fd = -1;
2665             break;
2666         }
2667         fdtmp[fdx++] = fd;
2668     }
2669     while (fdx > 0)
2670         PerlLIO_close(fdtmp[--fdx]);
2671     return fd;
2672 #endif
2673 }
2674 #endif
2675
2676 #ifndef PERL_MICRO
2677 #ifdef HAS_SIGACTION
2678
2679 Sighandler_t
2680 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2681 {
2682     dVAR;
2683     struct sigaction act, oact;
2684
2685 #ifdef USE_ITHREADS
2686     /* only "parent" interpreter can diddle signals */
2687     if (PL_curinterp != aTHX)
2688         return (Sighandler_t) SIG_ERR;
2689 #endif
2690
2691     act.sa_handler = (void(*)(int))handler;
2692     sigemptyset(&act.sa_mask);
2693     act.sa_flags = 0;
2694 #ifdef SA_RESTART
2695     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2696         act.sa_flags |= SA_RESTART;     /* SVR4, 4.3+BSD */
2697 #endif
2698 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2699     if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
2700         act.sa_flags |= SA_NOCLDWAIT;
2701 #endif
2702     if (sigaction(signo, &act, &oact) == -1)
2703         return (Sighandler_t) SIG_ERR;
2704     else
2705         return (Sighandler_t) oact.sa_handler;
2706 }
2707
2708 Sighandler_t
2709 Perl_rsignal_state(pTHX_ int signo)
2710 {
2711     struct sigaction oact;
2712     PERL_UNUSED_CONTEXT;
2713
2714     if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
2715         return (Sighandler_t) SIG_ERR;
2716     else
2717         return (Sighandler_t) oact.sa_handler;
2718 }
2719
2720 int
2721 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2722 {
2723     dVAR;
2724     struct sigaction act;
2725
2726     PERL_ARGS_ASSERT_RSIGNAL_SAVE;
2727
2728 #ifdef USE_ITHREADS
2729     /* only "parent" interpreter can diddle signals */
2730     if (PL_curinterp != aTHX)
2731         return -1;
2732 #endif
2733
2734     act.sa_handler = (void(*)(int))handler;
2735     sigemptyset(&act.sa_mask);
2736     act.sa_flags = 0;
2737 #ifdef SA_RESTART
2738     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2739         act.sa_flags |= SA_RESTART;     /* SVR4, 4.3+BSD */
2740 #endif
2741 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2742     if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
2743         act.sa_flags |= SA_NOCLDWAIT;
2744 #endif
2745     return sigaction(signo, &act, save);
2746 }
2747
2748 int
2749 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2750 {
2751     dVAR;
2752 #ifdef USE_ITHREADS
2753     /* only "parent" interpreter can diddle signals */
2754     if (PL_curinterp != aTHX)
2755         return -1;
2756 #endif
2757
2758     return sigaction(signo, save, (struct sigaction *)NULL);
2759 }
2760
2761 #else /* !HAS_SIGACTION */
2762
2763 Sighandler_t
2764 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2765 {
2766 #if defined(USE_ITHREADS) && !defined(WIN32)
2767     /* only "parent" interpreter can diddle signals */
2768     if (PL_curinterp != aTHX)
2769         return (Sighandler_t) SIG_ERR;
2770 #endif
2771
2772     return PerlProc_signal(signo, handler);
2773 }
2774
2775 static Signal_t
2776 sig_trap(int signo)
2777 {
2778     dVAR;
2779     PL_sig_trapped++;
2780 }
2781
2782 Sighandler_t
2783 Perl_rsignal_state(pTHX_ int signo)
2784 {
2785     dVAR;
2786     Sighandler_t oldsig;
2787
2788 #if defined(USE_ITHREADS) && !defined(WIN32)
2789     /* only "parent" interpreter can diddle signals */
2790     if (PL_curinterp != aTHX)
2791         return (Sighandler_t) SIG_ERR;
2792 #endif
2793
2794     PL_sig_trapped = 0;
2795     oldsig = PerlProc_signal(signo, sig_trap);
2796     PerlProc_signal(signo, oldsig);
2797     if (PL_sig_trapped)
2798         PerlProc_kill(PerlProc_getpid(), signo);
2799     return oldsig;
2800 }
2801
2802 int
2803 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2804 {
2805 #if defined(USE_ITHREADS) && !defined(WIN32)
2806     /* only "parent" interpreter can diddle signals */
2807     if (PL_curinterp != aTHX)
2808         return -1;
2809 #endif
2810     *save = PerlProc_signal(signo, handler);
2811     return (*save == (Sighandler_t) SIG_ERR) ? -1 : 0;
2812 }
2813
2814 int
2815 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2816 {
2817 #if defined(USE_ITHREADS) && !defined(WIN32)
2818     /* only "parent" interpreter can diddle signals */
2819     if (PL_curinterp != aTHX)
2820         return -1;
2821 #endif
2822     return (PerlProc_signal(signo, *save) == (Sighandler_t) SIG_ERR) ? -1 : 0;
2823 }
2824
2825 #endif /* !HAS_SIGACTION */
2826 #endif /* !PERL_MICRO */
2827
2828     /* VMS' my_pclose() is in VMS.c; same with OS/2 */
2829 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__LIBCATAMOUNT__)
2830 I32
2831 Perl_my_pclose(pTHX_ PerlIO *ptr)
2832 {
2833     dVAR;
2834     Sigsave_t hstat, istat, qstat;
2835     int status;
2836     SV **svp;
2837     Pid_t pid;
2838     Pid_t pid2 = 0;
2839     bool close_failed;
2840     dSAVEDERRNO;
2841     const int fd = PerlIO_fileno(ptr);
2842
2843 #ifdef USE_PERLIO
2844     /* Find out whether the refcount is low enough for us to wait for the
2845        child proc without blocking. */
2846     const bool should_wait = PerlIOUnix_refcnt(fd) == 1;
2847 #else
2848     const bool should_wait = 1;
2849 #endif
2850
2851     svp = av_fetch(PL_fdpid,fd,TRUE);
2852     pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
2853     SvREFCNT_dec(*svp);
2854     *svp = &PL_sv_undef;
2855 #ifdef OS2
2856     if (pid == -1) {                    /* Opened by popen. */
2857         return my_syspclose(ptr);
2858     }
2859 #endif
2860     close_failed = (PerlIO_close(ptr) == EOF);
2861     SAVE_ERRNO;
2862 #ifndef PERL_MICRO
2863     rsignal_save(SIGHUP,  (Sighandler_t) SIG_IGN, &hstat);
2864     rsignal_save(SIGINT,  (Sighandler_t) SIG_IGN, &istat);
2865     rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qstat);
2866 #endif
2867     if (should_wait) do {
2868         pid2 = wait4pid(pid, &status, 0);
2869     } while (pid2 == -1 && errno == EINTR);
2870 #ifndef PERL_MICRO
2871     rsignal_restore(SIGHUP, &hstat);
2872     rsignal_restore(SIGINT, &istat);
2873     rsignal_restore(SIGQUIT, &qstat);
2874 #endif
2875     if (close_failed) {
2876         RESTORE_ERRNO;
2877         return -1;
2878     }
2879     return(
2880       should_wait
2881        ? pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status)
2882        : 0
2883     );
2884 }
2885 #else
2886 #if defined(__LIBCATAMOUNT__)
2887 I32
2888 Perl_my_pclose(pTHX_ PerlIO *ptr)
2889 {
2890     return -1;
2891 }
2892 #endif
2893 #endif /* !DOSISH */
2894
2895 #if  (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(__LIBCATAMOUNT__)
2896 I32
2897 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
2898 {
2899     dVAR;
2900     I32 result = 0;
2901     PERL_ARGS_ASSERT_WAIT4PID;
2902     if (!pid)
2903         return -1;
2904 #ifdef PERL_USES_PL_PIDSTATUS
2905     {
2906         if (pid > 0) {
2907             /* The keys in PL_pidstatus are now the raw 4 (or 8) bytes of the
2908                pid, rather than a string form.  */
2909             SV * const * const svp = hv_fetch(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),FALSE);
2910             if (svp && *svp != &PL_sv_undef) {
2911                 *statusp = SvIVX(*svp);
2912                 (void)hv_delete(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),
2913                                 G_DISCARD);
2914                 return pid;
2915             }
2916         }
2917         else {
2918             HE *entry;
2919
2920             hv_iterinit(PL_pidstatus);
2921             if ((entry = hv_iternext(PL_pidstatus))) {
2922                 SV * const sv = hv_iterval(PL_pidstatus,entry);
2923                 I32 len;
2924                 const char * const spid = hv_iterkey(entry,&len);
2925
2926                 assert (len == sizeof(Pid_t));
2927                 memcpy((char *)&pid, spid, len);
2928                 *statusp = SvIVX(sv);
2929                 /* The hash iterator is currently on this entry, so simply
2930                    calling hv_delete would trigger the lazy delete, which on
2931                    aggregate does more work, beacuse next call to hv_iterinit()
2932                    would spot the flag, and have to call the delete routine,
2933                    while in the meantime any new entries can't re-use that
2934                    memory.  */
2935                 hv_iterinit(PL_pidstatus);
2936                 (void)hv_delete(PL_pidstatus,spid,len,G_DISCARD);
2937                 return pid;
2938             }
2939         }
2940     }
2941 #endif
2942 #ifdef HAS_WAITPID
2943 #  ifdef HAS_WAITPID_RUNTIME
2944     if (!HAS_WAITPID_RUNTIME)
2945         goto hard_way;
2946 #  endif
2947     result = PerlProc_waitpid(pid,statusp,flags);
2948     goto finish;
2949 #endif
2950 #if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
2951     result = wait4((pid==-1)?0:pid,statusp,flags,NULL);
2952     goto finish;
2953 #endif
2954 #ifdef PERL_USES_PL_PIDSTATUS
2955 #if defined(HAS_WAITPID) && defined(HAS_WAITPID_RUNTIME)
2956   hard_way:
2957 #endif
2958     {
2959         if (flags)
2960             Perl_croak(aTHX_ "Can't do waitpid with flags");
2961         else {
2962             while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
2963                 pidgone(result,*statusp);
2964             if (result < 0)
2965                 *statusp = -1;
2966         }
2967     }
2968 #endif
2969 #if defined(HAS_WAITPID) || defined(HAS_WAIT4)
2970   finish:
2971 #endif
2972     if (result < 0 && errno == EINTR) {
2973         PERL_ASYNC_CHECK();
2974         errno = EINTR; /* reset in case a signal handler changed $! */
2975     }
2976     return result;
2977 }
2978 #endif /* !DOSISH || OS2 || WIN32 || NETWARE */
2979
2980 #ifdef PERL_USES_PL_PIDSTATUS
2981 void
2982 S_pidgone(pTHX_ Pid_t pid, int status)
2983 {
2984     SV *sv;
2985
2986     sv = *hv_fetch(PL_pidstatus,(const char*)&pid,sizeof(Pid_t),TRUE);
2987     SvUPGRADE(sv,SVt_IV);
2988     SvIV_set(sv, status);
2989     return;
2990 }
2991 #endif
2992
2993 #if defined(OS2)
2994 int pclose();
2995 #ifdef HAS_FORK
2996 int                                     /* Cannot prototype with I32
2997                                            in os2ish.h. */
2998 my_syspclose(PerlIO *ptr)
2999 #else
3000 I32
3001 Perl_my_pclose(pTHX_ PerlIO *ptr)
3002 #endif
3003 {
3004     /* Needs work for PerlIO ! */
3005     FILE * const f = PerlIO_findFILE(ptr);
3006     const I32 result = pclose(f);
3007     PerlIO_releaseFILE(ptr,f);
3008     return result;
3009 }
3010 #endif
3011
3012 #if defined(DJGPP)
3013 int djgpp_pclose();
3014 I32
3015 Perl_my_pclose(pTHX_ PerlIO *ptr)
3016 {
3017     /* Needs work for PerlIO ! */
3018     FILE * const f = PerlIO_findFILE(ptr);
3019     I32 result = djgpp_pclose(f);
3020     result = (result << 8) & 0xff00;
3021     PerlIO_releaseFILE(ptr,f);
3022     return result;
3023 }
3024 #endif
3025
3026 #define PERL_REPEATCPY_LINEAR 4
3027 void
3028 Perl_repeatcpy(char *to, const char *from, I32 len, IV count)
3029 {
3030     PERL_ARGS_ASSERT_REPEATCPY;
3031
3032     assert(len >= 0);
3033
3034     if (count < 0)
3035         Perl_croak_memory_wrap();
3036
3037     if (len == 1)
3038         memset(to, *from, count);
3039     else if (count) {
3040         char *p = to;
3041         IV items, linear, half;
3042
3043         linear = count < PERL_REPEATCPY_LINEAR ? count : PERL_REPEATCPY_LINEAR;
3044         for (items = 0; items < linear; ++items) {
3045             const char *q = from;
3046             IV todo;
3047             for (todo = len; todo > 0; todo--)
3048                 *p++ = *q++;
3049         }
3050
3051         half = count / 2;
3052         while (items <= half) {
3053             IV size = items * len;
3054             memcpy(p, to, size);
3055             p     += size;
3056             items *= 2;
3057         }
3058
3059         if (count > items)
3060             memcpy(p, to, (count - items) * len);
3061     }
3062 }
3063
3064 #ifndef HAS_RENAME
3065 I32
3066 Perl_same_dirent(pTHX_ const char *a, const char *b)
3067 {
3068     char *fa = strrchr(a,'/');
3069     char *fb = strrchr(b,'/');
3070     Stat_t tmpstatbuf1;
3071     Stat_t tmpstatbuf2;
3072     SV * const tmpsv = sv_newmortal();
3073
3074     PERL_ARGS_ASSERT_SAME_DIRENT;
3075
3076     if (fa)
3077         fa++;
3078     else
3079         fa = a;
3080     if (fb)
3081         fb++;
3082     else
3083         fb = b;
3084     if (strNE(a,b))
3085         return FALSE;
3086     if (fa == a)
3087         sv_setpvs(tmpsv, ".");
3088     else
3089         sv_setpvn(tmpsv, a, fa - a);
3090     if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0)
3091         return FALSE;
3092     if (fb == b)
3093         sv_setpvs(tmpsv, ".");
3094     else
3095         sv_setpvn(tmpsv, b, fb - b);
3096     if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0)
3097         return FALSE;
3098     return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
3099            tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
3100 }
3101 #endif /* !HAS_RENAME */
3102
3103 char*
3104 Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
3105                  const char *const *const search_ext, I32 flags)
3106 {
3107     dVAR;
3108     const char *xfound = NULL;
3109     char *xfailed = NULL;
3110     char tmpbuf[MAXPATHLEN];
3111     char *s;
3112     I32 len = 0;
3113     int retval;
3114     char *bufend;
3115 #if defined(DOSISH) && !defined(OS2)
3116 #  define SEARCH_EXTS ".bat", ".cmd", NULL
3117 #  define MAX_EXT_LEN 4
3118 #endif
3119 #ifdef OS2
3120 #  define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
3121 #  define MAX_EXT_LEN 4
3122 #endif
3123 #ifdef VMS
3124 #  define SEARCH_EXTS ".pl", ".com", NULL
3125 #  define MAX_EXT_LEN 4
3126 #endif
3127     /* additional extensions to try in each dir if scriptname not found */
3128 #ifdef SEARCH_EXTS
3129     static const char *const exts[] = { SEARCH_EXTS };
3130     const char *const *const ext = search_ext ? search_ext : exts;
3131     int extidx = 0, i = 0;
3132     const char *curext = NULL;
3133 #else
3134     PERL_UNUSED_ARG(search_ext);
3135 #  define MAX_EXT_LEN 0
3136 #endif
3137
3138     PERL_ARGS_ASSERT_FIND_SCRIPT;
3139
3140     /*
3141      * If dosearch is true and if scriptname does not contain path
3142      * delimiters, search the PATH for scriptname.
3143      *
3144      * If SEARCH_EXTS is also defined, will look for each
3145      * scriptname{SEARCH_EXTS} whenever scriptname is not found
3146      * while searching the PATH.
3147      *
3148      * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
3149      * proceeds as follows:
3150      *   If DOSISH or VMSISH:
3151      *     + look for ./scriptname{,.foo,.bar}
3152      *     + search the PATH for scriptname{,.foo,.bar}
3153      *
3154      *   If !DOSISH:
3155      *     + look *only* in the PATH for scriptname{,.foo,.bar} (note
3156      *       this will not look in '.' if it's not in the PATH)
3157      */
3158     tmpbuf[0] = '\0';
3159
3160 #ifdef VMS
3161 #  ifdef ALWAYS_DEFTYPES
3162     len = strlen(scriptname);
3163     if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
3164         int idx = 0, deftypes = 1;
3165         bool seen_dot = 1;
3166
3167         const int hasdir = !dosearch || (strpbrk(scriptname,":[</") != NULL);
3168 #  else
3169     if (dosearch) {
3170         int idx = 0, deftypes = 1;
3171         bool seen_dot = 1;
3172
3173         const int hasdir = (strpbrk(scriptname,":[</") != NULL);
3174 #  endif
3175         /* The first time through, just add SEARCH_EXTS to whatever we
3176          * already have, so we can check for default file types. */
3177         while (deftypes ||
3178                (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
3179         {
3180             if (deftypes) {
3181                 deftypes = 0;
3182                 *tmpbuf = '\0';
3183             }
3184             if ((strlen(tmpbuf) + strlen(scriptname)
3185                  + MAX_EXT_LEN) >= sizeof tmpbuf)
3186                 continue;       /* don't search dir with too-long name */
3187             my_strlcat(tmpbuf, scriptname, sizeof(tmpbuf));
3188 #else  /* !VMS */
3189
3190 #ifdef DOSISH
3191     if (strEQ(scriptname, "-"))
3192         dosearch = 0;
3193     if (dosearch) {             /* Look in '.' first. */
3194         const char *cur = scriptname;
3195 #ifdef SEARCH_EXTS
3196         if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
3197             while (ext[i])
3198                 if (strEQ(ext[i++],curext)) {
3199                     extidx = -1;                /* already has an ext */
3200                     break;
3201                 }
3202         do {
3203 #endif
3204             DEBUG_p(PerlIO_printf(Perl_debug_log,
3205                                   "Looking for %s\n",cur));
3206             if (PerlLIO_stat(cur,&PL_statbuf) >= 0
3207                 && !S_ISDIR(PL_statbuf.st_mode)) {
3208                 dosearch = 0;
3209                 scriptname = cur;
3210 #ifdef SEARCH_EXTS
3211                 break;
3212 #endif
3213             }
3214 #ifdef SEARCH_EXTS
3215             if (cur == scriptname) {
3216                 len = strlen(scriptname);
3217                 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
3218                     break;
3219                 my_strlcpy(tmpbuf, scriptname, sizeof(tmpbuf));
3220                 cur = tmpbuf;
3221             }
3222         } while (extidx >= 0 && ext[extidx]     /* try an extension? */
3223                  && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len));
3224 #endif
3225     }
3226 #endif
3227
3228     if (dosearch && !strchr(scriptname, '/')
3229 #ifdef DOSISH
3230                  && !strchr(scriptname, '\\')
3231 #endif
3232                  && (s = PerlEnv_getenv("PATH")))
3233     {
3234         bool seen_dot = 0;
3235
3236         bufend = s + strlen(s);
3237         while (s < bufend) {
3238 #  ifdef DOSISH
3239             for (len = 0; *s
3240                     && *s != ';'; len++, s++) {
3241                 if (len < sizeof tmpbuf)
3242                     tmpbuf[len] = *s;
3243             }
3244             if (len < sizeof tmpbuf)
3245                 tmpbuf[len] = '\0';
3246 #  else
3247             s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend,
3248                         ':',
3249                         &len);
3250 #  endif
3251             if (s < bufend)
3252                 s++;
3253             if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
3254                 continue;       /* don't search dir with too-long name */
3255             if (len
3256 #  ifdef DOSISH
3257                 && tmpbuf[len - 1] != '/'
3258                 && tmpbuf[len - 1] != '\\'
3259 #  endif
3260                )
3261                 tmpbuf[len++] = '/';
3262             if (len == 2 && tmpbuf[0] == '.')
3263                 seen_dot = 1;
3264             (void)my_strlcpy(tmpbuf + len, scriptname, sizeof(tmpbuf) - len);
3265 #endif  /* !VMS */
3266
3267 #ifdef SEARCH_EXTS
3268             len = strlen(tmpbuf);
3269             if (extidx > 0)     /* reset after previous loop */
3270                 extidx = 0;
3271             do {
3272 #endif
3273                 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
3274                 retval = PerlLIO_stat(tmpbuf,&PL_statbuf);
3275                 if (S_ISDIR(PL_statbuf.st_mode)) {
3276                     retval = -1;
3277                 }
3278 #ifdef SEARCH_EXTS
3279             } while (  retval < 0               /* not there */
3280                     && extidx>=0 && ext[extidx] /* try an extension? */
3281                     && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len)
3282                 );
3283 #endif
3284             if (retval < 0)
3285                 continue;
3286             if (S_ISREG(PL_statbuf.st_mode)
3287                 && cando(S_IRUSR,TRUE,&PL_statbuf)
3288 #if !defined(DOSISH)
3289                 && cando(S_IXUSR,TRUE,&PL_statbuf)
3290 #endif
3291                 )
3292             {
3293                 xfound = tmpbuf;                /* bingo! */
3294                 break;
3295             }
3296             if (!xfailed)
3297                 xfailed = savepv(tmpbuf);
3298         }
3299 #ifndef DOSISH
3300         if (!xfound && !seen_dot && !xfailed &&
3301             (PerlLIO_stat(scriptname,&PL_statbuf) < 0
3302              || S_ISDIR(PL_statbuf.st_mode)))
3303 #endif
3304             seen_dot = 1;                       /* Disable message. */
3305         if (!xfound) {
3306             if (flags & 1) {                    /* do or die? */
3307                 /* diag_listed_as: Can't execute %s */
3308                 Perl_croak(aTHX_ "Can't %s %s%s%s",
3309                       (xfailed ? "execute" : "find"),
3310                       (xfailed ? xfailed : scriptname),
3311                       (xfailed ? "" : " on PATH"),
3312                       (xfailed || seen_dot) ? "" : ", '.' not in PATH");
3313             }
3314             scriptname = NULL;
3315         }
3316         Safefree(xfailed);
3317         scriptname = xfound;
3318     }
3319     return (scriptname ? savepv(scriptname) : NULL);
3320 }
3321
3322 #ifndef PERL_GET_CONTEXT_DEFINED
3323
3324 void *
3325 Perl_get_context(void)
3326 {
3327     dVAR;
3328 #if defined(USE_ITHREADS)
3329 #  ifdef OLD_PTHREADS_API
3330     pthread_addr_t t;
3331     int error = pthread_getspecific(PL_thr_key, &t)
3332     if (error)
3333         Perl_croak_nocontext("panic: pthread_getspecific, error=%d", error);
3334     return (void*)t;
3335 #  else
3336 #    ifdef I_MACH_CTHREADS
3337     return (void*)cthread_data(cthread_self());
3338 #    else
3339     return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
3340 #    endif
3341 #  endif
3342 #else
3343     return (void*)NULL;
3344 #endif
3345 }
3346
3347 void
3348 Perl_set_context(void *t)
3349 {
3350     dVAR;
3351     PERL_ARGS_ASSERT_SET_CONTEXT;
3352 #if defined(USE_ITHREADS)
3353 #  ifdef I_MACH_CTHREADS
3354     cthread_set_data(cthread_self(), t);
3355 #  else
3356     {
3357         const int error = pthread_setspecific(PL_thr_key, t);
3358         if (error)
3359             Perl_croak_nocontext("panic: pthread_setspecific, error=%d", error);
3360     }
3361 #  endif
3362 #else
3363     PERL_UNUSED_ARG(t);
3364 #endif
3365 }
3366
3367 #endif /* !PERL_GET_CONTEXT_DEFINED */
3368
3369 #if defined(PERL_GLOBAL_STRUCT) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
3370 struct perl_vars *
3371 Perl_GetVars(pTHX)
3372 {
3373  return &PL_Vars;
3374 }
3375 #endif
3376
3377 char **
3378 Perl_get_op_names(pTHX)
3379 {
3380     PERL_UNUSED_CONTEXT;
3381     return (char **)PL_op_name;
3382 }
3383
3384 char **
3385 Perl_get_op_descs(pTHX)
3386 {
3387     PERL_UNUSED_CONTEXT;
3388     return (char **)PL_op_desc;
3389 }
3390
3391 const char *
3392 Perl_get_no_modify(pTHX)
3393 {
3394     PERL_UNUSED_CONTEXT;
3395     return PL_no_modify;
3396 }
3397
3398 U32 *
3399 Perl_get_opargs(pTHX)
3400 {
3401     PERL_UNUSED_CONTEXT;
3402     return (U32 *)PL_opargs;
3403 }
3404
3405 PPADDR_t*
3406 Perl_get_ppaddr(pTHX)
3407 {
3408     dVAR;
3409     PERL_UNUSED_CONTEXT;
3410     return (PPADDR_t*)PL_ppaddr;
3411 }
3412
3413 #ifndef HAS_GETENV_LEN
3414 char *
3415 Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
3416 {
3417     char * const env_trans = PerlEnv_getenv(env_elem);
3418     PERL_UNUSED_CONTEXT;
3419     PERL_ARGS_ASSERT_GETENV_LEN;
3420     if (env_trans)
3421         *len = strlen(env_trans);
3422     return env_trans;
3423 }
3424 #endif
3425
3426
3427 MGVTBL*
3428 Perl_get_vtbl(pTHX_ int vtbl_id)
3429 {
3430     PERL_UNUSED_CONTEXT;
3431
3432     return (vtbl_id < 0 || vtbl_id >= magic_vtable_max)
3433         ? NULL : PL_magic_vtables + vtbl_id;
3434 }
3435
3436 I32
3437 Perl_my_fflush_all(pTHX)
3438 {
3439 #if defined(USE_PERLIO) || defined(FFLUSH_NULL) || defined(USE_SFIO)
3440     return PerlIO_flush(NULL);
3441 #else
3442 # if defined(HAS__FWALK)
3443     extern int fflush(FILE *);
3444     /* undocumented, unprototyped, but very useful BSDism */
3445     extern void _fwalk(int (*)(FILE *));
3446     _fwalk(&fflush);
3447     return 0;
3448 # else
3449 #  if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
3450     long open_max = -1;
3451 #   ifdef PERL_FFLUSH_ALL_FOPEN_MAX
3452     open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
3453 #   else
3454 #    if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
3455     open_max = sysconf(_SC_OPEN_MAX);
3456 #     else
3457 #      ifdef FOPEN_MAX
3458     open_max = FOPEN_MAX;
3459 #      else
3460 #       ifdef OPEN_MAX
3461     open_max = OPEN_MAX;
3462 #       else
3463 #        ifdef _NFILE
3464     open_max = _NFILE;
3465 #        endif
3466 #       endif
3467 #      endif
3468 #     endif
3469 #    endif
3470     if (open_max > 0) {
3471       long i;
3472       for (i = 0; i < open_max; i++)
3473             if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
3474                 STDIO_STREAM_ARRAY[i]._file < open_max &&
3475                 STDIO_STREAM_ARRAY[i]._flag)
3476                 PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
3477       return 0;
3478     }
3479 #  endif
3480     SETERRNO(EBADF,RMS_IFI);
3481     return EOF;
3482 # endif
3483 #endif
3484 }
3485
3486 void
3487 Perl_report_wrongway_fh(pTHX_ const GV *gv, const char have)
3488 {
3489     if (ckWARN(WARN_IO)) {
3490         HEK * const name
3491            = gv && (isGV_with_GP(gv))
3492                 ? GvENAME_HEK((gv))
3493                 : NULL;
3494         const char * const direction = have == '>' ? "out" : "in";
3495
3496         if (name && HEK_LEN(name))
3497             Perl_warner(aTHX_ packWARN(WARN_IO),
3498                         "Filehandle %"HEKf" opened only for %sput",
3499                         name, direction);
3500         else
3501             Perl_warner(aTHX_ packWARN(WARN_IO),
3502                         "Filehandle opened only for %sput", direction);
3503     }
3504 }
3505
3506 void
3507 Perl_report_evil_fh(pTHX_ const GV *gv)
3508 {
3509     const IO *io = gv ? GvIO(gv) : NULL;
3510     const PERL_BITFIELD16 op = PL_op->op_type;
3511     const char *vile;
3512     I32 warn_type;
3513
3514     if (io && IoTYPE(io) == IoTYPE_CLOSED) {
3515         vile = "closed";
3516         warn_type = WARN_CLOSED;
3517     }
3518     else {
3519         vile = "unopened";
3520         warn_type = WARN_UNOPENED;
3521     }
3522
3523     if (ckWARN(warn_type)) {
3524         SV * const name
3525             = gv && isGV_with_GP(gv) && GvENAMELEN(gv) ?
3526                                      sv_2mortal(newSVhek(GvENAME_HEK(gv))) : NULL;
3527         const char * const pars =
3528             (const char *)(OP_IS_FILETEST(op) ? "" : "()");
3529         const char * const func =
3530             (const char *)
3531             (op == OP_READLINE   ? "readline"  :        /* "<HANDLE>" not nice */
3532              op == OP_LEAVEWRITE ? "write" :            /* "write exit" not nice */
3533              PL_op_desc[op]);
3534         const char * const type =
3535             (const char *)
3536             (OP_IS_SOCKET(op) || (io && IoTYPE(io) == IoTYPE_SOCKET)
3537              ? "socket" : "filehandle");
3538         const bool have_name = name && SvCUR(name);
3539         Perl_warner(aTHX_ packWARN(warn_type),
3540                    "%s%s on %s %s%s%"SVf, func, pars, vile, type,
3541                     have_name ? " " : "",
3542                     SVfARG(have_name ? name : &PL_sv_no));
3543         if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3544                 Perl_warner(
3545                             aTHX_ packWARN(warn_type),
3546                         "\t(Are you trying to call %s%s on dirhandle%s%"SVf"?)\n",
3547                         func, pars, have_name ? " " : "",
3548                         SVfARG(have_name ? name : &PL_sv_no)
3549                             );
3550     }
3551 }
3552
3553 /* To workaround core dumps from the uninitialised tm_zone we get the
3554  * system to give us a reasonable struct to copy.  This fix means that
3555  * strftime uses the tm_zone and tm_gmtoff values returned by
3556  * localtime(time()). That should give the desired result most of the
3557  * time. But probably not always!
3558  *
3559  * This does not address tzname aspects of NETaa14816.
3560  *
3561  */
3562
3563 #ifdef HAS_GNULIBC
3564 # ifndef STRUCT_TM_HASZONE
3565 #    define STRUCT_TM_HASZONE
3566 # endif
3567 #endif
3568
3569 #ifdef STRUCT_TM_HASZONE /* Backward compat */
3570 # ifndef HAS_TM_TM_ZONE
3571 #    define HAS_TM_TM_ZONE
3572 # endif
3573 #endif
3574
3575 void
3576 Perl_init_tm(pTHX_ struct tm *ptm)      /* see mktime, strftime and asctime */
3577 {
3578 #ifdef HAS_TM_TM_ZONE
3579     Time_t now;
3580     const struct tm* my_tm;
3581     PERL_ARGS_ASSERT_INIT_TM;
3582     (void)time(&now);
3583     my_tm = localtime(&now);
3584     if (my_tm)
3585         Copy(my_tm, ptm, 1, struct tm);
3586 #else
3587     PERL_ARGS_ASSERT_INIT_TM;
3588     PERL_UNUSED_ARG(ptm);
3589 #endif
3590 }
3591
3592 /*
3593  * mini_mktime - normalise struct tm values without the localtime()
3594  * semantics (and overhead) of mktime().
3595  */
3596 void
3597 Perl_mini_mktime(pTHX_ struct tm *ptm)
3598 {
3599     int yearday;
3600     int secs;
3601     int month, mday, year, jday;
3602     int odd_cent, odd_year;
3603     PERL_UNUSED_CONTEXT;
3604
3605     PERL_ARGS_ASSERT_MINI_MKTIME;
3606
3607 #define DAYS_PER_YEAR   365
3608 #define DAYS_PER_QYEAR  (4*DAYS_PER_YEAR+1)
3609 #define DAYS_PER_CENT   (25*DAYS_PER_QYEAR-1)
3610 #define DAYS_PER_QCENT  (4*DAYS_PER_CENT+1)
3611 #define SECS_PER_HOUR   (60*60)
3612 #define SECS_PER_DAY    (24*SECS_PER_HOUR)
3613 /* parentheses deliberately absent on these two, otherwise they don't work */
3614 #define MONTH_TO_DAYS   153/5
3615 #define DAYS_TO_MONTH   5/153
3616 /* offset to bias by March (month 4) 1st between month/mday & year finding */
3617 #define YEAR_ADJUST     (4*MONTH_TO_DAYS+1)
3618 /* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */
3619 #define WEEKDAY_BIAS    6       /* (1+6)%7 makes Sunday 0 again */
3620
3621 /*
3622  * Year/day algorithm notes:
3623  *
3624  * With a suitable offset for numeric value of the month, one can find
3625  * an offset into the year by considering months to have 30.6 (153/5) days,
3626  * using integer arithmetic (i.e., with truncation).  To avoid too much
3627  * messing about with leap days, we consider January and February to be
3628  * the 13th and 14th month of the previous year.  After that transformation,
3629  * we need the month index we use to be high by 1 from 'normal human' usage,
3630  * so the month index values we use run from 4 through 15.
3631  *
3632  * Given that, and the rules for the Gregorian calendar (leap years are those
3633  * divisible by 4 unless also divisible by 100, when they must be divisible
3634  * by 400 instead), we can simply calculate the number of days since some
3635  * arbitrary 'beginning of time' by futzing with the (adjusted) year number,
3636  * the days we derive from our month index, and adding in the day of the
3637  * month.  The value used here is not adjusted for the actual origin which
3638  * it normally would use (1 January A.D. 1), since we're not exposing it.
3639  * We're only building the value so we can turn around and get the
3640  * normalised values for the year, month, day-of-month, and day-of-year.
3641  *
3642  * For going backward, we need to bias the value we're using so that we find
3643  * the right year value.  (Basically, we don't want the contribution of
3644  * March 1st to the number to apply while deriving the year).  Having done
3645  * that, we 'count up' the contribution to the year number by accounting for
3646  * full quadracenturies (400-year periods) with their extra leap days, plus
3647  * the contribution from full centuries (to avoid counting in the lost leap
3648  * days), plus the contribution from full quad-years (to count in the normal
3649  * leap days), plus the leftover contribution from any non-leap years.
3650  * At this point, if we were working with an actual leap day, we'll have 0
3651  * days left over.  This is also true for March 1st, however.  So, we have
3652  * to special-case that result, and (earlier) keep track of the 'odd'
3653  * century and year contributions.  If we got 4 extra centuries in a qcent,
3654  * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb.
3655  * Otherwise, we add back in the earlier bias we removed (the 123 from
3656  * figuring in March 1st), find the month index (integer division by 30.6),
3657  * and the remainder is the day-of-month.  We then have to convert back to
3658  * 'real' months (including fixing January and February from being 14/15 in
3659  * the previous year to being in the proper year).  After that, to get
3660  * tm_yday, we work with the normalised year and get a new yearday value for
3661  * January 1st, which we subtract from the yearday value we had earlier,
3662  * representing the date we've re-built.  This is done from January 1
3663  * because tm_yday is 0-origin.
3664  *
3665  * Since POSIX time routines are only guaranteed to work for times since the
3666  * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm
3667  * applies Gregorian calendar rules even to dates before the 16th century
3668  * doesn't bother me.  Besides, you'd need cultural context for a given
3669  * date to know whether it was Julian or Gregorian calendar, and that's
3670  * outside the scope for this routine.  Since we convert back based on the
3671  * same rules we used to build the yearday, you'll only get strange results
3672  * for input which needed normalising, or for the 'odd' century years which
3673  * were leap years in the Julian calendar but not in the Gregorian one.
3674  * I can live with that.
3675  *
3676  * This algorithm also fails to handle years before A.D. 1 gracefully, but
3677  * that's still outside the scope for POSIX time manipulation, so I don't
3678  * care.
3679  */
3680
3681     year = 1900 + ptm->tm_year;
3682     month = ptm->tm_mon;
3683     mday = ptm->tm_mday;
3684     jday = 0;
3685     if (month >= 2)
3686         month+=2;
3687     else
3688         month+=14, year--;
3689     yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400;
3690     yearday += month*MONTH_TO_DAYS + mday + jday;
3691     /*
3692      * Note that we don't know when leap-seconds were or will be,
3693      * so we have to trust the user if we get something which looks
3694      * like a sensible leap-second.  Wild values for seconds will
3695      * be rationalised, however.
3696      */
3697     if ((unsigned) ptm->tm_sec <= 60) {
3698         secs = 0;
3699     }
3700     else {
3701         secs = ptm->tm_sec;
3702         ptm->tm_sec = 0;
3703     }
3704     secs += 60 * ptm->tm_min;
3705     secs += SECS_PER_HOUR * ptm->tm_hour;
3706     if (secs < 0) {
3707         if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) {
3708             /* got negative remainder, but need positive time */
3709             /* back off an extra day to compensate */
3710             yearday += (secs/SECS_PER_DAY)-1;
3711             secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1);
3712         }
3713         else {
3714             yearday += (secs/SECS_PER_DAY);
3715             secs -= SECS_PER_DAY * (secs/SECS_PER_DAY);
3716         }
3717     }
3718     else if (secs >= SECS_PER_DAY) {
3719         yearday += (secs/SECS_PER_DAY);
3720         secs %= SECS_PER_DAY;
3721     }
3722     ptm->tm_hour = secs/SECS_PER_HOUR;
3723     secs %= SECS_PER_HOUR;
3724     ptm->tm_min = secs/60;
3725     secs %= 60;
3726     ptm->tm_sec += secs;
3727     /* done with time of day effects */
3728     /*
3729      * The algorithm for yearday has (so far) left it high by 428.
3730      * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to
3731      * bias it by 123 while trying to figure out what year it
3732      * really represents.  Even with this tweak, the reverse
3733      * translation fails for years before A.D. 0001.
3734      * It would still fail for Feb 29, but we catch that one below.
3735      */
3736     jday = yearday;     /* save for later fixup vis-a-vis Jan 1 */
3737     yearday -= YEAR_ADJUST;
3738     year = (yearday / DAYS_PER_QCENT) * 400;
3739     yearday %= DAYS_PER_QCENT;
3740     odd_cent = yearday / DAYS_PER_CENT;
3741     year += odd_cent * 100;
3742     yearday %= DAYS_PER_CENT;
3743     year += (yearday / DAYS_PER_QYEAR) * 4;
3744     yearday %= DAYS_PER_QYEAR;
3745     odd_year = yearday / DAYS_PER_YEAR;
3746     year += odd_year;
3747     yearday %= DAYS_PER_YEAR;
3748     if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */
3749         month = 1;
3750         yearday = 29;
3751     }
3752     else {
3753         yearday += YEAR_ADJUST; /* recover March 1st crock */
3754         month = yearday*DAYS_TO_MONTH;
3755         yearday -= month*MONTH_TO_DAYS;
3756         /* recover other leap-year adjustment */
3757         if (month > 13) {
3758             month-=14;
3759             year++;
3760         }
3761         else {
3762             month-=2;
3763         }
3764     }
3765     ptm->tm_year = year - 1900;
3766     if (yearday) {
3767       ptm->tm_mday = yearday;
3768       ptm->tm_mon = month;
3769     }
3770     else {
3771       ptm->tm_mday = 31;
3772       ptm->tm_mon = month - 1;
3773     }
3774     /* re-build yearday based on Jan 1 to get tm_yday */
3775     year--;
3776     yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400;
3777     yearday += 14*MONTH_TO_DAYS + 1;
3778     ptm->tm_yday = jday - yearday;
3779     ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
3780 }
3781
3782 char *
3783 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)
3784 {
3785 #ifdef HAS_STRFTIME
3786   char *buf;
3787   int buflen;
3788   struct tm mytm;
3789   int len;
3790
3791   PERL_ARGS_ASSERT_MY_STRFTIME;
3792
3793   init_tm(&mytm);       /* XXX workaround - see init_tm() above */
3794   mytm.tm_sec = sec;
3795   mytm.tm_min = min;
3796   mytm.tm_hour = hour;
3797   mytm.tm_mday = mday;
3798   mytm.tm_mon = mon;
3799   mytm.tm_year = year;
3800   mytm.tm_wday = wday;
3801   mytm.tm_yday = yday;
3802   mytm.tm_isdst = isdst;
3803   mini_mktime(&mytm);
3804   /* use libc to get the values for tm_gmtoff and tm_zone [perl #18238] */
3805 #if defined(HAS_MKTIME) && (defined(HAS_TM_TM_GMTOFF) || defined(HAS_TM_TM_ZONE))
3806   STMT_START {
3807     struct tm mytm2;
3808     mytm2 = mytm;
3809     mktime(&mytm2);
3810 #ifdef HAS_TM_TM_GMTOFF
3811     mytm.tm_gmtoff = mytm2.tm_gmtoff;
3812 #endif
3813 #ifdef HAS_TM_TM_ZONE
3814     mytm.tm_zone = mytm2.tm_zone;
3815 #endif
3816   } STMT_END;
3817 #endif
3818   buflen = 64;
3819   Newx(buf, buflen, char);
3820   len = strftime(buf, buflen, fmt, &mytm);
3821   /*
3822   ** The following is needed to handle to the situation where
3823   ** tmpbuf overflows.  Basically we want to allocate a buffer
3824   ** and try repeatedly.  The reason why it is so complicated
3825   ** is that getting a return value of 0 from strftime can indicate
3826   ** one of the following:
3827   ** 1. buffer overflowed,
3828   ** 2. illegal conversion specifier, or
3829   ** 3. the format string specifies nothing to be returned(not
3830   **      an error).  This could be because format is an empty string
3831   **    or it specifies %p that yields an empty string in some locale.
3832   ** If there is a better way to make it portable, go ahead by
3833   ** all means.
3834   */
3835   if ((len > 0 && len < buflen) || (len == 0 && *fmt == '\0'))
3836     return buf;
3837   else {
3838     /* Possibly buf overflowed - try again with a bigger buf */
3839     const int fmtlen = strlen(fmt);
3840     int bufsize = fmtlen + buflen;
3841
3842     Renew(buf, bufsize, char);
3843     while (buf) {
3844       buflen = strftime(buf, bufsize, fmt, &mytm);
3845       if (buflen > 0 && buflen < bufsize)
3846         break;
3847       /* heuristic to prevent out-of-memory errors */
3848       if (bufsize > 100*fmtlen) {
3849         Safefree(buf);
3850         buf = NULL;
3851         break;
3852       }
3853       bufsize *= 2;
3854       Renew(buf, bufsize, char);
3855     }
3856     return buf;
3857   }
3858 #else
3859   Perl_croak(aTHX_ "panic: no strftime");
3860   return NULL;
3861 #endif
3862 }
3863
3864
3865 #define SV_CWD_RETURN_UNDEF \
3866 sv_setsv(sv, &PL_sv_undef); \
3867 return FALSE
3868
3869 #define SV_CWD_ISDOT(dp) \
3870     (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
3871         (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
3872
3873 /*
3874 =head1 Miscellaneous Functions
3875
3876 =for apidoc getcwd_sv
3877
3878 Fill the sv with current working directory
3879
3880 =cut
3881 */
3882
3883 /* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars.
3884  * rewritten again by dougm, optimized for use with xs TARG, and to prefer
3885  * getcwd(3) if available
3886  * Comments from the orignal:
3887  *     This is a faster version of getcwd.  It's also more dangerous
3888  *     because you might chdir out of a directory that you can't chdir
3889  *     back into. */
3890
3891 int
3892 Perl_getcwd_sv(pTHX_ SV *sv)
3893 {
3894 #ifndef PERL_MICRO
3895     dVAR;
3896 #ifndef INCOMPLETE_TAINTS
3897     SvTAINTED_on(sv);
3898 #endif
3899
3900     PERL_ARGS_ASSERT_GETCWD_SV;
3901
3902 #ifdef HAS_GETCWD
3903     {
3904         char buf[MAXPATHLEN];
3905
3906         /* Some getcwd()s automatically allocate a buffer of the given
3907          * size from the heap if they are given a NULL buffer pointer.
3908          * The problem is that this behaviour is not portable. */
3909         if (getcwd(buf, sizeof(buf) - 1)) {
3910             sv_setpv(sv, buf);
3911             return TRUE;
3912         }
3913         else {
3914             sv_setsv(sv, &PL_sv_undef);
3915             return FALSE;
3916         }
3917     }
3918
3919 #else
3920
3921     Stat_t statbuf;
3922     int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
3923     int pathlen=0;
3924     Direntry_t *dp;
3925
3926     SvUPGRADE(sv, SVt_PV);
3927
3928     if (PerlLIO_lstat(".", &statbuf) < 0) {
3929         SV_CWD_RETURN_UNDEF;
3930     }
3931
3932     orig_cdev = statbuf.st_dev;
3933     orig_cino = statbuf.st_ino;
3934     cdev = orig_cdev;
3935     cino = orig_cino;
3936
3937     for (;;) {
3938         DIR *dir;
3939         int namelen;
3940         odev = cdev;
3941         oino = cino;
3942
3943         if (PerlDir_chdir("..") < 0) {
3944             SV_CWD_RETURN_UNDEF;
3945         }
3946         if (PerlLIO_stat(".", &statbuf) < 0) {
3947             SV_CWD_RETURN_UNDEF;
3948         }
3949
3950         cdev = statbuf.st_dev;
3951         cino = statbuf.st_ino;
3952
3953         if (odev == cdev && oino == cino) {
3954             break;
3955         }
3956         if (!(dir = PerlDir_open("."))) {
3957             SV_CWD_RETURN_UNDEF;
3958         }
3959
3960         while ((dp = PerlDir_read(dir)) != NULL) {
3961 #ifdef DIRNAMLEN
3962             namelen = dp->d_namlen;
3963 #else
3964             namelen = strlen(dp->d_name);
3965 #endif
3966             /* skip . and .. */
3967             if (SV_CWD_ISDOT(dp)) {
3968                 continue;
3969             }
3970
3971             if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
3972                 SV_CWD_RETURN_UNDEF;
3973             }
3974
3975             tdev = statbuf.st_dev;
3976             tino = statbuf.st_ino;
3977             if (tino == oino && tdev == odev) {
3978                 break;
3979             }
3980         }
3981
3982         if (!dp) {
3983             SV_CWD_RETURN_UNDEF;
3984         }
3985
3986         if (pathlen + namelen + 1 >= MAXPATHLEN) {
3987             SV_CWD_RETURN_UNDEF;
3988         }
3989
3990         SvGROW(sv, pathlen + namelen + 1);
3991
3992         if (pathlen) {
3993             /* shift down */
3994             Move(SvPVX_const(sv), SvPVX(sv) + namelen + 1, pathlen, char);
3995         }
3996
3997         /* prepend current directory to the front */
3998         *SvPVX(sv) = '/';
3999         Move(dp->d_name, SvPVX(sv)+1, namelen, char);
4000         pathlen += (namelen + 1);
4001
4002 #ifdef VOID_CLOSEDIR
4003         PerlDir_close(dir);
4004 #else
4005         if (PerlDir_close(dir) < 0) {
4006             SV_CWD_RETURN_UNDEF;
4007         }
4008 #endif
4009     }
4010
4011     if (pathlen) {
4012         SvCUR_set(sv, pathlen);
4013         *SvEND(sv) = '\0';
4014         SvPOK_only(sv);
4015
4016         if (PerlDir_chdir(SvPVX_const(sv)) < 0) {
4017             SV_CWD_RETURN_UNDEF;
4018         }
4019     }
4020     if (PerlLIO_stat(".", &statbuf) < 0) {
4021         SV_CWD_RETURN_UNDEF;
4022     }
4023
4024     cdev = statbuf.st_dev;
4025     cino = statbuf.st_ino;
4026
4027     if (cdev != orig_cdev || cino != orig_cino) {
4028         Perl_croak(aTHX_ "Unstable directory path, "
4029                    "current directory changed unexpectedly");
4030     }
4031
4032     return TRUE;
4033 #endif
4034
4035 #else
4036     return FALSE;
4037 #endif
4038 }
4039
4040 #define VERSION_MAX 0x7FFFFFFF
4041
4042 /*
4043 =for apidoc prescan_version
4044
4045 Validate that a given string can be parsed as a version object, but doesn't
4046 actually perform the parsing.  Can use either strict or lax validation rules.
4047 Can optionally set a number of hint variables to save the parsing code
4048 some time when tokenizing.
4049
4050 =cut
4051 */
4052 const char *
4053 Perl_prescan_version(pTHX_ const char *s, bool strict,
4054                      const char **errstr,
4055                      bool *sqv, int *ssaw_decimal, int *swidth, bool *salpha) {
4056     bool qv = (sqv ? *sqv : FALSE);
4057     int width = 3;
4058     int saw_decimal = 0;
4059     bool alpha = FALSE;
4060     const char *d = s;
4061
4062     PERL_ARGS_ASSERT_PRESCAN_VERSION;
4063
4064     if (qv && isDIGIT(*d))
4065         goto dotted_decimal_version;
4066
4067     if (*d == 'v') { /* explicit v-string */
4068         d++;
4069         if (isDIGIT(*d)) {
4070             qv = TRUE;
4071         }
4072         else { /* degenerate v-string */
4073             /* requires v1.2.3 */
4074             BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
4075         }
4076
4077 dotted_decimal_version:
4078         if (strict && d[0] == '0' && isDIGIT(d[1])) {
4079             /* no leading zeros allowed */
4080             BADVERSION(s,errstr,"Invalid version format (no leading zeros)");
4081         }
4082
4083         while (isDIGIT(*d))     /* integer part */
4084             d++;
4085
4086         if (*d == '.')
4087         {
4088             saw_decimal++;
4089             d++;                /* decimal point */
4090         }
4091         else
4092         {
4093             if (strict) {
4094                 /* require v1.2.3 */
4095                 BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
4096             }
4097             else {
4098                 goto version_prescan_finish;
4099             }
4100         }
4101
4102         {
4103             int i = 0;
4104             int j = 0;
4105             while (isDIGIT(*d)) {       /* just keep reading */
4106                 i++;
4107                 while (isDIGIT(*d)) {
4108                     d++; j++;
4109                     /* maximum 3 digits between decimal */
4110                     if (strict && j > 3) {
4111                         BADVERSION(s,errstr,"Invalid version format (maximum 3 digits between decimals)");
4112                     }
4113                 }
4114                 if (*d == '_') {
4115                     if (strict) {
4116                         BADVERSION(s,errstr,"Invalid version format (no underscores)");
4117                     }
4118                     if ( alpha ) {
4119                         BADVERSION(s,errstr,"Invalid version format (multiple underscores)");
4120                     }
4121                     d++;
4122                     alpha = TRUE;
4123                 }
4124                 else if (*d == '.') {
4125                     if (alpha) {
4126                         BADVERSION(s,errstr,"Invalid version format (underscores before decimal)");
4127                     }
4128                     saw_decimal++;
4129                     d++;
4130                 }
4131                 else if (!isDIGIT(*d)) {
4132                     break;
4133                 }
4134                 j = 0;
4135             }
4136
4137             if (strict && i < 2) {
4138                 /* requires v1.2.3 */
4139                 BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
4140             }
4141         }
4142     }                                   /* end if dotted-decimal */
4143     else
4144     {                                   /* decimal versions */
4145         int j = 0;                      /* may need this later */
4146         /* special strict case for leading '.' or '0' */
4147         if (strict) {
4148             if (*d == '.') {
4149                 BADVERSION(s,errstr,"Invalid version format (0 before decimal required)");
4150             }
4151             if (*d == '0' && isDIGIT(d[1])) {
4152                 BADVERSION(s,errstr,"Invalid version format (no leading zeros)");
4153             }
4154         }
4155
4156         /* and we never support negative versions */
4157         if ( *d == '-') {
4158             BADVERSION(s,errstr,"Invalid version format (negative version number)");
4159         }
4160
4161         /* consume all of the integer part */
4162         while (isDIGIT(*d))
4163             d++;
4164
4165         /* look for a fractional part */
4166         if (*d == '.') {
4167             /* we found it, so consume it */
4168             saw_decimal++;
4169             d++;
4170         }
4171         else if (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') {
4172             if ( d == s ) {
4173                 /* found nothing */
4174                 BADVERSION(s,errstr,"Invalid version format (version required)");
4175             }
4176             /* found just an integer */
4177             goto version_prescan_finish;
4178         }
4179         else if ( d == s ) {
4180             /* didn't find either integer or period */
4181             BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
4182         }
4183         else if (*d == '_') {
4184             /* underscore can't come after integer part */
4185             if (strict) {
4186                 BADVERSION(s,errstr,"Invalid version format (no underscores)");
4187             }
4188             else if (isDIGIT(d[1])) {
4189                 BADVERSION(s,errstr,"Invalid version format (alpha without decimal)");
4190             }
4191             else {
4192                 BADVERSION(s,errstr,"Invalid version format (misplaced underscore)");
4193             }
4194         }
4195         else {
4196             /* anything else after integer part is just invalid data */
4197             BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
4198         }
4199
4200         /* scan the fractional part after the decimal point*/
4201
4202         if (!isDIGIT(*d) && (strict || ! (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') )) {
4203                 /* strict or lax-but-not-the-end */
4204                 BADVERSION(s,errstr,"Invalid version format (fractional part required)");
4205         }
4206
4207         while (isDIGIT(*d)) {
4208             d++; j++;
4209             if (*d == '.' && isDIGIT(d[-1])) {
4210                 if (alpha) {
4211                     BADVERSION(s,errstr,"Invalid version format (underscores before decimal)");
4212                 }
4213                 if (strict) {
4214                     BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions must begin with 'v')");
4215                 }
4216                 d = (char *)s;          /* start all over again */
4217                 qv = TRUE;
4218                 goto dotted_decimal_version;
4219             }
4220             if (*d == '_') {
4221                 if (strict) {
4222                     BADVERSION(s,errstr,"Invalid version format (no underscores)");
4223                 }
4224                 if ( alpha ) {
4225                     BADVERSION(s,errstr,"Invalid version format (multiple underscores)");
4226                 }
4227                 if ( ! isDIGIT(d[1]) ) {
4228                     BADVERSION(s,errstr,"Invalid version format (misplaced underscore)");
4229                 }
4230                 width = j;
4231                 d++;
4232                 alpha = TRUE;
4233             }
4234         }
4235     }
4236
4237 version_prescan_finish:
4238     while (isSPACE(*d))
4239         d++;
4240
4241     if (!isDIGIT(*d) && (! (!*d || *d == ';' || *d == '{' || *d == '}') )) {
4242         /* trailing non-numeric data */
4243         BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
4244     }
4245
4246     if (sqv)
4247         *sqv = qv;
4248     if (swidth)
4249         *swidth = width;
4250     if (ssaw_decimal)
4251         *ssaw_decimal = saw_decimal;
4252     if (salpha)
4253         *salpha = alpha;
4254     return d;
4255 }
4256
4257 /*
4258 =for apidoc scan_version
4259
4260 Returns a pointer to the next character after the parsed
4261 version string, as well as upgrading the passed in SV to
4262 an RV.
4263
4264 Function must be called with an already existing SV like
4265
4266     sv = newSV(0);
4267     s = scan_version(s, SV *sv, bool qv);
4268
4269 Performs some preprocessing to the string to ensure that
4270 it has the correct characteristics of a version.  Flags the
4271 object if it contains an underscore (which denotes this
4272 is an alpha version).  The boolean qv denotes that the version
4273 should be interpreted as if it had multiple decimals, even if
4274 it doesn't.
4275
4276 =cut
4277 */
4278
4279 const char *
4280 Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
4281 {
4282     const char *start = s;
4283     const char *pos;
4284     const char *last;
4285     const char *errstr = NULL;
4286     int saw_decimal = 0;
4287     int width = 3;
4288     bool alpha = FALSE;
4289     bool vinf = FALSE;
4290     AV * av;
4291     SV * hv;
4292
4293     PERL_ARGS_ASSERT_SCAN_VERSION;
4294
4295     while (isSPACE(*s)) /* leading whitespace is OK */
4296         s++;
4297
4298     last = prescan_version(s, FALSE, &errstr, &qv, &saw_decimal, &width, &alpha);
4299     if (errstr) {
4300         /* "undef" is a special case and not an error */
4301         if ( ! ( *s == 'u' && strEQ(s,"undef")) ) {
4302             Safefree(start);
4303             Perl_croak(aTHX_ "%s", errstr);
4304         }
4305     }
4306
4307     start = s;
4308     if (*s == 'v')
4309         s++;
4310     pos = s;
4311
4312     /* Now that we are through the prescan, start creating the object */
4313     av = newAV();
4314     hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
4315     (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
4316
4317 #ifndef NODEFAULT_SHAREKEYS
4318     HvSHAREKEYS_on(hv);         /* key-sharing on by default */
4319 #endif
4320
4321     if ( qv )
4322         (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(qv));
4323     if ( alpha )
4324         (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(alpha));
4325     if ( !qv && width < 3 )
4326         (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
4327
4328     while (isDIGIT(*pos))
4329         pos++;
4330     if (!isALPHA(*pos)) {
4331         I32 rev;
4332
4333         for (;;) {
4334             rev = 0;
4335             {
4336                 /* this is atoi() that delimits on underscores */
4337                 const char *end = pos;
4338                 I32 mult = 1;
4339                 I32 orev;
4340
4341                 /* the following if() will only be true after the decimal
4342                  * point of a version originally created with a bare
4343                  * floating point number, i.e. not quoted in any way
4344                  */
4345                 if ( !qv && s > start && saw_decimal == 1 ) {
4346                     mult *= 100;
4347                     while ( s < end ) {
4348                         orev = rev;
4349                         rev += (*s - '0') * mult;
4350                         mult /= 10;
4351                         if (   (PERL_ABS(orev) > PERL_ABS(rev)) 
4352                             || (PERL_ABS(rev) > VERSION_MAX )) {
4353                             Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), 
4354                                            "Integer overflow in version %d",VERSION_MAX);
4355                             s = end - 1;
4356                             rev = VERSION_MAX;
4357                             vinf = 1;
4358                         }
4359                         s++;
4360                         if ( *s == '_' )
4361                             s++;
4362                     }
4363                 }
4364                 else {
4365                     while (--end >= s) {
4366                         orev = rev;
4367                         rev += (*end - '0') * mult;
4368                         mult *= 10;
4369                         if (   (PERL_ABS(orev) > PERL_ABS(rev)) 
4370                             || (PERL_ABS(rev) > VERSION_MAX )) {
4371                             Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), 
4372                                            "Integer overflow in version");
4373                             end = s - 1;
4374                             rev = VERSION_MAX;
4375                             vinf = 1;
4376                         }
4377                     }
4378                 } 
4379             }
4380
4381             /* Append revision */
4382             av_push(av, newSViv(rev));
4383             if ( vinf ) {
4384                 s = last;
4385                 break;
4386             }
4387             else if ( *pos == '.' )
4388                 s = ++pos;
4389             else if ( *pos == '_' && isDIGIT(pos[1]) )
4390                 s = ++pos;
4391             else if ( *pos == ',' && isDIGIT(pos[1]) )
4392                 s = ++pos;
4393             else if ( isDIGIT(*pos) )
4394                 s = pos;
4395             else {
4396                 s = pos;
4397                 break;
4398             }
4399             if ( qv ) {
4400                 while ( isDIGIT(*pos) )
4401                     pos++;
4402             }
4403             else {
4404                 int digits = 0;
4405                 while ( ( isDIGIT(*pos) || *pos == '_' ) && digits < 3 ) {
4406                     if ( *pos != '_' )
4407                         digits++;
4408                     pos++;
4409                 }
4410             }
4411         }
4412     }
4413     if ( qv ) { /* quoted versions always get at least three terms*/
4414         I32 len = av_len(av);
4415         /* This for loop appears to trigger a compiler bug on OS X, as it
4416            loops infinitely. Yes, len is negative. No, it makes no sense.
4417            Compiler in question is:
4418            gcc version 3.3 20030304 (Apple Computer, Inc. build 1640)
4419            for ( len = 2 - len; len > 0; len-- )
4420            av_push(MUTABLE_AV(sv), newSViv(0));
4421         */
4422         len = 2 - len;
4423         while (len-- > 0)
4424             av_push(av, newSViv(0));
4425     }
4426
4427     /* need to save off the current version string for later */
4428     if ( vinf ) {
4429         SV * orig = newSVpvn("v.Inf", sizeof("v.Inf")-1);
4430         (void)hv_stores(MUTABLE_HV(hv), "original", orig);
4431         (void)hv_stores(MUTABLE_HV(hv), "vinf", newSViv(1));
4432     }
4433     else if ( s > start ) {
4434         SV * orig = newSVpvn(start,s-start);
4435         if ( qv && saw_decimal == 1 && *start != 'v' ) {
4436             /* need to insert a v to be consistent */
4437             sv_insert(orig, 0, 0, "v", 1);
4438         }
4439         (void)hv_stores(MUTABLE_HV(hv), "original", orig);
4440     }
4441     else {
4442         (void)hv_stores(MUTABLE_HV(hv), "original", newSVpvs("0"));
4443         av_push(av, newSViv(0));
4444     }
4445
4446     /* And finally, store the AV in the hash */
4447     (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av)));
4448
4449     /* fix RT#19517 - special case 'undef' as string */
4450     if ( *s == 'u' && strEQ(s,"undef") ) {
4451         s += 5;
4452     }
4453
4454     return s;
4455 }
4456
4457 /*
4458 =for apidoc new_version
4459
4460 Returns a new version object based on the passed in SV:
4461
4462     SV *sv = new_version(SV *ver);
4463
4464 Does not alter the passed in ver SV.  See "upg_version" if you
4465 want to upgrade the SV.
4466
4467 =cut
4468 */
4469
4470 SV *
4471 Perl_new_version(pTHX_ SV *ver)
4472 {
4473     dVAR;
4474     SV * const rv = newSV(0);
4475     PERL_ARGS_ASSERT_NEW_VERSION;
4476     if ( sv_isobject(ver) && sv_derived_from(ver, "version") )
4477          /* can just copy directly */
4478     {
4479         I32 key;
4480         AV * const av = newAV();
4481         AV *sav;
4482         /* This will get reblessed later if a derived class*/
4483         SV * const hv = newSVrv(rv, "version"); 
4484         (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
4485 #ifndef NODEFAULT_SHAREKEYS
4486         HvSHAREKEYS_on(hv);         /* key-sharing on by default */
4487 #endif
4488
4489         if ( SvROK(ver) )
4490             ver = SvRV(ver);
4491
4492         /* Begin copying all of the elements */
4493         if ( hv_exists(MUTABLE_HV(ver), "qv", 2) )
4494             (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(1));
4495
4496         if ( hv_exists(MUTABLE_HV(ver), "alpha", 5) )
4497             (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(1));
4498
4499         if ( hv_exists(MUTABLE_HV(ver), "width", 5 ) )
4500         {
4501             const I32 width = SvIV(*hv_fetchs(MUTABLE_HV(ver), "width", FALSE));
4502             (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
4503         }
4504
4505         if ( hv_exists(MUTABLE_HV(ver), "original", 8 ) )
4506         {
4507             SV * pv = *hv_fetchs(MUTABLE_HV(ver), "original", FALSE);
4508             (void)hv_stores(MUTABLE_HV(hv), "original", newSVsv(pv));
4509         }
4510
4511         sav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(ver), "version", FALSE)));
4512         /* This will get reblessed later if a derived class*/
4513         for ( key = 0; key <= av_len(sav); key++ )
4514         {
4515             const I32 rev = SvIV(*av_fetch(sav, key, FALSE));
4516             av_push(av, newSViv(rev));
4517         }
4518
4519         (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av)));
4520         return rv;
4521     }
4522 #ifdef SvVOK
4523     {
4524         const MAGIC* const mg = SvVSTRING_mg(ver);
4525         if ( mg ) { /* already a v-string */
4526             const STRLEN len = mg->mg_len;
4527             char * const version = savepvn( (const char*)mg->mg_ptr, len);
4528             sv_setpvn(rv,version,len);
4529             /* this is for consistency with the pure Perl class */
4530             if ( isDIGIT(*version) )
4531                 sv_insert(rv, 0, 0, "v", 1);
4532             Safefree(version);
4533         }
4534         else {
4535 #endif
4536         sv_setsv(rv,ver); /* make a duplicate */
4537 #ifdef SvVOK
4538         }
4539     }
4540 #endif
4541     return upg_version(rv, FALSE);
4542 }
4543
4544 /*
4545 =for apidoc upg_version
4546
4547 In-place upgrade of the supplied SV to a version object.
4548
4549     SV *sv = upg_version(SV *sv, bool qv);
4550
4551 Returns a pointer to the upgraded SV.  Set the boolean qv if you want
4552 to force this SV to be interpreted as an "extended" version.
4553
4554 =cut
4555 */
4556
4557 SV *
4558 Perl_upg_version(pTHX_ SV *ver, bool qv)
4559 {
4560     const char *version, *s;
4561 #ifdef SvVOK
4562     const MAGIC *mg;
4563 #endif
4564
4565     PERL_ARGS_ASSERT_UPG_VERSION;
4566
4567     if ( SvNOK(ver) && !( SvPOK(ver) && sv_len(ver) == 3 ) )
4568     {
4569         STRLEN len;
4570
4571         /* may get too much accuracy */ 
4572         char tbuf[64];
4573         SV *sv = SvNVX(ver) > 10e50 ? newSV(64) : 0;
4574         char *buf;
4575 #ifdef USE_LOCALE_NUMERIC
4576         char *loc = savepv(setlocale(LC_NUMERIC, NULL));
4577         setlocale(LC_NUMERIC, "C");
4578 #endif
4579         if (sv) {
4580             Perl_sv_setpvf(aTHX_ sv, "%.9"NVff, SvNVX(ver));
4581             buf = SvPV(sv, len);
4582         }
4583         else {
4584             len = my_snprintf(tbuf, sizeof(tbuf), "%.9"NVff, SvNVX(ver));
4585             buf = tbuf;
4586         }
4587 #ifdef USE_LOCALE_NUMERIC
4588         setlocale(LC_NUMERIC, loc);
4589         Safefree(loc);
4590 #endif
4591         while (buf[len-1] == '0' && len > 0) len--;
4592         if ( buf[len-1] == '.' ) len--; /* eat the trailing decimal */
4593         version = savepvn(buf, len);
4594         SvREFCNT_dec(sv);
4595     }
4596 #ifdef SvVOK
4597     else if ( (mg = SvVSTRING_mg(ver)) ) { /* already a v-string */
4598         version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
4599         qv = TRUE;
4600     }
4601 #endif
4602     else /* must be a string or something like a string */
4603     {
4604         STRLEN len;
4605         version = savepv(SvPV(ver,len));
4606 #ifndef SvVOK
4607 #  if PERL_VERSION > 5
4608         /* This will only be executed for 5.6.0 - 5.8.0 inclusive */
4609         if ( len >= 3 && !instr(version,".") && !instr(version,"_")) {
4610             /* may be a v-string */
4611             char *testv = (char *)version;
4612             STRLEN tlen = len;
4613             for (tlen=0; tlen < len; tlen++, testv++) {
4614                 /* if one of the characters is non-text assume v-string */
4615                 if (testv[0] < ' ') {
4616                     SV * const nsv = sv_newmortal();
4617                     const char *nver;
4618                     const char *pos;
4619                     int saw_decimal = 0;
4620                     sv_setpvf(nsv,"v%vd",ver);
4621                     pos = nver = savepv(SvPV_nolen(nsv));
4622
4623                     /* scan the resulting formatted string */
4624                     pos++; /* skip the leading 'v' */
4625                     while ( *pos == '.' || isDIGIT(*pos) ) {
4626                         if ( *pos == '.' )
4627                             saw_decimal++ ;
4628                         pos++;
4629                     }
4630
4631                     /* is definitely a v-string */
4632                     if ( saw_decimal >= 2 ) {
4633                         Safefree(version);
4634                         version = nver;
4635                     }
4636                     break;
4637                 }
4638             }
4639         }
4640 #  endif
4641 #endif
4642     }
4643
4644     s = scan_version(version, ver, qv);
4645     if ( *s != '\0' ) 
4646         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), 
4647                        "Version string '%s' contains invalid data; "
4648                        "ignoring: '%s'", version, s);
4649     Safefree(version);
4650     return ver;
4651 }
4652
4653 /*
4654 =for apidoc vverify
4655
4656 Validates that the SV contains valid internal structure for a version object.
4657 It may be passed either the version object (RV) or the hash itself (HV).  If
4658 the structure is valid, it returns the HV.  If the structure is invalid,
4659 it returns NULL.
4660
4661     SV *hv = vverify(sv);
4662
4663 Note that it only confirms the bare minimum structure (so as not to get
4664 confused by derived classes which may contain additional hash entries):
4665
4666 =over 4
4667
4668 =item * The SV is an HV or a reference to an HV
4669
4670 =item * The hash contains a "version" key
4671
4672 =item * The "version" key has a reference to an AV as its value
4673
4674 =back
4675
4676 =cut
4677 */
4678
4679 SV *
4680 Perl_vverify(pTHX_ SV *vs)
4681 {
4682     SV *sv;
4683
4684     PERL_ARGS_ASSERT_VVERIFY;
4685
4686     if ( SvROK(vs) )
4687         vs = SvRV(vs);
4688
4689     /* see if the appropriate elements exist */
4690     if ( SvTYPE(vs) == SVt_PVHV
4691          && hv_exists(MUTABLE_HV(vs), "version", 7)
4692          && (sv = SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)))
4693          && SvTYPE(sv) == SVt_PVAV )
4694         return vs;
4695     else
4696         return NULL;
4697 }
4698
4699 /*
4700 =for apidoc vnumify
4701
4702 Accepts a version object and returns the normalized floating
4703 point representation.  Call like:
4704
4705     sv = vnumify(rv);
4706
4707 NOTE: you can pass either the object directly or the SV
4708 contained within the RV.
4709
4710 The SV returned has a refcount of 1.
4711
4712 =cut
4713 */
4714
4715 SV *
4716 Perl_vnumify(pTHX_ SV *vs)
4717 {
4718     I32 i, len, digit;
4719     int width;
4720     bool alpha = FALSE;
4721     SV *sv;
4722     AV *av;
4723
4724     PERL_ARGS_ASSERT_VNUMIFY;
4725
4726     /* extract the HV from the object */
4727     vs = vverify(vs);
4728     if ( ! vs )
4729         Perl_croak(aTHX_ "Invalid version object");
4730
4731     /* see if various flags exist */
4732     if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
4733         alpha = TRUE;
4734     if ( hv_exists(MUTABLE_HV(vs), "width", 5 ) )
4735         width = SvIV(*hv_fetchs(MUTABLE_HV(vs), "width", FALSE));
4736     else
4737         width = 3;
4738
4739
4740     /* attempt to retrieve the version array */
4741     if ( !(av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE))) ) ) {
4742         return newSVpvs("0");
4743     }
4744
4745     len = av_len(av);
4746     if ( len == -1 )
4747     {
4748         return newSVpvs("0");
4749     }
4750
4751     digit = SvIV(*av_fetch(av, 0, 0));
4752     sv = Perl_newSVpvf(aTHX_ "%d.", (int)PERL_ABS(digit));
4753     for ( i = 1 ; i < len ; i++ )
4754     {
4755         digit = SvIV(*av_fetch(av, i, 0));
4756         if ( width < 3 ) {
4757             const int denom = (width == 2 ? 10 : 100);
4758             const div_t term = div((int)PERL_ABS(digit),denom);
4759             Perl_sv_catpvf(aTHX_ sv, "%0*d_%d", width, term.quot, term.rem);
4760         }
4761         else {
4762             Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
4763         }
4764     }
4765
4766     if ( len > 0 )
4767     {
4768         digit = SvIV(*av_fetch(av, len, 0));
4769         if ( alpha && width == 3 ) /* alpha version */
4770             sv_catpvs(sv,"_");
4771         Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
4772     }
4773     else /* len == 0 */
4774     {
4775         sv_catpvs(sv, "000");
4776     }
4777     return sv;
4778 }
4779
4780 /*
4781 =for apidoc vnormal
4782
4783 Accepts a version object and returns the normalized string
4784 representation.  Call like:
4785
4786     sv = vnormal(rv);
4787
4788 NOTE: you can pass either the object directly or the SV
4789 contained within the RV.
4790
4791 The SV returned has a refcount of 1.
4792
4793 =cut
4794 */
4795
4796 SV *
4797 Perl_vnormal(pTHX_ SV *vs)
4798 {
4799     I32 i, len, digit;
4800     bool alpha = FALSE;
4801     SV *sv;
4802     AV *av;
4803
4804     PERL_ARGS_ASSERT_VNORMAL;
4805
4806     /* extract the HV from the object */
4807     vs = vverify(vs);
4808     if ( ! vs )
4809         Perl_croak(aTHX_ "Invalid version object");
4810
4811     if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
4812         alpha = TRUE;
4813     av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)));
4814
4815     len = av_len(av);
4816     if ( len == -1 )
4817     {
4818         return newSVpvs("");
4819     }
4820     digit = SvIV(*av_fetch(av, 0, 0));
4821     sv = Perl_newSVpvf(aTHX_ "v%"IVdf, (IV)digit);
4822     for ( i = 1 ; i < len ; i++ ) {
4823         digit = SvIV(*av_fetch(av, i, 0));
4824         Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
4825     }
4826
4827     if ( len > 0 )
4828     {
4829         /* handle last digit specially */
4830         digit = SvIV(*av_fetch(av, len, 0));
4831         if ( alpha )
4832             Perl_sv_catpvf(aTHX_ sv, "_%"IVdf, (IV)digit);
4833         else
4834             Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
4835     }
4836
4837     if ( len <= 2 ) { /* short version, must be at least three */
4838         for ( len = 2 - len; len != 0; len-- )
4839             sv_catpvs(sv,".0");
4840     }
4841     return sv;
4842 }
4843
4844 /*
4845 =for apidoc vstringify
4846
4847 In order to maintain maximum compatibility with earlier versions
4848 of Perl, this function will return either the floating point
4849 notation or the multiple dotted notation, depending on whether
4850 the original version contained 1 or more dots, respectively.
4851
4852 The SV returned has a refcount of 1.
4853
4854 =cut
4855 */
4856
4857 SV *
4858 Perl_vstringify(pTHX_ SV *vs)
4859 {
4860     PERL_ARGS_ASSERT_VSTRINGIFY;
4861
4862     /* extract the HV from the object */
4863     vs = vverify(vs);
4864     if ( ! vs )
4865         Perl_croak(aTHX_ "Invalid version object");
4866
4867     if (hv_exists(MUTABLE_HV(vs), "original",  sizeof("original") - 1)) {
4868         SV *pv;
4869         pv = *hv_fetchs(MUTABLE_HV(vs), "original", FALSE);
4870         if ( SvPOK(pv) )
4871             return newSVsv(pv);
4872         else
4873             return &PL_sv_undef;
4874     }
4875     else {
4876         if ( hv_exists(MUTABLE_HV(vs), "qv", 2) )
4877             return vnormal(vs);
4878         else
4879             return vnumify(vs);
4880     }
4881 }
4882
4883 /*
4884 =for apidoc vcmp
4885
4886 Version object aware cmp.  Both operands must already have been 
4887 converted into version objects.
4888
4889 =cut
4890 */
4891
4892 int
4893 Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
4894 {
4895     I32 i,l,m,r,retval;
4896     bool lalpha = FALSE;
4897     bool ralpha = FALSE;
4898     I32 left = 0;
4899     I32 right = 0;
4900     AV *lav, *rav;
4901
4902     PERL_ARGS_ASSERT_VCMP;
4903
4904     /* extract the HVs from the objects */
4905     lhv = vverify(lhv);
4906     rhv = vverify(rhv);
4907     if ( ! ( lhv && rhv ) )
4908         Perl_croak(aTHX_ "Invalid version object");
4909
4910     /* get the left hand term */
4911     lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(lhv), "version", FALSE)));
4912     if ( hv_exists(MUTABLE_HV(lhv), "alpha", 5 ) )
4913         lalpha = TRUE;
4914
4915     /* and the right hand term */
4916     rav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(rhv), "version", FALSE)));
4917     if ( hv_exists(MUTABLE_HV(rhv), "alpha", 5 ) )
4918         ralpha = TRUE;
4919
4920     l = av_len(lav);
4921     r = av_len(rav);
4922     m = l < r ? l : r;
4923     retval = 0;
4924     i = 0;
4925     while ( i <= m && retval == 0 )
4926     {
4927         left  = SvIV(*av_fetch(lav,i,0));
4928         right = SvIV(*av_fetch(rav,i,0));
4929         if ( left < right  )
4930             retval = -1;
4931         if ( left > right )
4932             retval = +1;
4933         i++;
4934     }
4935
4936     /* tiebreaker for alpha with identical terms */
4937     if ( retval == 0 && l == r && left == right && ( lalpha || ralpha ) )
4938     {
4939         if ( lalpha && !ralpha )
4940         {
4941             retval = -1;
4942         }
4943         else if ( ralpha && !lalpha)
4944         {
4945             retval = +1;
4946         }
4947     }
4948
4949     if ( l != r && retval == 0 ) /* possible match except for trailing 0's */
4950     {
4951         if ( l < r )
4952         {
4953             while ( i <= r && retval == 0 )
4954             {
4955                 if ( SvIV(*av_fetch(rav,i,0)) != 0 )
4956                     retval = -1; /* not a match after all */
4957                 i++;
4958             }
4959         }
4960         else
4961         {
4962             while ( i <= l && retval == 0 )
4963             {
4964                 if ( SvIV(*av_fetch(lav,i,0)) != 0 )
4965                     retval = +1; /* not a match after all */
4966                 i++;
4967             }
4968         }
4969     }
4970     return retval;
4971 }
4972
4973 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT)
4974 #   define EMULATE_SOCKETPAIR_UDP
4975 #endif
4976
4977 #ifdef EMULATE_SOCKETPAIR_UDP
4978 static int
4979 S_socketpair_udp (int fd[2]) {
4980     dTHX;
4981     /* Fake a datagram socketpair using UDP to localhost.  */
4982     int sockets[2] = {-1, -1};
4983     struct sockaddr_in addresses[2];
4984     int i;
4985     Sock_size_t size = sizeof(struct sockaddr_in);
4986     unsigned short port;
4987     int got;
4988
4989     memset(&addresses, 0, sizeof(addresses));
4990     i = 1;
4991     do {
4992         sockets[i] = PerlSock_socket(AF_INET, SOCK_DGRAM, PF_INET);
4993         if (sockets[i] == -1)
4994             goto tidy_up_and_fail;
4995
4996         addresses[i].sin_family = AF_INET;
4997         addresses[i].sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4998         addresses[i].sin_port = 0;      /* kernel choses port.  */
4999         if (PerlSock_bind(sockets[i], (struct sockaddr *) &addresses[i],
5000                 sizeof(struct sockaddr_in)) == -1)
5001             goto tidy_up_and_fail;
5002     } while (i--);
5003
5004     /* Now have 2 UDP sockets. Find out which port each is connected to, and
5005        for each connect the other socket to it.  */
5006     i = 1;
5007     do {
5008         if (PerlSock_getsockname(sockets[i], (struct sockaddr *) &addresses[i],
5009                 &size) == -1)
5010             goto tidy_up_and_fail;
5011         if (size != sizeof(struct sockaddr_in))
5012             goto abort_tidy_up_and_fail;
5013         /* !1 is 0, !0 is 1 */
5014         if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i],
5015                 sizeof(struct sockaddr_in)) == -1)
5016             goto