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