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