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