better perldelta description for #120091/#118059
[perl.git] / util.c
1 /*    util.c
2  *
3  *    Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001,
4  *    2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
5  *
6  *    You may distribute under the terms of either the GNU General Public
7  *    License or the Artistic License, as specified in the README file.
8  *
9  */
10
11 /*
12  * 'Very useful, no doubt, that was to Saruman; yet it seems that he was
13  *  not content.'                                    --Gandalf to Pippin
14  *
15  *     [p.598 of _The Lord of the Rings_, III/xi: "The Palantír"]
16  */
17
18 /* This file contains assorted utility routines.
19  * Which is a polite way of saying any stuff that people couldn't think of
20  * a better place for. Amongst other things, it includes the warning and
21  * dieing stuff, plus wrappers for malloc code.
22  */
23
24 #include "EXTERN.h"
25 #define PERL_IN_UTIL_C
26 #include "perl.h"
27 #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     (void)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     bool should_wait;
2710
2711     svp = av_fetch(PL_fdpid,fd,TRUE);
2712     pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
2713     SvREFCNT_dec(*svp);
2714     *svp = NULL;
2715
2716 #ifdef USE_PERLIO
2717     /* Find out whether the refcount is low enough for us to wait for the
2718        child proc without blocking. */
2719     should_wait = PerlIOUnix_refcnt(fd) == 1 && pid > 0;
2720 #else
2721     should_wait = pid > 0;
2722 #endif
2723
2724 #ifdef OS2
2725     if (pid == -1) {                    /* Opened by popen. */
2726         return my_syspclose(ptr);
2727     }
2728 #endif
2729     close_failed = (PerlIO_close(ptr) == EOF);
2730     SAVE_ERRNO;
2731     if (should_wait) do {
2732         pid2 = wait4pid(pid, &status, 0);
2733     } while (pid2 == -1 && errno == EINTR);
2734     if (close_failed) {
2735         RESTORE_ERRNO;
2736         return -1;
2737     }
2738     return(
2739       should_wait
2740        ? pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status)
2741        : 0
2742     );
2743 }
2744 #else
2745 #if defined(__LIBCATAMOUNT__)
2746 I32
2747 Perl_my_pclose(pTHX_ PerlIO *ptr)
2748 {
2749     return -1;
2750 }
2751 #endif
2752 #endif /* !DOSISH */
2753
2754 #if  (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(__LIBCATAMOUNT__)
2755 I32
2756 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
2757 {
2758     dVAR;
2759     I32 result = 0;
2760     PERL_ARGS_ASSERT_WAIT4PID;
2761 #ifdef PERL_USES_PL_PIDSTATUS
2762     if (!pid) {
2763         /* PERL_USES_PL_PIDSTATUS is only defined when neither
2764            waitpid() nor wait4() is available, or on OS/2, which
2765            doesn't appear to support waiting for a progress group
2766            member, so we can only treat a 0 pid as an unknown child.
2767         */
2768         errno = ECHILD;
2769         return -1;
2770     }
2771     {
2772         if (pid > 0) {
2773             /* The keys in PL_pidstatus are now the raw 4 (or 8) bytes of the
2774                pid, rather than a string form.  */
2775             SV * const * const svp = hv_fetch(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),FALSE);
2776             if (svp && *svp != &PL_sv_undef) {
2777                 *statusp = SvIVX(*svp);
2778                 (void)hv_delete(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),
2779                                 G_DISCARD);
2780                 return pid;
2781             }
2782         }
2783         else {
2784             HE *entry;
2785
2786             hv_iterinit(PL_pidstatus);
2787             if ((entry = hv_iternext(PL_pidstatus))) {
2788                 SV * const sv = hv_iterval(PL_pidstatus,entry);
2789                 I32 len;
2790                 const char * const spid = hv_iterkey(entry,&len);
2791
2792                 assert (len == sizeof(Pid_t));
2793                 memcpy((char *)&pid, spid, len);
2794                 *statusp = SvIVX(sv);
2795                 /* The hash iterator is currently on this entry, so simply
2796                    calling hv_delete would trigger the lazy delete, which on
2797                    aggregate does more work, beacuse next call to hv_iterinit()
2798                    would spot the flag, and have to call the delete routine,
2799                    while in the meantime any new entries can't re-use that
2800                    memory.  */
2801                 hv_iterinit(PL_pidstatus);
2802                 (void)hv_delete(PL_pidstatus,spid,len,G_DISCARD);
2803                 return pid;
2804             }
2805         }
2806     }
2807 #endif
2808 #ifdef HAS_WAITPID
2809 #  ifdef HAS_WAITPID_RUNTIME
2810     if (!HAS_WAITPID_RUNTIME)
2811         goto hard_way;
2812 #  endif
2813     result = PerlProc_waitpid(pid,statusp,flags);
2814     goto finish;
2815 #endif
2816 #if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
2817     result = wait4(pid,statusp,flags,NULL);
2818     goto finish;
2819 #endif
2820 #ifdef PERL_USES_PL_PIDSTATUS
2821 #if defined(HAS_WAITPID) && defined(HAS_WAITPID_RUNTIME)
2822   hard_way:
2823 #endif
2824     {
2825         if (flags)
2826             Perl_croak(aTHX_ "Can't do waitpid with flags");
2827         else {
2828             while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
2829                 pidgone(result,*statusp);
2830             if (result < 0)
2831                 *statusp = -1;
2832         }
2833     }
2834 #endif
2835 #if defined(HAS_WAITPID) || defined(HAS_WAIT4)
2836   finish:
2837 #endif
2838     if (result < 0 && errno == EINTR) {
2839         PERL_ASYNC_CHECK();
2840         errno = EINTR; /* reset in case a signal handler changed $! */
2841     }
2842     return result;
2843 }
2844 #endif /* !DOSISH || OS2 || WIN32 || NETWARE */
2845
2846 #ifdef PERL_USES_PL_PIDSTATUS
2847 void
2848 S_pidgone(pTHX_ Pid_t pid, int status)
2849 {
2850     SV *sv;
2851
2852     sv = *hv_fetch(PL_pidstatus,(const char*)&pid,sizeof(Pid_t),TRUE);
2853     SvUPGRADE(sv,SVt_IV);
2854     SvIV_set(sv, status);
2855     return;
2856 }
2857 #endif
2858
2859 #if defined(OS2)
2860 int pclose();
2861 #ifdef HAS_FORK
2862 int                                     /* Cannot prototype with I32
2863                                            in os2ish.h. */
2864 my_syspclose(PerlIO *ptr)
2865 #else
2866 I32
2867 Perl_my_pclose(pTHX_ PerlIO *ptr)
2868 #endif
2869 {
2870     /* Needs work for PerlIO ! */
2871     FILE * const f = PerlIO_findFILE(ptr);
2872     const I32 result = pclose(f);
2873     PerlIO_releaseFILE(ptr,f);
2874     return result;
2875 }
2876 #endif
2877
2878 #if defined(DJGPP)
2879 int djgpp_pclose();
2880 I32
2881 Perl_my_pclose(pTHX_ PerlIO *ptr)
2882 {
2883     /* Needs work for PerlIO ! */
2884     FILE * const f = PerlIO_findFILE(ptr);
2885     I32 result = djgpp_pclose(f);
2886     result = (result << 8) & 0xff00;
2887     PerlIO_releaseFILE(ptr,f);
2888     return result;
2889 }
2890 #endif
2891
2892 #define PERL_REPEATCPY_LINEAR 4
2893 void
2894 Perl_repeatcpy(char *to, const char *from, I32 len, IV count)
2895 {
2896     PERL_ARGS_ASSERT_REPEATCPY;
2897
2898     assert(len >= 0);
2899
2900     if (count < 0)
2901         croak_memory_wrap();
2902
2903     if (len == 1)
2904         memset(to, *from, count);
2905     else if (count) {
2906         char *p = to;
2907         IV items, linear, half;
2908
2909         linear = count < PERL_REPEATCPY_LINEAR ? count : PERL_REPEATCPY_LINEAR;
2910         for (items = 0; items < linear; ++items) {
2911             const char *q = from;
2912             IV todo;
2913             for (todo = len; todo > 0; todo--)
2914                 *p++ = *q++;
2915         }
2916
2917         half = count / 2;
2918         while (items <= half) {
2919             IV size = items * len;
2920             memcpy(p, to, size);
2921             p     += size;
2922             items *= 2;
2923         }
2924
2925         if (count > items)
2926             memcpy(p, to, (count - items) * len);
2927     }
2928 }
2929
2930 #ifndef HAS_RENAME
2931 I32
2932 Perl_same_dirent(pTHX_ const char *a, const char *b)
2933 {
2934     char *fa = strrchr(a,'/');
2935     char *fb = strrchr(b,'/');
2936     Stat_t tmpstatbuf1;
2937     Stat_t tmpstatbuf2;
2938     SV * const tmpsv = sv_newmortal();
2939
2940     PERL_ARGS_ASSERT_SAME_DIRENT;
2941
2942     if (fa)
2943         fa++;
2944     else
2945         fa = a;
2946     if (fb)
2947         fb++;
2948     else
2949         fb = b;
2950     if (strNE(a,b))
2951         return FALSE;
2952     if (fa == a)
2953         sv_setpvs(tmpsv, ".");
2954     else
2955         sv_setpvn(tmpsv, a, fa - a);
2956     if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0)
2957         return FALSE;
2958     if (fb == b)
2959         sv_setpvs(tmpsv, ".");
2960     else
2961         sv_setpvn(tmpsv, b, fb - b);
2962     if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0)
2963         return FALSE;
2964     return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
2965            tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
2966 }
2967 #endif /* !HAS_RENAME */
2968
2969 char*
2970 Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
2971                  const char *const *const search_ext, I32 flags)
2972 {
2973     dVAR;
2974     const char *xfound = NULL;
2975     char *xfailed = NULL;
2976     char tmpbuf[MAXPATHLEN];
2977     char *s;
2978     I32 len = 0;
2979     int retval;
2980     char *bufend;
2981 #if defined(DOSISH) && !defined(OS2)
2982 #  define SEARCH_EXTS ".bat", ".cmd", NULL
2983 #  define MAX_EXT_LEN 4
2984 #endif
2985 #ifdef OS2
2986 #  define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
2987 #  define MAX_EXT_LEN 4
2988 #endif
2989 #ifdef VMS
2990 #  define SEARCH_EXTS ".pl", ".com", NULL
2991 #  define MAX_EXT_LEN 4
2992 #endif
2993     /* additional extensions to try in each dir if scriptname not found */
2994 #ifdef SEARCH_EXTS
2995     static const char *const exts[] = { SEARCH_EXTS };
2996     const char *const *const ext = search_ext ? search_ext : exts;
2997     int extidx = 0, i = 0;
2998     const char *curext = NULL;
2999 #else
3000     PERL_UNUSED_ARG(search_ext);
3001 #  define MAX_EXT_LEN 0
3002 #endif
3003
3004     PERL_ARGS_ASSERT_FIND_SCRIPT;
3005
3006     /*
3007      * If dosearch is true and if scriptname does not contain path
3008      * delimiters, search the PATH for scriptname.
3009      *
3010      * If SEARCH_EXTS is also defined, will look for each
3011      * scriptname{SEARCH_EXTS} whenever scriptname is not found
3012      * while searching the PATH.
3013      *
3014      * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
3015      * proceeds as follows:
3016      *   If DOSISH or VMSISH:
3017      *     + look for ./scriptname{,.foo,.bar}
3018      *     + search the PATH for scriptname{,.foo,.bar}
3019      *
3020      *   If !DOSISH:
3021      *     + look *only* in the PATH for scriptname{,.foo,.bar} (note
3022      *       this will not look in '.' if it's not in the PATH)
3023      */
3024     tmpbuf[0] = '\0';
3025
3026 #ifdef VMS
3027 #  ifdef ALWAYS_DEFTYPES
3028     len = strlen(scriptname);
3029     if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
3030         int idx = 0, deftypes = 1;
3031         bool seen_dot = 1;
3032
3033         const int hasdir = !dosearch || (strpbrk(scriptname,":[</") != NULL);
3034 #  else
3035     if (dosearch) {
3036         int idx = 0, deftypes = 1;
3037         bool seen_dot = 1;
3038
3039         const int hasdir = (strpbrk(scriptname,":[</") != NULL);
3040 #  endif
3041         /* The first time through, just add SEARCH_EXTS to whatever we
3042          * already have, so we can check for default file types. */
3043         while (deftypes ||
3044                (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
3045         {
3046             if (deftypes) {
3047                 deftypes = 0;
3048                 *tmpbuf = '\0';
3049             }
3050             if ((strlen(tmpbuf) + strlen(scriptname)
3051                  + MAX_EXT_LEN) >= sizeof tmpbuf)
3052                 continue;       /* don't search dir with too-long name */
3053             my_strlcat(tmpbuf, scriptname, sizeof(tmpbuf));
3054 #else  /* !VMS */
3055
3056 #ifdef DOSISH
3057     if (strEQ(scriptname, "-"))
3058         dosearch = 0;
3059     if (dosearch) {             /* Look in '.' first. */
3060         const char *cur = scriptname;
3061 #ifdef SEARCH_EXTS
3062         if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
3063             while (ext[i])
3064                 if (strEQ(ext[i++],curext)) {
3065                     extidx = -1;                /* already has an ext */
3066                     break;
3067                 }
3068         do {
3069 #endif
3070             DEBUG_p(PerlIO_printf(Perl_debug_log,
3071                                   "Looking for %s\n",cur));
3072             if (PerlLIO_stat(cur,&PL_statbuf) >= 0
3073                 && !S_ISDIR(PL_statbuf.st_mode)) {
3074                 dosearch = 0;
3075                 scriptname = cur;
3076 #ifdef SEARCH_EXTS
3077                 break;
3078 #endif
3079             }
3080 #ifdef SEARCH_EXTS
3081             if (cur == scriptname) {
3082                 len = strlen(scriptname);
3083                 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
3084                     break;
3085                 my_strlcpy(tmpbuf, scriptname, sizeof(tmpbuf));
3086                 cur = tmpbuf;
3087             }
3088         } while (extidx >= 0 && ext[extidx]     /* try an extension? */
3089                  && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len));
3090 #endif
3091     }
3092 #endif
3093
3094     if (dosearch && !strchr(scriptname, '/')
3095 #ifdef DOSISH
3096                  && !strchr(scriptname, '\\')
3097 #endif
3098                  && (s = PerlEnv_getenv("PATH")))
3099     {
3100         bool seen_dot = 0;
3101
3102         bufend = s + strlen(s);
3103         while (s < bufend) {
3104 #  ifdef DOSISH
3105             for (len = 0; *s
3106                     && *s != ';'; len++, s++) {
3107                 if (len < sizeof tmpbuf)
3108                     tmpbuf[len] = *s;
3109             }
3110             if (len < sizeof tmpbuf)
3111                 tmpbuf[len] = '\0';
3112 #  else
3113             s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend,
3114                         ':',
3115                         &len);
3116 #  endif
3117             if (s < bufend)
3118                 s++;
3119             if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
3120                 continue;       /* don't search dir with too-long name */
3121             if (len
3122 #  ifdef DOSISH
3123                 && tmpbuf[len - 1] != '/'
3124                 && tmpbuf[len - 1] != '\\'
3125 #  endif
3126                )
3127                 tmpbuf[len++] = '/';
3128             if (len == 2 && tmpbuf[0] == '.')
3129                 seen_dot = 1;
3130             (void)my_strlcpy(tmpbuf + len, scriptname, sizeof(tmpbuf) - len);
3131 #endif  /* !VMS */
3132
3133 #ifdef SEARCH_EXTS
3134             len = strlen(tmpbuf);
3135             if (extidx > 0)     /* reset after previous loop */
3136                 extidx = 0;
3137             do {
3138 #endif
3139                 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
3140                 retval = PerlLIO_stat(tmpbuf,&PL_statbuf);
3141                 if (S_ISDIR(PL_statbuf.st_mode)) {
3142                     retval = -1;
3143                 }
3144 #ifdef SEARCH_EXTS
3145             } while (  retval < 0               /* not there */
3146                     && extidx>=0 && ext[extidx] /* try an extension? */
3147                     && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len)
3148                 );
3149 #endif
3150             if (retval < 0)
3151                 continue;
3152             if (S_ISREG(PL_statbuf.st_mode)
3153                 && cando(S_IRUSR,TRUE,&PL_statbuf)
3154 #if !defined(DOSISH)
3155                 && cando(S_IXUSR,TRUE,&PL_statbuf)
3156 #endif
3157                 )
3158             {
3159                 xfound = tmpbuf;                /* bingo! */
3160                 break;
3161             }
3162             if (!xfailed)
3163                 xfailed = savepv(tmpbuf);
3164         }
3165 #ifndef DOSISH
3166         if (!xfound && !seen_dot && !xfailed &&
3167             (PerlLIO_stat(scriptname,&PL_statbuf) < 0
3168              || S_ISDIR(PL_statbuf.st_mode)))
3169 #endif
3170             seen_dot = 1;                       /* Disable message. */
3171         if (!xfound) {
3172             if (flags & 1) {                    /* do or die? */
3173                 /* diag_listed_as: Can't execute %s */
3174                 Perl_croak(aTHX_ "Can't %s %s%s%s",
3175                       (xfailed ? "execute" : "find"),
3176                       (xfailed ? xfailed : scriptname),
3177                       (xfailed ? "" : " on PATH"),
3178                       (xfailed || seen_dot) ? "" : ", '.' not in PATH");
3179             }
3180             scriptname = NULL;
3181         }
3182         Safefree(xfailed);
3183         scriptname = xfound;
3184     }
3185     return (scriptname ? savepv(scriptname) : NULL);
3186 }
3187
3188 #ifndef PERL_GET_CONTEXT_DEFINED
3189
3190 void *
3191 Perl_get_context(void)
3192 {
3193     dVAR;
3194 #if defined(USE_ITHREADS)
3195 #  ifdef OLD_PTHREADS_API
3196     pthread_addr_t t;
3197     int error = pthread_getspecific(PL_thr_key, &t)
3198     if (error)
3199         Perl_croak_nocontext("panic: pthread_getspecific, error=%d", error);
3200     return (void*)t;
3201 #  else
3202 #    ifdef I_MACH_CTHREADS
3203     return (void*)cthread_data(cthread_self());
3204 #    else
3205     return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
3206 #    endif
3207 #  endif
3208 #else
3209     return (void*)NULL;
3210 #endif
3211 }
3212
3213 void
3214 Perl_set_context(void *t)
3215 {
3216     dVAR;
3217     PERL_ARGS_ASSERT_SET_CONTEXT;
3218 #if defined(USE_ITHREADS)
3219 #  ifdef I_MACH_CTHREADS
3220     cthread_set_data(cthread_self(), t);
3221 #  else
3222     {
3223         const int error = pthread_setspecific(PL_thr_key, t);
3224         if (error)
3225             Perl_croak_nocontext("panic: pthread_setspecific, error=%d", error);
3226     }
3227 #  endif
3228 #else
3229     PERL_UNUSED_ARG(t);
3230 #endif
3231 }
3232
3233 #endif /* !PERL_GET_CONTEXT_DEFINED */
3234
3235 #if defined(PERL_GLOBAL_STRUCT) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
3236 struct perl_vars *
3237 Perl_GetVars(pTHX)
3238 {
3239  return &PL_Vars;
3240 }
3241 #endif
3242
3243 char **
3244 Perl_get_op_names(pTHX)
3245 {
3246     PERL_UNUSED_CONTEXT;
3247     return (char **)PL_op_name;
3248 }
3249
3250 char **
3251 Perl_get_op_descs(pTHX)
3252 {
3253     PERL_UNUSED_CONTEXT;
3254     return (char **)PL_op_desc;
3255 }
3256
3257 const char *
3258 Perl_get_no_modify(pTHX)
3259 {
3260     PERL_UNUSED_CONTEXT;
3261     return PL_no_modify;
3262 }
3263
3264 U32 *
3265 Perl_get_opargs(pTHX)
3266 {
3267     PERL_UNUSED_CONTEXT;
3268     return (U32 *)PL_opargs;
3269 }
3270
3271 PPADDR_t*
3272 Perl_get_ppaddr(pTHX)
3273 {
3274     dVAR;
3275     PERL_UNUSED_CONTEXT;
3276     return (PPADDR_t*)PL_ppaddr;
3277 }
3278
3279 #ifndef HAS_GETENV_LEN
3280 char *
3281 Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
3282 {
3283     char * const env_trans = PerlEnv_getenv(env_elem);
3284     PERL_UNUSED_CONTEXT;
3285     PERL_ARGS_ASSERT_GETENV_LEN;
3286     if (env_trans)
3287         *len = strlen(env_trans);
3288     return env_trans;
3289 }
3290 #endif
3291
3292
3293 MGVTBL*
3294 Perl_get_vtbl(pTHX_ int vtbl_id)
3295 {
3296     PERL_UNUSED_CONTEXT;
3297
3298     return (vtbl_id < 0 || vtbl_id >= magic_vtable_max)
3299         ? NULL : PL_magic_vtables + vtbl_id;
3300 }
3301
3302 I32
3303 Perl_my_fflush_all(pTHX)
3304 {
3305 #if defined(USE_PERLIO) || defined(FFLUSH_NULL) || defined(USE_SFIO)
3306     return PerlIO_flush(NULL);
3307 #else
3308 # if defined(HAS__FWALK)
3309     extern int fflush(FILE *);
3310     /* undocumented, unprototyped, but very useful BSDism */
3311     extern void _fwalk(int (*)(FILE *));
3312     _fwalk(&fflush);
3313     return 0;
3314 # else
3315 #  if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
3316     long open_max = -1;
3317 #   ifdef PERL_FFLUSH_ALL_FOPEN_MAX
3318     open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
3319 #   else
3320 #    if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
3321     open_max = sysconf(_SC_OPEN_MAX);
3322 #     else
3323 #      ifdef FOPEN_MAX
3324     open_max = FOPEN_MAX;
3325 #      else
3326 #       ifdef OPEN_MAX
3327     open_max = OPEN_MAX;
3328 #       else
3329 #        ifdef _NFILE
3330     open_max = _NFILE;
3331 #        endif
3332 #       endif
3333 #      endif
3334 #     endif
3335 #    endif
3336     if (open_max > 0) {
3337       long i;
3338       for (i = 0; i < open_max; i++)
3339             if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
3340                 STDIO_STREAM_ARRAY[i]._file < open_max &&
3341                 STDIO_STREAM_ARRAY[i]._flag)
3342                 PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
3343       return 0;
3344     }
3345 #  endif
3346     SETERRNO(EBADF,RMS_IFI);
3347     return EOF;
3348 # endif
3349 #endif
3350 }
3351
3352 void
3353 Perl_report_wrongway_fh(pTHX_ const GV *gv, const char have)
3354 {
3355     if (ckWARN(WARN_IO)) {
3356         HEK * const name
3357            = gv && (isGV_with_GP(gv))
3358                 ? GvENAME_HEK((gv))
3359                 : NULL;
3360         const char * const direction = have == '>' ? "out" : "in";
3361
3362         if (name && HEK_LEN(name))
3363             Perl_warner(aTHX_ packWARN(WARN_IO),
3364                         "Filehandle %"HEKf" opened only for %sput",
3365                         name, direction);
3366         else
3367             Perl_warner(aTHX_ packWARN(WARN_IO),
3368                         "Filehandle opened only for %sput", direction);
3369     }
3370 }
3371
3372 void
3373 Perl_report_evil_fh(pTHX_ const GV *gv)
3374 {
3375     const IO *io = gv ? GvIO(gv) : NULL;
3376     const PERL_BITFIELD16 op = PL_op->op_type;
3377     const char *vile;
3378     I32 warn_type;
3379
3380     if (io && IoTYPE(io) == IoTYPE_CLOSED) {
3381         vile = "closed";
3382         warn_type = WARN_CLOSED;
3383     }
3384     else {
3385         vile = "unopened";
3386         warn_type = WARN_UNOPENED;
3387     }
3388
3389     if (ckWARN(warn_type)) {
3390         SV * const name
3391             = gv && isGV_with_GP(gv) && GvENAMELEN(gv) ?
3392                                      sv_2mortal(newSVhek(GvENAME_HEK(gv))) : NULL;
3393         const char * const pars =
3394             (const char *)(OP_IS_FILETEST(op) ? "" : "()");
3395         const char * const func =
3396             (const char *)
3397             (op == OP_READLINE   ? "readline"  :        /* "<HANDLE>" not nice */
3398              op == OP_LEAVEWRITE ? "write" :            /* "write exit" not nice */
3399              PL_op_desc[op]);
3400         const char * const type =
3401             (const char *)
3402             (OP_IS_SOCKET(op) || (io && IoTYPE(io) == IoTYPE_SOCKET)
3403              ? "socket" : "filehandle");
3404         const bool have_name = name && SvCUR(name);
3405         Perl_warner(aTHX_ packWARN(warn_type),
3406                    "%s%s on %s %s%s%"SVf, func, pars, vile, type,
3407                     have_name ? " " : "",
3408                     SVfARG(have_name ? name : &PL_sv_no));
3409         if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3410                 Perl_warner(
3411                             aTHX_ packWARN(warn_type),
3412                         "\t(Are you trying to call %s%s on dirhandle%s%"SVf"?)\n",
3413                         func, pars, have_name ? " " : "",
3414                         SVfARG(have_name ? name : &PL_sv_no)
3415                             );
3416     }
3417 }
3418
3419 /* To workaround core dumps from the uninitialised tm_zone we get the
3420  * system to give us a reasonable struct to copy.  This fix means that
3421  * strftime uses the tm_zone and tm_gmtoff values returned by
3422  * localtime(time()). That should give the desired result most of the
3423  * time. But probably not always!
3424  *
3425  * This does not address tzname aspects of NETaa14816.
3426  *
3427  */
3428
3429 #ifdef __GLIBC__
3430 # ifndef STRUCT_TM_HASZONE
3431 #    define STRUCT_TM_HASZONE
3432 # endif
3433 #endif
3434
3435 #ifdef STRUCT_TM_HASZONE /* Backward compat */
3436 # ifndef HAS_TM_TM_ZONE
3437 #    define HAS_TM_TM_ZONE
3438 # endif
3439 #endif
3440
3441 void
3442 Perl_init_tm(pTHX_ struct tm *ptm)      /* see mktime, strftime and asctime */
3443 {
3444 #ifdef HAS_TM_TM_ZONE
3445     Time_t now;
3446     const struct tm* my_tm;
3447     PERL_ARGS_ASSERT_INIT_TM;
3448     (void)time(&now);
3449     my_tm = localtime(&now);
3450     if (my_tm)
3451         Copy(my_tm, ptm, 1, struct tm);
3452 #else
3453     PERL_ARGS_ASSERT_INIT_TM;
3454     PERL_UNUSED_ARG(ptm);
3455 #endif
3456 }
3457
3458 /*
3459  * mini_mktime - normalise struct tm values without the localtime()
3460  * semantics (and overhead) of mktime().
3461  */
3462 void
3463 Perl_mini_mktime(pTHX_ struct tm *ptm)
3464 {
3465     int yearday;
3466     int secs;
3467     int month, mday, year, jday;
3468     int odd_cent, odd_year;
3469     PERL_UNUSED_CONTEXT;
3470
3471     PERL_ARGS_ASSERT_MINI_MKTIME;
3472
3473 #define DAYS_PER_YEAR   365
3474 #define DAYS_PER_QYEAR  (4*DAYS_PER_YEAR+1)
3475 #define DAYS_PER_CENT   (25*DAYS_PER_QYEAR-1)
3476 #define DAYS_PER_QCENT  (4*DAYS_PER_CENT+1)
3477 #define SECS_PER_HOUR   (60*60)
3478 #define SECS_PER_DAY    (24*SECS_PER_HOUR)
3479 /* parentheses deliberately absent on these two, otherwise they don't work */
3480 #define MONTH_TO_DAYS   153/5
3481 #define DAYS_TO_MONTH   5/153
3482 /* offset to bias by March (month 4) 1st between month/mday & year finding */
3483 #define YEAR_ADJUST     (4*MONTH_TO_DAYS+1)
3484 /* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */
3485 #define WEEKDAY_BIAS    6       /* (1+6)%7 makes Sunday 0 again */
3486
3487 /*
3488  * Year/day algorithm notes:
3489  *
3490  * With a suitable offset for numeric value of the month, one can find
3491  * an offset into the year by considering months to have 30.6 (153/5) days,
3492  * using integer arithmetic (i.e., with truncation).  To avoid too much
3493  * messing about with leap days, we consider January and February to be
3494  * the 13th and 14th month of the previous year.  After that transformation,
3495  * we need the month index we use to be high by 1 from 'normal human' usage,
3496  * so the month index values we use run from 4 through 15.
3497  *
3498  * Given that, and the rules for the Gregorian calendar (leap years are those
3499  * divisible by 4 unless also divisible by 100, when they must be divisible
3500  * by 400 instead), we can simply calculate the number of days since some
3501  * arbitrary 'beginning of time' by futzing with the (adjusted) year number,
3502  * the days we derive from our month index, and adding in the day of the
3503  * month.  The value used here is not adjusted for the actual origin which
3504  * it normally would use (1 January A.D. 1), since we're not exposing it.
3505  * We're only building the value so we can turn around and get the
3506  * normalised values for the year, month, day-of-month, and day-of-year.
3507  *
3508  * For going backward, we need to bias the value we're using so that we find
3509  * the right year value.  (Basically, we don't want the contribution of
3510  * March 1st to the number to apply while deriving the year).  Having done
3511  * that, we 'count up' the contribution to the year number by accounting for
3512  * full quadracenturies (400-year periods) with their extra leap days, plus
3513  * the contribution from full centuries (to avoid counting in the lost leap
3514  * days), plus the contribution from full quad-years (to count in the normal
3515  * leap days), plus the leftover contribution from any non-leap years.
3516  * At this point, if we were working with an actual leap day, we'll have 0
3517  * days left over.  This is also true for March 1st, however.  So, we have
3518  * to special-case that result, and (earlier) keep track of the 'odd'
3519  * century and year contributions.  If we got 4 extra centuries in a qcent,
3520  * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb.
3521  * Otherwise, we add back in the earlier bias we removed (the 123 from
3522  * figuring in March 1st), find the month index (integer division by 30.6),
3523  * and the remainder is the day-of-month.  We then have to convert back to
3524  * 'real' months (including fixing January and February from being 14/15 in
3525  * the previous year to being in the proper year).  After that, to get
3526  * tm_yday, we work with the normalised year and get a new yearday value for
3527  * January 1st, which we subtract from the yearday value we had earlier,
3528  * representing the date we've re-built.  This is done from January 1
3529  * because tm_yday is 0-origin.
3530  *
3531  * Since POSIX time routines are only guaranteed to work for times since the
3532  * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm
3533  * applies Gregorian calendar rules even to dates before the 16th century
3534  * doesn't bother me.  Besides, you'd need cultural context for a given
3535  * date to know whether it was Julian or Gregorian calendar, and that's
3536  * outside the scope for this routine.  Since we convert back based on the
3537  * same rules we used to build the yearday, you'll only get strange results
3538  * for input which needed normalising, or for the 'odd' century years which
3539  * were leap years in the Julian calendar but not in the Gregorian one.
3540  * I can live with that.
3541  *
3542  * This algorithm also fails to handle years before A.D. 1 gracefully, but
3543  * that's still outside the scope for POSIX time manipulation, so I don't
3544  * care.
3545  */
3546
3547     year = 1900 + ptm->tm_year;
3548     month = ptm->tm_mon;
3549     mday = ptm->tm_mday;
3550     jday = 0;
3551     if (month >= 2)
3552         month+=2;
3553     else
3554         month+=14, year--;
3555     yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400;
3556     yearday += month*MONTH_TO_DAYS + mday + jday;
3557     /*
3558      * Note that we don't know when leap-seconds were or will be,
3559      * so we have to trust the user if we get something which looks
3560      * like a sensible leap-second.  Wild values for seconds will
3561      * be rationalised, however.
3562      */
3563     if ((unsigned) ptm->tm_sec <= 60) {
3564         secs = 0;
3565     }
3566     else {
3567         secs = ptm->tm_sec;
3568         ptm->tm_sec = 0;
3569     }
3570     secs += 60 * ptm->tm_min;
3571     secs += SECS_PER_HOUR * ptm->tm_hour;
3572     if (secs < 0) {
3573         if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) {
3574             /* got negative remainder, but need positive time */
3575             /* back off an extra day to compensate */
3576             yearday += (secs/SECS_PER_DAY)-1;
3577             secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1);
3578         }
3579         else {
3580             yearday += (secs/SECS_PER_DAY);
3581             secs -= SECS_PER_DAY * (secs/SECS_PER_DAY);
3582         }
3583     }
3584     else if (secs >= SECS_PER_DAY) {
3585         yearday += (secs/SECS_PER_DAY);
3586         secs %= SECS_PER_DAY;
3587     }
3588     ptm->tm_hour = secs/SECS_PER_HOUR;
3589     secs %= SECS_PER_HOUR;
3590     ptm->tm_min = secs/60;
3591     secs %= 60;
3592     ptm->tm_sec += secs;
3593     /* done with time of day effects */
3594     /*
3595      * The algorithm for yearday has (so far) left it high by 428.
3596      * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to
3597      * bias it by 123 while trying to figure out what year it
3598      * really represents.  Even with this tweak, the reverse
3599      * translation fails for years before A.D. 0001.
3600      * It would still fail for Feb 29, but we catch that one below.
3601      */
3602     jday = yearday;     /* save for later fixup vis-a-vis Jan 1 */
3603     yearday -= YEAR_ADJUST;
3604     year = (yearday / DAYS_PER_QCENT) * 400;
3605     yearday %= DAYS_PER_QCENT;
3606     odd_cent = yearday / DAYS_PER_CENT;
3607     year += odd_cent * 100;
3608     yearday %= DAYS_PER_CENT;
3609     year += (yearday / DAYS_PER_QYEAR) * 4;
3610     yearday %= DAYS_PER_QYEAR;
3611     odd_year = yearday / DAYS_PER_YEAR;
3612     year += odd_year;
3613     yearday %= DAYS_PER_YEAR;
3614     if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */
3615         month = 1;
3616         yearday = 29;
3617     }
3618     else {
3619         yearday += YEAR_ADJUST; /* recover March 1st crock */
3620         month = yearday*DAYS_TO_MONTH;
3621         yearday -= month*MONTH_TO_DAYS;
3622         /* recover other leap-year adjustment */
3623         if (month > 13) {
3624             month-=14;
3625             year++;
3626         }
3627         else {
3628             month-=2;
3629         }
3630     }
3631     ptm->tm_year = year - 1900;
3632     if (yearday) {
3633       ptm->tm_mday = yearday;
3634       ptm->tm_mon = month;
3635     }
3636     else {
3637       ptm->tm_mday = 31;
3638       ptm->tm_mon = month - 1;
3639     }
3640     /* re-build yearday based on Jan 1 to get tm_yday */
3641     year--;
3642     yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400;
3643     yearday += 14*MONTH_TO_DAYS + 1;
3644     ptm->tm_yday = jday - yearday;
3645     ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
3646 }
3647
3648 char *
3649 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)
3650 {
3651 #ifdef HAS_STRFTIME
3652   char *buf;
3653   int buflen;
3654   struct tm mytm;
3655   int len;
3656
3657   PERL_ARGS_ASSERT_MY_STRFTIME;
3658
3659   init_tm(&mytm);       /* XXX workaround - see init_tm() above */
3660   mytm.tm_sec = sec;
3661   mytm.tm_min = min;
3662   mytm.tm_hour = hour;
3663   mytm.tm_mday = mday;
3664   mytm.tm_mon = mon;
3665   mytm.tm_year = year;
3666   mytm.tm_wday = wday;
3667   mytm.tm_yday = yday;
3668   mytm.tm_isdst = isdst;
3669   mini_mktime(&mytm);
3670   /* use libc to get the values for tm_gmtoff and tm_zone [perl #18238] */
3671 #if defined(HAS_MKTIME) && (defined(HAS_TM_TM_GMTOFF) || defined(HAS_TM_TM_ZONE))
3672   STMT_START {
3673     struct tm mytm2;
3674     mytm2 = mytm;
3675     mktime(&mytm2);
3676 #ifdef HAS_TM_TM_GMTOFF
3677     mytm.tm_gmtoff = mytm2.tm_gmtoff;
3678 #endif
3679 #ifdef HAS_TM_TM_ZONE
3680     mytm.tm_zone = mytm2.tm_zone;
3681 #endif
3682   } STMT_END;
3683 #endif
3684   buflen = 64;
3685   Newx(buf, buflen, char);
3686   len = strftime(buf, buflen, fmt, &mytm);
3687   /*
3688   ** The following is needed to handle to the situation where
3689   ** tmpbuf overflows.  Basically we want to allocate a buffer
3690   ** and try repeatedly.  The reason why it is so complicated
3691   ** is that getting a return value of 0 from strftime can indicate
3692   ** one of the following:
3693   ** 1. buffer overflowed,
3694   ** 2. illegal conversion specifier, or
3695   ** 3. the format string specifies nothing to be returned(not
3696   **      an error).  This could be because format is an empty string
3697   **    or it specifies %p that yields an empty string in some locale.
3698   ** If there is a better way to make it portable, go ahead by
3699   ** all means.
3700   */
3701   if ((len > 0 && len < buflen) || (len == 0 && *fmt == '\0'))
3702     return buf;
3703   else {
3704     /* Possibly buf overflowed - try again with a bigger buf */
3705     const int fmtlen = strlen(fmt);
3706     int bufsize = fmtlen + buflen;
3707
3708     Renew(buf, bufsize, char);
3709     while (buf) {
3710       buflen = strftime(buf, bufsize, fmt, &mytm);
3711       if (buflen > 0 && buflen < bufsize)
3712         break;
3713       /* heuristic to prevent out-of-memory errors */
3714       if (bufsize > 100*fmtlen) {
3715         Safefree(buf);
3716         buf = NULL;
3717         break;
3718       }
3719       bufsize *= 2;
3720       Renew(buf, bufsize, char);
3721     }
3722     return buf;
3723   }
3724 #else
3725   Perl_croak(aTHX_ "panic: no strftime");
3726   return NULL;
3727 #endif
3728 }
3729
3730
3731 #define SV_CWD_RETURN_UNDEF \
3732 sv_setsv(sv, &PL_sv_undef); \
3733 return FALSE
3734
3735 #define SV_CWD_ISDOT(dp) \
3736     (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
3737         (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
3738
3739 /*
3740 =head1 Miscellaneous Functions
3741
3742 =for apidoc getcwd_sv
3743
3744 Fill the sv with current working directory
3745
3746 =cut
3747 */
3748
3749 /* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars.
3750  * rewritten again by dougm, optimized for use with xs TARG, and to prefer
3751  * getcwd(3) if available
3752  * Comments from the orignal:
3753  *     This is a faster version of getcwd.  It's also more dangerous
3754  *     because you might chdir out of a directory that you can't chdir
3755  *     back into. */
3756
3757 int
3758 Perl_getcwd_sv(pTHX_ SV *sv)
3759 {
3760 #ifndef PERL_MICRO
3761     dVAR;
3762     SvTAINTED_on(sv);
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             sizeof(connect_addr)) == -1)
5046         goto tidy_up_and_fail;
5047
5048     size = sizeof(listen_addr);
5049     acceptor = PerlSock_accept(listener, (struct sockaddr *) &listen_addr,
5050             &size);
5051     if (acceptor == -1)
5052         goto tidy_up_and_fail;
5053     if (size != sizeof(listen_addr))
5054         goto abort_tidy_up_and_fail;
5055     PerlLIO_close(listener);
5056     /* Now check we are talking to ourself by matching port and host on the
5057        two sockets.  */
5058     if (PerlSock_getsockname(connector, (struct sockaddr *) &connect_addr,
5059             &size) == -1)
5060         goto tidy_up_and_fail;
5061     if (size != sizeof(connect_addr)
5062             || listen_addr.sin_family != connect_addr.sin_family
5063             || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr
5064             || listen_addr.sin_port != connect_addr.sin_port) {
5065         goto abort_tidy_up_and_fail;
5066     }
5067     fd[0] = connector;
5068     fd[1] = acceptor;
5069     return 0;
5070
5071   abort_tidy_up_and_fail:
5072 #ifdef ECONNABORTED
5073   errno = ECONNABORTED; /* This would be the standard thing to do. */
5074 #else
5075 #  ifdef ECONNREFUSED
5076   errno = ECONNREFUSED; /* E.g. Symbian does not have ECONNABORTED. */
5077 #  else
5078   errno = ETIMEDOUT;    /* Desperation time. */
5079 #  endif
5080 #endif
5081   tidy_up_and_fail:
5082     {
5083         dSAVE_ERRNO;
5084         if (listener != -1)
5085             PerlLIO_close(listener);
5086         if (connector != -1)
5087             PerlLIO_close(connector);
5088         if (acceptor != -1)
5089             PerlLIO_clos