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