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