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