This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[perl #119169] index with __PACKAGE__ for 2nd argument
[perl5.git] / util.c
1 /*    util.c
2  *
3  *    Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001,
4  *    2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
5  *
6  *    You may distribute under the terms of either the GNU General Public
7  *    License or the Artistic License, as specified in the README file.
8  *
9  */
10
11 /*
12  * 'Very useful, no doubt, that was to Saruman; yet it seems that he was
13  *  not content.'                                    --Gandalf to Pippin
14  *
15  *     [p.598 of _The Lord of the Rings_, III/xi: "The Palantír"]
16  */
17
18 /* This file contains assorted utility routines.
19  * Which is a polite way of saying any stuff that people couldn't think of
20  * a better place for. Amongst other things, it includes the warning and
21  * dieing stuff, plus wrappers for malloc code.
22  */
23
24 #include "EXTERN.h"
25 #define PERL_IN_UTIL_C
26 #include "perl.h"
27 #include "reentr.h"
28
29 #ifdef USE_PERLIO
30 #include "perliol.h" /* For PerlIOUnix_refcnt */
31 #endif
32
33 #ifndef PERL_MICRO
34 #include <signal.h>
35 #ifndef SIG_ERR
36 # define SIG_ERR ((Sighandler_t) -1)
37 #endif
38 #endif
39
40 #ifdef __Lynx__
41 /* Missing protos on LynxOS */
42 int putenv(char *);
43 #endif
44
45 #ifdef HAS_SELECT
46 # ifdef I_SYS_SELECT
47 #  include <sys/select.h>
48 # endif
49 #endif
50
51 #define FLUSH
52
53 #if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC)
54 #  define FD_CLOEXEC 1                  /* NeXT needs this */
55 #endif
56
57 /* NOTE:  Do not call the next three routines directly.  Use the macros
58  * in handy.h, so that we can easily redefine everything to do tracking of
59  * allocated hunks back to the original New to track down any memory leaks.
60  * XXX This advice seems to be widely ignored :-(   --AD  August 1996.
61  */
62
63 #if defined (DEBUGGING) || defined(PERL_IMPLICIT_SYS) || defined (PERL_TRACK_MEMPOOL)
64 #  define ALWAYS_NEED_THX
65 #endif
66
67 /* paranoid version of system's malloc() */
68
69 Malloc_t
70 Perl_safesysmalloc(MEM_SIZE size)
71 {
72 #ifdef ALWAYS_NEED_THX
73     dTHX;
74 #endif
75     Malloc_t ptr;
76 #ifdef HAS_64K_LIMIT
77         if (size > 0xffff) {
78             PerlIO_printf(Perl_error_log,
79                           "Allocation too large: %lx\n", size) FLUSH;
80             my_exit(1);
81         }
82 #endif /* HAS_64K_LIMIT */
83 #ifdef PERL_TRACK_MEMPOOL
84     size += sTHX;
85 #endif
86 #ifdef DEBUGGING
87     if ((SSize_t)size < 0)
88         Perl_croak_nocontext("panic: malloc, size=%"UVuf, (UV) size);
89 #endif
90     ptr = (Malloc_t)PerlMem_malloc(size?size:1);        /* malloc(0) is NASTY on our system */
91     PERL_ALLOC_CHECK(ptr);
92     if (ptr != NULL) {
93 #ifdef PERL_TRACK_MEMPOOL
94         struct perl_memory_debug_header *const header
95             = (struct perl_memory_debug_header *)ptr;
96 #endif
97
98 #ifdef PERL_POISON
99         PoisonNew(((char *)ptr), size, char);
100 #endif
101
102 #ifdef PERL_TRACK_MEMPOOL
103         header->interpreter = aTHX;
104         /* Link us into the list.  */
105         header->prev = &PL_memory_debug_header;
106         header->next = PL_memory_debug_header.next;
107         PL_memory_debug_header.next = header;
108         header->next->prev = header;
109 #  ifdef PERL_POISON
110         header->size = size;
111 #  endif
112         ptr = (Malloc_t)((char*)ptr+sTHX);
113 #endif
114         DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
115         return ptr;
116 }
117     else {
118 #ifndef ALWAYS_NEED_THX
119         dTHX;
120 #endif
121         if (PL_nomemok)
122             return NULL;
123         else {
124             croak_no_mem();
125         }
126     }
127     /*NOTREACHED*/
128 }
129
130 /* paranoid version of system's realloc() */
131
132 Malloc_t
133 Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
134 {
135 #ifdef ALWAYS_NEED_THX
136     dTHX;
137 #endif
138     Malloc_t ptr;
139 #if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) && !defined(PERL_MICRO)
140     Malloc_t PerlMem_realloc();
141 #endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */
142
143 #ifdef HAS_64K_LIMIT
144     if (size > 0xffff) {
145         PerlIO_printf(Perl_error_log,
146                       "Reallocation too large: %lx\n", size) FLUSH;
147         my_exit(1);
148     }
149 #endif /* HAS_64K_LIMIT */
150     if (!size) {
151         safesysfree(where);
152         return NULL;
153     }
154
155     if (!where)
156         return safesysmalloc(size);
157 #ifdef PERL_TRACK_MEMPOOL
158     where = (Malloc_t)((char*)where-sTHX);
159     size += sTHX;
160     {
161         struct perl_memory_debug_header *const header
162             = (struct perl_memory_debug_header *)where;
163
164         if (header->interpreter != aTHX) {
165             Perl_croak_nocontext("panic: realloc from wrong pool, %p!=%p",
166                                  header->interpreter, aTHX);
167         }
168         assert(header->next->prev == header);
169         assert(header->prev->next == header);
170 #  ifdef PERL_POISON
171         if (header->size > size) {
172             const MEM_SIZE freed_up = header->size - size;
173             char *start_of_freed = ((char *)where) + size;
174             PoisonFree(start_of_freed, freed_up, char);
175         }
176         header->size = size;
177 #  endif
178     }
179 #endif
180 #ifdef DEBUGGING
181     if ((SSize_t)size < 0)
182         Perl_croak_nocontext("panic: realloc, size=%"UVuf, (UV)size);
183 #endif
184     ptr = (Malloc_t)PerlMem_realloc(where,size);
185     PERL_ALLOC_CHECK(ptr);
186
187     /* MUST do this fixup first, before doing ANYTHING else, as anything else
188        might allocate memory/free/move memory, and until we do the fixup, it
189        may well be chasing (and writing to) free memory.  */
190 #ifdef PERL_TRACK_MEMPOOL
191     if (ptr != NULL) {
192         struct perl_memory_debug_header *const header
193             = (struct perl_memory_debug_header *)ptr;
194
195 #  ifdef PERL_POISON
196         if (header->size < size) {
197             const MEM_SIZE fresh = size - header->size;
198             char *start_of_fresh = ((char *)ptr) + size;
199             PoisonNew(start_of_fresh, fresh, char);
200         }
201 #  endif
202
203         header->next->prev = header;
204         header->prev->next = header;
205
206         ptr = (Malloc_t)((char*)ptr+sTHX);
207     }
208 #endif
209
210     /* In particular, must do that fixup above before logging anything via
211      *printf(), as it can reallocate memory, which can cause SEGVs.  */
212
213     DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++));
214     DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
215
216
217     if (ptr != NULL) {
218         return ptr;
219     }
220     else {
221 #ifndef ALWAYS_NEED_THX
222         dTHX;
223 #endif
224         if (PL_nomemok)
225             return NULL;
226         else {
227             croak_no_mem();
228         }
229     }
230     /*NOTREACHED*/
231 }
232
233 /* safe version of system's free() */
234
235 Free_t
236 Perl_safesysfree(Malloc_t where)
237 {
238 #ifdef ALWAYS_NEED_THX
239     dTHX;
240 #else
241     dVAR;
242 #endif
243     DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) free\n",PTR2UV(where),(long)PL_an++));
244     if (where) {
245 #ifdef PERL_TRACK_MEMPOOL
246         where = (Malloc_t)((char*)where-sTHX);
247         {
248             struct perl_memory_debug_header *const header
249                 = (struct perl_memory_debug_header *)where;
250
251             if (header->interpreter != aTHX) {
252                 Perl_croak_nocontext("panic: free from wrong pool, %p!=%p",
253                                      header->interpreter, aTHX);
254             }
255             if (!header->prev) {
256                 Perl_croak_nocontext("panic: duplicate free");
257             }
258             if (!(header->next))
259                 Perl_croak_nocontext("panic: bad free, header->next==NULL");
260             if (header->next->prev != header || header->prev->next != header) {
261                 Perl_croak_nocontext("panic: bad free, ->next->prev=%p, "
262                                      "header=%p, ->prev->next=%p",
263                                      header->next->prev, header,
264                                      header->prev->next);
265             }
266             /* Unlink us from the chain.  */
267             header->next->prev = header->prev;
268             header->prev->next = header->next;
269 #  ifdef PERL_POISON
270             PoisonNew(where, header->size, char);
271 #  endif
272             /* Trigger the duplicate free warning.  */
273             header->next = NULL;
274         }
275 #endif
276         PerlMem_free(where);
277     }
278 }
279
280 /* safe version of system's calloc() */
281
282 Malloc_t
283 Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
284 {
285 #ifdef ALWAYS_NEED_THX
286     dTHX;
287 #endif
288     Malloc_t ptr;
289 #if defined(PERL_TRACK_MEMPOOL) || defined(HAS_64K_LIMIT) || defined(DEBUGGING)
290     MEM_SIZE total_size = 0;
291 #endif
292
293     /* Even though calloc() for zero bytes is strange, be robust. */
294     if (size && (count <= MEM_SIZE_MAX / size)) {
295 #if defined(PERL_TRACK_MEMPOOL) || defined(HAS_64K_LIMIT) || defined(DEBUGGING)
296         total_size = size * count;
297 #endif
298     }
299     else
300         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         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     U32 frequency = 256;
525     MAGIC *mg;
526     PERL_DEB( STRLEN rarest = 0 );
527
528     PERL_ARGS_ASSERT_FBM_COMPILE;
529
530     if (isGV_with_GP(sv) || SvROK(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     if (!SvPOK(sv) || SvNIOKp(sv))
543         s = (U8*)SvPV_force_mutable(sv, len);
544     else s = (U8 *)SvPV_mutable(sv, len);
545     if (len == 0)               /* TAIL might be on a zero-length string. */
546         return;
547     SvUPGRADE(sv, SVt_PVMG);
548     SvIOK_off(sv);
549     SvNOK_off(sv);
550     SvVALID_on(sv);
551
552     /* "deep magic", the comment used to add. The use of MAGIC itself isn't
553        really. MAGIC was originally added in 79072805bf63abe5 (perl 5.0 alpha 2)
554        to call SvVALID_off() if the scalar was assigned to.
555
556        The comment itself (and "deeper magic" below) date back to
557        378cc40b38293ffc (perl 2.0). "deep magic" was an annotation on
558        str->str_pok |= 2;
559        where the magic (presumably) was that the scalar had a BM table hidden
560        inside itself.
561
562        As MAGIC is always present on BMs [in Perl 5 :-)], we can use it to store
563        the table instead of the previous (somewhat hacky) approach of co-opting
564        the string buffer and storing it after the string.  */
565
566     assert(!mg_find(sv, PERL_MAGIC_bm));
567     mg = sv_magicext(sv, NULL, PERL_MAGIC_bm, &PL_vtbl_bm, NULL, 0);
568     assert(mg);
569
570     if (len > 2) {
571         /* Shorter strings are special-cased in Perl_fbm_instr(), and don't use
572            the BM table.  */
573         const U8 mlen = (len>255) ? 255 : (U8)len;
574         const unsigned char *const sb = s + len - mlen; /* first char (maybe) */
575         U8 *table;
576
577         Newx(table, 256, U8);
578         memset((void*)table, mlen, 256);
579         mg->mg_ptr = (char *)table;
580         mg->mg_len = 256;
581
582         s += len - 1; /* last char */
583         i = 0;
584         while (s >= sb) {
585             if (table[*s] == mlen)
586                 table[*s] = (U8)i;
587             s--, i++;
588         }
589     }
590
591     s = (const unsigned char*)(SvPVX_const(sv));        /* deeper magic */
592     for (i = 0; i < len; i++) {
593         if (PL_freq[s[i]] < frequency) {
594             PERL_DEB( rarest = i );
595             frequency = PL_freq[s[i]];
596         }
597     }
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                           s[rarest], (UV)rarest));
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, SV_CONST(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 /* does not return, used only in POPSTACK */
1618 void
1619 Perl_croak_popstack(void)
1620 {
1621     dTHX;
1622     PerlIO_printf(Perl_error_log, "panic: POPSTACK\n");
1623     my_exit(1);
1624 }
1625
1626 /*
1627 =for apidoc Am|void|warn_sv|SV *baseex
1628
1629 This is an XS interface to Perl's C<warn> function.
1630
1631 C<baseex> is the error message or object.  If it is a reference, it
1632 will be used as-is.  Otherwise it is used as a string, and if it does
1633 not end with a newline then it will be extended with some indication of
1634 the current location in the code, as described for L</mess_sv>.
1635
1636 The error message or object will by default be written to standard error,
1637 but this is subject to modification by a C<$SIG{__WARN__}> handler.
1638
1639 To warn with a simple string message, the L</warn> function may be
1640 more convenient.
1641
1642 =cut
1643 */
1644
1645 void
1646 Perl_warn_sv(pTHX_ SV *baseex)
1647 {
1648     SV *ex = mess_sv(baseex, 0);
1649     PERL_ARGS_ASSERT_WARN_SV;
1650     if (!invoke_exception_hook(ex, TRUE))
1651         write_to_stderr(ex);
1652 }
1653
1654 /*
1655 =for apidoc Am|void|vwarn|const char *pat|va_list *args
1656
1657 This is an XS interface to Perl's C<warn> function.
1658
1659 C<pat> and C<args> are a sprintf-style format pattern and encapsulated
1660 argument list.  These are used to generate a string message.  If the
1661 message does not end with a newline, then it will be extended with
1662 some indication of the current location in the code, as described for
1663 L</mess_sv>.
1664
1665 The error message or object will by default be written to standard error,
1666 but this is subject to modification by a C<$SIG{__WARN__}> handler.
1667
1668 Unlike with L</vcroak>, C<pat> is not permitted to be null.
1669
1670 =cut
1671 */
1672
1673 void
1674 Perl_vwarn(pTHX_ const char* pat, va_list *args)
1675 {
1676     SV *ex = vmess(pat, args);
1677     PERL_ARGS_ASSERT_VWARN;
1678     if (!invoke_exception_hook(ex, TRUE))
1679         write_to_stderr(ex);
1680 }
1681
1682 /*
1683 =for apidoc Am|void|warn|const char *pat|...
1684
1685 This is an XS interface to Perl's C<warn> function.
1686
1687 Take a sprintf-style format pattern and argument list.  These are used to
1688 generate a string message.  If the message does not end with a newline,
1689 then it will be extended with some indication of the current location
1690 in the code, as described for L</mess_sv>.
1691
1692 The error message or object will by default be written to standard error,
1693 but this is subject to modification by a C<$SIG{__WARN__}> handler.
1694
1695 Unlike with L</croak>, C<pat> is not permitted to be null.
1696
1697 =cut
1698 */
1699
1700 #if defined(PERL_IMPLICIT_CONTEXT)
1701 void
1702 Perl_warn_nocontext(const char *pat, ...)
1703 {
1704     dTHX;
1705     va_list args;
1706     PERL_ARGS_ASSERT_WARN_NOCONTEXT;
1707     va_start(args, pat);
1708     vwarn(pat, &args);
1709     va_end(args);
1710 }
1711 #endif /* PERL_IMPLICIT_CONTEXT */
1712
1713 void
1714 Perl_warn(pTHX_ const char *pat, ...)
1715 {
1716     va_list args;
1717     PERL_ARGS_ASSERT_WARN;
1718     va_start(args, pat);
1719     vwarn(pat, &args);
1720     va_end(args);
1721 }
1722
1723 #if defined(PERL_IMPLICIT_CONTEXT)
1724 void
1725 Perl_warner_nocontext(U32 err, const char *pat, ...)
1726 {
1727     dTHX; 
1728     va_list args;
1729     PERL_ARGS_ASSERT_WARNER_NOCONTEXT;
1730     va_start(args, pat);
1731     vwarner(err, pat, &args);
1732     va_end(args);
1733 }
1734 #endif /* PERL_IMPLICIT_CONTEXT */
1735
1736 void
1737 Perl_ck_warner_d(pTHX_ U32 err, const char* pat, ...)
1738 {
1739     PERL_ARGS_ASSERT_CK_WARNER_D;
1740
1741     if (Perl_ckwarn_d(aTHX_ err)) {
1742         va_list args;
1743         va_start(args, pat);
1744         vwarner(err, pat, &args);
1745         va_end(args);
1746     }
1747 }
1748
1749 void
1750 Perl_ck_warner(pTHX_ U32 err, const char* pat, ...)
1751 {
1752     PERL_ARGS_ASSERT_CK_WARNER;
1753
1754     if (Perl_ckwarn(aTHX_ err)) {
1755         va_list args;
1756         va_start(args, pat);
1757         vwarner(err, pat, &args);
1758         va_end(args);
1759     }
1760 }
1761
1762 void
1763 Perl_warner(pTHX_ U32  err, const char* pat,...)
1764 {
1765     va_list args;
1766     PERL_ARGS_ASSERT_WARNER;
1767     va_start(args, pat);
1768     vwarner(err, pat, &args);
1769     va_end(args);
1770 }
1771
1772 void
1773 Perl_vwarner(pTHX_ U32  err, const char* pat, va_list* args)
1774 {
1775     dVAR;
1776     PERL_ARGS_ASSERT_VWARNER;
1777     if (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) {
1778         SV * const msv = vmess(pat, args);
1779
1780         invoke_exception_hook(msv, FALSE);
1781         die_unwind(msv);
1782     }
1783     else {
1784         Perl_vwarn(aTHX_ pat, args);
1785     }
1786 }
1787
1788 /* implements the ckWARN? macros */
1789
1790 bool
1791 Perl_ckwarn(pTHX_ U32 w)
1792 {
1793     dVAR;
1794     /* If lexical warnings have not been set, use $^W.  */
1795     if (isLEXWARN_off)
1796         return PL_dowarn & G_WARN_ON;
1797
1798     return ckwarn_common(w);
1799 }
1800
1801 /* implements the ckWARN?_d macro */
1802
1803 bool
1804 Perl_ckwarn_d(pTHX_ U32 w)
1805 {
1806     dVAR;
1807     /* If lexical warnings have not been set then default classes warn.  */
1808     if (isLEXWARN_off)
1809         return TRUE;
1810
1811     return ckwarn_common(w);
1812 }
1813
1814 static bool
1815 S_ckwarn_common(pTHX_ U32 w)
1816 {
1817     if (PL_curcop->cop_warnings == pWARN_ALL)
1818         return TRUE;
1819
1820     if (PL_curcop->cop_warnings == pWARN_NONE)
1821         return FALSE;
1822
1823     /* Check the assumption that at least the first slot is non-zero.  */
1824     assert(unpackWARN1(w));
1825
1826     /* Check the assumption that it is valid to stop as soon as a zero slot is
1827        seen.  */
1828     if (!unpackWARN2(w)) {
1829         assert(!unpackWARN3(w));
1830         assert(!unpackWARN4(w));
1831     } else if (!unpackWARN3(w)) {
1832         assert(!unpackWARN4(w));
1833     }
1834         
1835     /* Right, dealt with all the special cases, which are implemented as non-
1836        pointers, so there is a pointer to a real warnings mask.  */
1837     do {
1838         if (isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w)))
1839             return TRUE;
1840     } while (w >>= WARNshift);
1841
1842     return FALSE;
1843 }
1844
1845 /* Set buffer=NULL to get a new one.  */
1846 STRLEN *
1847 Perl_new_warnings_bitfield(pTHX_ STRLEN *buffer, const char *const bits,
1848                            STRLEN size) {
1849     const MEM_SIZE len_wanted =
1850         sizeof(STRLEN) + (size > WARNsize ? size : WARNsize);
1851     PERL_UNUSED_CONTEXT;
1852     PERL_ARGS_ASSERT_NEW_WARNINGS_BITFIELD;
1853
1854     buffer = (STRLEN*)
1855         (specialWARN(buffer) ?
1856          PerlMemShared_malloc(len_wanted) :
1857          PerlMemShared_realloc(buffer, len_wanted));
1858     buffer[0] = size;
1859     Copy(bits, (buffer + 1), size, char);
1860     if (size < WARNsize)
1861         Zero((char *)(buffer + 1) + size, WARNsize - size, char);
1862     return buffer;
1863 }
1864
1865 /* since we've already done strlen() for both nam and val
1866  * we can use that info to make things faster than
1867  * sprintf(s, "%s=%s", nam, val)
1868  */
1869 #define my_setenv_format(s, nam, nlen, val, vlen) \
1870    Copy(nam, s, nlen, char); \
1871    *(s+nlen) = '='; \
1872    Copy(val, s+(nlen+1), vlen, char); \
1873    *(s+(nlen+1+vlen)) = '\0'
1874
1875 #ifdef USE_ENVIRON_ARRAY
1876        /* VMS' my_setenv() is in vms.c */
1877 #if !defined(WIN32) && !defined(NETWARE)
1878 void
1879 Perl_my_setenv(pTHX_ const char *nam, const char *val)
1880 {
1881   dVAR;
1882 #ifdef USE_ITHREADS
1883   /* only parent thread can modify process environment */
1884   if (PL_curinterp == aTHX)
1885 #endif
1886   {
1887 #ifndef PERL_USE_SAFE_PUTENV
1888     if (!PL_use_safe_putenv) {
1889     /* most putenv()s leak, so we manipulate environ directly */
1890     I32 i;
1891     const I32 len = strlen(nam);
1892     int nlen, vlen;
1893
1894     /* where does it go? */
1895     for (i = 0; environ[i]; i++) {
1896         if (strnEQ(environ[i],nam,len) && environ[i][len] == '=')
1897             break;
1898     }
1899
1900     if (environ == PL_origenviron) {   /* need we copy environment? */
1901        I32 j;
1902        I32 max;
1903        char **tmpenv;
1904
1905        max = i;
1906        while (environ[max])
1907            max++;
1908        tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*));
1909        for (j=0; j<max; j++) {         /* copy environment */
1910            const int len = strlen(environ[j]);
1911            tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char));
1912            Copy(environ[j], tmpenv[j], len+1, char);
1913        }
1914        tmpenv[max] = NULL;
1915        environ = tmpenv;               /* tell exec where it is now */
1916     }
1917     if (!val) {
1918        safesysfree(environ[i]);
1919        while (environ[i]) {
1920            environ[i] = environ[i+1];
1921            i++;
1922         }
1923        return;
1924     }
1925     if (!environ[i]) {                 /* does not exist yet */
1926        environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
1927        environ[i+1] = NULL;    /* make sure it's null terminated */
1928     }
1929     else
1930        safesysfree(environ[i]);
1931        nlen = strlen(nam);
1932        vlen = strlen(val);
1933
1934        environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char));
1935        /* all that work just for this */
1936        my_setenv_format(environ[i], nam, nlen, val, vlen);
1937     } else {
1938 # endif
1939 #   if defined(__CYGWIN__)|| defined(__SYMBIAN32__) || defined(__riscos__)
1940 #       if defined(HAS_UNSETENV)
1941         if (val == NULL) {
1942             (void)unsetenv(nam);
1943         } else {
1944             (void)setenv(nam, val, 1);
1945         }
1946 #       else /* ! HAS_UNSETENV */
1947         (void)setenv(nam, val, 1);
1948 #       endif /* HAS_UNSETENV */
1949 #   else
1950 #       if defined(HAS_UNSETENV)
1951         if (val == NULL) {
1952             if (environ) /* old glibc can crash with null environ */
1953                 (void)unsetenv(nam);
1954         } else {
1955             const int nlen = strlen(nam);
1956             const int vlen = strlen(val);
1957             char * const new_env =
1958                 (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
1959             my_setenv_format(new_env, nam, nlen, val, vlen);
1960             (void)putenv(new_env);
1961         }
1962 #       else /* ! HAS_UNSETENV */
1963         char *new_env;
1964         const int nlen = strlen(nam);
1965         int vlen;
1966         if (!val) {
1967            val = "";
1968         }
1969         vlen = strlen(val);
1970         new_env = (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
1971         /* all that work just for this */
1972         my_setenv_format(new_env, nam, nlen, val, vlen);
1973         (void)putenv(new_env);
1974 #       endif /* HAS_UNSETENV */
1975 #   endif /* __CYGWIN__ */
1976 #ifndef PERL_USE_SAFE_PUTENV
1977     }
1978 #endif
1979   }
1980 }
1981
1982 #else /* WIN32 || NETWARE */
1983
1984 void
1985 Perl_my_setenv(pTHX_ const char *nam, const char *val)
1986 {
1987     dVAR;
1988     char *envstr;
1989     const int nlen = strlen(nam);
1990     int vlen;
1991
1992     if (!val) {
1993        val = "";
1994     }
1995     vlen = strlen(val);
1996     Newx(envstr, nlen+vlen+2, char);
1997     my_setenv_format(envstr, nam, nlen, val, vlen);
1998     (void)PerlEnv_putenv(envstr);
1999     Safefree(envstr);
2000 }
2001
2002 #endif /* WIN32 || NETWARE */
2003
2004 #endif /* !VMS */
2005
2006 #ifdef UNLINK_ALL_VERSIONS
2007 I32
2008 Perl_unlnk(pTHX_ const char *f) /* unlink all versions of a file */
2009 {
2010     I32 retries = 0;
2011
2012     PERL_ARGS_ASSERT_UNLNK;
2013
2014     while (PerlLIO_unlink(f) >= 0)
2015         retries++;
2016     return retries ? 0 : -1;
2017 }
2018 #endif
2019
2020 /* this is a drop-in replacement for bcopy() */
2021 #if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY))
2022 char *
2023 Perl_my_bcopy(const char *from, char *to, I32 len)
2024 {
2025     char * const retval = to;
2026
2027     PERL_ARGS_ASSERT_MY_BCOPY;
2028
2029     assert(len >= 0);
2030
2031     if (from - to >= 0) {
2032         while (len--)
2033             *to++ = *from++;
2034     }
2035     else {
2036         to += len;
2037         from += len;
2038         while (len--)
2039             *(--to) = *(--from);
2040     }
2041     return retval;
2042 }
2043 #endif
2044
2045 /* this is a drop-in replacement for memset() */
2046 #ifndef HAS_MEMSET
2047 void *
2048 Perl_my_memset(char *loc, I32 ch, I32 len)
2049 {
2050     char * const retval = loc;
2051
2052     PERL_ARGS_ASSERT_MY_MEMSET;
2053
2054     assert(len >= 0);
2055
2056     while (len--)
2057         *loc++ = ch;
2058     return retval;
2059 }
2060 #endif
2061
2062 /* this is a drop-in replacement for bzero() */
2063 #if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
2064 char *
2065 Perl_my_bzero(char *loc, I32 len)
2066 {
2067     char * const retval = loc;
2068
2069     PERL_ARGS_ASSERT_MY_BZERO;
2070
2071     assert(len >= 0);
2072
2073     while (len--)
2074         *loc++ = 0;
2075     return retval;
2076 }
2077 #endif
2078
2079 /* this is a drop-in replacement for memcmp() */
2080 #if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
2081 I32
2082 Perl_my_memcmp(const char *s1, const char *s2, I32 len)
2083 {
2084     const U8 *a = (const U8 *)s1;
2085     const U8 *b = (const U8 *)s2;
2086     I32 tmp;
2087
2088     PERL_ARGS_ASSERT_MY_MEMCMP;
2089
2090     assert(len >= 0);
2091
2092     while (len--) {
2093         if ((tmp = *a++ - *b++))
2094             return tmp;
2095     }
2096     return 0;
2097 }
2098 #endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */
2099
2100 #ifndef HAS_VPRINTF
2101 /* This vsprintf replacement should generally never get used, since
2102    vsprintf was available in both System V and BSD 2.11.  (There may
2103    be some cross-compilation or embedded set-ups where it is needed,
2104    however.)
2105
2106    If you encounter a problem in this function, it's probably a symptom
2107    that Configure failed to detect your system's vprintf() function.
2108    See the section on "item vsprintf" in the INSTALL file.
2109
2110    This version may compile on systems with BSD-ish <stdio.h>,
2111    but probably won't on others.
2112 */
2113
2114 #ifdef USE_CHAR_VSPRINTF
2115 char *
2116 #else
2117 int
2118 #endif
2119 vsprintf(char *dest, const char *pat, void *args)
2120 {
2121     FILE fakebuf;
2122
2123 #if defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE)
2124     FILE_ptr(&fakebuf) = (STDCHAR *) dest;
2125     FILE_cnt(&fakebuf) = 32767;
2126 #else
2127     /* These probably won't compile -- If you really need
2128        this, you'll have to figure out some other method. */
2129     fakebuf._ptr = dest;
2130     fakebuf._cnt = 32767;
2131 #endif
2132 #ifndef _IOSTRG
2133 #define _IOSTRG 0
2134 #endif
2135     fakebuf._flag = _IOWRT|_IOSTRG;
2136     _doprnt(pat, args, &fakebuf);       /* what a kludge */
2137 #if defined(STDIO_PTR_LVALUE)
2138     *(FILE_ptr(&fakebuf)++) = '\0';
2139 #else
2140     /* PerlIO has probably #defined away fputc, but we want it here. */
2141 #  ifdef fputc
2142 #    undef fputc  /* XXX Should really restore it later */
2143 #  endif
2144     (void)fputc('\0', &fakebuf);
2145 #endif
2146 #ifdef USE_CHAR_VSPRINTF
2147     return(dest);
2148 #else
2149     return 0;           /* perl doesn't use return value */
2150 #endif
2151 }
2152
2153 #endif /* HAS_VPRINTF */
2154
2155 PerlIO *
2156 Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
2157 {
2158 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(NETWARE) && !defined(__LIBCATAMOUNT__)
2159     dVAR;
2160     int p[2];
2161     I32 This, that;
2162     Pid_t pid;
2163     SV *sv;
2164     I32 did_pipes = 0;
2165     int pp[2];
2166
2167     PERL_ARGS_ASSERT_MY_POPEN_LIST;
2168
2169     PERL_FLUSHALL_FOR_CHILD;
2170     This = (*mode == 'w');
2171     that = !This;
2172     if (TAINTING_get) {
2173         taint_env();
2174         taint_proper("Insecure %s%s", "EXEC");
2175     }
2176     if (PerlProc_pipe(p) < 0)
2177         return NULL;
2178     /* Try for another pipe pair for error return */
2179     if (PerlProc_pipe(pp) >= 0)
2180         did_pipes = 1;
2181     while ((pid = PerlProc_fork()) < 0) {
2182         if (errno != EAGAIN) {
2183             PerlLIO_close(p[This]);
2184             PerlLIO_close(p[that]);
2185             if (did_pipes) {
2186                 PerlLIO_close(pp[0]);
2187                 PerlLIO_close(pp[1]);
2188             }
2189             return NULL;
2190         }
2191         Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
2192         sleep(5);
2193     }
2194     if (pid == 0) {
2195         /* Child */
2196 #undef THIS
2197 #undef THAT
2198 #define THIS that
2199 #define THAT This
2200         /* Close parent's end of error status pipe (if any) */
2201         if (did_pipes) {
2202             PerlLIO_close(pp[0]);
2203 #if defined(HAS_FCNTL) && defined(F_SETFD)
2204             /* Close error pipe automatically if exec works */
2205             fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2206 #endif
2207         }
2208         /* Now dup our end of _the_ pipe to right position */
2209         if (p[THIS] != (*mode == 'r')) {
2210             PerlLIO_dup2(p[THIS], *mode == 'r');
2211             PerlLIO_close(p[THIS]);
2212             if (p[THAT] != (*mode == 'r'))      /* if dup2() didn't close it */
2213                 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
2214         }
2215         else
2216             PerlLIO_close(p[THAT]);     /* close parent's end of _the_ pipe */
2217 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2218         /* No automatic close - do it by hand */
2219 #  ifndef NOFILE
2220 #  define NOFILE 20
2221 #  endif
2222         {
2223             int fd;
2224
2225             for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) {
2226                 if (fd != pp[1])
2227                     PerlLIO_close(fd);
2228             }
2229         }
2230 #endif
2231         do_aexec5(NULL, args-1, args-1+n, pp[1], did_pipes);
2232         PerlProc__exit(1);
2233 #undef THIS
2234 #undef THAT
2235     }
2236     /* Parent */
2237     do_execfree();      /* free any memory malloced by child on fork */
2238     if (did_pipes)
2239         PerlLIO_close(pp[1]);
2240     /* Keep the lower of the two fd numbers */
2241     if (p[that] < p[This]) {
2242         PerlLIO_dup2(p[This], p[that]);
2243         PerlLIO_close(p[This]);
2244         p[This] = p[that];
2245     }
2246     else
2247         PerlLIO_close(p[that]);         /* close child's end of pipe */
2248
2249     sv = *av_fetch(PL_fdpid,p[This],TRUE);
2250     SvUPGRADE(sv,SVt_IV);
2251     SvIV_set(sv, pid);
2252     PL_forkprocess = pid;
2253     /* If we managed to get status pipe check for exec fail */
2254     if (did_pipes && pid > 0) {
2255         int errkid;
2256         unsigned n = 0;
2257         SSize_t n1;
2258
2259         while (n < sizeof(int)) {
2260             n1 = PerlLIO_read(pp[0],
2261                               (void*)(((char*)&errkid)+n),
2262                               (sizeof(int)) - n);
2263             if (n1 <= 0)
2264                 break;
2265             n += n1;
2266         }
2267         PerlLIO_close(pp[0]);
2268         did_pipes = 0;
2269         if (n) {                        /* Error */
2270             int pid2, status;
2271             PerlLIO_close(p[This]);
2272             if (n != sizeof(int))
2273                 Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", n);
2274             do {
2275                 pid2 = wait4pid(pid, &status, 0);
2276             } while (pid2 == -1 && errno == EINTR);
2277             errno = errkid;             /* Propagate errno from kid */
2278             return NULL;
2279         }
2280     }
2281     if (did_pipes)
2282          PerlLIO_close(pp[0]);
2283     return PerlIO_fdopen(p[This], mode);
2284 #else
2285 #  ifdef OS2    /* Same, without fork()ing and all extra overhead... */
2286     return my_syspopen4(aTHX_ NULL, mode, n, args);
2287 #  else
2288     Perl_croak(aTHX_ "List form of piped open not implemented");
2289     return (PerlIO *) NULL;
2290 #  endif
2291 #endif
2292 }
2293
2294     /* VMS' my_popen() is in VMS.c, same with OS/2. */
2295 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__LIBCATAMOUNT__)
2296 PerlIO *
2297 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2298 {
2299     dVAR;
2300     int p[2];
2301     I32 This, that;
2302     Pid_t pid;
2303     SV *sv;
2304     const I32 doexec = !(*cmd == '-' && cmd[1] == '\0');
2305     I32 did_pipes = 0;
2306     int pp[2];
2307
2308     PERL_ARGS_ASSERT_MY_POPEN;
2309
2310     PERL_FLUSHALL_FOR_CHILD;
2311 #ifdef OS2
2312     if (doexec) {
2313         return my_syspopen(aTHX_ cmd,mode);
2314     }
2315 #endif
2316     This = (*mode == 'w');
2317     that = !This;
2318     if (doexec && TAINTING_get) {
2319         taint_env();
2320         taint_proper("Insecure %s%s", "EXEC");
2321     }
2322     if (PerlProc_pipe(p) < 0)
2323         return NULL;
2324     if (doexec && PerlProc_pipe(pp) >= 0)
2325         did_pipes = 1;
2326     while ((pid = PerlProc_fork()) < 0) {
2327         if (errno != EAGAIN) {
2328             PerlLIO_close(p[This]);
2329             PerlLIO_close(p[that]);
2330             if (did_pipes) {
2331                 PerlLIO_close(pp[0]);
2332                 PerlLIO_close(pp[1]);
2333             }
2334             if (!doexec)
2335                 Perl_croak(aTHX_ "Can't fork: %s", Strerror(errno));
2336             return NULL;
2337         }
2338         Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
2339         sleep(5);
2340     }
2341     if (pid == 0) {
2342
2343 #undef THIS
2344 #undef THAT
2345 #define THIS that
2346 #define THAT This
2347         if (did_pipes) {
2348             PerlLIO_close(pp[0]);
2349 #if defined(HAS_FCNTL) && defined(F_SETFD)
2350             fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2351 #endif
2352         }
2353         if (p[THIS] != (*mode == 'r')) {
2354             PerlLIO_dup2(p[THIS], *mode == 'r');
2355             PerlLIO_close(p[THIS]);
2356             if (p[THAT] != (*mode == 'r'))      /* if dup2() didn't close it */
2357                 PerlLIO_close(p[THAT]);
2358         }
2359         else
2360             PerlLIO_close(p[THAT]);
2361 #ifndef OS2
2362         if (doexec) {
2363 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2364 #ifndef NOFILE
2365 #define NOFILE 20
2366 #endif
2367             {
2368                 int fd;
2369
2370                 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
2371                     if (fd != pp[1])
2372                         PerlLIO_close(fd);
2373             }
2374 #endif
2375             /* may or may not use the shell */
2376             do_exec3(cmd, pp[1], did_pipes);
2377             PerlProc__exit(1);
2378         }
2379 #endif  /* defined OS2 */
2380
2381 #ifdef PERLIO_USING_CRLF
2382    /* Since we circumvent IO layers when we manipulate low-level
2383       filedescriptors directly, need to manually switch to the
2384       default, binary, low-level mode; see PerlIOBuf_open(). */
2385    PerlLIO_setmode((*mode == 'r'), O_BINARY);
2386 #endif 
2387         PL_forkprocess = 0;
2388 #ifdef PERL_USES_PL_PIDSTATUS
2389         hv_clear(PL_pidstatus); /* we have no children */
2390 #endif
2391         return NULL;
2392 #undef THIS
2393 #undef THAT
2394     }
2395     do_execfree();      /* free any memory malloced by child on vfork */
2396     if (did_pipes)
2397         PerlLIO_close(pp[1]);
2398     if (p[that] < p[This]) {
2399         PerlLIO_dup2(p[This], p[that]);
2400         PerlLIO_close(p[This]);
2401         p[This] = p[that];
2402     }
2403     else
2404         PerlLIO_close(p[that]);
2405
2406     sv = *av_fetch(PL_fdpid,p[This],TRUE);
2407     SvUPGRADE(sv,SVt_IV);
2408     SvIV_set(sv, pid);
2409     PL_forkprocess = pid;
2410     if (did_pipes && pid > 0) {
2411         int errkid;
2412         unsigned n = 0;
2413         SSize_t n1;
2414
2415         while (n < sizeof(int)) {
2416             n1 = PerlLIO_read(pp[0],
2417                               (void*)(((char*)&errkid)+n),
2418                               (sizeof(int)) - n);
2419             if (n1 <= 0)
2420                 break;
2421             n += n1;
2422         }
2423         PerlLIO_close(pp[0]);
2424         did_pipes = 0;
2425         if (n) {                        /* Error */
2426             int pid2, status;
2427             PerlLIO_close(p[This]);
2428             if (n != sizeof(int))
2429                 Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", n);
2430             do {
2431                 pid2 = wait4pid(pid, &status, 0);
2432             } while (pid2 == -1 && errno == EINTR);
2433             errno = errkid;             /* Propagate errno from kid */
2434             return NULL;
2435         }
2436     }
2437     if (did_pipes)
2438          PerlLIO_close(pp[0]);
2439     return PerlIO_fdopen(p[This], mode);
2440 }
2441 #else
2442 #if defined(DJGPP)
2443 FILE *djgpp_popen();
2444 PerlIO *
2445 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2446 {
2447     PERL_FLUSHALL_FOR_CHILD;
2448     /* Call system's popen() to get a FILE *, then import it.
2449        used 0 for 2nd parameter to PerlIO_importFILE;
2450        apparently not used
2451     */
2452     return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
2453 }
2454 #else
2455 #if defined(__LIBCATAMOUNT__)
2456 PerlIO *
2457 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2458 {
2459     return NULL;
2460 }
2461 #endif
2462 #endif
2463
2464 #endif /* !DOSISH */
2465
2466 /* this is called in parent before the fork() */
2467 void
2468 Perl_atfork_lock(void)
2469 {
2470    dVAR;
2471 #if defined(USE_ITHREADS)
2472     /* locks must be held in locking order (if any) */
2473 #  ifdef USE_PERLIO
2474     MUTEX_LOCK(&PL_perlio_mutex);
2475 #  endif
2476 #  ifdef MYMALLOC
2477     MUTEX_LOCK(&PL_malloc_mutex);
2478 #  endif
2479     OP_REFCNT_LOCK;
2480 #endif
2481 }
2482
2483 /* this is called in both parent and child after the fork() */
2484 void
2485 Perl_atfork_unlock(void)
2486 {
2487     dVAR;
2488 #if defined(USE_ITHREADS)
2489     /* locks must be released in same order as in atfork_lock() */
2490 #  ifdef USE_PERLIO
2491     MUTEX_UNLOCK(&PL_perlio_mutex);
2492 #  endif
2493 #  ifdef MYMALLOC
2494     MUTEX_UNLOCK(&PL_malloc_mutex);
2495 #  endif
2496     OP_REFCNT_UNLOCK;
2497 #endif
2498 }
2499
2500 Pid_t
2501 Perl_my_fork(void)
2502 {
2503 #if defined(HAS_FORK)
2504     Pid_t pid;
2505 #if defined(USE_ITHREADS) && !defined(HAS_PTHREAD_ATFORK)
2506     atfork_lock();
2507     pid = fork();
2508     atfork_unlock();
2509 #else
2510     /* atfork_lock() and atfork_unlock() are installed as pthread_atfork()
2511      * handlers elsewhere in the code */
2512     pid = fork();
2513 #endif
2514     return pid;
2515 #else
2516     /* this "canna happen" since nothing should be calling here if !HAS_FORK */
2517     Perl_croak_nocontext("fork() not available");
2518     return 0;
2519 #endif /* HAS_FORK */
2520 }
2521
2522 #ifdef DUMP_FDS
2523 void
2524 Perl_dump_fds(pTHX_ const char *const s)
2525 {
2526     int fd;
2527     Stat_t tmpstatbuf;
2528
2529     PERL_ARGS_ASSERT_DUMP_FDS;
2530
2531     PerlIO_printf(Perl_debug_log,"%s", s);
2532     for (fd = 0; fd < 32; fd++) {
2533         if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0)
2534             PerlIO_printf(Perl_debug_log," %d",fd);
2535     }
2536     PerlIO_printf(Perl_debug_log,"\n");
2537     return;
2538 }
2539 #endif  /* DUMP_FDS */
2540
2541 #ifndef HAS_DUP2
2542 int
2543 dup2(int oldfd, int newfd)
2544 {
2545 #if defined(HAS_FCNTL) && defined(F_DUPFD)
2546     if (oldfd == newfd)
2547         return oldfd;
2548     PerlLIO_close(newfd);
2549     return fcntl(oldfd, F_DUPFD, newfd);
2550 #else
2551 #define DUP2_MAX_FDS 256
2552     int fdtmp[DUP2_MAX_FDS];
2553     I32 fdx = 0;
2554     int fd;
2555
2556     if (oldfd == newfd)
2557         return oldfd;
2558     PerlLIO_close(newfd);
2559     /* good enough for low fd's... */
2560     while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
2561         if (fdx >= DUP2_MAX_FDS) {
2562             PerlLIO_close(fd);
2563             fd = -1;
2564             break;
2565         }
2566         fdtmp[fdx++] = fd;
2567     }
2568     while (fdx > 0)
2569         PerlLIO_close(fdtmp[--fdx]);
2570     return fd;
2571 #endif
2572 }
2573 #endif
2574
2575 #ifndef PERL_MICRO
2576 #ifdef HAS_SIGACTION
2577
2578 Sighandler_t
2579 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2580 {
2581     dVAR;
2582     struct sigaction act, oact;
2583
2584 #ifdef USE_ITHREADS
2585     /* only "parent" interpreter can diddle signals */
2586     if (PL_curinterp != aTHX)
2587         return (Sighandler_t) SIG_ERR;
2588 #endif
2589
2590     act.sa_handler = (void(*)(int))handler;
2591     sigemptyset(&act.sa_mask);
2592     act.sa_flags = 0;
2593 #ifdef SA_RESTART
2594     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2595         act.sa_flags |= SA_RESTART;     /* SVR4, 4.3+BSD */
2596 #endif
2597 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2598     if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
2599         act.sa_flags |= SA_NOCLDWAIT;
2600 #endif
2601     if (sigaction(signo, &act, &oact) == -1)
2602         return (Sighandler_t) SIG_ERR;
2603     else
2604         return (Sighandler_t) oact.sa_handler;
2605 }
2606
2607 Sighandler_t
2608 Perl_rsignal_state(pTHX_ int signo)
2609 {
2610     struct sigaction oact;
2611     PERL_UNUSED_CONTEXT;
2612
2613     if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
2614         return (Sighandler_t) SIG_ERR;
2615     else
2616         return (Sighandler_t) oact.sa_handler;
2617 }
2618
2619 int
2620 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2621 {
2622     dVAR;
2623     struct sigaction act;
2624
2625     PERL_ARGS_ASSERT_RSIGNAL_SAVE;
2626
2627 #ifdef USE_ITHREADS
2628     /* only "parent" interpreter can diddle signals */
2629     if (PL_curinterp != aTHX)
2630         return -1;
2631 #endif
2632
2633     act.sa_handler = (void(*)(int))handler;
2634     sigemptyset(&act.sa_mask);
2635     act.sa_flags = 0;
2636 #ifdef SA_RESTART
2637     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2638         act.sa_flags |= SA_RESTART;     /* SVR4, 4.3+BSD */
2639 #endif
2640 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2641     if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
2642         act.sa_flags |= SA_NOCLDWAIT;
2643 #endif
2644     return sigaction(signo, &act, save);
2645 }
2646
2647 int
2648 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2649 {
2650     dVAR;
2651 #ifdef USE_ITHREADS
2652     /* only "parent" interpreter can diddle signals */
2653     if (PL_curinterp != aTHX)
2654         return -1;
2655 #endif
2656
2657     return sigaction(signo, save, (struct sigaction *)NULL);
2658 }
2659
2660 #else /* !HAS_SIGACTION */
2661
2662 Sighandler_t
2663 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2664 {
2665 #if defined(USE_ITHREADS) && !defined(WIN32)
2666     /* only "parent" interpreter can diddle signals */
2667     if (PL_curinterp != aTHX)
2668         return (Sighandler_t) SIG_ERR;
2669 #endif
2670
2671     return PerlProc_signal(signo, handler);
2672 }
2673
2674 static Signal_t
2675 sig_trap(int signo)
2676 {
2677     dVAR;
2678     PL_sig_trapped++;
2679 }
2680
2681 Sighandler_t
2682 Perl_rsignal_state(pTHX_ int signo)
2683 {
2684     dVAR;
2685     Sighandler_t oldsig;
2686
2687 #if defined(USE_ITHREADS) && !defined(WIN32)
2688     /* only "parent" interpreter can diddle signals */
2689     if (PL_curinterp != aTHX)
2690         return (Sighandler_t) SIG_ERR;
2691 #endif
2692
2693     PL_sig_trapped = 0;
2694     oldsig = PerlProc_signal(signo, sig_trap);
2695     PerlProc_signal(signo, oldsig);
2696     if (PL_sig_trapped)
2697         PerlProc_kill(PerlProc_getpid(), signo);
2698     return oldsig;
2699 }
2700
2701 int
2702 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2703 {
2704 #if defined(USE_ITHREADS) && !defined(WIN32)
2705     /* only "parent" interpreter can diddle signals */
2706     if (PL_curinterp != aTHX)
2707         return -1;
2708 #endif
2709     *save = PerlProc_signal(signo, handler);
2710     return (*save == (Sighandler_t) SIG_ERR) ? -1 : 0;
2711 }
2712
2713 int
2714 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2715 {
2716 #if defined(USE_ITHREADS) && !defined(WIN32)
2717     /* only "parent" interpreter can diddle signals */
2718     if (PL_curinterp != aTHX)
2719         return -1;
2720 #endif
2721     return (PerlProc_signal(signo, *save) == (Sighandler_t) SIG_ERR) ? -1 : 0;
2722 }
2723
2724 #endif /* !HAS_SIGACTION */
2725 #endif /* !PERL_MICRO */
2726
2727     /* VMS' my_pclose() is in VMS.c; same with OS/2 */
2728 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__LIBCATAMOUNT__)
2729 I32
2730 Perl_my_pclose(pTHX_ PerlIO *ptr)
2731 {
2732     dVAR;
2733     int status;
2734     SV **svp;
2735     Pid_t pid;
2736     Pid_t pid2 = 0;
2737     bool close_failed;
2738     dSAVEDERRNO;
2739     const int fd = PerlIO_fileno(ptr);
2740
2741 #ifdef USE_PERLIO
2742     /* Find out whether the refcount is low enough for us to wait for the
2743        child proc without blocking. */
2744     const bool should_wait = PerlIOUnix_refcnt(fd) == 1;
2745 #else
2746     const bool should_wait = 1;
2747 #endif
2748
2749     svp = av_fetch(PL_fdpid,fd,TRUE);
2750     pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
2751     SvREFCNT_dec(*svp);
2752     *svp = &PL_sv_undef;
2753 #ifdef OS2
2754     if (pid == -1) {                    /* Opened by popen. */
2755         return my_syspclose(ptr);
2756     }
2757 #endif
2758     close_failed = (PerlIO_close(ptr) == EOF);
2759     SAVE_ERRNO;
2760     if (should_wait) do {
2761         pid2 = wait4pid(pid, &status, 0);
2762     } while (pid2 == -1 && errno == EINTR);
2763     if (close_failed) {
2764         RESTORE_ERRNO;
2765         return -1;
2766     }
2767     return(
2768       should_wait
2769        ? pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status)
2770        : 0
2771     );
2772 }
2773 #else
2774 #if defined(__LIBCATAMOUNT__)
2775 I32
2776 Perl_my_pclose(pTHX_ PerlIO *ptr)
2777 {
2778     return -1;
2779 }
2780 #endif
2781 #endif /* !DOSISH */
2782
2783 #if  (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(__LIBCATAMOUNT__)
2784 I32
2785 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
2786 {
2787     dVAR;
2788     I32 result = 0;
2789     PERL_ARGS_ASSERT_WAIT4PID;
2790     if (!pid)
2791         return -1;
2792 #ifdef PERL_USES_PL_PIDSTATUS
2793     {
2794         if (pid > 0) {
2795             /* The keys in PL_pidstatus are now the raw 4 (or 8) bytes of the
2796                pid, rather than a string form.  */
2797             SV * const * const svp = hv_fetch(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),FALSE);
2798             if (svp && *svp != &PL_sv_undef) {
2799                 *statusp = SvIVX(*svp);
2800                 (void)hv_delete(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),
2801                                 G_DISCARD);
2802                 return pid;
2803             }
2804         }
2805         else {
2806             HE *entry;
2807
2808             hv_iterinit(PL_pidstatus);
2809             if ((entry = hv_iternext(PL_pidstatus))) {
2810                 SV * const sv = hv_iterval(PL_pidstatus,entry);
2811                 I32 len;
2812                 const char * const spid = hv_iterkey(entry,&len);
2813
2814                 assert (len == sizeof(Pid_t));
2815                 memcpy((char *)&pid, spid, len);
2816                 *statusp = SvIVX(sv);
2817                 /* The hash iterator is currently on this entry, so simply
2818                    calling hv_delete would trigger the lazy delete, which on
2819                    aggregate does more work, beacuse next call to hv_iterinit()
2820                    would spot the flag, and have to call the delete routine,
2821                    while in the meantime any new entries can't re-use that
2822                    memory.  */
2823                 hv_iterinit(PL_pidstatus);
2824                 (void)hv_delete(PL_pidstatus,spid,len,G_DISCARD);
2825                 return pid;
2826             }
2827         }
2828     }
2829 #endif
2830 #ifdef HAS_WAITPID
2831 #  ifdef HAS_WAITPID_RUNTIME
2832     if (!HAS_WAITPID_RUNTIME)
2833         goto hard_way;
2834 #  endif
2835     result = PerlProc_waitpid(pid,statusp,flags);
2836     goto finish;
2837 #endif
2838 #if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
2839     result = wait4((pid==-1)?0:pid,statusp,flags,NULL);
2840     goto finish;
2841 #endif
2842 #ifdef PERL_USES_PL_PIDSTATUS
2843 #if defined(HAS_WAITPID) && defined(HAS_WAITPID_RUNTIME)
2844   hard_way:
2845 #endif
2846     {
2847         if (flags)
2848             Perl_croak(aTHX_ "Can't do waitpid with flags");
2849         else {
2850             while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
2851                 pidgone(result,*statusp);
2852             if (result < 0)
2853                 *statusp = -1;
2854         }
2855     }
2856 #endif
2857 #if defined(HAS_WAITPID) || defined(HAS_WAIT4)
2858   finish:
2859 #endif
2860     if (result < 0 && errno == EINTR) {
2861         PERL_ASYNC_CHECK();
2862         errno = EINTR; /* reset in case a signal handler changed $! */
2863     }
2864     return result;
2865 }
2866 #endif /* !DOSISH || OS2 || WIN32 || NETWARE */
2867
2868 #ifdef PERL_USES_PL_PIDSTATUS
2869 void
2870 S_pidgone(pTHX_ Pid_t pid, int status)
2871 {
2872     SV *sv;
2873
2874     sv = *hv_fetch(PL_pidstatus,(const char*)&pid,sizeof(Pid_t),TRUE);
2875     SvUPGRADE(sv,SVt_IV);
2876     SvIV_set(sv, status);
2877     return;
2878 }
2879 #endif
2880
2881 #if defined(OS2)
2882 int pclose();
2883 #ifdef HAS_FORK
2884 int                                     /* Cannot prototype with I32
2885                                            in os2ish.h. */
2886 my_syspclose(PerlIO *ptr)
2887 #else
2888 I32
2889 Perl_my_pclose(pTHX_ PerlIO *ptr)
2890 #endif
2891 {
2892     /* Needs work for PerlIO ! */
2893     FILE * const f = PerlIO_findFILE(ptr);
2894     const I32 result = pclose(f);
2895     PerlIO_releaseFILE(ptr,f);
2896     return result;
2897 }
2898 #endif
2899
2900 #if defined(DJGPP)
2901 int djgpp_pclose();
2902 I32
2903 Perl_my_pclose(pTHX_ PerlIO *ptr)
2904 {
2905     /* Needs work for PerlIO ! */
2906     FILE * const f = PerlIO_findFILE(ptr);
2907     I32 result = djgpp_pclose(f);
2908     result = (result << 8) & 0xff00;
2909     PerlIO_releaseFILE(ptr,f);
2910     return result;
2911 }
2912 #endif
2913
2914 #define PERL_REPEATCPY_LINEAR 4
2915 void
2916 Perl_repeatcpy(char *to, const char *from, I32 len, IV count)
2917 {
2918     PERL_ARGS_ASSERT_REPEATCPY;
2919
2920     assert(len >= 0);
2921
2922     if (count < 0)
2923         croak_memory_wrap();
2924
2925     if (len == 1)
2926         memset(to, *from, count);
2927     else if (count) {
2928         char *p = to;
2929         IV items, linear, half;
2930
2931         linear = count < PERL_REPEATCPY_LINEAR ? count : PERL_REPEATCPY_LINEAR;
2932         for (items = 0; items < linear; ++items) {
2933             const char *q = from;
2934             IV todo;
2935             for (todo = len; todo > 0; todo--)
2936                 *p++ = *q++;
2937         }
2938
2939         half = count / 2;
2940         while (items <= half) {
2941             IV size = items * len;
2942             memcpy(p, to, size);
2943             p     += size;
2944             items *= 2;
2945         }
2946
2947         if (count > items)
2948             memcpy(p, to, (count - items) * len);
2949     }
2950 }
2951
2952 #ifndef HAS_RENAME
2953 I32
2954 Perl_same_dirent(pTHX_ const char *a, const char *b)
2955 {
2956     char *fa = strrchr(a,'/');
2957     char *fb = strrchr(b,'/');
2958     Stat_t tmpstatbuf1;
2959     Stat_t tmpstatbuf2;
2960     SV * const tmpsv = sv_newmortal();
2961
2962     PERL_ARGS_ASSERT_SAME_DIRENT;
2963
2964     if (fa)
2965         fa++;
2966     else
2967         fa = a;
2968     if (fb)
2969         fb++;
2970     else
2971         fb = b;
2972     if (strNE(a,b))
2973         return FALSE;
2974     if (fa == a)
2975         sv_setpvs(tmpsv, ".");
2976     else
2977         sv_setpvn(tmpsv, a, fa - a);
2978     if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0)
2979         return FALSE;
2980     if (fb == b)
2981         sv_setpvs(tmpsv, ".");
2982     else
2983         sv_setpvn(tmpsv, b, fb - b);
2984     if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0)
2985         return FALSE;
2986     return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
2987            tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
2988 }
2989 #endif /* !HAS_RENAME */
2990
2991 char*
2992 Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
2993                  const char *const *const search_ext, I32 flags)
2994 {
2995     dVAR;
2996     const char *xfound = NULL;
2997     char *xfailed = NULL;
2998     char tmpbuf[MAXPATHLEN];
2999     char *s;
3000     I32 len = 0;
3001     int retval;
3002     char *bufend;
3003 #if defined(DOSISH) && !defined(OS2)
3004 #  define SEARCH_EXTS ".bat", ".cmd", NULL
3005 #  define MAX_EXT_LEN 4
3006 #endif
3007 #ifdef OS2
3008 #  define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
3009 #  define MAX_EXT_LEN 4
3010 #endif
3011 #ifdef VMS
3012 #  define SEARCH_EXTS ".pl", ".com", NULL
3013 #  define MAX_EXT_LEN 4
3014 #endif
3015     /* additional extensions to try in each dir if scriptname not found */
3016 #ifdef SEARCH_EXTS
3017     static const char *const exts[] = { SEARCH_EXTS };
3018     const char *const *const ext = search_ext ? search_ext : exts;
3019     int extidx = 0, i = 0;
3020     const char *curext = NULL;
3021 #else
3022     PERL_UNUSED_ARG(search_ext);
3023 #  define MAX_EXT_LEN 0
3024 #endif
3025
3026     PERL_ARGS_ASSERT_FIND_SCRIPT;
3027
3028     /*
3029      * If dosearch is true and if scriptname does not contain path
3030      * delimiters, search the PATH for scriptname.
3031      *
3032      * If SEARCH_EXTS is also defined, will look for each
3033      * scriptname{SEARCH_EXTS} whenever scriptname is not found
3034      * while searching the PATH.
3035      *
3036      * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
3037      * proceeds as follows:
3038      *   If DOSISH or VMSISH:
3039      *     + look for ./scriptname{,.foo,.bar}
3040      *     + search the PATH for scriptname{,.foo,.bar}
3041      *
3042      *   If !DOSISH:
3043      *     + look *only* in the PATH for scriptname{,.foo,.bar} (note
3044      *       this will not look in '.' if it's not in the PATH)
3045      */
3046     tmpbuf[0] = '\0';
3047
3048 #ifdef VMS
3049 #  ifdef ALWAYS_DEFTYPES
3050     len = strlen(scriptname);
3051     if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
3052         int idx = 0, deftypes = 1;
3053         bool seen_dot = 1;
3054
3055         const int hasdir = !dosearch || (strpbrk(scriptname,":[</") != NULL);
3056 #  else
3057     if (dosearch) {
3058         int idx = 0, deftypes = 1;
3059         bool seen_dot = 1;
3060
3061         const int hasdir = (strpbrk(scriptname,":[</") != NULL);
3062 #  endif
3063         /* The first time through, just add SEARCH_EXTS to whatever we
3064          * already have, so we can check for default file types. */
3065         while (deftypes ||
3066                (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
3067         {
3068             if (deftypes) {
3069                 deftypes = 0;
3070                 *tmpbuf = '\0';
3071             }
3072             if ((strlen(tmpbuf) + strlen(scriptname)
3073                  + MAX_EXT_LEN) >= sizeof tmpbuf)
3074                 continue;       /* don't search dir with too-long name */
3075             my_strlcat(tmpbuf, scriptname, sizeof(tmpbuf));
3076 #else  /* !VMS */
3077
3078 #ifdef DOSISH
3079     if (strEQ(scriptname, "-"))
3080         dosearch = 0;
3081     if (dosearch) {             /* Look in '.' first. */
3082         const char *cur = scriptname;
3083 #ifdef SEARCH_EXTS
3084         if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
3085             while (ext[i])
3086                 if (strEQ(ext[i++],curext)) {
3087                     extidx = -1;                /* already has an ext */
3088                     break;
3089                 }
3090         do {
3091 #endif
3092             DEBUG_p(PerlIO_printf(Perl_debug_log,
3093                                   "Looking for %s\n",cur));
3094             if (PerlLIO_stat(cur,&PL_statbuf) >= 0
3095                 && !S_ISDIR(PL_statbuf.st_mode)) {
3096                 dosearch = 0;
3097                 scriptname = cur;
3098 #ifdef SEARCH_EXTS
3099                 break;
3100 #endif
3101             }
3102 #ifdef SEARCH_EXTS
3103             if (cur == scriptname) {
3104                 len = strlen(scriptname);
3105                 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
3106                     break;
3107                 my_strlcpy(tmpbuf, scriptname, sizeof(tmpbuf));
3108                 cur = tmpbuf;
3109             }
3110         } while (extidx >= 0 && ext[extidx]     /* try an extension? */
3111                  && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len));
3112 #endif
3113     }
3114 #endif
3115
3116     if (dosearch && !strchr(scriptname, '/')
3117 #ifdef DOSISH
3118                  && !strchr(scriptname, '\\')
3119 #endif
3120                  && (s = PerlEnv_getenv("PATH")))
3121     {
3122         bool seen_dot = 0;
3123
3124         bufend = s + strlen(s);
3125         while (s < bufend) {
3126 #  ifdef DOSISH
3127             for (len = 0; *s
3128                     && *s != ';'; len++, s++) {
3129                 if (len < sizeof tmpbuf)
3130                     tmpbuf[len] = *s;
3131             }
3132             if (len < sizeof tmpbuf)
3133                 tmpbuf[len] = '\0';
3134 #  else
3135             s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend,
3136                         ':',
3137                         &len);
3138 #  endif
3139             if (s < bufend)
3140                 s++;
3141             if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
3142                 continue;       /* don't search dir with too-long name */
3143             if (len
3144 #  ifdef DOSISH
3145                 && tmpbuf[len - 1] != '/'
3146                 && tmpbuf[len - 1] != '\\'
3147 #  endif
3148                )
3149                 tmpbuf[len++] = '/';
3150             if (len == 2 && tmpbuf[0] == '.')
3151                 seen_dot = 1;
3152             (void)my_strlcpy(tmpbuf + len, scriptname, sizeof(tmpbuf) - len);
3153 #endif  /* !VMS */
3154
3155 #ifdef SEARCH_EXTS
3156             len = strlen(tmpbuf);
3157             if (extidx > 0)     /* reset after previous loop */
3158                 extidx = 0;
3159             do {
3160 #endif
3161                 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
3162                 retval = PerlLIO_stat(tmpbuf,&PL_statbuf);
3163                 if (S_ISDIR(PL_statbuf.st_mode)) {
3164                     retval = -1;
3165                 }
3166 #ifdef SEARCH_EXTS
3167             } while (  retval < 0               /* not there */
3168                     && extidx>=0 && ext[extidx] /* try an extension? */
3169                     && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len)
3170                 );
3171 #endif
3172             if (retval < 0)
3173                 continue;
3174             if (S_ISREG(PL_statbuf.st_mode)
3175                 && cando(S_IRUSR,TRUE,&PL_statbuf)
3176 #if !defined(DOSISH)
3177                 && cando(S_IXUSR,TRUE,&PL_statbuf)
3178 #endif
3179                 )
3180             {
3181                 xfound = tmpbuf;                /* bingo! */
3182                 break;
3183             }
3184             if (!xfailed)
3185                 xfailed = savepv(tmpbuf);
3186         }
3187 #ifndef DOSISH
3188         if (!xfound && !seen_dot && !xfailed &&
3189             (PerlLIO_stat(scriptname,&PL_statbuf) < 0
3190              || S_ISDIR(PL_statbuf.st_mode)))
3191 #endif
3192             seen_dot = 1;                       /* Disable message. */
3193         if (!xfound) {
3194             if (flags & 1) {                    /* do or die? */
3195                 /* diag_listed_as: Can't execute %s */
3196                 Perl_croak(aTHX_ "Can't %s %s%s%s",
3197                       (xfailed ? "execute" : "find"),
3198                       (xfailed ? xfailed : scriptname),
3199                       (xfailed ? "" : " on PATH"),
3200                       (xfailed || seen_dot) ? "" : ", '.' not in PATH");
3201             }
3202             scriptname = NULL;
3203         }
3204         Safefree(xfailed);
3205         scriptname = xfound;
3206     }
3207     return (scriptname ? savepv(scriptname) : NULL);
3208 }
3209
3210 #ifndef PERL_GET_CONTEXT_DEFINED
3211
3212 void *
3213 Perl_get_context(void)
3214 {
3215     dVAR;
3216 #if defined(USE_ITHREADS)
3217 #  ifdef OLD_PTHREADS_API
3218     pthread_addr_t t;
3219     int error = pthread_getspecific(PL_thr_key, &t)
3220     if (error)
3221         Perl_croak_nocontext("panic: pthread_getspecific, error=%d", error);
3222     return (void*)t;
3223 #  else
3224 #    ifdef I_MACH_CTHREADS
3225     return (void*)cthread_data(cthread_self());
3226 #    else
3227     return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
3228 #    endif
3229 #  endif
3230 #else
3231     return (void*)NULL;
3232 #endif
3233 }
3234
3235 void
3236 Perl_set_context(void *t)
3237 {
3238     dVAR;
3239     PERL_ARGS_ASSERT_SET_CONTEXT;
3240 #if defined(USE_ITHREADS)
3241 #  ifdef I_MACH_CTHREADS
3242     cthread_set_data(cthread_self(), t);
3243 #  else
3244     {
3245         const int error = pthread_setspecific(PL_thr_key, t);
3246         if (error)
3247             Perl_croak_nocontext("panic: pthread_setspecific, error=%d", error);
3248     }
3249 #  endif
3250 #else
3251     PERL_UNUSED_ARG(t);
3252 #endif
3253 }
3254
3255 #endif /* !PERL_GET_CONTEXT_DEFINED */
3256
3257 #if defined(PERL_GLOBAL_STRUCT) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
3258 struct perl_vars *
3259 Perl_GetVars(pTHX)
3260 {
3261  return &PL_Vars;
3262 }
3263 #endif
3264
3265 char **
3266 Perl_get_op_names(pTHX)
3267 {
3268     PERL_UNUSED_CONTEXT;
3269     return (char **)PL_op_name;
3270 }
3271
3272 char **
3273 Perl_get_op_descs(pTHX)
3274 {
3275     PERL_UNUSED_CONTEXT;
3276     return (char **)PL_op_desc;
3277 }
3278
3279 const char *
3280 Perl_get_no_modify(pTHX)
3281 {
3282     PERL_UNUSED_CONTEXT;
3283     return PL_no_modify;
3284 }
3285
3286 U32 *
3287 Perl_get_opargs(pTHX)
3288 {
3289     PERL_UNUSED_CONTEXT;
3290     return (U32 *)PL_opargs;
3291 }
3292
3293 PPADDR_t*
3294 Perl_get_ppaddr(pTHX)
3295 {
3296     dVAR;
3297     PERL_UNUSED_CONTEXT;
3298     return (PPADDR_t*)PL_ppaddr;
3299 }
3300
3301 #ifndef HAS_GETENV_LEN
3302 char *
3303 Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
3304 {
3305     char * const env_trans = PerlEnv_getenv(env_elem);
3306     PERL_UNUSED_CONTEXT;
3307     PERL_ARGS_ASSERT_GETENV_LEN;
3308     if (env_trans)
3309         *len = strlen(env_trans);
3310     return env_trans;
3311 }
3312 #endif
3313
3314
3315 MGVTBL*
3316 Perl_get_vtbl(pTHX_ int vtbl_id)
3317 {
3318     PERL_UNUSED_CONTEXT;
3319
3320     return (vtbl_id < 0 || vtbl_id >= magic_vtable_max)
3321         ? NULL : PL_magic_vtables + vtbl_id;
3322 }
3323
3324 I32
3325 Perl_my_fflush_all(pTHX)
3326 {
3327 #if defined(USE_PERLIO) || defined(FFLUSH_NULL) || defined(USE_SFIO)
3328     return PerlIO_flush(NULL);
3329 #else
3330 # if defined(HAS__FWALK)
3331     extern int fflush(FILE *);
3332     /* undocumented, unprototyped, but very useful BSDism */
3333     extern void _fwalk(int (*)(FILE *));
3334     _fwalk(&fflush);
3335     return 0;
3336 # else
3337 #  if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
3338     long open_max = -1;
3339 #   ifdef PERL_FFLUSH_ALL_FOPEN_MAX
3340     open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
3341 #   else
3342 #    if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
3343     open_max = sysconf(_SC_OPEN_MAX);
3344 #     else
3345 #      ifdef FOPEN_MAX
3346     open_max = FOPEN_MAX;
3347 #      else
3348 #       ifdef OPEN_MAX
3349     open_max = OPEN_MAX;
3350 #       else
3351 #        ifdef _NFILE
3352     open_max = _NFILE;
3353 #        endif
3354 #       endif
3355 #      endif
3356 #     endif
3357 #    endif
3358     if (open_max > 0) {
3359       long i;
3360       for (i = 0; i < open_max; i++)
3361             if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
3362                 STDIO_STREAM_ARRAY[i]._file < open_max &&
3363                 STDIO_STREAM_ARRAY[i]._flag)
3364                 PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
3365       return 0;
3366     }
3367 #  endif
3368     SETERRNO(EBADF,RMS_IFI);
3369     return EOF;
3370 # endif
3371 #endif
3372 }
3373
3374 void
3375 Perl_report_wrongway_fh(pTHX_ const GV *gv, const char have)
3376 {
3377     if (ckWARN(WARN_IO)) {
3378         HEK * const name
3379            = gv && (isGV_with_GP(gv))
3380                 ? GvENAME_HEK((gv))
3381                 : NULL;
3382         const char * const direction = have == '>' ? "out" : "in";
3383
3384         if (name && HEK_LEN(name))
3385             Perl_warner(aTHX_ packWARN(WARN_IO),
3386                         "Filehandle %"HEKf" opened only for %sput",
3387                         name, direction);
3388         else
3389             Perl_warner(aTHX_ packWARN(WARN_IO),
3390                         "Filehandle opened only for %sput", direction);
3391     }
3392 }
3393
3394 void
3395 Perl_report_evil_fh(pTHX_ const GV *gv)
3396 {
3397     const IO *io = gv ? GvIO(gv) : NULL;
3398     const PERL_BITFIELD16 op = PL_op->op_type;
3399     const char *vile;
3400     I32 warn_type;
3401
3402     if (io && IoTYPE(io) == IoTYPE_CLOSED) {
3403         vile = "closed";
3404         warn_type = WARN_CLOSED;
3405     }
3406     else {
3407         vile = "unopened";
3408         warn_type = WARN_UNOPENED;
3409     }
3410
3411     if (ckWARN(warn_type)) {
3412         SV * const name
3413             = gv && isGV_with_GP(gv) && GvENAMELEN(gv) ?
3414                                      sv_2mortal(newSVhek(GvENAME_HEK(gv))) : NULL;
3415         const char * const pars =
3416             (const char *)(OP_IS_FILETEST(op) ? "" : "()");
3417         const char * const func =
3418             (const char *)
3419             (op == OP_READLINE   ? "readline"  :        /* "<HANDLE>" not nice */
3420              op == OP_LEAVEWRITE ? "write" :            /* "write exit" not nice */
3421              PL_op_desc[op]);
3422         const char * const type =
3423             (const char *)
3424             (OP_IS_SOCKET(op) || (io && IoTYPE(io) == IoTYPE_SOCKET)
3425              ? "socket" : "filehandle");
3426         const bool have_name = name && SvCUR(name);
3427         Perl_warner(aTHX_ packWARN(warn_type),
3428                    "%s%s on %s %s%s%"SVf, func, pars, vile, type,
3429                     have_name ? " " : "",
3430                     SVfARG(have_name ? name : &PL_sv_no));
3431         if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3432                 Perl_warner(
3433                             aTHX_ packWARN(warn_type),
3434                         "\t(Are you trying to call %s%s on dirhandle%s%"SVf"?)\n",
3435                         func, pars, have_name ? " " : "",
3436                         SVfARG(have_name ? name : &PL_sv_no)
3437                             );
3438     }
3439 }
3440
3441 /* To workaround core dumps from the uninitialised tm_zone we get the
3442  * system to give us a reasonable struct to copy.  This fix means that
3443  * strftime uses the tm_zone and tm_gmtoff values returned by
3444  * localtime(time()). That should give the desired result most of the
3445  * time. But probably not always!
3446  *
3447  * This does not address tzname aspects of NETaa14816.
3448  *
3449  */
3450
3451 #ifdef HAS_GNULIBC
3452 # ifndef STRUCT_TM_HASZONE
3453 #    define STRUCT_TM_HASZONE
3454 # endif
3455 #endif
3456
3457 #ifdef STRUCT_TM_HASZONE /* Backward compat */
3458 # ifndef HAS_TM_TM_ZONE
3459 #    define HAS_TM_TM_ZONE
3460 # endif
3461 #endif
3462
3463 void
3464 Perl_init_tm(pTHX_ struct tm *ptm)      /* see mktime, strftime and asctime */
3465 {
3466 #ifdef HAS_TM_TM_ZONE
3467     Time_t now;
3468     const struct tm* my_tm;
3469     PERL_ARGS_ASSERT_INIT_TM;
3470     (void)time(&now);
3471     my_tm = localtime(&now);
3472     if (my_tm)
3473         Copy(my_tm, ptm, 1, struct tm);
3474 #else
3475     PERL_ARGS_ASSERT_INIT_TM;
3476     PERL_UNUSED_ARG(ptm);
3477 #endif
3478 }
3479
3480 /*
3481  * mini_mktime - normalise struct tm values without the localtime()
3482  * semantics (and overhead) of mktime().
3483  */
3484 void
3485 Perl_mini_mktime(pTHX_ struct tm *ptm)
3486 {
3487     int yearday;
3488     int secs;
3489     int month, mday, year, jday;
3490     int odd_cent, odd_year;
3491     PERL_UNUSED_CONTEXT;
3492
3493     PERL_ARGS_ASSERT_MINI_MKTIME;
3494
3495 #define DAYS_PER_YEAR   365
3496 #define DAYS_PER_QYEAR  (4*DAYS_PER_YEAR+1)
3497 #define DAYS_PER_CENT   (25*DAYS_PER_QYEAR-1)
3498 #define DAYS_PER_QCENT  (4*DAYS_PER_CENT+1)
3499 #define SECS_PER_HOUR   (60*60)
3500 #define SECS_PER_DAY    (24*SECS_PER_HOUR)
3501 /* parentheses deliberately absent on these two, otherwise they don't work */
3502 #define MONTH_TO_DAYS   153/5
3503 #define DAYS_TO_MONTH   5/153
3504 /* offset to bias by March (month 4) 1st between month/mday & year finding */
3505 #define YEAR_ADJUST     (4*MONTH_TO_DAYS+1)
3506 /* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */
3507 #define WEEKDAY_BIAS    6       /* (1+6)%7 makes Sunday 0 again */
3508
3509 /*
3510  * Year/day algorithm notes:
3511  *
3512  * With a suitable offset for numeric value of the month, one can find
3513  * an offset into the year by considering months to have 30.6 (153/5) days,
3514  * using integer arithmetic (i.e., with truncation).  To avoid too much
3515  * messing about with leap days, we consider January and February to be
3516  * the 13th and 14th month of the previous year.  After that transformation,
3517  * we need the month index we use to be high by 1 from 'normal human' usage,
3518  * so the month index values we use run from 4 through 15.
3519  *
3520  * Given that, and the rules for the Gregorian calendar (leap years are those
3521  * divisible by 4 unless also divisible by 100, when they must be divisible
3522  * by 400 instead), we can simply calculate the number of days since some
3523  * arbitrary 'beginning of time' by futzing with the (adjusted) year number,
3524  * the days we derive from our month index, and adding in the day of the
3525  * month.  The value used here is not adjusted for the actual origin which
3526  * it normally would use (1 January A.D. 1), since we're not exposing it.
3527  * We're only building the value so we can turn around and get the
3528  * normalised values for the year, month, day-of-month, and day-of-year.
3529  *
3530  * For going backward, we need to bias the value we're using so that we find
3531  * the right year value.  (Basically, we don't want the contribution of
3532  * March 1st to the number to apply while deriving the year).  Having done
3533  * that, we 'count up' the contribution to the year number by accounting for
3534  * full quadracenturies (400-year periods) with their extra leap days, plus
3535  * the contribution from full centuries (to avoid counting in the lost leap
3536  * days), plus the contribution from full quad-years (to count in the normal
3537  * leap days), plus the leftover contribution from any non-leap years.
3538  * At this point, if we were working with an actual leap day, we'll have 0
3539  * days left over.  This is also true for March 1st, however.  So, we have
3540  * to special-case that result, and (earlier) keep track of the 'odd'
3541  * century and year contributions.  If we got 4 extra centuries in a qcent,
3542  * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb.
3543  * Otherwise, we add back in the earlier bias we removed (the 123 from
3544  * figuring in March 1st), find the month index (integer division by 30.6),
3545  * and the remainder is the day-of-month.  We then have to convert back to
3546  * 'real' months (including fixing January and February from being 14/15 in
3547  * the previous year to being in the proper year).  After that, to get
3548  * tm_yday, we work with the normalised year and get a new yearday value for
3549  * January 1st, which we subtract from the yearday value we had earlier,
3550  * representing the date we've re-built.  This is done from January 1
3551  * because tm_yday is 0-origin.
3552  *
3553  * Since POSIX time routines are only guaranteed to work for times since the
3554  * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm
3555  * applies Gregorian calendar rules even to dates before the 16th century
3556  * doesn't bother me.  Besides, you'd need cultural context for a given
3557  * date to know whether it was Julian or Gregorian calendar, and that's
3558  * outside the scope for this routine.  Since we convert back based on the
3559  * same rules we used to build the yearday, you'll only get strange results
3560  * for input which needed normalising, or for the 'odd' century years which
3561  * were leap years in the Julian calendar but not in the Gregorian one.
3562  * I can live with that.
3563  *
3564  * This algorithm also fails to handle years before A.D. 1 gracefully, but
3565  * that's still outside the scope for POSIX time manipulation, so I don't
3566  * care.
3567  */
3568
3569     year = 1900 + ptm->tm_year;
3570     month = ptm->tm_mon;
3571     mday = ptm->tm_mday;
3572     jday = 0;
3573     if (month >= 2)
3574         month+=2;
3575     else
3576         month+=14, year--;
3577     yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400;
3578     yearday += month*MONTH_TO_DAYS + mday + jday;
3579     /*
3580      * Note that we don't know when leap-seconds were or will be,
3581      * so we have to trust the user if we get something which looks
3582      * like a sensible leap-second.  Wild values for seconds will
3583      * be rationalised, however.
3584      */
3585     if ((unsigned) ptm->tm_sec <= 60) {
3586         secs = 0;
3587     }
3588     else {
3589         secs = ptm->tm_sec;
3590         ptm->tm_sec = 0;
3591     }
3592     secs += 60 * ptm->tm_min;
3593     secs += SECS_PER_HOUR * ptm->tm_hour;
3594     if (secs < 0) {
3595         if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) {
3596             /* got negative remainder, but need positive time */
3597             /* back off an extra day to compensate */
3598             yearday += (secs/SECS_PER_DAY)-1;
3599             secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1);
3600         }
3601         else {
3602             yearday += (secs/SECS_PER_DAY);
3603             secs -= SECS_PER_DAY * (secs/SECS_PER_DAY);
3604         }
3605     }
3606     else if (secs >= SECS_PER_DAY) {
3607         yearday += (secs/SECS_PER_DAY);
3608         secs %= SECS_PER_DAY;
3609     }
3610     ptm->tm_hour = secs/SECS_PER_HOUR;
3611     secs %= SECS_PER_HOUR;
3612     ptm->tm_min = secs/60;
3613     secs %= 60;
3614     ptm->tm_sec += secs;
3615     /* done with time of day effects */
3616     /*
3617      * The algorithm for yearday has (so far) left it high by 428.
3618      * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to
3619      * bias it by 123 while trying to figure out what year it
3620      * really represents.  Even with this tweak, the reverse
3621      * translation fails for years before A.D. 0001.
3622      * It would still fail for Feb 29, but we catch that one below.
3623      */
3624     jday = yearday;     /* save for later fixup vis-a-vis Jan 1 */
3625     yearday -= YEAR_ADJUST;
3626     year = (yearday / DAYS_PER_QCENT) * 400;
3627     yearday %= DAYS_PER_QCENT;
3628     odd_cent = yearday / DAYS_PER_CENT;
3629     year += odd_cent * 100;
3630     yearday %= DAYS_PER_CENT;
3631     year += (yearday / DAYS_PER_QYEAR) * 4;
3632     yearday %= DAYS_PER_QYEAR;
3633     odd_year = yearday / DAYS_PER_YEAR;
3634     year += odd_year;
3635     yearday %= DAYS_PER_YEAR;
3636     if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */
3637         month = 1;
3638         yearday = 29;
3639     }
3640     else {
3641         yearday += YEAR_ADJUST; /* recover March 1st crock */
3642         month = yearday*DAYS_TO_MONTH;
3643         yearday -= month*MONTH_TO_DAYS;
3644         /* recover other leap-year adjustment */
3645         if (month > 13) {
3646             month-=14;
3647             year++;
3648         }
3649         else {
3650             month-=2;
3651         }
3652     }
3653     ptm->tm_year = year - 1900;
3654     if (yearday) {
3655       ptm->tm_mday = yearday;
3656       ptm->tm_mon = month;
3657     }
3658     else {
3659       ptm->tm_mday = 31;
3660       ptm->tm_mon = month - 1;
3661     }
3662     /* re-build yearday based on Jan 1 to get tm_yday */
3663     year--;
3664     yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400;
3665     yearday += 14*MONTH_TO_DAYS + 1;
3666     ptm->tm_yday = jday - yearday;
3667     ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
3668 }
3669
3670 char *
3671 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)
3672 {
3673 #ifdef HAS_STRFTIME
3674   char *buf;
3675   int buflen;
3676   struct tm mytm;
3677   int len;
3678
3679   PERL_ARGS_ASSERT_MY_STRFTIME;
3680
3681   init_tm(&mytm);       /* XXX workaround - see init_tm() above */
3682   mytm.tm_sec = sec;
3683   mytm.tm_min = min;
3684   mytm.tm_hour = hour;
3685   mytm.tm_mday = mday;
3686   mytm.tm_mon = mon;
3687   mytm.tm_year = year;
3688   mytm.tm_wday = wday;
3689   mytm.tm_yday = yday;
3690   mytm.tm_isdst = isdst;
3691   mini_mktime(&mytm);
3692   /* use libc to get the values for tm_gmtoff and tm_zone [perl #18238] */
3693 #if defined(HAS_MKTIME) && (defined(HAS_TM_TM_GMTOFF) || defined(HAS_TM_TM_ZONE))
3694   STMT_START {
3695     struct tm mytm2;
3696     mytm2 = mytm;
3697     mktime(&mytm2);
3698 #ifdef HAS_TM_TM_GMTOFF
3699     mytm.tm_gmtoff = mytm2.tm_gmtoff;
3700 #endif
3701 #ifdef HAS_TM_TM_ZONE
3702     mytm.tm_zone = mytm2.tm_zone;
3703 #endif
3704   } STMT_END;
3705 #endif
3706   buflen = 64;
3707   Newx(buf, buflen, char);
3708   len = strftime(buf, buflen, fmt, &mytm);
3709   /*
3710   ** The following is needed to handle to the situation where
3711   ** tmpbuf overflows.  Basically we want to allocate a buffer
3712   ** and try repeatedly.  The reason why it is so complicated
3713   ** is that getting a return value of 0 from strftime can indicate
3714   ** one of the following:
3715   ** 1. buffer overflowed,
3716   ** 2. illegal conversion specifier, or
3717   ** 3. the format string specifies nothing to be returned(not
3718   **      an error).  This could be because format is an empty string
3719   **    or it specifies %p that yields an empty string in some locale.
3720   ** If there is a better way to make it portable, go ahead by
3721   ** all means.
3722   */
3723   if ((len > 0 && len < buflen) || (len == 0 && *fmt == '\0'))
3724     return buf;
3725   else {
3726     /* Possibly buf overflowed - try again with a bigger buf */
3727     const int fmtlen = strlen(fmt);
3728     int bufsize = fmtlen + buflen;
3729
3730     Renew(buf, bufsize, char);
3731     while (buf) {
3732       buflen = strftime(buf, bufsize, fmt, &mytm);
3733       if (buflen > 0 && buflen < bufsize)
3734         break;
3735       /* heuristic to prevent out-of-memory errors */
3736       if (bufsize > 100*fmtlen) {
3737         Safefree(buf);
3738         buf = NULL;
3739         break;
3740       }
3741       bufsize *= 2;
3742       Renew(buf, bufsize, char);
3743     }
3744     return buf;
3745   }
3746 #else
3747   Perl_croak(aTHX_ "panic: no strftime");
3748   return NULL;
3749 #endif
3750 }
3751
3752
3753 #define SV_CWD_RETURN_UNDEF \
3754 sv_setsv(sv, &PL_sv_undef); \
3755 return FALSE
3756
3757 #define SV_CWD_ISDOT(dp) \
3758     (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
3759         (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
3760
3761 /*
3762 =head1 Miscellaneous Functions
3763
3764 =for apidoc getcwd_sv
3765
3766 Fill the sv with current working directory
3767
3768 =cut
3769 */
3770
3771 /* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars.
3772  * rewritten again by dougm, optimized for use with xs TARG, and to prefer
3773  * getcwd(3) if available
3774  * Comments from the orignal:
3775  *     This is a faster version of getcwd.  It's also more dangerous
3776  *     because you might chdir out of a directory that you can't chdir
3777  *     back into. */
3778
3779 int
3780 Perl_getcwd_sv(pTHX_ SV *sv)
3781 {
3782 #ifndef PERL_MICRO
3783     dVAR;
3784 #ifndef INCOMPLETE_TAINTS
3785     SvTAINTED_on(sv);
3786 #endif
3787
3788     PERL_ARGS_ASSERT_GETCWD_SV;
3789
3790 #ifdef HAS_GETCWD
3791     {
3792         char buf[MAXPATHLEN];
3793
3794         /* Some getcwd()s automatically allocate a buffer of the given
3795          * size from the heap if they are given a NULL buffer pointer.
3796          * The problem is that this behaviour is not portable. */
3797         if (getcwd(buf, sizeof(buf) - 1)) {
3798             sv_setpv(sv, buf);
3799             return TRUE;
3800         }
3801         else {
3802             sv_setsv(sv, &PL_sv_undef);
3803             return FALSE;
3804         }
3805     }
3806
3807 #else
3808
3809     Stat_t statbuf;
3810     int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
3811     int pathlen=0;
3812     Direntry_t *dp;
3813
3814     SvUPGRADE(sv, SVt_PV);
3815
3816     if (PerlLIO_lstat(".", &statbuf) < 0) {
3817         SV_CWD_RETURN_UNDEF;
3818     }
3819
3820     orig_cdev = statbuf.st_dev;
3821     orig_cino = statbuf.st_ino;
3822     cdev = orig_cdev;
3823     cino = orig_cino;
3824
3825     for (;;) {
3826         DIR *dir;
3827         int namelen;
3828         odev = cdev;
3829         oino = cino;
3830
3831         if (PerlDir_chdir("..") < 0) {
3832             SV_CWD_RETURN_UNDEF;
3833         }
3834         if (PerlLIO_stat(".", &statbuf) < 0) {
3835             SV_CWD_RETURN_UNDEF;
3836         }
3837
3838         cdev = statbuf.st_dev;
3839         cino = statbuf.st_ino;
3840
3841         if (odev == cdev && oino == cino) {
3842             break;
3843         }
3844         if (!(dir = PerlDir_open("."))) {
3845             SV_CWD_RETURN_UNDEF;
3846         }
3847
3848         while ((dp = PerlDir_read(dir)) != NULL) {
3849 #ifdef DIRNAMLEN
3850             namelen = dp->d_namlen;
3851 #else
3852             namelen = strlen(dp->d_name);
3853 #endif
3854             /* skip . and .. */
3855             if (SV_CWD_ISDOT(dp)) {
3856                 continue;
3857             }
3858
3859             if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
3860                 SV_CWD_RETURN_UNDEF;
3861             }
3862
3863             tdev = statbuf.st_dev;
3864             tino = statbuf.st_ino;
3865             if (tino == oino && tdev == odev) {
3866                 break;
3867             }
3868         }
3869
3870         if (!dp) {
3871             SV_CWD_RETURN_UNDEF;
3872         }
3873
3874         if (pathlen + namelen + 1 >= MAXPATHLEN) {
3875             SV_CWD_RETURN_UNDEF;
3876         }
3877
3878         SvGROW(sv, pathlen + namelen + 1);
3879
3880         if (pathlen) {
3881             /* shift down */
3882             Move(SvPVX_const(sv), SvPVX(sv) + namelen + 1, pathlen, char);
3883         }
3884
3885         /* prepend current directory to the front */
3886         *SvPVX(sv) = '/';
3887         Move(dp->d_name, SvPVX(sv)+1, namelen, char);
3888         pathlen += (namelen + 1);
3889
3890 #ifdef VOID_CLOSEDIR
3891         PerlDir_close(dir);
3892 #else
3893         if (PerlDir_close(dir) < 0) {
3894             SV_CWD_RETURN_UNDEF;
3895         }
3896 #endif
3897     }
3898
3899     if (pathlen) {
3900         SvCUR_set(sv, pathlen);
3901         *SvEND(sv) = '\0';
3902         SvPOK_only(sv);
3903
3904         if (PerlDir_chdir(SvPVX_const(sv)) < 0) {
3905             SV_CWD_RETURN_UNDEF;
3906         }
3907     }
3908     if (PerlLIO_stat(".", &statbuf) < 0) {
3909         SV_CWD_RETURN_UNDEF;
3910     }
3911
3912     cdev = statbuf.st_dev;
3913     cino = statbuf.st_ino;
3914
3915     if (cdev != orig_cdev || cino != orig_cino) {
3916         Perl_croak(aTHX_ "Unstable directory path, "
3917                    "current directory changed unexpectedly");
3918     }
3919
3920     return TRUE;
3921 #endif
3922
3923 #else
3924     return FALSE;
3925 #endif
3926 }
3927
3928 #define VERSION_MAX 0x7FFFFFFF
3929
3930 /*
3931 =for apidoc prescan_version
3932
3933 Validate that a given string can be parsed as a version object, but doesn't
3934 actually perform the parsing.  Can use either strict or lax validation rules.
3935 Can optionally set a number of hint variables to save the parsing code
3936 some time when tokenizing.
3937
3938 =cut
3939 */
3940 const char *
3941 Perl_prescan_version(pTHX_ const char *s, bool strict,
3942                      const char **errstr,
3943                      bool *sqv, int *ssaw_decimal, int *swidth, bool *salpha) {
3944     bool qv = (sqv ? *sqv : FALSE);
3945     int width = 3;
3946     int saw_decimal = 0;
3947     bool alpha = FALSE;
3948     const char *d = s;
3949
3950     PERL_ARGS_ASSERT_PRESCAN_VERSION;
3951
3952     if (qv && isDIGIT(*d))
3953         goto dotted_decimal_version;
3954
3955     if (*d == 'v') { /* explicit v-string */
3956         d++;
3957         if (isDIGIT(*d)) {
3958             qv = TRUE;
3959         }
3960         else { /* degenerate v-string */
3961             /* requires v1.2.3 */
3962             BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
3963         }
3964
3965 dotted_decimal_version:
3966         if (strict && d[0] == '0' && isDIGIT(d[1])) {
3967             /* no leading zeros allowed */
3968             BADVERSION(s,errstr,"Invalid version format (no leading zeros)");
3969         }
3970
3971         while (isDIGIT(*d))     /* integer part */
3972             d++;
3973
3974         if (*d == '.')
3975         {
3976             saw_decimal++;
3977             d++;                /* decimal point */
3978         }
3979         else
3980         {
3981             if (strict) {
3982                 /* require v1.2.3 */
3983                 BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
3984             }
3985             else {
3986                 goto version_prescan_finish;
3987             }
3988         }
3989
3990         {
3991             int i = 0;
3992             int j = 0;
3993             while (isDIGIT(*d)) {       /* just keep reading */
3994                 i++;
3995                 while (isDIGIT(*d)) {
3996                     d++; j++;
3997                     /* maximum 3 digits between decimal */
3998                     if (strict && j > 3) {
3999                         BADVERSION(s,errstr,"Invalid version format (maximum 3 digits between decimals)");
4000                     }
4001                 }
4002                 if (*d == '_') {
4003                     if (strict) {
4004                         BADVERSION(s,errstr,"Invalid version format (no underscores)");
4005                     }
4006                     if ( alpha ) {
4007                         BADVERSION(s,errstr,"Invalid version format (multiple underscores)");
4008                     }
4009                     d++;
4010                     alpha = TRUE;
4011                 }
4012                 else if (*d == '.') {
4013                     if (alpha) {
4014                         BADVERSION(s,errstr,"Invalid version format (underscores before decimal)");
4015                     }
4016                     saw_decimal++;
4017                     d++;
4018                 }
4019                 else if (!isDIGIT(*d)) {
4020                     break;
4021                 }
4022                 j = 0;
4023             }
4024
4025             if (strict && i < 2) {
4026                 /* requires v1.2.3 */
4027                 BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
4028             }
4029         }
4030     }                                   /* end if dotted-decimal */
4031     else
4032     {                                   /* decimal versions */
4033         int j = 0;                      /* may need this later */
4034         /* special strict case for leading '.' or '0' */
4035         if (strict) {
4036             if (*d == '.') {
4037                 BADVERSION(s,errstr,"Invalid version format (0 before decimal required)");
4038             }
4039             if (*d == '0' && isDIGIT(d[1])) {
4040                 BADVERSION(s,errstr,"Invalid version format (no leading zeros)");
4041             }
4042         }
4043
4044         /* and we never support negative versions */
4045         if ( *d == '-') {
4046             BADVERSION(s,errstr,"Invalid version format (negative version number)");
4047         }
4048
4049         /* consume all of the integer part */
4050         while (isDIGIT(*d))
4051             d++;
4052
4053         /* look for a fractional part */
4054         if (*d == '.') {
4055             /* we found it, so consume it */
4056             saw_decimal++;
4057             d++;
4058         }
4059         else if (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') {
4060             if ( d == s ) {
4061                 /* found nothing */
4062                 BADVERSION(s,errstr,"Invalid version format (version required)");
4063             }
4064             /* found just an integer */
4065             goto version_prescan_finish;
4066         }
4067         else if ( d == s ) {
4068             /* didn't find either integer or period */
4069             BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
4070         }
4071         else if (*d == '_') {
4072             /* underscore can't come after integer part */
4073             if (strict) {
4074                 BADVERSION(s,errstr,"Invalid version format (no underscores)");
4075             }
4076             else if (isDIGIT(d[1])) {
4077                 BADVERSION(s,errstr,"Invalid version format (alpha without decimal)");
4078             }
4079             else {
4080                 BADVERSION(s,errstr,"Invalid version format (misplaced underscore)");
4081             }
4082         }
4083         else {
4084             /* anything else after integer part is just invalid data */
4085             BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
4086         }
4087
4088         /* scan the fractional part after the decimal point*/
4089
4090         if (!isDIGIT(*d) && (strict || ! (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') )) {
4091                 /* strict or lax-but-not-the-end */
4092                 BADVERSION(s,errstr,"Invalid version format (fractional part required)");
4093         }
4094
4095         while (isDIGIT(*d)) {
4096             d++; j++;
4097             if (*d == '.' && isDIGIT(d[-1])) {
4098                 if (alpha) {
4099                     BADVERSION(s,errstr,"Invalid version format (underscores before decimal)");
4100                 }
4101                 if (strict) {
4102                     BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions must begin with 'v')");
4103                 }
4104                 d = (char *)s;          /* start all over again */
4105                 qv = TRUE;
4106                 goto dotted_decimal_version;
4107             }
4108             if (*d == '_') {
4109                 if (strict) {
4110                     BADVERSION(s,errstr,"Invalid version format (no underscores)");
4111                 }
4112                 if ( alpha ) {
4113                     BADVERSION(s,errstr,"Invalid version format (multiple underscores)");
4114                 }
4115                 if ( ! isDIGIT(d[1]) ) {
4116                     BADVERSION(s,errstr,"Invalid version format (misplaced underscore)");
4117                 }
4118                 width = j;
4119                 d++;
4120                 alpha = TRUE;
4121             }
4122         }
4123     }
4124
4125 version_prescan_finish:
4126     while (isSPACE(*d))
4127         d++;
4128
4129     if (!isDIGIT(*d) && (! (!*d || *d == ';' || *d == '{' || *d == '}') )) {
4130         /* trailing non-numeric data */
4131         BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
4132     }
4133
4134     if (sqv)
4135         *sqv = qv;
4136     if (swidth)
4137         *swidth = width;
4138     if (ssaw_decimal)
4139         *ssaw_decimal = saw_decimal;
4140     if (salpha)
4141         *salpha = alpha;
4142     return d;
4143 }
4144
4145 /*
4146 =for apidoc scan_version
4147
4148 Returns a pointer to the next character after the parsed
4149 version string, as well as upgrading the passed in SV to
4150 an RV.
4151
4152 Function must be called with an already existing SV like
4153
4154     sv = newSV(0);
4155     s = scan_version(s, SV *sv, bool qv);
4156
4157 Performs some preprocessing to the string to ensure that
4158 it has the correct characteristics of a version.  Flags the
4159 object if it contains an underscore (which denotes this
4160 is an alpha version).  The boolean qv denotes that the version
4161 should be interpreted as if it had multiple decimals, even if
4162 it doesn't.
4163
4164 =cut
4165 */
4166
4167 const char *
4168 Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
4169 {
4170     const char *start = s;
4171     const char *pos;
4172     const char *last;
4173     const char *errstr = NULL;
4174     int saw_decimal = 0;
4175     int width = 3;
4176     bool alpha = FALSE;
4177     bool vinf = FALSE;
4178     AV * av;
4179     SV * hv;
4180
4181     PERL_ARGS_ASSERT_SCAN_VERSION;
4182
4183     while (isSPACE(*s)) /* leading whitespace is OK */
4184         s++;
4185
4186     last = prescan_version(s, FALSE, &errstr, &qv, &saw_decimal, &width, &alpha);
4187     if (errstr) {
4188         /* "undef" is a special case and not an error */
4189         if ( ! ( *s == 'u' && strEQ(s,"undef")) ) {
4190             Safefree(start);
4191             Perl_croak(aTHX_ "%s", errstr);
4192         }
4193     }
4194
4195     start = s;
4196     if (*s == 'v')
4197         s++;
4198     pos = s;
4199
4200     /* Now that we are through the prescan, start creating the object */
4201     av = newAV();
4202     hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
4203     (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
4204
4205 #ifndef NODEFAULT_SHAREKEYS
4206     HvSHAREKEYS_on(hv);         /* key-sharing on by default */
4207 #endif
4208
4209     if ( qv )
4210         (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(qv));
4211     if ( alpha )
4212         (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(alpha));
4213     if ( !qv && width < 3 )
4214         (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
4215
4216     while (isDIGIT(*pos))
4217         pos++;
4218     if (!isALPHA(*pos)) {
4219         I32 rev;
4220
4221         for (;;) {
4222             rev = 0;
4223             {
4224                 /* this is atoi() that delimits on underscores */
4225                 const char *end = pos;
4226                 I32 mult = 1;
4227                 I32 orev;
4228
4229                 /* the following if() will only be true after the decimal
4230                  * point of a version originally created with a bare
4231                  * floating point number, i.e. not quoted in any way
4232                  */
4233                 if ( !qv && s > start && saw_decimal == 1 ) {
4234                     mult *= 100;
4235                     while ( s < end ) {
4236                         orev = rev;
4237                         rev += (*s - '0') * mult;
4238                         mult /= 10;
4239                         if (   (PERL_ABS(orev) > PERL_ABS(rev)) 
4240                             || (PERL_ABS(rev) > VERSION_MAX )) {
4241                             Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), 
4242                                            "Integer overflow in version %d",VERSION_MAX);
4243                             s = end - 1;
4244                             rev = VERSION_MAX;
4245                             vinf = 1;
4246                         }
4247                         s++;
4248                         if ( *s == '_' )
4249                             s++;
4250                     }
4251                 }
4252                 else {
4253                     while (--end >= s) {
4254                         orev = rev;
4255                         rev += (*end - '0') * mult;
4256                         mult *= 10;
4257                         if (   (PERL_ABS(orev) > PERL_ABS(rev)) 
4258                             || (PERL_ABS(rev) > VERSION_MAX )) {
4259                             Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), 
4260                                            "Integer overflow in version");
4261                             end = s - 1;
4262                             rev = VERSION_MAX;
4263                             vinf = 1;
4264                         }
4265                     }
4266                 } 
4267             }
4268
4269             /* Append revision */
4270             av_push(av, newSViv(rev));
4271             if ( vinf ) {
4272                 s = last;
4273                 break;
4274             }
4275             else if ( *pos == '.' )
4276                 s = ++pos;
4277             else if ( *pos == '_' && isDIGIT(pos[1]) )
4278                 s = ++pos;
4279             else if ( *pos == ',' && isDIGIT(pos[1]) )
4280                 s = ++pos;
4281             else if ( isDIGIT(*pos) )
4282                 s = pos;
4283             else {
4284                 s = pos;
4285                 break;
4286             }
4287             if ( qv ) {
4288                 while ( isDIGIT(*pos) )
4289                     pos++;
4290             }
4291             else {
4292                 int digits = 0;
4293                 while ( ( isDIGIT(*pos) || *pos == '_' ) && digits < 3 ) {
4294                     if ( *pos != '_' )
4295                         digits++;
4296                     pos++;
4297                 }
4298             }
4299         }
4300     }
4301     if ( qv ) { /* quoted versions always get at least three terms*/
4302         I32 len = av_len(av);
4303         /* This for loop appears to trigger a compiler bug on OS X, as it
4304            loops infinitely. Yes, len is negative. No, it makes no sense.
4305            Compiler in question is:
4306            gcc version 3.3 20030304 (Apple Computer, Inc. build 1640)
4307            for ( len = 2 - len; len > 0; len-- )
4308            av_push(MUTABLE_AV(sv), newSViv(0));
4309         */
4310         len = 2 - len;
4311         while (len-- > 0)
4312             av_push(av, newSViv(0));
4313     }
4314
4315     /* need to save off the current version string for later */
4316     if ( vinf ) {
4317         SV * orig = newSVpvn("v.Inf", sizeof("v.Inf")-1);
4318         (void)hv_stores(MUTABLE_HV(hv), "original", orig);
4319         (void)hv_stores(MUTABLE_HV(hv), "vinf", newSViv(1));
4320     }
4321     else if ( s > start ) {
4322         SV * orig = newSVpvn(start,s-start);
4323         if ( qv && saw_decimal == 1 && *start != 'v' ) {
4324             /* need to insert a v to be consistent */
4325             sv_insert(orig, 0, 0, "v", 1);
4326         }
4327         (void)hv_stores(MUTABLE_HV(hv), "original", orig);
4328     }
4329     else {
4330         (void)hv_stores(MUTABLE_HV(hv), "original", newSVpvs("0"));
4331         av_push(av, newSViv(0));
4332     }
4333
4334     /* And finally, store the AV in the hash */
4335     (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av)));
4336
4337     /* fix RT#19517 - special case 'undef' as string */
4338     if ( *s == 'u' && strEQ(s,"undef") ) {
4339         s += 5;
4340     }
4341
4342     return s;
4343 }
4344
4345 /*
4346 =for apidoc new_version
4347
4348 Returns a new version object based on the passed in SV:
4349
4350     SV *sv = new_version(SV *ver);
4351
4352 Does not alter the passed in ver SV.  See "upg_version" if you
4353 want to upgrade the SV.
4354
4355 =cut
4356 */
4357
4358 SV *
4359 Perl_new_version(pTHX_ SV *ver)
4360 {
4361     dVAR;
4362     SV * const rv = newSV(0);
4363     PERL_ARGS_ASSERT_NEW_VERSION;
4364     if ( sv_isobject(ver) && sv_derived_from(ver, "version") )
4365          /* can just copy directly */
4366     {
4367         I32 key;
4368         AV * const av = newAV();
4369         AV *sav;
4370         /* This will get reblessed later if a derived class*/
4371         SV * const hv = newSVrv(rv, "version"); 
4372         (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
4373 #ifndef NODEFAULT_SHAREKEYS
4374         HvSHAREKEYS_on(hv);         /* key-sharing on by default */
4375 #endif
4376
4377         if ( SvROK(ver) )
4378             ver = SvRV(ver);
4379
4380         /* Begin copying all of the elements */
4381         if ( hv_exists(MUTABLE_HV(ver), "qv", 2) )
4382             (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(1));
4383
4384         if ( hv_exists(MUTABLE_HV(ver), "alpha", 5) )
4385             (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(1));
4386
4387         if ( hv_exists(MUTABLE_HV(ver), "width", 5 ) )
4388         {
4389             const I32 width = SvIV(*hv_fetchs(MUTABLE_HV(ver), "width", FALSE));
4390             (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
4391         }
4392
4393         if ( hv_exists(MUTABLE_HV(ver), "original", 8 ) )
4394         {
4395             SV * pv = *hv_fetchs(MUTABLE_HV(ver), "original", FALSE);
4396             (void)hv_stores(MUTABLE_HV(hv), "original", newSVsv(pv));
4397         }
4398
4399         sav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(ver), "version", FALSE)));
4400         /* This will get reblessed later if a derived class*/
4401         for ( key = 0; key <= av_len(sav); key++ )
4402         {
4403             const I32 rev = SvIV(*av_fetch(sav, key, FALSE));
4404             av_push(av, newSViv(rev));
4405         }
4406
4407         (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av)));
4408         return rv;
4409     }
4410 #ifdef SvVOK
4411     {
4412         const MAGIC* const mg = SvVSTRING_mg(ver);
4413         if ( mg ) { /* already a v-string */
4414             const STRLEN len = mg->mg_len;
4415             char * const version = savepvn( (const char*)mg->mg_ptr, len);
4416             sv_setpvn(rv,version,len);
4417             /* this is for consistency with the pure Perl class */
4418             if ( isDIGIT(*version) )
4419                 sv_insert(rv, 0, 0, "v", 1);
4420             Safefree(version);
4421         }
4422         else {
4423 #endif
4424         sv_setsv(rv,ver); /* make a duplicate */
4425 #ifdef SvVOK
4426         }
4427     }
4428 #endif
4429     return upg_version(rv, FALSE);
4430 }
4431
4432 /*
4433 =for apidoc upg_version
4434
4435 In-place upgrade of the supplied SV to a version object.
4436
4437     SV *sv = upg_version(SV *sv, bool qv);
4438
4439 Returns a pointer to the upgraded SV.  Set the boolean qv if you want
4440 to force this SV to be interpreted as an "extended" version.
4441
4442 =cut
4443 */
4444
4445 SV *
4446 Perl_upg_version(pTHX_ SV *ver, bool qv)
4447 {
4448     const char *version, *s;
4449 #ifdef SvVOK
4450     const MAGIC *mg;
4451 #endif
4452
4453     PERL_ARGS_ASSERT_UPG_VERSION;
4454
4455     if ( SvNOK(ver) && !( SvPOK(ver) && sv_len(ver) == 3 ) )
4456     {
4457         STRLEN len;
4458
4459         /* may get too much accuracy */ 
4460         char tbuf[64];
4461         SV *sv = SvNVX(ver) > 10e50 ? newSV(64) : 0;
4462         char *buf;
4463 #ifdef USE_LOCALE_NUMERIC
4464         char *loc = NULL;
4465         if (! PL_numeric_standard) {
4466             loc = savepv(setlocale(LC_NUMERIC, NULL));
4467             setlocale(LC_NUMERIC, "C");
4468         }
4469 #endif
4470         if (sv) {
4471             Perl_sv_setpvf(aTHX_ sv, "%.9"NVff, SvNVX(ver));
4472             buf = SvPV(sv, len);
4473         }
4474         else {
4475             len = my_snprintf(tbuf, sizeof(tbuf), "%.9"NVff, SvNVX(ver));
4476             buf = tbuf;
4477         }
4478 #ifdef USE_LOCALE_NUMERIC
4479         if (loc) {
4480             setlocale(LC_NUMERIC, loc);
4481             Safefree(loc);
4482         }
4483 #endif
4484         while (buf[len-1] == '0' && len > 0) len--;
4485         if ( buf[len-1] == '.' ) len--; /* eat the trailing decimal */
4486         version = savepvn(buf, len);
4487         SvREFCNT_dec(sv);
4488     }
4489 #ifdef SvVOK
4490     else if ( (mg = SvVSTRING_mg(ver)) ) { /* already a v-string */
4491         version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
4492         qv = TRUE;
4493     }
4494 #endif
4495     else /* must be a string or something like a string */
4496     {
4497         STRLEN len;
4498         version = savepv(SvPV(ver,len));
4499 #ifndef SvVOK
4500 #  if PERL_VERSION > 5
4501         /* This will only be executed for 5.6.0 - 5.8.0 inclusive */
4502         if ( len >= 3 && !instr(version,".") && !instr(version,"_")) {
4503             /* may be a v-string */
4504             char *testv = (char *)version;
4505             STRLEN tlen = len;
4506             for (tlen=0; tlen < len; tlen++, testv++) {
4507                 /* if one of the characters is non-text assume v-string */
4508                 if (testv[0] < ' ') {
4509                     SV * const nsv = sv_newmortal();
4510                     const char *nver;
4511                     const char *pos;
4512                     int saw_decimal = 0;
4513                     sv_setpvf(nsv,"v%vd",ver);
4514                     pos = nver = savepv(SvPV_nolen(nsv));
4515
4516                     /* scan the resulting formatted string */
4517                     pos++; /* skip the leading 'v' */
4518                     while ( *pos == '.' || isDIGIT(*pos) ) {
4519                         if ( *pos == '.' )
4520                             saw_decimal++ ;
4521                         pos++;
4522                     }
4523
4524                     /* is definitely a v-string */
4525                     if ( saw_decimal >= 2 ) {
4526                         Safefree(version);
4527                         version = nver;
4528                     }
4529                     break;
4530                 }
4531             }
4532         }
4533 #  endif
4534 #endif
4535     }
4536
4537     s = scan_version(version, ver, qv);
4538     if ( *s != '\0' ) 
4539         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), 
4540                        "Version string '%s' contains invalid data; "
4541                        "ignoring: '%s'", version, s);
4542     Safefree(version);
4543     return ver;
4544 }
4545
4546 /*
4547 =for apidoc vverify
4548
4549 Validates that the SV contains valid internal structure for a version object.
4550 It may be passed either the version object (RV) or the hash itself (HV).  If
4551 the structure is valid, it returns the HV.  If the structure is invalid,
4552 it returns NULL.
4553
4554     SV *hv = vverify(sv);
4555
4556 Note that it only confirms the bare minimum structure (so as not to get
4557 confused by derived classes which may contain additional hash entries):
4558
4559 =over 4
4560
4561 =item * The SV is an HV or a reference to an HV
4562
4563 =item * The hash contains a "version" key
4564
4565 =item * The "version" key has a reference to an AV as its value
4566
4567 =back
4568
4569 =cut
4570 */
4571
4572 SV *
4573 Perl_vverify(pTHX_ SV *vs)
4574 {
4575     SV *sv;
4576
4577     PERL_ARGS_ASSERT_VVERIFY;
4578
4579     if ( SvROK(vs) )
4580         vs = SvRV(vs);
4581
4582     /* see if the appropriate elements exist */
4583     if ( SvTYPE(vs) == SVt_PVHV
4584          && hv_exists(MUTABLE_HV(vs), "version", 7)
4585          && (sv = SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)))
4586          && SvTYPE(sv) == SVt_PVAV )
4587         return vs;
4588     else
4589         return NULL;
4590 }
4591
4592 /*
4593 =for apidoc vnumify
4594
4595 Accepts a version object and returns the normalized floating
4596 point representation.  Call like:
4597
4598     sv = vnumify(rv);
4599
4600 NOTE: you can pass either the object directly or the SV
4601 contained within the RV.
4602
4603 The SV returned has a refcount of 1.
4604
4605 =cut
4606 */
4607
4608 SV *
4609 Perl_vnumify(pTHX_ SV *vs)
4610 {
4611     I32 i, len, digit;
4612     int width;
4613     bool alpha = FALSE;
4614     SV *sv;
4615     AV *av;
4616
4617     PERL_ARGS_ASSERT_VNUMIFY;
4618
4619     /* extract the HV from the object */
4620     vs = vverify(vs);
4621     if ( ! vs )
4622         Perl_croak(aTHX_ "Invalid version object");
4623
4624     /* see if various flags exist */
4625     if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
4626         alpha = TRUE;
4627     if ( hv_exists(MUTABLE_HV(vs), "width", 5 ) )
4628         width = SvIV(*hv_fetchs(MUTABLE_HV(vs), "width", FALSE));
4629     else
4630         width = 3;
4631
4632
4633     /* attempt to retrieve the version array */
4634     if ( !(av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE))) ) ) {
4635         return newSVpvs("0");
4636     }
4637
4638     len = av_len(av);
4639     if ( len == -1 )
4640     {
4641         return newSVpvs("0");
4642     }
4643
4644     digit = SvIV(*av_fetch(av, 0, 0));
4645     sv = Perl_newSVpvf(aTHX_ "%d.", (int)PERL_ABS(digit));
4646     for ( i = 1 ; i < len ; i++ )
4647     {
4648         digit = SvIV(*av_fetch(av, i, 0));
4649         if ( width < 3 ) {
4650             const int denom = (width == 2 ? 10 : 100);
4651             const div_t term = div((int)PERL_ABS(digit),denom);
4652             Perl_sv_catpvf(aTHX_ sv, "%0*d_%d", width, term.quot, term.rem);
4653         }
4654         else {
4655             Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
4656         }
4657     }
4658
4659     if ( len > 0 )
4660     {
4661         digit = SvIV(*av_fetch(av, len, 0));
4662         if ( alpha && width == 3 ) /* alpha version */
4663             sv_catpvs(sv,"_");
4664         Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
4665     }
4666     else /* len == 0 */
4667     {
4668         sv_catpvs(sv, "000");
4669     }
4670     return sv;
4671 }
4672
4673 /*
4674 =for apidoc vnormal
4675
4676 Accepts a version object and returns the normalized string
4677 representation.  Call like:
4678
4679     sv = vnormal(rv);
4680
4681 NOTE: you can pass either the object directly or the SV
4682 contained within the RV.
4683
4684 The SV returned has a refcount of 1.
4685
4686 =cut
4687 */
4688
4689 SV *
4690 Perl_vnormal(pTHX_ SV *vs)
4691 {
4692     I32 i, len, digit;
4693     bool alpha = FALSE;
4694     SV *sv;
4695     AV *av;
4696
4697     PERL_ARGS_ASSERT_VNORMAL;
4698
4699     /* extract the HV from the object */
4700     vs = vverify(vs);
4701     if ( ! vs )
4702         Perl_croak(aTHX_ "Invalid version object");
4703
4704     if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
4705         alpha = TRUE;
4706     av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)));
4707
4708     len = av_len(av);
4709     if ( len == -1 )
4710     {
4711         return newSVpvs("");
4712     }
4713     digit = SvIV(*av_fetch(av, 0, 0));
4714     sv = Perl_newSVpvf(aTHX_ "v%"IVdf, (IV)digit);
4715     for ( i = 1 ; i < len ; i++ ) {
4716         digit = SvIV(*av_fetch(av, i, 0));
4717         Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
4718     }
4719
4720     if ( len > 0 )
4721     {
4722         /* handle last digit specially */
4723         digit = SvIV(*av_fetch(av, len, 0));
4724         if ( alpha )
4725             Perl_sv_catpvf(aTHX_ sv, "_%"IVdf, (IV)digit);
4726         else
4727             Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
4728     }
4729
4730     if ( len <= 2 ) { /* short version, must be at least three */
4731         for ( len = 2 - len; len != 0; len-- )
4732             sv_catpvs(sv,".0");
4733     }
4734     return sv;
4735 }
4736
4737 /*
4738 =for apidoc vstringify
4739
4740 In order to maintain maximum compatibility with earlier versions
4741 of Perl, this function will return either the floating point
4742 notation or the multiple dotted notation, depending on whether
4743 the original version contained 1 or more dots, respectively.
4744
4745 The SV returned has a refcount of 1.
4746
4747 =cut
4748 */
4749
4750 SV *
4751 Perl_vstringify(pTHX_ SV *vs)
4752 {
4753     PERL_ARGS_ASSERT_VSTRINGIFY;
4754
4755     /* extract the HV from the object */
4756     vs = vverify(vs);
4757     if ( ! vs )
4758         Perl_croak(aTHX_ "Invalid version object");
4759
4760     if (hv_exists(MUTABLE_HV(vs), "original",  sizeof("original") - 1)) {
4761         SV *pv;
4762         pv = *hv_fetchs(MUTABLE_HV(vs), "original", FALSE);
4763         if ( SvPOK(pv) )
4764             return newSVsv(pv);
4765         else
4766             return &PL_sv_undef;
4767     }
4768     else {
4769         if ( hv_exists(MUTABLE_HV(vs), "qv", 2) )
4770             return vnormal(vs);
4771         else
4772             return vnumify(vs);
4773     }
4774 }
4775
4776 /*
4777 =for apidoc vcmp
4778
4779 Version object aware cmp.  Both operands must already have been 
4780 converted into version objects.
4781
4782 =cut
4783 */
4784
4785 int
4786 Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
4787 {
4788     I32 i,l,m,r,retval;
4789     bool lalpha = FALSE;
4790     bool ralpha = FALSE;
4791     I32 left = 0;
4792     I32 right = 0;
4793     AV *lav, *rav;
4794
4795     PERL_ARGS_ASSERT_VCMP;
4796
4797     /* extract the HVs from the objects */
4798     lhv = vverify(lhv);
4799     rhv = vverify(rhv);
4800     if ( ! ( lhv && rhv ) )
4801         Perl_croak(aTHX_ "Invalid version object");
4802
4803     /* get the left hand term */
4804     lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(lhv), "version", FALSE)));
4805     if ( hv_exists(MUTABLE_HV(lhv), "alpha", 5 ) )
4806         lalpha = TRUE;
4807
4808     /* and the right hand term */
4809     rav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(rhv), "version", FALSE)));
4810     if ( hv_exists(MUTABLE_HV(rhv), "alpha", 5 ) )
4811         ralpha = TRUE;
4812
4813     l = av_len(lav);
4814     r = av_len(rav);
4815     m = l < r ? l : r;
4816     retval = 0;
4817     i = 0;
4818     while ( i <= m && retval == 0 )
4819     {
4820         left  = SvIV(*av_fetch(lav,i,0));
4821         right = SvIV(*av_fetch(rav,i,0));
4822         if ( left < right  )
4823             retval = -1;
4824         if ( left > right )
4825             retval = +1;
4826         i++;
4827     }
4828
4829     /* tiebreaker for alpha with identical terms */
4830     if ( retval == 0 && l == r && left == right && ( lalpha || ralpha ) )
4831     {
4832         if ( lalpha && !ralpha )
4833         {
4834             retval = -1;
4835         }
4836         else if ( ralpha && !lalpha)
4837         {
4838             retval = +1;
4839         }
4840     }
4841
4842     if ( l != r && retval == 0 ) /* possible match except for trailing 0's */
4843     {
4844         if ( l < r )
4845         {
4846             while ( i <= r && retval == 0 )
4847             {
4848                 if ( SvIV(*av_fetch(rav,i,0)) != 0 )
4849                     retval = -1; /* not a match after all */
4850                 i++;
4851             }
4852         }
4853         else
4854         {
4855             while ( i <= l && retval == 0 )
4856             {
4857                 if ( SvIV(*av_fetch(lav,i,0)) != 0 )
4858                     retval = +1; /* not a match after all */
4859                 i++;
4860             }
4861         }
4862     }
4863     return retval;
4864 }
4865
4866 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT)
4867 #   define EMULATE_SOCKETPAIR_UDP
4868 #endif
4869
4870 #ifdef EMULATE_SOCKETPAIR_UDP
4871 static int
4872 S_socketpair_udp (int fd[2]) {
4873     dTHX;
4874     /* Fake a datagram socketpair using UDP to localhost.  */
4875     int sockets[2] = {-1, -1};
4876     struct sockaddr_in addresses[2];
4877     int i;
4878     Sock_size_t size = sizeof(struct sockaddr_in);
4879     unsigned short port;
4880     int got;
4881
4882     memset(&addresses, 0, sizeof(addresses));
4883     i = 1;
4884     do {
4885         sockets[i] = PerlSock_socket(AF_INET, SOCK_DGRAM, PF_INET);
4886         if (sockets[i] == -1)
4887             goto tidy_up_and_fail;
4888
4889         addresses[i].sin_family = AF_INET;
4890         addresses[i].sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4891         addresses[i].sin_port = 0;      /* kernel choses port.  */
4892         if (PerlSock_bind(sockets[i], (struct sockaddr *) &addresses[i],
4893                 sizeof(struct sockaddr_in)) == -1)
4894             goto tidy_up_and_fail;
4895     } while (i--);
4896
4897     /* Now have 2 UDP sockets. Find out which port each is connected to, and
4898        for each connect the other socket to it.  */
4899     i = 1;
4900     do {
4901         if (PerlSock_getsockname(sockets[i], (struct sockaddr *) &addresses[i],
4902                 &size) == -1)
4903             goto tidy_up_and_fail;
4904         if (size != sizeof(struct sockaddr_in))
4905             goto abort_tidy_up_and_fail;
4906         /* !1 is 0, !0 is 1 */
4907         if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i],
4908                 sizeof(struct sockaddr_in)) == -1)
4909             goto tidy_up_and_fail;
4910     } while (i--);
4911
4912     /* Now we have 2 sockets connected to each other. I don't trust some other
4913        process not to have already sent a packet to us (by random) so send
4914        a packet from each to the other.  */
4915     i = 1;
4916     do {
4917         /* I'm going to send my own port number.  As a short.
4918            (Who knows if someone somewhere has sin_port as a bitfield and needs
4919            this routine. (I'm assuming crays have socketpair)) */
4920         port = addresses[i].sin_port;
4921         got = PerlLIO_write(sockets[i], &port, sizeof(port));
4922         if (got != sizeof(port)) {
4923             if (got == -1)
4924                 goto tidy_up_and_fail;
4925             goto abort_tidy_up_and_fail;
4926         }
4927     } while (i--);
4928
4929     /* Packets sent. I don't trust them to have arrived though.
4930        (As I understand it Solaris TCP stack is multithreaded. Non-blocking
4931        connect to localhost will use a second kernel thread. In 2.6 the
4932        first thread running the connect() returns before the second completes,
4933        so EINPROGRESS> In 2.7 the improved stack is faster and connect()
4934        returns 0. Poor programs have tripped up. One poor program's authors'
4935        had a 50-1 reverse stock split. Not sure how connected these were.)
4936        So I don't trust someone not to have an unpredictable UDP stack.
4937     */
4938
4939     {
4940         struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */
4941         int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0];
4942         fd_set rset;
4943
4944         FD_ZERO(&rset);
4945         FD_SET((unsigned int)sockets[0], &rset);
4946         FD_SET((unsigned int)sockets[1], &rset);
4947
4948         got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor);
4949         if (got != 2 || !FD_ISSET(sockets[0], &rset)
4950                 || !FD_ISSET(sockets[1], &rset)) {
4951             /* I hope this is portable and appropriate.  */
4952             if (got == -1)
4953                 goto tidy_up_and_fail;
4954             goto abort_tidy_up_and_fail;
4955         }
4956     }
4957
4958     /* And the paranoia department even now doesn't trust it to have arrive
4959        (hence MSG_DONTWAIT). Or that what arrives was sent by us.  */
4960     {
4961         struct sockaddr_in readfrom;
4962         unsigned short buffer[2];
4963
4964         i = 1;
4965         do {
4966 #ifdef MSG_DONTWAIT
4967             got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4968                     sizeof(buffer), MSG_DONTWAIT,
4969                     (struct sockaddr *) &readfrom, &size);
4970 #else
4971             got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4972                     sizeof(buffer), 0,
4973                     (struct sockaddr *) &readfrom, &size);
4974 #endif
4975
4976             if (got == -1)
4977                 goto tidy_up_and_fail;
4978             if (got != sizeof(port)
4979                     || size != sizeof(struct sockaddr_in)
4980                     /* Check other socket sent us its port.  */
4981                     || buffer[0] != (unsigned short) addresses[!i].sin_port
4982                     /* Check kernel says we got the datagram from that socket */
4983                     || readfrom.sin_family != addresses[!i].sin_family
4984                     || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr
4985                     || readfrom.sin_port != addresses[!i].sin_port)
4986                 goto abort_tidy_up_and_fail;
4987         } while (i--);
4988     }
4989     /* My caller (my_socketpair) has validated that this is non-NULL  */
4990     fd[0] = sockets[0];
4991     fd[1] = sockets[1];
4992     /* I hereby declare this connection open.  May God bless all who cross
4993        her.  */
4994     return 0;
4995
4996   abort_tidy_up_and_fail:
4997     errno = ECONNABORTED;
4998   tidy_up_and_fail:
4999     {
5000         dSAVE_ERRNO;
5001         if (sockets[0] != -1)
5002             PerlLIO_close(sockets[0]);
5003         if (sockets[1] != -1)
5004             PerlLIO_close(sockets[1]);
5005         RESTORE_ERRNO;
5006         return -1;
5007     }
5008 }
5009 #endif /*  EMULATE_SOCKETPAIR_UDP */
5010
5011 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET)
5012 int
5013 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
5014     /* Stevens says that family must be AF_LOCAL, protocol 0.
5015        I'm going to enforce that, then ignore it, and use TCP (or UDP).  */
5016     dTHXa(NULL);
5017     int listener = -1;
5018     int connector = -1;
5019     int acceptor = -1;
5020     struct sockaddr_in listen_addr;
5021     struct sockaddr_in connect_addr;
5022     Sock_size_t size;
5023
5024     if (protocol
5025 #ifdef AF_UNIX
5026         || family != AF_UNIX
5027 #endif
5028     ) {
5029         errno = EAFNOSUPPORT;
5030         return -1;
5031     }
5032     if (!fd) {
5033         errno = EINVAL;
5034         return -1;
5035     }
5036
5037 #ifdef EMULATE_SOCKETPAIR_UDP
5038     if (type == SOCK_DGRAM)
5039         return S_socketpair_udp(fd);
5040 #endif
5041
5042     aTHXa(PERL_GET_THX);
5043     listener = PerlSock_socket(AF_INET, type, 0);
5044     if (listener == -1)
5045         return -1;
5046     memset(&listen_addr, 0, sizeof(listen_addr));
5047     listen_addr.sin_family = AF_INET;
5048     listen_addr.sin_addr.s_addr = htonl(INADDR_LOOPBACK);
5049     listen_addr.sin_port = 0;   /* kernel choses port.  */
5050     if (PerlSock_bind(listener, (struct sockaddr *) &listen_addr,
5051             sizeof(listen_addr)) == -1)
5052         goto tidy_up_and_fail;
5053     if (PerlSock_listen(listener, 1) == -1)
5054         goto tidy_up_and_fail;
5055
5056     connector = PerlSock_socket(AF_INET, type, 0);
5057     if (connector == -1)
5058         goto tidy_up_and_fail;
5059     /* We want to find out the port number to connect to.  */
5060     size = sizeof(connect_addr);
5061     if (PerlSock_getsockname(listener, (struct sockaddr *) &connect_addr,
5062             &size) == -1)
5063         goto tidy_up_and_fail;
5064     if (size != sizeof(connect_addr))
5065         goto abort_tidy_up_and_fail;
5066     if (PerlSock_connect(connector, (struct sockaddr *) &connect_addr,
5067             sizeof(connect_addr)) == -1)
5068      &