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