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