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