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