vms.c backslash efs and long name fixes
[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         const 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     if (PL_diehook) {
1360         S_vdie_common(aTHX_ message, *msglen, *utf8, FALSE);
1361     }
1362     return message;
1363 }
1364
1365 static OP *
1366 S_vdie(pTHX_ const char* pat, va_list *args)
1367 {
1368     dVAR;
1369     const char *message;
1370     const int was_in_eval = PL_in_eval;
1371     STRLEN msglen;
1372     I32 utf8 = 0;
1373
1374     message = vdie_croak_common(pat, args, &msglen, &utf8);
1375
1376     PL_restartop = die_where(message, msglen);
1377     SvFLAGS(ERRSV) |= utf8;
1378     if ((!PL_restartop && was_in_eval) || PL_top_env->je_prev)
1379         JMPENV_JUMP(3);
1380     return PL_restartop;
1381 }
1382
1383 #if defined(PERL_IMPLICIT_CONTEXT)
1384 OP *
1385 Perl_die_nocontext(const char* pat, ...)
1386 {
1387     dTHX;
1388     OP *o;
1389     va_list args;
1390     PERL_ARGS_ASSERT_DIE_NOCONTEXT;
1391     va_start(args, pat);
1392     o = vdie(pat, &args);
1393     va_end(args);
1394     return o;
1395 }
1396 #endif /* PERL_IMPLICIT_CONTEXT */
1397
1398 OP *
1399 Perl_die(pTHX_ const char* pat, ...)
1400 {
1401     OP *o;
1402     va_list args;
1403     va_start(args, pat);
1404     o = vdie(pat, &args);
1405     va_end(args);
1406     return o;
1407 }
1408
1409 void
1410 Perl_vcroak(pTHX_ const char* pat, va_list *args)
1411 {
1412     dVAR;
1413     const char *message;
1414     STRLEN msglen;
1415     I32 utf8 = 0;
1416
1417     message = S_vdie_croak_common(aTHX_ pat, args, &msglen, &utf8);
1418
1419     if (PL_in_eval) {
1420         PL_restartop = die_where(message, msglen);
1421         SvFLAGS(ERRSV) |= utf8;
1422         JMPENV_JUMP(3);
1423     }
1424     else if (!message)
1425         message = SvPVx_const(ERRSV, msglen);
1426
1427     write_to_stderr(message, msglen);
1428     my_failure_exit();
1429 }
1430
1431 #if defined(PERL_IMPLICIT_CONTEXT)
1432 void
1433 Perl_croak_nocontext(const char *pat, ...)
1434 {
1435     dTHX;
1436     va_list args;
1437     va_start(args, pat);
1438     vcroak(pat, &args);
1439     /* NOTREACHED */
1440     va_end(args);
1441 }
1442 #endif /* PERL_IMPLICIT_CONTEXT */
1443
1444 /*
1445 =head1 Warning and Dieing
1446
1447 =for apidoc croak
1448
1449 This is the XSUB-writer's interface to Perl's C<die> function.
1450 Normally call this function the same way you call the C C<printf>
1451 function.  Calling C<croak> returns control directly to Perl,
1452 sidestepping the normal C order of execution. See C<warn>.
1453
1454 If you want to throw an exception object, assign the object to
1455 C<$@> and then pass C<NULL> to croak():
1456
1457    errsv = get_sv("@", TRUE);
1458    sv_setsv(errsv, exception_object);
1459    croak(NULL);
1460
1461 =cut
1462 */
1463
1464 void
1465 Perl_croak(pTHX_ const char *pat, ...)
1466 {
1467     va_list args;
1468     va_start(args, pat);
1469     vcroak(pat, &args);
1470     /* NOTREACHED */
1471     va_end(args);
1472 }
1473
1474 void
1475 Perl_vwarn(pTHX_ const char* pat, va_list *args)
1476 {
1477     dVAR;
1478     STRLEN msglen;
1479     SV * const msv = vmess(pat, args);
1480     const I32 utf8 = SvUTF8(msv);
1481     const char * const message = SvPV_const(msv, msglen);
1482
1483     PERL_ARGS_ASSERT_VWARN;
1484
1485     if (PL_warnhook) {
1486         if (vdie_common(message, msglen, utf8, TRUE))
1487             return;
1488     }
1489
1490     write_to_stderr(message, msglen);
1491 }
1492
1493 #if defined(PERL_IMPLICIT_CONTEXT)
1494 void
1495 Perl_warn_nocontext(const char *pat, ...)
1496 {
1497     dTHX;
1498     va_list args;
1499     PERL_ARGS_ASSERT_WARN_NOCONTEXT;
1500     va_start(args, pat);
1501     vwarn(pat, &args);
1502     va_end(args);
1503 }
1504 #endif /* PERL_IMPLICIT_CONTEXT */
1505
1506 /*
1507 =for apidoc warn
1508
1509 This is the XSUB-writer's interface to Perl's C<warn> function.  Call this
1510 function the same way you call the C C<printf> function.  See C<croak>.
1511
1512 =cut
1513 */
1514
1515 void
1516 Perl_warn(pTHX_ const char *pat, ...)
1517 {
1518     va_list args;
1519     PERL_ARGS_ASSERT_WARN;
1520     va_start(args, pat);
1521     vwarn(pat, &args);
1522     va_end(args);
1523 }
1524
1525 #if defined(PERL_IMPLICIT_CONTEXT)
1526 void
1527 Perl_warner_nocontext(U32 err, const char *pat, ...)
1528 {
1529     dTHX; 
1530     va_list args;
1531     PERL_ARGS_ASSERT_WARNER_NOCONTEXT;
1532     va_start(args, pat);
1533     vwarner(err, pat, &args);
1534     va_end(args);
1535 }
1536 #endif /* PERL_IMPLICIT_CONTEXT */
1537
1538 void
1539 Perl_warner(pTHX_ U32  err, const char* pat,...)
1540 {
1541     va_list args;
1542     PERL_ARGS_ASSERT_WARNER;
1543     va_start(args, pat);
1544     vwarner(err, pat, &args);
1545     va_end(args);
1546 }
1547
1548 void
1549 Perl_vwarner(pTHX_ U32  err, const char* pat, va_list* args)
1550 {
1551     dVAR;
1552     PERL_ARGS_ASSERT_VWARNER;
1553     if (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) {
1554         SV * const msv = vmess(pat, args);
1555         STRLEN msglen;
1556         const char * const message = SvPV_const(msv, msglen);
1557         const I32 utf8 = SvUTF8(msv);
1558
1559         if (PL_diehook) {
1560             assert(message);
1561             S_vdie_common(aTHX_ message, msglen, utf8, FALSE);
1562         }
1563         if (PL_in_eval) {
1564             PL_restartop = die_where(message, msglen);
1565             SvFLAGS(ERRSV) |= utf8;
1566             JMPENV_JUMP(3);
1567         }
1568         write_to_stderr(message, msglen);
1569         my_failure_exit();
1570     }
1571     else {
1572         Perl_vwarn(aTHX_ pat, args);
1573     }
1574 }
1575
1576 /* implements the ckWARN? macros */
1577
1578 bool
1579 Perl_ckwarn(pTHX_ U32 w)
1580 {
1581     dVAR;
1582     return
1583         (
1584                isLEXWARN_on
1585             && PL_curcop->cop_warnings != pWARN_NONE
1586             && (
1587                    PL_curcop->cop_warnings == pWARN_ALL
1588                 || isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w))
1589                 || (unpackWARN2(w) &&
1590                      isWARN_on(PL_curcop->cop_warnings, unpackWARN2(w)))
1591                 || (unpackWARN3(w) &&
1592                      isWARN_on(PL_curcop->cop_warnings, unpackWARN3(w)))
1593                 || (unpackWARN4(w) &&
1594                      isWARN_on(PL_curcop->cop_warnings, unpackWARN4(w)))
1595                 )
1596         )
1597         ||
1598         (
1599             isLEXWARN_off && PL_dowarn & G_WARN_ON
1600         )
1601         ;
1602 }
1603
1604 /* implements the ckWARN?_d macro */
1605
1606 bool
1607 Perl_ckwarn_d(pTHX_ U32 w)
1608 {
1609     dVAR;
1610     return
1611            isLEXWARN_off
1612         || PL_curcop->cop_warnings == pWARN_ALL
1613         || (
1614               PL_curcop->cop_warnings != pWARN_NONE 
1615            && (
1616                    isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w))
1617               || (unpackWARN2(w) &&
1618                    isWARN_on(PL_curcop->cop_warnings, unpackWARN2(w)))
1619               || (unpackWARN3(w) &&
1620                    isWARN_on(PL_curcop->cop_warnings, unpackWARN3(w)))
1621               || (unpackWARN4(w) &&
1622                    isWARN_on(PL_curcop->cop_warnings, unpackWARN4(w)))
1623               )
1624            )
1625         ;
1626 }
1627
1628 /* Set buffer=NULL to get a new one.  */
1629 STRLEN *
1630 Perl_new_warnings_bitfield(pTHX_ STRLEN *buffer, const char *const bits,
1631                            STRLEN size) {
1632     const MEM_SIZE len_wanted = sizeof(STRLEN) + size;
1633     PERL_UNUSED_CONTEXT;
1634     PERL_ARGS_ASSERT_NEW_WARNINGS_BITFIELD;
1635
1636     buffer = (STRLEN*)
1637         (specialWARN(buffer) ?
1638          PerlMemShared_malloc(len_wanted) :
1639          PerlMemShared_realloc(buffer, len_wanted));
1640     buffer[0] = size;
1641     Copy(bits, (buffer + 1), size, char);
1642     return buffer;
1643 }
1644
1645 /* since we've already done strlen() for both nam and val
1646  * we can use that info to make things faster than
1647  * sprintf(s, "%s=%s", nam, val)
1648  */
1649 #define my_setenv_format(s, nam, nlen, val, vlen) \
1650    Copy(nam, s, nlen, char); \
1651    *(s+nlen) = '='; \
1652    Copy(val, s+(nlen+1), vlen, char); \
1653    *(s+(nlen+1+vlen)) = '\0'
1654
1655 #ifdef USE_ENVIRON_ARRAY
1656        /* VMS' my_setenv() is in vms.c */
1657 #if !defined(WIN32) && !defined(NETWARE)
1658 void
1659 Perl_my_setenv(pTHX_ const char *nam, const char *val)
1660 {
1661   dVAR;
1662 #ifdef USE_ITHREADS
1663   /* only parent thread can modify process environment */
1664   if (PL_curinterp == aTHX)
1665 #endif
1666   {
1667 #ifndef PERL_USE_SAFE_PUTENV
1668     if (!PL_use_safe_putenv) {
1669     /* most putenv()s leak, so we manipulate environ directly */
1670     register I32 i;
1671     register const I32 len = strlen(nam);
1672     int nlen, vlen;
1673
1674     /* where does it go? */
1675     for (i = 0; environ[i]; i++) {
1676         if (strnEQ(environ[i],nam,len) && environ[i][len] == '=')
1677             break;
1678     }
1679
1680     if (environ == PL_origenviron) {   /* need we copy environment? */
1681        I32 j;
1682        I32 max;
1683        char **tmpenv;
1684
1685        max = i;
1686        while (environ[max])
1687            max++;
1688        tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*));
1689        for (j=0; j<max; j++) {         /* copy environment */
1690            const int len = strlen(environ[j]);
1691            tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char));
1692            Copy(environ[j], tmpenv[j], len+1, char);
1693        }
1694        tmpenv[max] = NULL;
1695        environ = tmpenv;               /* tell exec where it is now */
1696     }
1697     if (!val) {
1698        safesysfree(environ[i]);
1699        while (environ[i]) {
1700            environ[i] = environ[i+1];
1701            i++;
1702         }
1703        return;
1704     }
1705     if (!environ[i]) {                 /* does not exist yet */
1706        environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
1707        environ[i+1] = NULL;    /* make sure it's null terminated */
1708     }
1709     else
1710        safesysfree(environ[i]);
1711        nlen = strlen(nam);
1712        vlen = strlen(val);
1713
1714        environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char));
1715        /* all that work just for this */
1716        my_setenv_format(environ[i], nam, nlen, val, vlen);
1717     } else {
1718 # endif
1719 #   if defined(__CYGWIN__) || defined(EPOC) || defined(__SYMBIAN32__) || defined(__riscos__)
1720 #       if defined(HAS_UNSETENV)
1721         if (val == NULL) {
1722             (void)unsetenv(nam);
1723         } else {
1724             (void)setenv(nam, val, 1);
1725         }
1726 #       else /* ! HAS_UNSETENV */
1727         (void)setenv(nam, val, 1);
1728 #       endif /* HAS_UNSETENV */
1729 #   else
1730 #       if defined(HAS_UNSETENV)
1731         if (val == NULL) {
1732             (void)unsetenv(nam);
1733         } else {
1734             const int nlen = strlen(nam);
1735             const int vlen = strlen(val);
1736             char * const new_env =
1737                 (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
1738             my_setenv_format(new_env, nam, nlen, val, vlen);
1739             (void)putenv(new_env);
1740         }
1741 #       else /* ! HAS_UNSETENV */
1742         char *new_env;
1743         const int nlen = strlen(nam);
1744         int vlen;
1745         if (!val) {
1746            val = "";
1747         }
1748         vlen = strlen(val);
1749         new_env = (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
1750         /* all that work just for this */
1751         my_setenv_format(new_env, nam, nlen, val, vlen);
1752         (void)putenv(new_env);
1753 #       endif /* HAS_UNSETENV */
1754 #   endif /* __CYGWIN__ */
1755 #ifndef PERL_USE_SAFE_PUTENV
1756     }
1757 #endif
1758   }
1759 }
1760
1761 #else /* WIN32 || NETWARE */
1762
1763 void
1764 Perl_my_setenv(pTHX_ const char *nam, const char *val)
1765 {
1766     dVAR;
1767     register char *envstr;
1768     const int nlen = strlen(nam);
1769     int vlen;
1770
1771     if (!val) {
1772        val = "";
1773     }
1774     vlen = strlen(val);
1775     Newx(envstr, nlen+vlen+2, char);
1776     my_setenv_format(envstr, nam, nlen, val, vlen);
1777     (void)PerlEnv_putenv(envstr);
1778     Safefree(envstr);
1779 }
1780
1781 #endif /* WIN32 || NETWARE */
1782
1783 #endif /* !VMS && !EPOC*/
1784
1785 #ifdef UNLINK_ALL_VERSIONS
1786 I32
1787 Perl_unlnk(pTHX_ const char *f) /* unlink all versions of a file */
1788 {
1789     I32 retries = 0;
1790
1791     PERL_ARGS_ASSERT_UNLNK;
1792
1793     while (PerlLIO_unlink(f) >= 0)
1794         retries++;
1795     return retries ? 0 : -1;
1796 }
1797 #endif
1798
1799 /* this is a drop-in replacement for bcopy() */
1800 #if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY))
1801 char *
1802 Perl_my_bcopy(register const char *from,register char *to,register I32 len)
1803 {
1804     char * const retval = to;
1805
1806     PERL_ARGS_ASSERT_MY_BCOPY;
1807
1808     if (from - to >= 0) {
1809         while (len--)
1810             *to++ = *from++;
1811     }
1812     else {
1813         to += len;
1814         from += len;
1815         while (len--)
1816             *(--to) = *(--from);
1817     }
1818     return retval;
1819 }
1820 #endif
1821
1822 /* this is a drop-in replacement for memset() */
1823 #ifndef HAS_MEMSET
1824 void *
1825 Perl_my_memset(register char *loc, register I32 ch, register I32 len)
1826 {
1827     char * const retval = loc;
1828
1829     PERL_ARGS_ASSERT_MY_MEMSET;
1830
1831     while (len--)
1832         *loc++ = ch;
1833     return retval;
1834 }
1835 #endif
1836
1837 /* this is a drop-in replacement for bzero() */
1838 #if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
1839 char *
1840 Perl_my_bzero(register char *loc, register I32 len)
1841 {
1842     char * const retval = loc;
1843
1844     PERL_ARGS_ASSERT_MY_BZERO;
1845
1846     while (len--)
1847         *loc++ = 0;
1848     return retval;
1849 }
1850 #endif
1851
1852 /* this is a drop-in replacement for memcmp() */
1853 #if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
1854 I32
1855 Perl_my_memcmp(const char *s1, const char *s2, register I32 len)
1856 {
1857     register const U8 *a = (const U8 *)s1;
1858     register const U8 *b = (const U8 *)s2;
1859     register I32 tmp;
1860
1861     PERL_ARGS_ASSERT_MY_MEMCMP;
1862
1863     while (len--) {
1864         if ((tmp = *a++ - *b++))
1865             return tmp;
1866     }
1867     return 0;
1868 }
1869 #endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */
1870
1871 #ifndef HAS_VPRINTF
1872 /* This vsprintf replacement should generally never get used, since
1873    vsprintf was available in both System V and BSD 2.11.  (There may
1874    be some cross-compilation or embedded set-ups where it is needed,
1875    however.)
1876
1877    If you encounter a problem in this function, it's probably a symptom
1878    that Configure failed to detect your system's vprintf() function.
1879    See the section on "item vsprintf" in the INSTALL file.
1880
1881    This version may compile on systems with BSD-ish <stdio.h>,
1882    but probably won't on others.
1883 */
1884
1885 #ifdef USE_CHAR_VSPRINTF
1886 char *
1887 #else
1888 int
1889 #endif
1890 vsprintf(char *dest, const char *pat, void *args)
1891 {
1892     FILE fakebuf;
1893
1894 #if defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE)
1895     FILE_ptr(&fakebuf) = (STDCHAR *) dest;
1896     FILE_cnt(&fakebuf) = 32767;
1897 #else
1898     /* These probably won't compile -- If you really need
1899        this, you'll have to figure out some other method. */
1900     fakebuf._ptr = dest;
1901     fakebuf._cnt = 32767;
1902 #endif
1903 #ifndef _IOSTRG
1904 #define _IOSTRG 0
1905 #endif
1906     fakebuf._flag = _IOWRT|_IOSTRG;
1907     _doprnt(pat, args, &fakebuf);       /* what a kludge */
1908 #if defined(STDIO_PTR_LVALUE)
1909     *(FILE_ptr(&fakebuf)++) = '\0';
1910 #else
1911     /* PerlIO has probably #defined away fputc, but we want it here. */
1912 #  ifdef fputc
1913 #    undef fputc  /* XXX Should really restore it later */
1914 #  endif
1915     (void)fputc('\0', &fakebuf);
1916 #endif
1917 #ifdef USE_CHAR_VSPRINTF
1918     return(dest);
1919 #else
1920     return 0;           /* perl doesn't use return value */
1921 #endif
1922 }
1923
1924 #endif /* HAS_VPRINTF */
1925
1926 #ifdef MYSWAP
1927 #if BYTEORDER != 0x4321
1928 short
1929 Perl_my_swap(pTHX_ short s)
1930 {
1931 #if (BYTEORDER & 1) == 0
1932     short result;
1933
1934     result = ((s & 255) << 8) + ((s >> 8) & 255);
1935     return result;
1936 #else
1937     return s;
1938 #endif
1939 }
1940
1941 long
1942 Perl_my_htonl(pTHX_ long l)
1943 {
1944     union {
1945         long result;
1946         char c[sizeof(long)];
1947     } u;
1948
1949 #if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678
1950 #if BYTEORDER == 0x12345678
1951     u.result = 0; 
1952 #endif 
1953     u.c[0] = (l >> 24) & 255;
1954     u.c[1] = (l >> 16) & 255;
1955     u.c[2] = (l >> 8) & 255;
1956     u.c[3] = l & 255;
1957     return u.result;
1958 #else
1959 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
1960     Perl_croak(aTHX_ "Unknown BYTEORDER\n");
1961 #else
1962     register I32 o;
1963     register I32 s;
1964
1965     for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
1966         u.c[o & 0xf] = (l >> s) & 255;
1967     }
1968     return u.result;
1969 #endif
1970 #endif
1971 }
1972
1973 long
1974 Perl_my_ntohl(pTHX_ long l)
1975 {
1976     union {
1977         long l;
1978         char c[sizeof(long)];
1979     } u;
1980
1981 #if BYTEORDER == 0x1234
1982     u.c[0] = (l >> 24) & 255;
1983     u.c[1] = (l >> 16) & 255;
1984     u.c[2] = (l >> 8) & 255;
1985     u.c[3] = l & 255;
1986     return u.l;
1987 #else
1988 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
1989     Perl_croak(aTHX_ "Unknown BYTEORDER\n");
1990 #else
1991     register I32 o;
1992     register I32 s;
1993
1994     u.l = l;
1995     l = 0;
1996     for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
1997         l |= (u.c[o & 0xf] & 255) << s;
1998     }
1999     return l;
2000 #endif
2001 #endif
2002 }
2003
2004 #endif /* BYTEORDER != 0x4321 */
2005 #endif /* MYSWAP */
2006
2007 /*
2008  * Little-endian byte order functions - 'v' for 'VAX', or 'reVerse'.
2009  * If these functions are defined,
2010  * the BYTEORDER is neither 0x1234 nor 0x4321.
2011  * However, this is not assumed.
2012  * -DWS
2013  */
2014
2015 #define HTOLE(name,type)                                        \
2016         type                                                    \
2017         name (register type n)                                  \
2018         {                                                       \
2019             union {                                             \
2020                 type value;                                     \
2021                 char c[sizeof(type)];                           \
2022             } u;                                                \
2023             register U32 i;                                     \
2024             register U32 s = 0;                                 \
2025             for (i = 0; i < sizeof(u.c); i++, s += 8) {         \
2026                 u.c[i] = (n >> s) & 0xFF;                       \
2027             }                                                   \
2028             return u.value;                                     \
2029         }
2030
2031 #define LETOH(name,type)                                        \
2032         type                                                    \
2033         name (register type n)                                  \
2034         {                                                       \
2035             union {                                             \
2036                 type value;                                     \
2037                 char c[sizeof(type)];                           \
2038             } u;                                                \
2039             register U32 i;                                     \
2040             register U32 s = 0;                                 \
2041             u.value = n;                                        \
2042             n = 0;                                              \
2043             for (i = 0; i < sizeof(u.c); i++, s += 8) {         \
2044                 n |= ((type)(u.c[i] & 0xFF)) << s;              \
2045             }                                                   \
2046             return n;                                           \
2047         }
2048
2049 /*
2050  * Big-endian byte order functions.
2051  */
2052
2053 #define HTOBE(name,type)                                        \
2054         type                                                    \
2055         name (register type n)                                  \
2056         {                                                       \
2057             union {                                             \
2058                 type value;                                     \
2059                 char c[sizeof(type)];                           \
2060             } u;                                                \
2061             register U32 i;                                     \
2062             register U32 s = 8*(sizeof(u.c)-1);                 \
2063             for (i = 0; i < sizeof(u.c); i++, s -= 8) {         \
2064                 u.c[i] = (n >> s) & 0xFF;                       \
2065             }                                                   \
2066             return u.value;                                     \
2067         }
2068
2069 #define BETOH(name,type)                                        \
2070         type                                                    \
2071         name (register type n)                                  \
2072         {                                                       \
2073             union {                                             \
2074                 type value;                                     \
2075                 char c[sizeof(type)];                           \
2076             } u;                                                \
2077             register U32 i;                                     \
2078             register U32 s = 8*(sizeof(u.c)-1);                 \
2079             u.value = n;                                        \
2080             n = 0;                                              \
2081             for (i = 0; i < sizeof(u.c); i++, s -= 8) {         \
2082                 n |= ((type)(u.c[i] & 0xFF)) << s;              \
2083             }                                                   \
2084             return n;                                           \
2085         }
2086
2087 /*
2088  * If we just can't do it...
2089  */
2090
2091 #define NOT_AVAIL(name,type)                                    \
2092         type                                                    \
2093         name (register type n)                                  \
2094         {                                                       \
2095             Perl_croak_nocontext(#name "() not available");     \
2096             return n; /* not reached */                         \
2097         }
2098
2099
2100 #if defined(HAS_HTOVS) && !defined(htovs)
2101 HTOLE(htovs,short)
2102 #endif
2103 #if defined(HAS_HTOVL) && !defined(htovl)
2104 HTOLE(htovl,long)
2105 #endif
2106 #if defined(HAS_VTOHS) && !defined(vtohs)
2107 LETOH(vtohs,short)
2108 #endif
2109 #if defined(HAS_VTOHL) && !defined(vtohl)
2110 LETOH(vtohl,long)
2111 #endif
2112
2113 #ifdef PERL_NEED_MY_HTOLE16
2114 # if U16SIZE == 2
2115 HTOLE(Perl_my_htole16,U16)
2116 # else
2117 NOT_AVAIL(Perl_my_htole16,U16)
2118 # endif
2119 #endif
2120 #ifdef PERL_NEED_MY_LETOH16
2121 # if U16SIZE == 2
2122 LETOH(Perl_my_letoh16,U16)
2123 # else
2124 NOT_AVAIL(Perl_my_letoh16,U16)
2125 # endif
2126 #endif
2127 #ifdef PERL_NEED_MY_HTOBE16
2128 # if U16SIZE == 2
2129 HTOBE(Perl_my_htobe16,U16)
2130 # else
2131 NOT_AVAIL(Perl_my_htobe16,U16)
2132 # endif
2133 #endif
2134 #ifdef PERL_NEED_MY_BETOH16
2135 # if U16SIZE == 2
2136 BETOH(Perl_my_betoh16,U16)
2137 # else
2138 NOT_AVAIL(Perl_my_betoh16,U16)
2139 # endif
2140 #endif
2141
2142 #ifdef PERL_NEED_MY_HTOLE32
2143 # if U32SIZE == 4
2144 HTOLE(Perl_my_htole32,U32)
2145 # else
2146 NOT_AVAIL(Perl_my_htole32,U32)
2147 # endif
2148 #endif
2149 #ifdef PERL_NEED_MY_LETOH32
2150 # if U32SIZE == 4
2151 LETOH(Perl_my_letoh32,U32)
2152 # else
2153 NOT_AVAIL(Perl_my_letoh32,U32)
2154 # endif
2155 #endif
2156 #ifdef PERL_NEED_MY_HTOBE32
2157 # if U32SIZE == 4
2158 HTOBE(Perl_my_htobe32,U32)
2159 # else
2160 NOT_AVAIL(Perl_my_htobe32,U32)
2161 # endif
2162 #endif
2163 #ifdef PERL_NEED_MY_BETOH32
2164 # if U32SIZE == 4
2165 BETOH(Perl_my_betoh32,U32)
2166 # else
2167 NOT_AVAIL(Perl_my_betoh32,U32)
2168 # endif
2169 #endif
2170
2171 #ifdef PERL_NEED_MY_HTOLE64
2172 # if U64SIZE == 8
2173 HTOLE(Perl_my_htole64,U64)
2174 # else
2175 NOT_AVAIL(Perl_my_htole64,U64)
2176 # endif
2177 #endif
2178 #ifdef PERL_NEED_MY_LETOH64
2179 # if U64SIZE == 8
2180 LETOH(Perl_my_letoh64,U64)
2181 # else
2182 NOT_AVAIL(Perl_my_letoh64,U64)
2183 # endif
2184 #endif
2185 #ifdef PERL_NEED_MY_HTOBE64
2186 # if U64SIZE == 8
2187 HTOBE(Perl_my_htobe64,U64)
2188 # else
2189 NOT_AVAIL(Perl_my_htobe64,U64)
2190 # endif
2191 #endif
2192 #ifdef PERL_NEED_MY_BETOH64
2193 # if U64SIZE == 8
2194 BETOH(Perl_my_betoh64,U64)
2195 # else
2196 NOT_AVAIL(Perl_my_betoh64,U64)
2197 # endif
2198 #endif
2199
2200 #ifdef PERL_NEED_MY_HTOLES
2201 HTOLE(Perl_my_htoles,short)
2202 #endif
2203 #ifdef PERL_NEED_MY_LETOHS
2204 LETOH(Perl_my_letohs,short)
2205 #endif
2206 #ifdef PERL_NEED_MY_HTOBES
2207 HTOBE(Perl_my_htobes,short)
2208 #endif
2209 #ifdef PERL_NEED_MY_BETOHS
2210 BETOH(Perl_my_betohs,short)
2211 #endif
2212
2213 #ifdef PERL_NEED_MY_HTOLEI
2214 HTOLE(Perl_my_htolei,int)
2215 #endif
2216 #ifdef PERL_NEED_MY_LETOHI
2217 LETOH(Perl_my_letohi,int)
2218 #endif
2219 #ifdef PERL_NEED_MY_HTOBEI
2220 HTOBE(Perl_my_htobei,int)
2221 #endif
2222 #ifdef PERL_NEED_MY_BETOHI
2223 BETOH(Perl_my_betohi,int)
2224 #endif
2225
2226 #ifdef PERL_NEED_MY_HTOLEL
2227 HTOLE(Perl_my_htolel,long)
2228 #endif
2229 #ifdef PERL_NEED_MY_LETOHL
2230 LETOH(Perl_my_letohl,long)
2231 #endif
2232 #ifdef PERL_NEED_MY_HTOBEL
2233 HTOBE(Perl_my_htobel,long)
2234 #endif
2235 #ifdef PERL_NEED_MY_BETOHL
2236 BETOH(Perl_my_betohl,long)
2237 #endif
2238
2239 void
2240 Perl_my_swabn(void *ptr, int n)
2241 {
2242     register char *s = (char *)ptr;
2243     register char *e = s + (n-1);
2244     register char tc;
2245
2246     PERL_ARGS_ASSERT_MY_SWABN;
2247
2248     for (n /= 2; n > 0; s++, e--, n--) {
2249       tc = *s;
2250       *s = *e;
2251       *e = tc;
2252     }
2253 }
2254
2255 PerlIO *
2256 Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
2257 {
2258 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) && !defined(NETWARE) && !defined(__LIBCATAMOUNT__)
2259     dVAR;
2260     int p[2];
2261     register I32 This, that;
2262     register Pid_t pid;
2263     SV *sv;
2264     I32 did_pipes = 0;
2265     int pp[2];
2266
2267     PERL_ARGS_ASSERT_MY_POPEN_LIST;
2268
2269     PERL_FLUSHALL_FOR_CHILD;
2270     This = (*mode == 'w');
2271     that = !This;
2272     if (PL_tainting) {
2273         taint_env();
2274         taint_proper("Insecure %s%s", "EXEC");
2275     }
2276     if (PerlProc_pipe(p) < 0)
2277         return NULL;
2278     /* Try for another pipe pair for error return */
2279     if (PerlProc_pipe(pp) >= 0)
2280         did_pipes = 1;
2281     while ((pid = PerlProc_fork()) < 0) {
2282         if (errno != EAGAIN) {
2283             PerlLIO_close(p[This]);
2284             PerlLIO_close(p[that]);
2285             if (did_pipes) {
2286                 PerlLIO_close(pp[0]);
2287                 PerlLIO_close(pp[1]);
2288             }
2289             return NULL;
2290         }
2291         sleep(5);
2292     }
2293     if (pid == 0) {
2294         /* Child */
2295 #undef THIS
2296 #undef THAT
2297 #define THIS that
2298 #define THAT This
2299         /* Close parent's end of error status pipe (if any) */
2300         if (did_pipes) {
2301             PerlLIO_close(pp[0]);
2302 #if defined(HAS_FCNTL) && defined(F_SETFD)
2303             /* Close error pipe automatically if exec works */
2304             fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2305 #endif
2306         }
2307         /* Now dup our end of _the_ pipe to right position */
2308         if (p[THIS] != (*mode == 'r')) {
2309             PerlLIO_dup2(p[THIS], *mode == 'r');
2310             PerlLIO_close(p[THIS]);
2311             if (p[THAT] != (*mode == 'r'))      /* if dup2() didn't close it */
2312                 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
2313         }
2314         else
2315             PerlLIO_close(p[THAT]);     /* close parent's end of _the_ pipe */
2316 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2317         /* No automatic close - do it by hand */
2318 #  ifndef NOFILE
2319 #  define NOFILE 20
2320 #  endif
2321         {
2322             int fd;
2323
2324             for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) {
2325                 if (fd != pp[1])
2326                     PerlLIO_close(fd);
2327             }
2328         }
2329 #endif
2330         do_aexec5(NULL, args-1, args-1+n, pp[1], did_pipes);
2331         PerlProc__exit(1);
2332 #undef THIS
2333 #undef THAT
2334     }
2335     /* Parent */
2336     do_execfree();      /* free any memory malloced by child on fork */
2337     if (did_pipes)
2338         PerlLIO_close(pp[1]);
2339     /* Keep the lower of the two fd numbers */
2340     if (p[that] < p[This]) {
2341         PerlLIO_dup2(p[This], p[that]);
2342         PerlLIO_close(p[This]);
2343         p[This] = p[that];
2344     }
2345     else
2346         PerlLIO_close(p[that]);         /* close child's end of pipe */
2347
2348     LOCK_FDPID_MUTEX;
2349     sv = *av_fetch(PL_fdpid,p[This],TRUE);
2350     UNLOCK_FDPID_MUTEX;
2351     SvUPGRADE(sv,SVt_IV);
2352     SvIV_set(sv, pid);
2353     PL_forkprocess = pid;
2354     /* If we managed to get status pipe check for exec fail */
2355     if (did_pipes && pid > 0) {
2356         int errkid;
2357         unsigned n = 0;
2358         SSize_t n1;
2359
2360         while (n < sizeof(int)) {
2361             n1 = PerlLIO_read(pp[0],
2362                               (void*)(((char*)&errkid)+n),
2363                               (sizeof(int)) - n);
2364             if (n1 <= 0)
2365                 break;
2366             n += n1;
2367         }
2368         PerlLIO_close(pp[0]);
2369         did_pipes = 0;
2370         if (n) {                        /* Error */
2371             int pid2, status;
2372             PerlLIO_close(p[This]);
2373             if (n != sizeof(int))
2374                 Perl_croak(aTHX_ "panic: kid popen errno read");
2375             do {
2376                 pid2 = wait4pid(pid, &status, 0);
2377             } while (pid2 == -1 && errno == EINTR);
2378             errno = errkid;             /* Propagate errno from kid */
2379             return NULL;
2380         }
2381     }
2382     if (did_pipes)
2383          PerlLIO_close(pp[0]);
2384     return PerlIO_fdopen(p[This], mode);
2385 #else
2386 #  ifdef OS2    /* Same, without fork()ing and all extra overhead... */
2387     return my_syspopen4(aTHX_ NULL, mode, n, args);
2388 #  else
2389     Perl_croak(aTHX_ "List form of piped open not implemented");
2390     return (PerlIO *) NULL;
2391 #  endif
2392 #endif
2393 }
2394
2395     /* VMS' my_popen() is in VMS.c, same with OS/2. */
2396 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) && !defined(__LIBCATAMOUNT__)
2397 PerlIO *
2398 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2399 {
2400     dVAR;
2401     int p[2];
2402     register I32 This, that;
2403     register Pid_t pid;
2404     SV *sv;
2405     const I32 doexec = !(*cmd == '-' && cmd[1] == '\0');
2406     I32 did_pipes = 0;
2407     int pp[2];
2408
2409     PERL_ARGS_ASSERT_MY_POPEN;
2410
2411     PERL_FLUSHALL_FOR_CHILD;
2412 #ifdef OS2
2413     if (doexec) {
2414         return my_syspopen(aTHX_ cmd,mode);
2415     }
2416 #endif
2417     This = (*mode == 'w');
2418     that = !This;
2419     if (doexec && PL_tainting) {
2420         taint_env();
2421         taint_proper("Insecure %s%s", "EXEC");
2422     }
2423     if (PerlProc_pipe(p) < 0)
2424         return NULL;
2425     if (doexec && PerlProc_pipe(pp) >= 0)
2426         did_pipes = 1;
2427     while ((pid = PerlProc_fork()) < 0) {
2428         if (errno != EAGAIN) {
2429             PerlLIO_close(p[This]);
2430             PerlLIO_close(p[that]);
2431             if (did_pipes) {
2432                 PerlLIO_close(pp[0]);
2433                 PerlLIO_close(pp[1]);
2434             }
2435             if (!doexec)
2436                 Perl_croak(aTHX_ "Can't fork");
2437             return NULL;
2438         }
2439         sleep(5);
2440     }
2441     if (pid == 0) {
2442         GV* tmpgv;
2443
2444 #undef THIS
2445 #undef THAT
2446 #define THIS that
2447 #define THAT This
2448         if (did_pipes) {
2449             PerlLIO_close(pp[0]);
2450 #if defined(HAS_FCNTL) && defined(F_SETFD)
2451             fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2452 #endif
2453         }
2454         if (p[THIS] != (*mode == 'r')) {
2455             PerlLIO_dup2(p[THIS], *mode == 'r');
2456             PerlLIO_close(p[THIS]);
2457             if (p[THAT] != (*mode == 'r'))      /* if dup2() didn't close it */
2458                 PerlLIO_close(p[THAT]);
2459         }
2460         else
2461             PerlLIO_close(p[THAT]);
2462 #ifndef OS2
2463         if (doexec) {
2464 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2465 #ifndef NOFILE
2466 #define NOFILE 20
2467 #endif
2468             {
2469                 int fd;
2470
2471                 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
2472                     if (fd != pp[1])
2473                         PerlLIO_close(fd);
2474             }
2475 #endif
2476             /* may or may not use the shell */
2477             do_exec3(cmd, pp[1], did_pipes);
2478             PerlProc__exit(1);
2479         }
2480 #endif  /* defined OS2 */
2481
2482 #ifdef PERLIO_USING_CRLF
2483    /* Since we circumvent IO layers when we manipulate low-level
2484       filedescriptors directly, need to manually switch to the
2485       default, binary, low-level mode; see PerlIOBuf_open(). */
2486    PerlLIO_setmode((*mode == 'r'), O_BINARY);
2487 #endif 
2488
2489         if ((tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV))) {
2490             SvREADONLY_off(GvSV(tmpgv));
2491             sv_setiv(GvSV(tmpgv), PerlProc_getpid());
2492             SvREADONLY_on(GvSV(tmpgv));
2493         }
2494 #ifdef THREADS_HAVE_PIDS
2495         PL_ppid = (IV)getppid();
2496 #endif
2497         PL_forkprocess = 0;
2498 #ifdef PERL_USES_PL_PIDSTATUS
2499         hv_clear(PL_pidstatus); /* we have no children */
2500 #endif
2501         return NULL;
2502 #undef THIS
2503 #undef THAT
2504     }
2505     do_execfree();      /* free any memory malloced by child on vfork */
2506     if (did_pipes)
2507         PerlLIO_close(pp[1]);
2508     if (p[that] < p[This]) {
2509         PerlLIO_dup2(p[This], p[that]);
2510         PerlLIO_close(p[This]);
2511         p[This] = p[that];
2512     }
2513     else
2514         PerlLIO_close(p[that]);
2515
2516     LOCK_FDPID_MUTEX;
2517     sv = *av_fetch(PL_fdpid,p[This],TRUE);
2518     UNLOCK_FDPID_MUTEX;
2519     SvUPGRADE(sv,SVt_IV);
2520     SvIV_set(sv, pid);
2521     PL_forkprocess = pid;
2522     if (did_pipes && pid > 0) {
2523         int errkid;
2524         unsigned n = 0;
2525         SSize_t n1;
2526
2527         while (n < sizeof(int)) {
2528             n1 = PerlLIO_read(pp[0],
2529                               (void*)(((char*)&errkid)+n),
2530                               (sizeof(int)) - n);
2531             if (n1 <= 0)
2532                 break;
2533             n += n1;
2534         }
2535         PerlLIO_close(pp[0]);
2536         did_pipes = 0;
2537         if (n) {                        /* Error */
2538             int pid2, status;
2539             PerlLIO_close(p[This]);
2540             if (n != sizeof(int))
2541                 Perl_croak(aTHX_ "panic: kid popen errno read");
2542             do {
2543                 pid2 = wait4pid(pid, &status, 0);
2544             } while (pid2 == -1 && errno == EINTR);
2545             errno = errkid;             /* Propagate errno from kid */
2546             return NULL;
2547         }
2548     }
2549     if (did_pipes)
2550          PerlLIO_close(pp[0]);
2551     return PerlIO_fdopen(p[This], mode);
2552 }
2553 #else
2554 #if defined(atarist) || defined(EPOC)
2555 FILE *popen();
2556 PerlIO *
2557 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2558 {
2559     PERL_ARGS_ASSERT_MY_POPEN;
2560     PERL_FLUSHALL_FOR_CHILD;
2561     /* Call system's popen() to get a FILE *, then import it.
2562        used 0 for 2nd parameter to PerlIO_importFILE;
2563        apparently not used
2564     */
2565     return PerlIO_importFILE(popen(cmd, mode), 0);
2566 }
2567 #else
2568 #if defined(DJGPP)
2569 FILE *djgpp_popen();
2570 PerlIO *
2571 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2572 {
2573     PERL_FLUSHALL_FOR_CHILD;
2574     /* Call system's popen() to get a FILE *, then import it.
2575        used 0 for 2nd parameter to PerlIO_importFILE;
2576        apparently not used
2577     */
2578     return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
2579 }
2580 #else
2581 #if defined(__LIBCATAMOUNT__)
2582 PerlIO *
2583 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2584 {
2585     return NULL;
2586 }
2587 #endif
2588 #endif
2589 #endif
2590
2591 #endif /* !DOSISH */
2592
2593 /* this is called in parent before the fork() */
2594 void
2595 Perl_atfork_lock(void)
2596 {
2597    dVAR;
2598 #if defined(USE_ITHREADS)
2599     /* locks must be held in locking order (if any) */
2600 #  ifdef MYMALLOC
2601     MUTEX_LOCK(&PL_malloc_mutex);
2602 #  endif
2603     OP_REFCNT_LOCK;
2604 #endif
2605 }
2606
2607 /* this is called in both parent and child after the fork() */
2608 void
2609 Perl_atfork_unlock(void)
2610 {
2611     dVAR;
2612 #if defined(USE_ITHREADS)
2613     /* locks must be released in same order as in atfork_lock() */
2614 #  ifdef MYMALLOC
2615     MUTEX_UNLOCK(&PL_malloc_mutex);
2616 #  endif
2617     OP_REFCNT_UNLOCK;
2618 #endif
2619 }
2620
2621 Pid_t
2622 Perl_my_fork(void)
2623 {
2624 #if defined(HAS_FORK)
2625     Pid_t pid;
2626 #if defined(USE_ITHREADS) && !defined(HAS_PTHREAD_ATFORK)
2627     atfork_lock();
2628     pid = fork();
2629     atfork_unlock();
2630 #else
2631     /* atfork_lock() and atfork_unlock() are installed as pthread_atfork()
2632      * handlers elsewhere in the code */
2633     pid = fork();
2634 #endif
2635     return pid;
2636 #else
2637     /* this "canna happen" since nothing should be calling here if !HAS_FORK */
2638     Perl_croak_nocontext("fork() not available");
2639     return 0;
2640 #endif /* HAS_FORK */
2641 }
2642
2643 #ifdef DUMP_FDS
2644 void
2645 Perl_dump_fds(pTHX_ const char *const s)
2646 {
2647     int fd;
2648     Stat_t tmpstatbuf;
2649
2650     PERL_ARGS_ASSERT_DUMP_FDS;
2651
2652     PerlIO_printf(Perl_debug_log,"%s", s);
2653     for (fd = 0; fd < 32; fd++) {
2654         if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0)
2655             PerlIO_printf(Perl_debug_log," %d",fd);
2656     }
2657     PerlIO_printf(Perl_debug_log,"\n");
2658     return;
2659 }
2660 #endif  /* DUMP_FDS */
2661
2662 #ifndef HAS_DUP2
2663 int
2664 dup2(int oldfd, int newfd)
2665 {
2666 #if defined(HAS_FCNTL) && defined(F_DUPFD)
2667     if (oldfd == newfd)
2668         return oldfd;
2669     PerlLIO_close(newfd);
2670     return fcntl(oldfd, F_DUPFD, newfd);
2671 #else
2672 #define DUP2_MAX_FDS 256
2673     int fdtmp[DUP2_MAX_FDS];
2674     I32 fdx = 0;
2675     int fd;
2676
2677     if (oldfd == newfd)
2678         return oldfd;
2679     PerlLIO_close(newfd);
2680     /* good enough for low fd's... */
2681     while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
2682         if (fdx >= DUP2_MAX_FDS) {
2683             PerlLIO_close(fd);
2684             fd = -1;
2685             break;
2686         }
2687         fdtmp[fdx++] = fd;
2688     }
2689     while (fdx > 0)
2690         PerlLIO_close(fdtmp[--fdx]);
2691     return fd;
2692 #endif
2693 }
2694 #endif
2695
2696 #ifndef PERL_MICRO
2697 #ifdef HAS_SIGACTION
2698
2699 #ifdef MACOS_TRADITIONAL
2700 /* We don't want restart behavior on MacOS */
2701 #undef SA_RESTART
2702 #endif
2703
2704 Sighandler_t
2705 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2706 {
2707     dVAR;
2708     struct sigaction act, oact;
2709
2710 #ifdef USE_ITHREADS
2711     /* only "parent" interpreter can diddle signals */
2712     if (PL_curinterp != aTHX)
2713         return (Sighandler_t) SIG_ERR;
2714 #endif
2715
2716     act.sa_handler = (void(*)(int))handler;
2717     sigemptyset(&act.sa_mask);
2718     act.sa_flags = 0;
2719 #ifdef SA_RESTART
2720     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2721         act.sa_flags |= SA_RESTART;     /* SVR4, 4.3+BSD */
2722 #endif
2723 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2724     if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
2725         act.sa_flags |= SA_NOCLDWAIT;
2726 #endif
2727     if (sigaction(signo, &act, &oact) == -1)
2728         return (Sighandler_t) SIG_ERR;
2729     else
2730         return (Sighandler_t) oact.sa_handler;
2731 }
2732
2733 Sighandler_t
2734 Perl_rsignal_state(pTHX_ int signo)
2735 {
2736     struct sigaction oact;
2737     PERL_UNUSED_CONTEXT;
2738
2739     if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
2740         return (Sighandler_t) SIG_ERR;
2741     else
2742         return (Sighandler_t) oact.sa_handler;
2743 }
2744
2745 int
2746 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2747 {
2748     dVAR;
2749     struct sigaction act;
2750
2751     PERL_ARGS_ASSERT_RSIGNAL_SAVE;
2752
2753 #ifdef USE_ITHREADS
2754     /* only "parent" interpreter can diddle signals */
2755     if (PL_curinterp != aTHX)
2756         return -1;
2757 #endif
2758
2759     act.sa_handler = (void(*)(int))handler;
2760     sigemptyset(&act.sa_mask);
2761     act.sa_flags = 0;
2762 #ifdef SA_RESTART
2763     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2764         act.sa_flags |= SA_RESTART;     /* SVR4, 4.3+BSD */
2765 #endif
2766 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2767     if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
2768         act.sa_flags |= SA_NOCLDWAIT;
2769 #endif
2770     return sigaction(signo, &act, save);
2771 }
2772
2773 int
2774 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2775 {
2776     dVAR;
2777 #ifdef USE_ITHREADS
2778     /* only "parent" interpreter can diddle signals */
2779     if (PL_curinterp != aTHX)
2780         return -1;
2781 #endif
2782
2783     return sigaction(signo, save, (struct sigaction *)NULL);
2784 }
2785
2786 #else /* !HAS_SIGACTION */
2787
2788 Sighandler_t
2789 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2790 {
2791 #if defined(USE_ITHREADS) && !defined(WIN32)
2792     /* only "parent" interpreter can diddle signals */
2793     if (PL_curinterp != aTHX)
2794         return (Sighandler_t) SIG_ERR;
2795 #endif
2796
2797     return PerlProc_signal(signo, handler);
2798 }
2799
2800 static Signal_t
2801 sig_trap(int signo)
2802 {
2803     dVAR;
2804     PL_sig_trapped++;
2805 }
2806
2807 Sighandler_t
2808 Perl_rsignal_state(pTHX_ int signo)
2809 {
2810     dVAR;
2811     Sighandler_t oldsig;
2812
2813 #if defined(USE_ITHREADS) && !defined(WIN32)
2814     /* only "parent" interpreter can diddle signals */
2815     if (PL_curinterp != aTHX)
2816         return (Sighandler_t) SIG_ERR;
2817 #endif
2818
2819     PL_sig_trapped = 0;
2820     oldsig = PerlProc_signal(signo, sig_trap);
2821     PerlProc_signal(signo, oldsig);
2822     if (PL_sig_trapped)
2823         PerlProc_kill(PerlProc_getpid(), signo);
2824     return oldsig;
2825 }
2826
2827 int
2828 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2829 {
2830 #if defined(USE_ITHREADS) && !defined(WIN32)
2831     /* only "parent" interpreter can diddle signals */
2832     if (PL_curinterp != aTHX)
2833         return -1;
2834 #endif
2835     *save = PerlProc_signal(signo, handler);
2836     return (*save == (Sighandler_t) SIG_ERR) ? -1 : 0;
2837 }
2838
2839 int
2840 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2841 {
2842 #if defined(USE_ITHREADS) && !defined(WIN32)
2843     /* only "parent" interpreter can diddle signals */
2844     if (PL_curinterp != aTHX)
2845         return -1;
2846 #endif
2847     return (PerlProc_signal(signo, *save) == (Sighandler_t) SIG_ERR) ? -1 : 0;
2848 }
2849
2850 #endif /* !HAS_SIGACTION */
2851 #endif /* !PERL_MICRO */
2852
2853     /* VMS' my_pclose() is in VMS.c; same with OS/2 */
2854 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) && !defined(__LIBCATAMOUNT__)
2855 I32
2856 Perl_my_pclose(pTHX_ PerlIO *ptr)
2857 {
2858     dVAR;
2859     Sigsave_t hstat, istat, qstat;
2860     int status;
2861     SV **svp;
2862     Pid_t pid;
2863     Pid_t pid2;
2864     bool close_failed;
2865     dSAVEDERRNO;
2866
2867     LOCK_FDPID_MUTEX;
2868     svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE);
2869     UNLOCK_FDPID_MUTEX;
2870     pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
2871     SvREFCNT_dec(*svp);
2872     *svp = &PL_sv_undef;
2873 #ifdef OS2
2874     if (pid == -1) {                    /* Opened by popen. */
2875         return my_syspclose(ptr);
2876     }
2877 #endif
2878     close_failed = (PerlIO_close(ptr) == EOF);
2879     SAVE_ERRNO;
2880 #ifdef UTS
2881     if(PerlProc_kill(pid, 0) < 0) { return(pid); }   /* HOM 12/23/91 */
2882 #endif
2883 #ifndef PERL_MICRO
2884     rsignal_save(SIGHUP,  (Sighandler_t) SIG_IGN, &hstat);
2885     rsignal_save(SIGINT,  (Sighandler_t) SIG_IGN, &istat);
2886     rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qstat);
2887 #endif
2888     do {
2889         pid2 = wait4pid(pid, &status, 0);
2890     } while (pid2 == -1 && errno == EINTR);
2891 #ifndef PERL_MICRO
2892     rsignal_restore(SIGHUP, &hstat);
2893     rsignal_restore(SIGINT, &istat);
2894     rsignal_restore(SIGQUIT, &qstat);
2895 #endif
2896     if (close_failed) {
2897         RESTORE_ERRNO;
2898         return -1;
2899     }
2900     return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status));
2901 }
2902 #else
2903 #if defined(__LIBCATAMOUNT__)
2904 I32
2905 Perl_my_pclose(pTHX_ PerlIO *ptr)
2906 {
2907     return -1;
2908 }
2909 #endif
2910 #endif /* !DOSISH */
2911
2912 #if  (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(MACOS_TRADITIONAL) && !defined(__LIBCATAMOUNT__)
2913 I32
2914 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
2915 {
2916     dVAR;
2917     I32 result = 0;
2918     PERL_ARGS_ASSERT_WAIT4PID;
2919     if (!pid)
2920         return -1;
2921 #ifdef PERL_USES_PL_PIDSTATUS
2922     {
2923         if (pid > 0) {
2924             /* The keys in PL_pidstatus are now the raw 4 (or 8) bytes of the
2925                pid, rather than a string form.  */
2926             SV * const * const svp = hv_fetch(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),FALSE);
2927             if (svp && *svp != &PL_sv_undef) {
2928                 *statusp = SvIVX(*svp);
2929                 (void)hv_delete(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),
2930                                 G_DISCARD);
2931                 return pid;
2932             }
2933         }
2934         else {
2935             HE *entry;
2936
2937             hv_iterinit(PL_pidstatus);
2938             if ((entry = hv_iternext(PL_pidstatus))) {
2939                 SV * const sv = hv_iterval(PL_pidstatus,entry);
2940                 I32 len;
2941                 const char * const spid = hv_iterkey(entry,&len);
2942
2943                 assert (len == sizeof(Pid_t));
2944                 memcpy((char *)&pid, spid, len);
2945                 *statusp = SvIVX(sv);
2946                 /* The hash iterator is currently on this entry, so simply
2947                    calling hv_delete would trigger the lazy delete, which on
2948                    aggregate does more work, beacuse next call to hv_iterinit()
2949                    would spot the flag, and have to call the delete routine,
2950                    while in the meantime any new entries can't re-use that
2951                    memory.  */
2952                 hv_iterinit(PL_pidstatus);
2953                 (void)hv_delete(PL_pidstatus,spid,len,G_DISCARD);
2954                 return pid;
2955             }
2956         }
2957     }
2958 #endif
2959 #ifdef HAS_WAITPID
2960 #  ifdef HAS_WAITPID_RUNTIME
2961     if (!HAS_WAITPID_RUNTIME)
2962         goto hard_way;
2963 #  endif
2964     result = PerlProc_waitpid(pid,statusp,flags);
2965     goto finish;
2966 #endif
2967 #if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
2968     result = wait4((pid==-1)?0:pid,statusp,flags,NULL);
2969     goto finish;
2970 #endif
2971 #ifdef PERL_USES_PL_PIDSTATUS
2972 #if defined(HAS_WAITPID) && defined(HAS_WAITPID_RUNTIME)
2973   hard_way:
2974 #endif
2975     {
2976         if (flags)
2977             Perl_croak(aTHX_ "Can't do waitpid with flags");
2978         else {
2979             while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
2980                 pidgone(result,*statusp);
2981             if (result < 0)
2982                 *statusp = -1;
2983         }
2984     }
2985 #endif
2986 #if defined(HAS_WAITPID) || defined(HAS_WAIT4)
2987   finish:
2988 #endif
2989     if (result < 0 && errno == EINTR) {
2990         PERL_ASYNC_CHECK();
2991         errno = EINTR; /* reset in case a signal handler changed $! */
2992     }
2993     return result;
2994 }
2995 #endif /* !DOSISH || OS2 || WIN32 || NETWARE */
2996
2997 #ifdef PERL_USES_PL_PIDSTATUS
2998 void
2999 S_pidgone(pTHX_ Pid_t pid, int status)
3000 {
3001     register SV *sv;
3002
3003     sv = *hv_fetch(PL_pidstatus,(const char*)&pid,sizeof(Pid_t),TRUE);
3004     SvUPGRADE(sv,SVt_IV);
3005     SvIV_set(sv, status);
3006     return;
3007 }
3008 #endif
3009
3010 #if defined(atarist) || defined(OS2) || defined(EPOC)
3011 int pclose();
3012 #ifdef HAS_FORK
3013 int                                     /* Cannot prototype with I32
3014                                            in os2ish.h. */
3015 my_syspclose(PerlIO *ptr)
3016 #else
3017 I32
3018 Perl_my_pclose(pTHX_ PerlIO *ptr)
3019 #endif
3020 {
3021     /* Needs work for PerlIO ! */
3022     FILE * const f = PerlIO_findFILE(ptr);
3023     const I32 result = pclose(f);
3024     PerlIO_releaseFILE(ptr,f);
3025     return result;
3026 }
3027 #endif
3028
3029 #if defined(DJGPP)
3030 int djgpp_pclose();
3031 I32
3032 Perl_my_pclose(pTHX_ PerlIO *ptr)
3033 {
3034     /* Needs work for PerlIO ! */
3035     FILE * const f = PerlIO_findFILE(ptr);
3036     I32 result = djgpp_pclose(f);
3037     result = (result << 8) & 0xff00;
3038     PerlIO_releaseFILE(ptr,f);
3039     return result;
3040 }
3041 #endif
3042
3043 void
3044 Perl_repeatcpy(pTHX_ register char *to, register const char *from, I32 len, register I32 count)
3045 {
3046     register I32 todo;
3047     register const char * const frombase = from;
3048     PERL_UNUSED_CONTEXT;
3049
3050     PERL_ARGS_ASSERT_REPEATCPY;
3051
3052     if (len == 1) {
3053         register const char c = *from;
3054         while (count-- > 0)
3055             *to++ = c;
3056         return;
3057     }
3058     while (count-- > 0) {
3059         for (todo = len; todo > 0; todo--) {
3060             *to++ = *from++;
3061         }
3062         from = frombase;
3063     }
3064 }
3065
3066 #ifndef HAS_RENAME
3067 I32
3068 Perl_same_dirent(pTHX_ const char *a, const char *b)
3069 {
3070     char *fa = strrchr(a,'/');
3071     char *fb = strrchr(b,'/');
3072     Stat_t tmpstatbuf1;
3073     Stat_t tmpstatbuf2;
3074     SV * const tmpsv = sv_newmortal();
3075
3076     PERL_ARGS_ASSERT_SAME_DIRENT;
3077
3078     if (fa)
3079         fa++;
3080     else
3081         fa = a;
3082     if (fb)
3083         fb++;
3084     else
3085         fb = b;
3086     if (strNE(a,b))
3087         return FALSE;
3088     if (fa == a)
3089         sv_setpvs(tmpsv, ".");
3090     else
3091         sv_setpvn(tmpsv, a, fa - a);
3092     if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0)
3093         return FALSE;
3094     if (fb == b)
3095         sv_setpvs(tmpsv, ".");
3096     else
3097         sv_setpvn(tmpsv, b, fb - b);
3098     if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0)
3099         return FALSE;
3100     return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
3101            tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
3102 }
3103 #endif /* !HAS_RENAME */
3104
3105 char*
3106 Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
3107                  const char *const *const search_ext, I32 flags)
3108 {
3109     dVAR;
3110     const char *xfound = NULL;
3111     char *xfailed = NULL;
3112     char tmpbuf[MAXPATHLEN];
3113     register char *s;
3114     I32 len = 0;
3115     int retval;
3116     char *bufend;
3117 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
3118 #  define SEARCH_EXTS ".bat", ".cmd", NULL
3119 #  define MAX_EXT_LEN 4
3120 #endif
3121 #ifdef OS2
3122 #  define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
3123 #  define MAX_EXT_LEN 4
3124 #endif
3125 #ifdef VMS
3126 #  define SEARCH_EXTS ".pl", ".com", NULL
3127 #  define MAX_EXT_LEN 4
3128 #endif
3129     /* additional extensions to try in each dir if scriptname not found */
3130 #ifdef SEARCH_EXTS
3131     static const char *const exts[] = { SEARCH_EXTS };
3132     const char *const *const ext = search_ext ? search_ext : exts;
3133     int extidx = 0, i = 0;
3134     const char *curext = NULL;
3135 #else
3136     PERL_UNUSED_ARG(search_ext);
3137 #  define MAX_EXT_LEN 0
3138 #endif
3139
3140     PERL_ARGS_ASSERT_FIND_SCRIPT;
3141
3142     /*
3143      * If dosearch is true and if scriptname does not contain path
3144      * delimiters, search the PATH for scriptname.
3145      *
3146      * If SEARCH_EXTS is also defined, will look for each
3147      * scriptname{SEARCH_EXTS} whenever scriptname is not found
3148      * while searching the PATH.
3149      *
3150      * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
3151      * proceeds as follows:
3152      *   If DOSISH or VMSISH:
3153      *     + look for ./scriptname{,.foo,.bar}
3154      *     + search the PATH for scriptname{,.foo,.bar}
3155      *
3156      *   If !DOSISH:
3157      *     + look *only* in the PATH for scriptname{,.foo,.bar} (note
3158      *       this will not look in '.' if it's not in the PATH)
3159      */
3160     tmpbuf[0] = '\0';
3161
3162 #ifdef VMS
3163 #  ifdef ALWAYS_DEFTYPES
3164     len = strlen(scriptname);
3165     if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
3166         int idx = 0, deftypes = 1;
3167         bool seen_dot = 1;
3168
3169         const int hasdir = !dosearch || (strpbrk(scriptname,":[</") != NULL);
3170 #  else
3171     if (dosearch) {
3172         int idx = 0, deftypes = 1;
3173         bool seen_dot = 1;
3174
3175         const int hasdir = (strpbrk(scriptname,":[</") != NULL);
3176 #  endif
3177         /* The first time through, just add SEARCH_EXTS to whatever we
3178          * already have, so we can check for default file types. */
3179         while (deftypes ||
3180                (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
3181         {
3182             if (deftypes) {
3183                 deftypes = 0;
3184                 *tmpbuf = '\0';
3185             }
3186             if ((strlen(tmpbuf) + strlen(scriptname)
3187                  + MAX_EXT_LEN) >= sizeof tmpbuf)
3188                 continue;       /* don't search dir with too-long name */
3189             my_strlcat(tmpbuf, scriptname, sizeof(tmpbuf));
3190 #else  /* !VMS */
3191
3192 #ifdef DOSISH
3193     if (strEQ(scriptname, "-"))
3194         dosearch = 0;
3195     if (dosearch) {             /* Look in '.' first. */
3196         const char *cur = scriptname;
3197 #ifdef SEARCH_EXTS
3198         if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
3199             while (ext[i])
3200                 if (strEQ(ext[i++],curext)) {
3201                     extidx = -1;                /* already has an ext */
3202                     break;
3203                 }
3204         do {
3205 #endif
3206             DEBUG_p(PerlIO_printf(Perl_debug_log,
3207                                   "Looking for %s\n",cur));
3208             if (PerlLIO_stat(cur,&PL_statbuf) >= 0
3209                 && !S_ISDIR(PL_statbuf.st_mode)) {
3210                 dosearch = 0;
3211                 scriptname = cur;
3212 #ifdef SEARCH_EXTS
3213                 break;
3214 #endif
3215             }
3216 #ifdef SEARCH_EXTS
3217             if (cur == scriptname) {
3218                 len = strlen(scriptname);
3219                 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
3220                     break;
3221                 my_strlcpy(tmpbuf, scriptname, sizeof(tmpbuf));
3222                 cur = tmpbuf;
3223             }
3224         } while (extidx >= 0 && ext[extidx]     /* try an extension? */
3225                  && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len));
3226 #endif
3227     }
3228 #endif
3229
3230 #ifdef MACOS_TRADITIONAL
3231     if (dosearch && !strchr(scriptname, ':') &&
3232         (s = PerlEnv_getenv("Commands")))
3233 #else
3234     if (dosearch && !strchr(scriptname, '/')
3235 #ifdef DOSISH
3236                  && !strchr(scriptname, '\\')
3237 #endif
3238                  && (s = PerlEnv_getenv("PATH")))
3239 #endif
3240     {
3241         bool seen_dot = 0;
3242
3243         bufend = s + strlen(s);
3244         while (s < bufend) {
3245 #ifdef MACOS_TRADITIONAL
3246             s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend,
3247                         ',',
3248                         &len);
3249 #else
3250 #if defined(atarist) || defined(DOSISH)
3251             for (len = 0; *s
3252 #  ifdef atarist
3253                     && *s != ','
3254 #  endif
3255                     && *s != ';'; len++, s++) {
3256                 if (len < sizeof tmpbuf)
3257                     tmpbuf[len] = *s;
3258             }
3259             if (len < sizeof tmpbuf)
3260                 tmpbuf[len] = '\0';
3261 #else  /* ! (atarist || DOSISH) */
3262             s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend,
3263                         ':',
3264                         &len);
3265 #endif /* ! (atarist || DOSISH) */
3266 #endif /* MACOS_TRADITIONAL */
3267             if (s < bufend)
3268                 s++;
3269             if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
3270                 continue;       /* don't search dir with too-long name */
3271 #ifdef MACOS_TRADITIONAL
3272             if (len && tmpbuf[len - 1] != ':')
3273                 tmpbuf[len++] = ':';
3274 #else
3275             if (len
3276 #  if defined(atarist) || defined(__MINT__) || defined(DOSISH)
3277                 && tmpbuf[len - 1] != '/'
3278                 && tmpbuf[len - 1] != '\\'
3279 #  endif
3280                )
3281                 tmpbuf[len++] = '/';
3282             if (len == 2 && tmpbuf[0] == '.')
3283                 seen_dot = 1;
3284 #endif
3285             (void)my_strlcpy(tmpbuf + len, scriptname, sizeof(tmpbuf) - len);
3286 #endif  /* !VMS */
3287
3288 #ifdef SEARCH_EXTS
3289             len = strlen(tmpbuf);
3290             if (extidx > 0)     /* reset after previous loop */
3291                 extidx = 0;
3292             do {
3293 #endif
3294                 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
3295                 retval = PerlLIO_stat(tmpbuf,&PL_statbuf);
3296                 if (S_ISDIR(PL_statbuf.st_mode)) {
3297                     retval = -1;
3298                 }
3299 #ifdef SEARCH_EXTS
3300             } while (  retval < 0               /* not there */
3301                     && extidx>=0 && ext[extidx] /* try an extension? */
3302                     && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len)
3303                 );
3304 #endif
3305             if (retval < 0)
3306                 continue;
3307             if (S_ISREG(PL_statbuf.st_mode)
3308                 && cando(S_IRUSR,TRUE,&PL_statbuf)
3309 #if !defined(DOSISH) && !defined(MACOS_TRADITIONAL)
3310                 && cando(S_IXUSR,TRUE,&PL_statbuf)
3311 #endif
3312                 )
3313             {
3314                 xfound = tmpbuf;                /* bingo! */
3315                 break;
3316             }
3317             if (!xfailed)
3318                 xfailed = savepv(tmpbuf);
3319         }
3320 #ifndef DOSISH
3321         if (!xfound && !seen_dot && !xfailed &&
3322             (PerlLIO_stat(scriptname,&PL_statbuf) < 0
3323              || S_ISDIR(PL_statbuf.st_mode)))
3324 #endif
3325             seen_dot = 1;                       /* Disable message. */
3326         if (!xfound) {
3327             if (flags & 1) {                    /* do or die? */
3328                 Perl_croak(aTHX_ "Can't %s %s%s%s",
3329                       (xfailed ? "execute" : "find"),
3330                       (xfailed ? xfailed : scriptname),
3331                       (xfailed ? "" : " on PATH"),
3332                       (xfailed || seen_dot) ? "" : ", '.' not in PATH");
3333             }
3334             scriptname = NULL;
3335         }
3336         Safefree(xfailed);
3337         scriptname = xfound;
3338     }
3339     return (scriptname ? savepv(scriptname) : NULL);
3340 }
3341
3342 #ifndef PERL_GET_CONTEXT_DEFINED
3343
3344 void *
3345 Perl_get_context(void)
3346 {
3347     dVAR;
3348 #if defined(USE_ITHREADS)
3349 #  ifdef OLD_PTHREADS_API
3350     pthread_addr_t t;
3351     if (pthread_getspecific(PL_thr_key, &t))
3352         Perl_croak_nocontext("panic: pthread_getspecific");
3353     return (void*)t;
3354 #  else
3355 #    ifdef I_MACH_CTHREADS
3356     return (void*)cthread_data(cthread_self());
3357 #    else
3358     return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
3359 #    endif
3360 #  endif
3361 #else
3362     return (void*)NULL;
3363 #endif
3364 }
3365
3366 void
3367 Perl_set_context(void *t)
3368 {
3369     dVAR;
3370     PERL_ARGS_ASSERT_SET_CONTEXT;
3371 #if defined(USE_ITHREADS)
3372 #  ifdef I_MACH_CTHREADS
3373     cthread_set_data(cthread_self(), t);
3374 #  else
3375     if (pthread_setspecific(PL_thr_key, t))
3376         Perl_croak_nocontext("panic: pthread_setspecific");
3377 #  endif
3378 #else
3379     PERL_UNUSED_ARG(t);
3380 #endif
3381 }
3382
3383 #endif /* !PERL_GET_CONTEXT_DEFINED */
3384
3385 #if defined(PERL_GLOBAL_STRUCT) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
3386 struct perl_vars *
3387 Perl_GetVars(pTHX)
3388 {
3389  return &PL_Vars;
3390 }
3391 #endif
3392
3393 char **
3394 Perl_get_op_names(pTHX)
3395 {
3396     PERL_UNUSED_CONTEXT;
3397     return (char **)PL_op_name;
3398 }
3399
3400 char **
3401 Perl_get_op_descs(pTHX)
3402 {
3403     PERL_UNUSED_CONTEXT;
3404     return (char **)PL_op_desc;
3405 }
3406
3407 const char *
3408 Perl_get_no_modify(pTHX)
3409 {
3410     PERL_UNUSED_CONTEXT;
3411     return PL_no_modify;
3412 }
3413
3414 U32 *
3415 Perl_get_opargs(pTHX)
3416 {
3417     PERL_UNUSED_CONTEXT;
3418     return (U32 *)PL_opargs;
3419 }
3420
3421 PPADDR_t*
3422 Perl_get_ppaddr(pTHX)
3423 {
3424     dVAR;
3425     PERL_UNUSED_CONTEXT;
3426     return (PPADDR_t*)PL_ppaddr;
3427 }
3428
3429 #ifndef HAS_GETENV_LEN
3430 char *
3431 Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
3432 {
3433     char * const env_trans = PerlEnv_getenv(env_elem);
3434     PERL_UNUSED_CONTEXT;
3435     PERL_ARGS_ASSERT_GETENV_LEN;
3436     if (env_trans)
3437         *len = strlen(env_trans);
3438     return env_trans;
3439 }
3440 #endif
3441
3442
3443 MGVTBL*
3444 Perl_get_vtbl(pTHX_ int vtbl_id)
3445 {
3446     const MGVTBL* result;
3447     PERL_UNUSED_CONTEXT;
3448
3449     switch(vtbl_id) {
3450     case want_vtbl_sv:
3451         result = &PL_vtbl_sv;
3452         break;
3453     case want_vtbl_env:
3454         result = &PL_vtbl_env;
3455         break;
3456     case want_vtbl_envelem:
3457         result = &PL_vtbl_envelem;
3458         break;
3459     case want_vtbl_sig:
3460         result = &PL_vtbl_sig;
3461         break;
3462     case want_vtbl_sigelem:
3463         result = &PL_vtbl_sigelem;
3464         break;
3465     case want_vtbl_pack:
3466         result = &PL_vtbl_pack;
3467         break;
3468     case want_vtbl_packelem:
3469         result = &PL_vtbl_packelem;
3470         break;
3471     case want_vtbl_dbline:
3472         result = &PL_vtbl_dbline;
3473         break;
3474     case want_vtbl_isa:
3475         result = &PL_vtbl_isa;
3476         break;
3477     case want_vtbl_isaelem:
3478         result = &PL_vtbl_isaelem;
3479         break;
3480     case want_vtbl_arylen:
3481         result = &PL_vtbl_arylen;
3482         break;
3483     case want_vtbl_mglob:
3484         result = &PL_vtbl_mglob;
3485         break;
3486     case want_vtbl_nkeys:
3487         result = &PL_vtbl_nkeys;
3488         break;
3489     case want_vtbl_taint:
3490         result = &PL_vtbl_taint;
3491         break;
3492     case want_vtbl_substr:
3493         result = &PL_vtbl_substr;
3494         break;
3495     case want_vtbl_vec:
3496         result = &PL_vtbl_vec;
3497         break;
3498     case want_vtbl_pos:
3499         result = &PL_vtbl_pos;
3500         break;
3501     case want_vtbl_bm:
3502         result = &PL_vtbl_bm;
3503         break;
3504     case want_vtbl_fm:
3505         result = &PL_vtbl_fm;
3506         break;
3507     case want_vtbl_uvar:
3508         result = &PL_vtbl_uvar;
3509         break;
3510     case want_vtbl_defelem:
3511         result = &PL_vtbl_defelem;
3512         break;
3513     case want_vtbl_regexp:
3514         result = &PL_vtbl_regexp;
3515         break;
3516     case want_vtbl_regdata:
3517         result = &PL_vtbl_regdata;
3518         break;
3519     case want_vtbl_regdatum:
3520         result = &PL_vtbl_regdatum;
3521         break;
3522 #ifdef USE_LOCALE_COLLATE
3523     case want_vtbl_collxfrm:
3524         result = &PL_vtbl_collxfrm;
3525         break;
3526 #endif
3527     case want_vtbl_amagic:
3528         result = &PL_vtbl_amagic;
3529         break;
3530     case want_vtbl_amagicelem:
3531         result = &PL_vtbl_amagicelem;
3532         break;
3533     case want_vtbl_backref:
3534         result = &PL_vtbl_backref;
3535         break;
3536     case want_vtbl_utf8:
3537         result = &PL_vtbl_utf8;
3538         break;
3539     default:
3540         result = NULL;
3541         break;
3542     }
3543     return (MGVTBL*)result;
3544 }
3545
3546 I32
3547 Perl_my_fflush_all(pTHX)
3548 {
3549 #if defined(USE_PERLIO) || defined(FFLUSH_NULL) || defined(USE_SFIO)
3550     return PerlIO_flush(NULL);
3551 #else
3552 # if defined(HAS__FWALK)
3553     extern int fflush(FILE *);
3554     /* undocumented, unprototyped, but very useful BSDism */
3555     extern void _fwalk(int (*)(FILE *));
3556     _fwalk(&fflush);
3557     return 0;
3558 # else
3559 #  if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
3560     long open_max = -1;
3561 #   ifdef PERL_FFLUSH_ALL_FOPEN_MAX
3562     open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
3563 #   else
3564 #    if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
3565     open_max = sysconf(_SC_OPEN_MAX);
3566 #     else
3567 #      ifdef FOPEN_MAX
3568     open_max = FOPEN_MAX;
3569 #      else
3570 #       ifdef OPEN_MAX
3571     open_max = OPEN_MAX;
3572 #       else
3573 #        ifdef _NFILE
3574     open_max = _NFILE;
3575 #        endif
3576 #       endif
3577 #      endif
3578 #     endif
3579 #    endif
3580     if (open_max > 0) {
3581       long i;
3582       for (i = 0; i < open_max; i++)
3583             if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
3584                 STDIO_STREAM_ARRAY[i]._file < open_max &&
3585                 STDIO_STREAM_ARRAY[i]._flag)
3586                 PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
3587       return 0;
3588     }
3589 #  endif
3590     SETERRNO(EBADF,RMS_IFI);
3591     return EOF;
3592 # endif
3593 #endif
3594 }
3595
3596 void
3597 Perl_report_evil_fh(pTHX_ const GV *gv, const IO *io, I32 op)
3598 {
3599     const char * const name = gv && isGV(gv) ? GvENAME(gv) : NULL;
3600
3601     if (op == OP_phoney_OUTPUT_ONLY || op == OP_phoney_INPUT_ONLY) {
3602         if (ckWARN(WARN_IO)) {
3603             const char * const direction =
3604                 (const char *)((op == OP_phoney_INPUT_ONLY) ? "in" : "out");
3605             if (name && *name)
3606                 Perl_warner(aTHX_ packWARN(WARN_IO),
3607                             "Filehandle %s opened only for %sput",
3608                             name, direction);
3609             else
3610                 Perl_warner(aTHX_ packWARN(WARN_IO),
3611                             "Filehandle opened only for %sput", direction);
3612         }
3613     }
3614     else {
3615         const char *vile;
3616         I32   warn_type;
3617
3618         if (gv && io && IoTYPE(io) == IoTYPE_CLOSED) {
3619             vile = "closed";
3620             warn_type = WARN_CLOSED;
3621         }
3622         else {
3623             vile = "unopened";
3624             warn_type = WARN_UNOPENED;
3625         }
3626
3627         if (ckWARN(warn_type)) {
3628             const char * const pars =
3629                 (const char *)(OP_IS_FILETEST(op) ? "" : "()");
3630             const char * const func =
3631                 (const char *)
3632                 (op == OP_READLINE   ? "readline"  :    /* "<HANDLE>" not nice */
3633                  op == OP_LEAVEWRITE ? "write" :                /* "write exit" not nice */
3634                  op < 0              ? "" :              /* handle phoney cases */
3635                  PL_op_desc[op]);
3636             const char * const type =
3637                 (const char *)
3638                 (OP_IS_SOCKET(op) ||
3639                  (gv && io && IoTYPE(io) == IoTYPE_SOCKET) ?
3640                  "socket" : "filehandle");
3641             if (name && *name) {
3642                 Perl_warner(aTHX_ packWARN(warn_type),
3643                             "%s%s on %s %s %s", func, pars, vile, type, name);
3644                 if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3645                     Perl_warner(
3646                         aTHX_ packWARN(warn_type),
3647                         "\t(Are you trying to call %s%s on dirhandle %s?)\n",
3648                         func, pars, name
3649                     );
3650             }
3651             else {
3652                 Perl_warner(aTHX_ packWARN(warn_type),
3653                             "%s%s on %s %s", func, pars, vile, type);
3654                 if (gv && io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3655                     Perl_warner(
3656                         aTHX_ packWARN(warn_type),
3657                         "\t(Are you trying to call %s%s on dirhandle?)\n",
3658                         func, pars
3659                     );
3660             }
3661         }
3662     }
3663 }
3664
3665 #ifdef EBCDIC
3666 /* in ASCII order, not that it matters */
3667 static const char controllablechars[] = "?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_";
3668
3669 int
3670 Perl_ebcdic_control(pTHX_ int ch)
3671 {
3672     if (ch > 'a') {
3673         const char *ctlp;
3674
3675         if (islower(ch))
3676             ch = toupper(ch);
3677
3678         if ((ctlp = strchr(controllablechars, ch)) == 0) {
3679             Perl_die(aTHX_ "unrecognised control character '%c'\n", ch);
3680         }
3681
3682         if (ctlp == controllablechars)
3683             return('\177'); /* DEL */
3684         else
3685             return((unsigned char)(ctlp - controllablechars - 1));
3686     } else { /* Want uncontrol */
3687         if (ch == '\177' || ch == -1)
3688             return('?');
3689         else if (ch == '\157')
3690             return('\177');
3691         else if (ch == '\174')
3692             return('\000');
3693         else if (ch == '^')    /* '\137' in 1047, '\260' in 819 */
3694             return('\036');
3695         else if (ch == '\155')
3696             return('\037');
3697         else if (0 < ch && ch < (sizeof(controllablechars) - 1))
3698             return(controllablechars[ch+1]);
3699         else
3700             Perl_die(aTHX_ "invalid control request: '\\%03o'\n", ch & 0xFF);
3701     }
3702 }
3703 #endif
3704
3705 /* To workaround core dumps from the uninitialised tm_zone we get the
3706  * system to give us a reasonable struct to copy.  This fix means that
3707  * strftime uses the tm_zone and tm_gmtoff values returned by
3708  * localtime(time()). That should give the desired result most of the
3709  * time. But probably not always!
3710  *
3711  * This does not address tzname aspects of NETaa14816.
3712  *
3713  */
3714
3715 #ifdef HAS_GNULIBC
3716 # ifndef STRUCT_TM_HASZONE
3717 #    define STRUCT_TM_HASZONE
3718 # endif
3719 #endif
3720
3721 #ifdef STRUCT_TM_HASZONE /* Backward compat */
3722 # ifndef HAS_TM_TM_ZONE
3723 #    define HAS_TM_TM_ZONE
3724 # endif
3725 #endif
3726
3727 void
3728 Perl_init_tm(pTHX_ struct tm *ptm)      /* see mktime, strftime and asctime */
3729 {
3730 #ifdef HAS_TM_TM_ZONE
3731     Time_t now;
3732     const struct tm* my_tm;
3733     PERL_ARGS_ASSERT_INIT_TM;
3734     (void)time(&now);
3735     my_tm = localtime(&now);
3736     if (my_tm)
3737         Copy(my_tm, ptm, 1, struct tm);
3738 #else
3739     PERL_ARGS_ASSERT_INIT_TM;
3740     PERL_UNUSED_ARG(ptm);
3741 #endif
3742 }
3743
3744 /*
3745  * mini_mktime - normalise struct tm values without the localtime()
3746  * semantics (and overhead) of mktime().
3747  */
3748 void
3749 Perl_mini_mktime(pTHX_ struct tm *ptm)
3750 {
3751     int yearday;
3752     int secs;
3753     int month, mday, year, jday;
3754     int odd_cent, odd_year;
3755     PERL_UNUSED_CONTEXT;
3756
3757     PERL_ARGS_ASSERT_MINI_MKTIME;
3758
3759 #define DAYS_PER_YEAR   365
3760 #define DAYS_PER_QYEAR  (4*DAYS_PER_YEAR+1)
3761 #define DAYS_PER_CENT   (25*DAYS_PER_QYEAR-1)
3762 #define DAYS_PER_QCENT  (4*DAYS_PER_CENT+1)
3763 #define SECS_PER_HOUR   (60*60)
3764 #define SECS_PER_DAY    (24*SECS_PER_HOUR)
3765 /* parentheses deliberately absent on these two, otherwise they don't work */
3766 #define MONTH_TO_DAYS   153/5
3767 #define DAYS_TO_MONTH   5/153
3768 /* offset to bias by March (month 4) 1st between month/mday & year finding */
3769 #define YEAR_ADJUST     (4*MONTH_TO_DAYS+1)
3770 /* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */
3771 #define WEEKDAY_BIAS    6       /* (1+6)%7 makes Sunday 0 again */
3772
3773 /*
3774  * Year/day algorithm notes:
3775  *
3776  * With a suitable offset for numeric value of the month, one can find
3777  * an offset into the year by considering months to have 30.6 (153/5) days,
3778  * using integer arithmetic (i.e., with truncation).  To avoid too much
3779  * messing about with leap days, we consider January and February to be
3780  * the 13th and 14th month of the previous year.  After that transformation,
3781  * we need the month index we use to be high by 1 from 'normal human' usage,
3782  * so the month index values we use run from 4 through 15.
3783  *
3784  * Given that, and the rules for the Gregorian calendar (leap years are those
3785  * divisible by 4 unless also divisible by 100, when they must be divisible
3786  * by 400 instead), we can simply calculate the number of days since some
3787  * arbitrary 'beginning of time' by futzing with the (adjusted) year number,
3788  * the days we derive from our month index, and adding in the day of the
3789  * month.  The value used here is not adjusted for the actual origin which
3790  * it normally would use (1 January A.D. 1), since we're not exposing it.
3791  * We're only building the value so we can turn around and get the
3792  * normalised values for the year, month, day-of-month, and day-of-year.
3793  *
3794  * For going backward, we need to bias the value we're using so that we find
3795  * the right year value.  (Basically, we don't want the contribution of
3796  * March 1st to the number to apply while deriving the year).  Having done
3797  * that, we 'count up' the contribution to the year number by accounting for
3798  * full quadracenturies (400-year periods) with their extra leap days, plus
3799  * the contribution from full centuries (to avoid counting in the lost leap
3800  * days), plus the contribution from full quad-years (to count in the normal
3801  * leap days), plus the leftover contribution from any non-leap years.
3802  * At this point, if we were working with an actual leap day, we'll have 0
3803  * days left over.  This is also true for March 1st, however.  So, we have
3804  * to special-case that result, and (earlier) keep track of the 'odd'
3805  * century and year contributions.  If we got 4 extra centuries in a qcent,
3806  * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb.
3807  * Otherwise, we add back in the earlier bias we removed (the 123 from
3808  * figuring in March 1st), find the month index (integer division by 30.6),
3809  * and the remainder is the day-of-month.  We then have to convert back to
3810  * 'real' months (including fixing January and February from being 14/15 in
3811  * the previous year to being in the proper year).  After that, to get
3812  * tm_yday, we work with the normalised year and get a new yearday value for
3813  * January 1st, which we subtract from the yearday value we had earlier,
3814  * representing the date we've re-built.  This is done from January 1
3815  * because tm_yday is 0-origin.
3816  *
3817  * Since POSIX time routines are only guaranteed to work for times since the
3818  * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm
3819  * applies Gregorian calendar rules even to dates before the 16th century
3820  * doesn't bother me.  Besides, you'd need cultural context for a given
3821  * date to know whether it was Julian or Gregorian calendar, and that's
3822  * outside the scope for this routine.  Since we convert back based on the
3823  * same rules we used to build the yearday, you'll only get strange results
3824  * for input which needed normalising, or for the 'odd' century years which
3825  * were leap years in the Julian calander but not in the Gregorian one.
3826  * I can live with that.
3827  *
3828  * This algorithm also fails to handle years before A.D. 1 gracefully, but
3829  * that's still outside the scope for POSIX time manipulation, so I don't
3830  * care.
3831  */
3832
3833     year = 1900 + ptm->tm_year;
3834     month = ptm->tm_mon;
3835     mday = ptm->tm_mday;
3836     /* allow given yday with no month & mday to dominate the result */
3837     if (ptm->tm_yday >= 0 && mday <= 0 && month <= 0) {
3838         month = 0;
3839         mday = 0;
3840         jday = 1 + ptm->tm_yday;
3841     }
3842     else {
3843         jday = 0;
3844     }
3845     if (month >= 2)
3846         month+=2;
3847     else
3848         month+=14, year--;
3849     yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400;
3850     yearday += month*MONTH_TO_DAYS + mday + jday;
3851     /*
3852      * Note that we don't know when leap-seconds were or will be,
3853      * so we have to trust the user if we get something which looks
3854      * like a sensible leap-second.  Wild values for seconds will
3855      * be rationalised, however.
3856      */
3857     if ((unsigned) ptm->tm_sec <= 60) {
3858         secs = 0;
3859     }
3860     else {
3861         secs = ptm->tm_sec;
3862         ptm->tm_sec = 0;
3863     }
3864     secs += 60 * ptm->tm_min;
3865     secs += SECS_PER_HOUR * ptm->tm_hour;
3866     if (secs < 0) {
3867         if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) {
3868             /* got negative remainder, but need positive time */
3869             /* back off an extra day to compensate */
3870             yearday += (secs/SECS_PER_DAY)-1;
3871             secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1);
3872         }
3873         else {
3874             yearday += (secs/SECS_PER_DAY);
3875             secs -= SECS_PER_DAY * (secs/SECS_PER_DAY);
3876         }
3877     }
3878     else if (secs >= SECS_PER_DAY) {
3879         yearday += (secs/SECS_PER_DAY);
3880         secs %= SECS_PER_DAY;
3881     }
3882     ptm->tm_hour = secs/SECS_PER_HOUR;
3883     secs %= SECS_PER_HOUR;
3884     ptm->tm_min = secs/60;
3885     secs %= 60;
3886     ptm->tm_sec += secs;
3887     /* done with time of day effects */
3888     /*
3889      * The algorithm for yearday has (so far) left it high by 428.
3890      * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to
3891      * bias it by 123 while trying to figure out what year it
3892      * really represents.  Even with this tweak, the reverse
3893      * translation fails for years before A.D. 0001.
3894      * It would still fail for Feb 29, but we catch that one below.
3895      */
3896     jday = yearday;     /* save for later fixup vis-a-vis Jan 1 */
3897     yearday -= YEAR_ADJUST;
3898     year = (yearday / DAYS_PER_QCENT) * 400;
3899     yearday %= DAYS_PER_QCENT;
3900     odd_cent = yearday / DAYS_PER_CENT;
3901     year += odd_cent * 100;
3902     yearday %= DAYS_PER_CENT;
3903     year += (yearday / DAYS_PER_QYEAR) * 4;
3904     yearday %= DAYS_PER_QYEAR;
3905     odd_year = yearday / DAYS_PER_YEAR;
3906     year += odd_year;
3907     yearday %= DAYS_PER_YEAR;
3908     if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */
3909         month = 1;
3910         yearday = 29;
3911     }
3912     else {
3913         yearday += YEAR_ADJUST; /* recover March 1st crock */
3914         month = yearday*DAYS_TO_MONTH;
3915         yearday -= month*MONTH_TO_DAYS;
3916         /* recover other leap-year adjustment */
3917         if (month > 13) {
3918             month-=14;
3919             year++;
3920         }
3921         else {
3922             month-=2;
3923         }
3924     }
3925     ptm->tm_year = year - 1900;
3926     if (yearday) {
3927       ptm->tm_mday = yearday;
3928       ptm->tm_mon = month;
3929     }
3930     else {
3931       ptm->tm_mday = 31;
3932       ptm->tm_mon = month - 1;
3933     }
3934     /* re-build yearday based on Jan 1 to get tm_yday */
3935     year--;
3936     yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400;
3937     yearday += 14*MONTH_TO_DAYS + 1;
3938     ptm->tm_yday = jday - yearday;
3939     /* fix tm_wday if not overridden by caller */
3940     if ((unsigned)ptm->tm_wday > 6)
3941         ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
3942 }
3943
3944 char *
3945 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)
3946 {
3947 #ifdef HAS_STRFTIME
3948   char *buf;
3949   int buflen;
3950   struct tm mytm;
3951   int len;
3952
3953   PERL_ARGS_ASSERT_MY_STRFTIME;
3954
3955   init_tm(&mytm);       /* XXX workaround - see init_tm() above */
3956   mytm.tm_sec = sec;
3957   mytm.tm_min = min;
3958   mytm.tm_hour = hour;
3959   mytm.tm_mday = mday;
3960   mytm.tm_mon = mon;
3961   mytm.tm_year = year;
3962   mytm.tm_wday = wday;
3963   mytm.tm_yday = yday;
3964   mytm.tm_isdst = isdst;
3965   mini_mktime(&mytm);
3966   /* use libc to get the values for tm_gmtoff and tm_zone [perl #18238] */
3967 #if defined(HAS_MKTIME) && (defined(HAS_TM_TM_GMTOFF) || defined(HAS_TM_TM_ZONE))
3968   STMT_START {
3969     struct tm mytm2;
3970     mytm2 = mytm;
3971     mktime(&mytm2);
3972 #ifdef HAS_TM_TM_GMTOFF
3973     mytm.tm_gmtoff = mytm2.tm_gmtoff;
3974 #endif
3975 #ifdef HAS_TM_TM_ZONE
3976     mytm.tm_zone = mytm2.tm_zone;
3977 #endif
3978   } STMT_END;
3979 #endif
3980   buflen = 64;
3981   Newx(buf, buflen, char);
3982   len = strftime(buf, buflen, fmt, &mytm);
3983   /*
3984   ** The following is needed to handle to the situation where
3985   ** tmpbuf overflows.  Basically we want to allocate a buffer
3986   ** and try repeatedly.  The reason why it is so complicated
3987   ** is that getting a return value of 0 from strftime can indicate
3988   ** one of the following:
3989   ** 1. buffer overflowed,
3990   ** 2. illegal conversion specifier, or
3991   ** 3. the format string specifies nothing to be returned(not
3992   **      an error).  This could be because format is an empty string
3993   **    or it specifies %p that yields an empty string in some locale.
3994   ** If there is a better way to make it portable, go ahead by
3995   ** all means.
3996   */
3997   if ((len > 0 && len < buflen) || (len == 0 && *fmt == '\0'))
3998     return buf;
3999   else {
4000     /* Possibly buf overflowed - try again with a bigger buf */
4001     const int fmtlen = strlen(fmt);
4002     int bufsize = fmtlen + buflen;
4003
4004     Newx(buf, bufsize, char);
4005     while (buf) {
4006       buflen = strftime(buf, bufsize, fmt, &mytm);
4007       if (buflen > 0 && buflen < bufsize)
4008         break;
4009       /* heuristic to prevent out-of-memory errors */
4010       if (bufsize > 100*fmtlen) {
4011         Safefree(buf);
4012         buf = NULL;
4013         break;
4014       }
4015       bufsize *= 2;
4016       Renew(buf, bufsize, char);
4017     }
4018     return buf;
4019   }
4020 #else
4021   Perl_croak(aTHX_ "panic: no strftime");
4022   return NULL;
4023 #endif
4024 }
4025
4026
4027 #define SV_CWD_RETURN_UNDEF \
4028 sv_setsv(sv, &PL_sv_undef); \
4029 return FALSE
4030
4031 #define SV_CWD_ISDOT(dp) \
4032     (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
4033         (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
4034
4035 /*
4036 =head1 Miscellaneous Functions
4037
4038 =for apidoc getcwd_sv
4039
4040 Fill the sv with current working directory
4041
4042 =cut
4043 */
4044
4045 /* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars.
4046  * rewritten again by dougm, optimized for use with xs TARG, and to prefer
4047  * getcwd(3) if available
4048  * Comments from the orignal:
4049  *     This is a faster version of getcwd.  It's also more dangerous
4050  *     because you might chdir out of a directory that you can't chdir
4051  *     back into. */
4052
4053 int
4054 Perl_getcwd_sv(pTHX_ register SV *sv)
4055 {
4056 #ifndef PERL_MICRO
4057     dVAR;
4058 #ifndef INCOMPLETE_TAINTS
4059     SvTAINTED_on(sv);
4060 #endif
4061
4062     PERL_ARGS_ASSERT_GETCWD_SV;
4063
4064 #ifdef HAS_GETCWD
4065     {
4066         char buf[MAXPATHLEN];
4067
4068         /* Some getcwd()s automatically allocate a buffer of the given
4069          * size from the heap if they are given a NULL buffer pointer.
4070          * The problem is that this behaviour is not portable. */
4071         if (getcwd(buf, sizeof(buf) - 1)) {
4072             sv_setpv(sv, buf);
4073             return TRUE;
4074         }
4075         else {
4076             sv_setsv(sv, &PL_sv_undef);
4077             return FALSE;
4078         }
4079     }
4080
4081 #else
4082
4083     Stat_t statbuf;
4084     int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
4085     int pathlen=0;
4086     Direntry_t *dp;
4087
4088     SvUPGRADE(sv, SVt_PV);
4089
4090     if (PerlLIO_lstat(".", &statbuf) < 0) {
4091         SV_CWD_RETURN_UNDEF;
4092     }
4093
4094     orig_cdev = statbuf.st_dev;
4095     orig_cino = statbuf.st_ino;
4096     cdev = orig_cdev;
4097     cino = orig_cino;
4098
4099     for (;;) {
4100         DIR *dir;
4101         odev = cdev;
4102         oino = cino;
4103
4104         if (PerlDir_chdir("..") < 0) {
4105             SV_CWD_RETURN_UNDEF;
4106         }
4107         if (PerlLIO_stat(".", &statbuf) < 0) {
4108             SV_CWD_RETURN_UNDEF;
4109         }
4110
4111         cdev = statbuf.st_dev;
4112         cino = statbuf.st_ino;
4113
4114         if (odev == cdev && oino == cino) {
4115             break;
4116         }
4117         if (!(dir = PerlDir_open("."))) {
4118             SV_CWD_RETURN_UNDEF;
4119         }
4120
4121         while ((dp = PerlDir_read(dir)) != NULL) {
4122 #ifdef DIRNAMLEN
4123             const int namelen = dp->d_namlen;
4124 #else
4125             const int namelen = strlen(dp->d_name);
4126 #endif
4127             /* skip . and .. */
4128             if (SV_CWD_ISDOT(dp)) {
4129                 continue;
4130             }
4131
4132             if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
4133                 SV_CWD_RETURN_UNDEF;
4134             }
4135
4136             tdev = statbuf.st_dev;
4137             tino = statbuf.st_ino;
4138             if (tino == oino && tdev == odev) {
4139                 break;
4140             }
4141         }
4142
4143         if (!dp) {
4144             SV_CWD_RETURN_UNDEF;
4145         }
4146
4147         if (pathlen + namelen + 1 >= MAXPATHLEN) {
4148             SV_CWD_RETURN_UNDEF;
4149         }
4150
4151         SvGROW(sv, pathlen + namelen + 1);
4152
4153         if (pathlen) {
4154             /* shift down */
4155             Move(SvPVX_const(sv), SvPVX(sv) + namelen + 1, pathlen, char);
4156         }
4157
4158         /* prepend current directory to the front */
4159         *SvPVX(sv) = '/';
4160         Move(dp->d_name, SvPVX(sv)+1, namelen, char);
4161         pathlen += (namelen + 1);
4162
4163 #ifdef VOID_CLOSEDIR
4164         PerlDir_close(dir);
4165 #else
4166         if (PerlDir_close(dir) < 0) {
4167             SV_CWD_RETURN_UNDEF;
4168         }
4169 #endif
4170     }
4171
4172     if (pathlen) {
4173         SvCUR_set(sv, pathlen);
4174         *SvEND(sv) = '\0';
4175         SvPOK_only(sv);
4176
4177         if (PerlDir_chdir(SvPVX_const(sv)) < 0) {
4178             SV_CWD_RETURN_UNDEF;
4179         }
4180     }
4181     if (PerlLIO_stat(".", &statbuf) < 0) {
4182         SV_CWD_RETURN_UNDEF;
4183     }
4184
4185     cdev = statbuf.st_dev;
4186     cino = statbuf.st_ino;
4187
4188     if (cdev != orig_cdev || cino != orig_cino) {
4189         Perl_croak(aTHX_ "Unstable directory path, "
4190                    "current directory changed unexpectedly");
4191     }
4192
4193     return TRUE;
4194 #endif
4195
4196 #else
4197     return FALSE;
4198 #endif
4199 }
4200
4201 #define VERSION_MAX 0x7FFFFFFF
4202 /*
4203 =for apidoc scan_version
4204
4205 Returns a pointer to the next character after the parsed
4206 version string, as well as upgrading the passed in SV to
4207 an RV.
4208
4209 Function must be called with an already existing SV like
4210
4211     sv = newSV(0);
4212     s = scan_version(s, SV *sv, bool qv);
4213
4214 Performs some preprocessing to the string to ensure that
4215 it has the correct characteristics of a version.  Flags the
4216 object if it contains an underscore (which denotes this
4217 is an alpha version).  The boolean qv denotes that the version
4218 should be interpreted as if it had multiple decimals, even if
4219 it doesn't.
4220
4221 =cut
4222 */
4223
4224 const char *
4225 Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
4226 {
4227     const char *start;
4228     const char *pos;
4229     const char *last;
4230     int saw_period = 0;
4231     int alpha = 0;
4232     int width = 3;
4233     bool vinf = FALSE;
4234     AV * const av = newAV();
4235     SV * const hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
4236
4237     PERL_ARGS_ASSERT_SCAN_VERSION;
4238
4239     (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
4240
4241     while (isSPACE(*s)) /* leading whitespace is OK */
4242         s++;
4243
4244     start = last = s;
4245
4246     if (*s == 'v') {
4247         s++;  /* get past 'v' */
4248         qv = 1; /* force quoted version processing */
4249     }
4250
4251     pos = s;
4252
4253     /* pre-scan the input string to check for decimals/underbars */
4254     while ( *pos == '.' || *pos == '_' || isDIGIT(*pos) )
4255     {
4256         if ( *pos == '.' )
4257         {
4258             if ( alpha )
4259                 Perl_croak(aTHX_ "Invalid version format (underscores before decimal)");
4260             saw_period++ ;
4261             last = pos;
4262         }
4263         else if ( *pos == '_' )
4264         {
4265             if ( alpha )
4266                 Perl_croak(aTHX_ "Invalid version format (multiple underscores)");
4267             alpha = 1;
4268             width = pos - last - 1; /* natural width of sub-version */
4269         }
4270         pos++;
4271     }
4272
4273     if ( alpha && !saw_period )
4274         Perl_croak(aTHX_ "Invalid version format (alpha without decimal)");
4275
4276     if ( alpha && saw_period && width == 0 )
4277         Perl_croak(aTHX_ "Invalid version format (misplaced _ in number)");
4278
4279     if ( saw_period > 1 )
4280         qv = 1; /* force quoted version processing */
4281
4282     last = pos;
4283     pos = s;
4284
4285     if ( qv )
4286         (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(qv));
4287     if ( alpha )
4288         (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(alpha));
4289     if ( !qv && width < 3 )
4290         (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
4291     
4292     while (isDIGIT(*pos))
4293         pos++;
4294     if (!isALPHA(*pos)) {
4295         I32 rev;
4296
4297         for (;;) {
4298             rev = 0;
4299             {
4300                 /* this is atoi() that delimits on underscores */
4301                 const char *end = pos;
4302                 I32 mult = 1;
4303                 I32 orev;
4304
4305                 /* the following if() will only be true after the decimal
4306                  * point of a version originally created with a bare
4307                  * floating point number, i.e. not quoted in any way
4308                  */
4309                 if ( !qv && s > start && saw_period == 1 ) {
4310                     mult *= 100;
4311                     while ( s < end ) {
4312                         orev = rev;
4313                         rev += (*s - '0') * mult;
4314                         mult /= 10;
4315                         if (   (PERL_ABS(orev) > PERL_ABS(rev)) 
4316                             || (PERL_ABS(rev) > VERSION_MAX )) {
4317                             if(ckWARN(WARN_OVERFLOW))
4318                                 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW), 
4319                                 "Integer overflow in version %d",VERSION_MAX);
4320                             s = end - 1;
4321                             rev = VERSION_MAX;
4322                             vinf = 1;
4323                         }
4324                         s++;
4325                         if ( *s == '_' )
4326                             s++;
4327                     }
4328                 }
4329                 else {
4330                     while (--end >= s) {
4331                         orev = rev;
4332                         rev += (*end - '0') * mult;
4333                         mult *= 10;
4334                         if (   (PERL_ABS(orev) > PERL_ABS(rev)) 
4335                             || (PERL_ABS(rev) > VERSION_MAX )) {
4336                             if(ckWARN(WARN_OVERFLOW))
4337                                 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW), 
4338                                 "Integer overflow in version");
4339                             end = s - 1;
4340                             rev = VERSION_MAX;
4341                             vinf = 1;
4342                         }
4343                     }
4344                 } 
4345             }
4346
4347             /* Append revision */
4348             av_push(av, newSViv(rev));
4349             if ( vinf ) {
4350                 s = last;
4351                 break;
4352             }
4353             else if ( *pos == '.' )
4354                 s = ++pos;
4355             else if ( *pos == '_' && isDIGIT(pos[1]) )
4356                 s = ++pos;
4357             else if ( isDIGIT(*pos) )
4358                 s = pos;
4359             else {
4360                 s = pos;
4361                 break;
4362             }
4363             if ( qv ) {
4364                 while ( isDIGIT(*pos) )
4365                     pos++;
4366             }
4367             else {
4368                 int digits = 0;
4369                 while ( ( isDIGIT(*pos) || *pos == '_' ) && digits < 3 ) {
4370                     if ( *pos != '_' )
4371                         digits++;
4372                     pos++;
4373                 }
4374             }
4375         }
4376     }
4377     if ( qv ) { /* quoted versions always get at least three terms*/
4378         I32 len = av_len(av);
4379         /* This for loop appears to trigger a compiler bug on OS X, as it
4380            loops infinitely. Yes, len is negative. No, it makes no sense.
4381            Compiler in question is:
4382            gcc version 3.3 20030304 (Apple Computer, Inc. build 1640)
4383            for ( len = 2 - len; len > 0; len-- )
4384            av_push(MUTABLE_AV(sv), newSViv(0));
4385         */
4386         len = 2 - len;
4387         while (len-- > 0)
4388             av_push(av, newSViv(0));
4389     }
4390
4391     /* need to save off the current version string for later */
4392     if ( vinf ) {
4393         SV * orig = newSVpvn("v.Inf", sizeof("v.Inf")-1);
4394         (void)hv_stores(MUTABLE_HV(hv), "original", orig);
4395         (void)hv_stores(MUTABLE_HV(hv), "vinf", newSViv(1));
4396     }
4397     else if ( s > start ) {
4398         SV * orig = newSVpvn(start,s-start);
4399         if ( qv && saw_period == 1 && *start != 'v' ) {
4400             /* need to insert a v to be consistent */
4401             sv_insert(orig, 0, 0, "v", 1);
4402         }
4403         (void)hv_stores(MUTABLE_HV(hv), "original", orig);
4404     }
4405     else {
4406         (void)hv_stores(MUTABLE_HV(hv), "original", newSVpvs("0"));
4407         av_push(av, newSViv(0));
4408     }
4409
4410     /* And finally, store the AV in the hash */
4411     (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av)));
4412
4413     /* fix RT#19517 - special case 'undef' as string */
4414     if ( *s == 'u' && strEQ(s,"undef") ) {
4415         s += 5;
4416     }
4417
4418     return s;
4419 }
4420
4421 /*
4422 =for apidoc new_version
4423
4424 Returns a new version object based on the passed in SV:
4425
4426     SV *sv = new_version(SV *ver);
4427
4428 Does not alter the passed in ver SV.  See "upg_version" if you
4429 want to upgrade the SV.
4430
4431 =cut
4432 */
4433
4434 SV *
4435 Perl_new_version(pTHX_ SV *ver)
4436 {
4437     dVAR;
4438     SV * const rv = newSV(0);
4439     PERL_ARGS_ASSERT_NEW_VERSION;
4440     if ( sv_derived_from(ver,"version") ) /* can just copy directly */
4441     {
4442         I32 key;
4443         AV * const av = newAV();
4444         AV *sav;
4445         /* This will get reblessed later if a derived class*/
4446         SV * const hv = newSVrv(rv, "version"); 
4447         (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
4448
4449         if ( SvROK(ver) )
4450             ver = SvRV(ver);
4451
4452         /* Begin copying all of the elements */
4453         if ( hv_exists(MUTABLE_HV(ver), "qv", 2) )
4454             (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(1));
4455
4456         if ( hv_exists(MUTABLE_HV(ver), "alpha", 5) )
4457             (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(1));
4458         
4459         if ( hv_exists(MUTABLE_HV(ver), "width", 5 ) )
4460         {
4461             const I32 width = SvIV(*hv_fetchs(MUTABLE_HV(ver), "width", FALSE));
4462             (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
4463         }
4464
4465         if ( hv_exists(MUTABLE_HV(ver), "original", 8 ) )
4466         {
4467             SV * pv = *hv_fetchs(MUTABLE_HV(ver), "original", FALSE);
4468             (void)hv_stores(MUTABLE_HV(hv), "original", newSVsv(pv));
4469         }
4470
4471         sav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(ver), "version", FALSE)));
4472         /* This will get reblessed later if a derived class*/
4473         for ( key = 0; key <= av_len(sav); key++ )
4474         {
4475             const I32 rev = SvIV(*av_fetch(sav, key, FALSE));
4476             av_push(av, newSViv(rev));
4477         }
4478
4479         (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av)));
4480         return rv;
4481     }
4482 #ifdef SvVOK
4483     {
4484         const MAGIC* const mg = SvVSTRING_mg(ver);
4485         if ( mg ) { /* already a v-string */
4486             const STRLEN len = mg->mg_len;
4487             char * const version = savepvn( (const char*)mg->mg_ptr, len);
4488             sv_setpvn(rv,version,len);
4489             /* this is for consistency with the pure Perl class */
4490             if ( *version != 'v' ) 
4491                 sv_insert(rv, 0, 0, "v", 1);
4492             Safefree(version);
4493         }
4494         else {
4495 #endif
4496         sv_setsv(rv,ver); /* make a duplicate */
4497 #ifdef SvVOK
4498         }
4499     }
4500 #endif
4501     return upg_version(rv, FALSE);
4502 }
4503
4504 /*
4505 =for apidoc upg_version
4506
4507 In-place upgrade of the supplied SV to a version object.
4508
4509     SV *sv = upg_version(SV *sv, bool qv);
4510
4511 Returns a pointer to the upgraded SV.  Set the boolean qv if you want
4512 to force this SV to be interpreted as an "extended" version.
4513
4514 =cut
4515 */
4516
4517 SV *
4518 Perl_upg_version(pTHX_ SV *ver, bool qv)
4519 {
4520     const char *version, *s;
4521 #ifdef SvVOK
4522     const MAGIC *mg;
4523 #endif
4524
4525     PERL_ARGS_ASSERT_UPG_VERSION;
4526
4527     if ( SvNOK(ver) && !( SvPOK(ver) && sv_len(ver) == 3 ) )
4528     {
4529         /* may get too much accuracy */ 
4530         char tbuf[64];
4531 #ifdef USE_LOCALE_NUMERIC
4532         char *loc = setlocale(LC_NUMERIC, "C");
4533 #endif
4534         STRLEN len = my_snprintf(tbuf, sizeof(tbuf), "%.9"NVff, SvNVX(ver));
4535 #ifdef USE_LOCALE_NUMERIC
4536         setlocale(LC_NUMERIC, loc);
4537 #endif
4538         while (tbuf[len-1] == '0' && len > 0) len--;
4539         if ( tbuf[len-1] == '.' ) len--; /* eat the trailing decimal */
4540         version = savepvn(tbuf, len);
4541     }
4542 #ifdef SvVOK
4543     else if ( (mg = SvVSTRING_mg(ver)) ) { /* already a v-string */
4544         version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
4545         qv = 1;
4546     }
4547 #endif
4548     else /* must be a string or something like a string */
4549     {
4550         STRLEN len;
4551         version = savepv(SvPV(ver,len));
4552 #ifndef SvVOK
4553 #  if PERL_VERSION > 5
4554         /* This will only be executed for 5.6.0 - 5.8.0 inclusive */
4555         if ( len == 3 && !instr(version,".") && !instr(version,"_") ) {
4556             /* may be a v-string */
4557             SV * const nsv = sv_newmortal();
4558             const char *nver;
4559             const char *pos;
4560             int saw_period = 0;
4561             sv_setpvf(nsv,"v%vd",ver);
4562             pos = nver = savepv(SvPV_nolen(nsv));
4563
4564             /* scan the resulting formatted string */
4565             pos++; /* skip the leading 'v' */
4566             while ( *pos == '.' || isDIGIT(*pos) ) {
4567                 if ( *pos == '.' )
4568                     saw_period++ ;
4569                 pos++;
4570             }
4571
4572             /* is definitely a v-string */
4573             if ( saw_period == 2 ) {    
4574                 Safefree(version);
4575                 version = nver;
4576             }
4577         }
4578 #  endif
4579 #endif
4580     }
4581
4582     s = scan_version(version, ver, qv);
4583     if ( *s != '\0' ) 
4584         if(ckWARN(WARN_MISC))
4585             Perl_warner(aTHX_ packWARN(WARN_MISC), 
4586                 "Version string '%s' contains invalid data; "
4587                 "ignoring: '%s'", version, s);
4588     Safefree(version);
4589     return ver;
4590 }
4591
4592 /*
4593 =for apidoc vverify
4594
4595 Validates that the SV contains a valid version object.
4596
4597     bool vverify(SV *vobj);
4598
4599 Note that it only confirms the bare minimum structure (so as not to get
4600 confused by derived classes which may contain additional hash entries):
4601
4602 =over 4
4603
4604 =item * The SV contains a [reference to a] hash
4605
4606 =item * The hash contains a "version" key
4607
4608 =item * The "version" key has [a reference to] an AV as its value
4609
4610 =back
4611
4612 =cut
4613 */
4614
4615 bool
4616 Perl_vverify(pTHX_ SV *vs)
4617 {
4618     SV *sv;
4619
4620     PERL_ARGS_ASSERT_VVERIFY;
4621
4622     if ( SvROK(vs) )
4623         vs = SvRV(vs);
4624
4625     /* see if the appropriate elements exist */
4626     if ( SvTYPE(vs) == SVt_PVHV
4627          && hv_exists(MUTABLE_HV(vs), "version", 7)
4628          && (sv = SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)))
4629          && SvTYPE(sv) == SVt_PVAV )
4630         return TRUE;
4631     else
4632         return FALSE;
4633 }
4634
4635 /*
4636 =for apidoc vnumify
4637
4638 Accepts a version object and returns the normalized floating
4639 point representation.  Call like:
4640
4641     sv = vnumify(rv);
4642
4643 NOTE: you can pass either the object directly or the SV
4644 contained within the RV.
4645
4646 =cut
4647 */
4648
4649 SV *
4650 Perl_vnumify(pTHX_ SV *vs)
4651 {
4652     I32 i, len, digit;
4653     int width;
4654     bool alpha = FALSE;
4655     SV * const sv = newSV(0);
4656     AV *av;
4657
4658     PERL_ARGS_ASSERT_VNUMIFY;
4659
4660     if ( SvROK(vs) )
4661         vs = SvRV(vs);
4662
4663     if ( !vverify(vs) )
4664         Perl_croak(aTHX_ "Invalid version object");
4665
4666     /* see if various flags exist */
4667     if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
4668         alpha = TRUE;
4669     if ( hv_exists(MUTABLE_HV(vs), "width", 5 ) )
4670         width = SvIV(*hv_fetchs(MUTABLE_HV(vs), "width", FALSE));
4671     else
4672         width = 3;
4673
4674
4675     /* attempt to retrieve the version array */
4676     if ( !(av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE))) ) ) {
4677         sv_catpvs(sv,"0");
4678         return sv;
4679     }
4680
4681     len = av_len(av);
4682     if ( len == -1 )
4683     {
4684         sv_catpvs(sv,"0");
4685         return sv;
4686     }
4687
4688     digit = SvIV(*av_fetch(av, 0, 0));
4689     Perl_sv_setpvf(aTHX_ sv, "%d.", (int)PERL_ABS(digit));
4690     for ( i = 1 ; i < len ; i++ )
4691     {
4692         digit = SvIV(*av_fetch(av, i, 0));
4693         if ( width < 3 ) {
4694             const int denom = (width == 2 ? 10 : 100);
4695             const div_t term = div((int)PERL_ABS(digit),denom);
4696             Perl_sv_catpvf(aTHX_ sv, "%0*d_%d", width, term.quot, term.rem);
4697         }
4698         else {
4699             Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
4700         }
4701     }
4702
4703     if ( len > 0 )
4704     {
4705         digit = SvIV(*av_fetch(av, len, 0));
4706         if ( alpha && width == 3 ) /* alpha version */
4707             sv_catpvs(sv,"_");
4708         Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
4709     }
4710     else /* len == 0 */
4711     {
4712         sv_catpvs(sv, "000");
4713     }
4714     return sv;
4715 }
4716
4717 /*
4718 =for apidoc vnormal
4719
4720 Accepts a version object and returns the normalized string
4721 representation.  Call like:
4722
4723     sv = vnormal(rv);
4724
4725 NOTE: you can pass either the object directly or the SV
4726 contained within the RV.
4727
4728 =cut
4729 */
4730
4731 SV *
4732 Perl_vnormal(pTHX_ SV *vs)
4733 {
4734     I32 i, len, digit;
4735     bool alpha = FALSE;
4736     SV * const sv = newSV(0);
4737     AV *av;
4738
4739     PERL_ARGS_ASSERT_VNORMAL;
4740
4741     if ( SvROK(vs) )
4742         vs = SvRV(vs);
4743
4744     if ( !vverify(vs) )
4745         Perl_croak(aTHX_ "Invalid version object");
4746
4747     if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
4748         alpha = TRUE;
4749     av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)));
4750
4751     len = av_len(av);
4752     if ( len == -1 )
4753     {
4754         sv_catpvs(sv,"");
4755         return sv;
4756     }
4757     digit = SvIV(*av_fetch(av, 0, 0));
4758     Perl_sv_setpvf(aTHX_ sv, "v%"IVdf, (IV)digit);
4759     for ( i = 1 ; i < len ; i++ ) {
4760         digit = SvIV(*av_fetch(av, i, 0));
4761         Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
4762     }
4763
4764     if ( len > 0 )
4765     {
4766         /* handle last digit specially */
4767         digit = SvIV(*av_fetch(av, len, 0));
4768         if ( alpha )
4769             Perl_sv_catpvf(aTHX_ sv, "_%"IVdf, (IV)digit);
4770         else
4771             Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
4772     }
4773
4774     if ( len <= 2 ) { /* short version, must be at least three */
4775         for ( len = 2 - len; len != 0; len-- )
4776             sv_catpvs(sv,".0");
4777     }
4778     return sv;
4779 }
4780
4781 /*
4782 =for apidoc vstringify
4783
4784 In order to maintain maximum compatibility with earlier versions
4785 of Perl, this function will return either the floating point
4786 notation or the multiple dotted notation, depending on whether
4787 the original version contained 1 or more dots, respectively
4788
4789 =cut
4790 */
4791
4792 SV *
4793 Perl_vstringify(pTHX_ SV *vs)
4794 {
4795     PERL_ARGS_ASSERT_VSTRINGIFY;
4796
4797     if ( SvROK(vs) )
4798         vs = SvRV(vs);
4799
4800     if ( !vverify(vs) )
4801         Perl_croak(aTHX_ "Invalid version object");
4802
4803     if (hv_exists(MUTABLE_HV(vs), "original",  sizeof("original") - 1)) {
4804         SV *pv;
4805         pv = *hv_fetchs(MUTABLE_HV(vs), "original", FALSE);
4806         if ( SvPOK(pv) )
4807             return newSVsv(pv);
4808         else
4809             return &PL_sv_undef;
4810     }
4811     else {
4812         if ( hv_exists(MUTABLE_HV(vs), "qv", 2) )
4813             return vnormal(vs);
4814         else
4815             return vnumify(vs);
4816     }
4817 }
4818
4819 /*
4820 =for apidoc vcmp
4821
4822 Version object aware cmp.  Both operands must already have been 
4823 converted into version objects.
4824
4825 =cut
4826 */
4827
4828 int
4829 Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
4830 {
4831     I32 i,l,m,r,retval;
4832     bool lalpha = FALSE;
4833     bool ralpha = FALSE;
4834     I32 left = 0;
4835     I32 right = 0;
4836     AV *lav, *rav;
4837
4838     PERL_ARGS_ASSERT_VCMP;
4839
4840     if ( SvROK(lhv) )
4841         lhv = SvRV(lhv);
4842     if ( SvROK(rhv) )
4843         rhv = SvRV(rhv);
4844
4845     if ( !vverify(lhv) )
4846         Perl_croak(aTHX_ "Invalid version object");
4847
4848     if ( !vverify(rhv) )
4849         Perl_croak(aTHX_ "Invalid version object");
4850
4851     /* get the left hand term */
4852     lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(lhv), "version", FALSE)));
4853     if ( hv_exists(MUTABLE_HV(lhv), "alpha", 5 ) )
4854         lalpha = TRUE;
4855
4856     /* and the right hand term */
4857     rav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(rhv), "version", FALSE)));
4858     if ( hv_exists(MUTABLE_HV(rhv), "alpha", 5 ) )
4859         ralpha = TRUE;
4860
4861     l = av_len(lav);
4862     r = av_len(rav);
4863     m = l < r ? l : r;
4864     retval = 0;
4865     i = 0;
4866     while ( i <= m && retval == 0 )
4867     {
4868         left  = SvIV(*av_fetch(lav,i,0));
4869         right = SvIV(*av_fetch(rav,i,0));
4870         if ( left < right  )
4871             retval = -1;
4872         if ( left > right )
4873             retval = +1;
4874         i++;
4875     }
4876
4877     /* tiebreaker for alpha with identical terms */
4878     if ( retval == 0 && l == r && left == right && ( lalpha || ralpha ) )
4879     {
4880         if ( lalpha && !ralpha )
4881         {
4882             retval = -1;
4883         }
4884         else if ( ralpha && !lalpha)
4885         {
4886             retval = +1;
4887         }
4888     }
4889
4890     if ( l != r && retval == 0 ) /* possible match except for trailing 0's */
4891     {
4892         if ( l < r )
4893         {
4894             while ( i <= r && retval == 0 )
4895             {
4896                 if ( SvIV(*av_fetch(rav,i,0)) != 0 )
4897                     retval = -1; /* not a match after all */
4898                 i++;
4899             }
4900         }
4901         else
4902         {
4903             while ( i <= l && retval == 0 )
4904             {
4905                 if ( SvIV(*av_fetch(lav,i,0)) != 0 )
4906                     retval = +1; /* not a match after all */
4907                 i++;
4908             }
4909         }
4910     }
4911     return retval;
4912 }
4913
4914 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT)
4915 #   define EMULATE_SOCKETPAIR_UDP
4916 #endif
4917
4918 #ifdef EMULATE_SOCKETPAIR_UDP
4919 static int
4920 S_socketpair_udp (int fd[2]) {
4921     dTHX;
4922     /* Fake a datagram socketpair using UDP to localhost.  */
4923     int sockets[2] = {-1, -1};
4924     struct sockaddr_in addresses[2];
4925     int i;
4926     Sock_size_t size = sizeof(struct sockaddr_in);
4927     unsigned short port;
4928     int got;
4929
4930     memset(&addresses, 0, sizeof(addresses));
4931     i = 1;
4932     do {
4933         sockets[i] = PerlSock_socket(AF_INET, SOCK_DGRAM, PF_INET);
4934         if (sockets[i] == -1)
4935             goto tidy_up_and_fail;
4936
4937         addresses[i].sin_family = AF_INET;
4938         addresses[i].sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4939         addresses[i].sin_port = 0;      /* kernel choses port.  */
4940         if (PerlSock_bind(sockets[i], (struct sockaddr *) &addresses[i],
4941                 sizeof(struct sockaddr_in)) == -1)
4942             goto tidy_up_and_fail;
4943     } while (i--);
4944
4945     /* Now have 2 UDP sockets. Find out which port each is connected to, and
4946        for each connect the other socket to it.  */
4947     i = 1;
4948     do {
4949         if (PerlSock_getsockname(sockets[i], (struct sockaddr *) &addresses[i],
4950                 &size) == -1)
4951             goto tidy_up_and_fail;
4952         if (size != sizeof(struct sockaddr_in))
4953             goto abort_tidy_up_and_fail;
4954         /* !1 is 0, !0 is 1 */
4955         if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i],
4956                 sizeof(struct sockaddr_in)) == -1)
4957             goto tidy_up_and_fail;
4958     } while (i--);
4959
4960     /* Now we have 2 sockets connected to each other. I don't trust some other
4961        process not to have already sent a packet to us (by random) so send
4962        a packet from each to the other.  */
4963     i = 1;
4964     do {
4965         /* I'm going to send my own port number.  As a short.
4966            (Who knows if someone somewhere has sin_port as a bitfield and needs
4967            this routine. (I'm assuming crays have socketpair)) */
4968         port = addresses[i].sin_port;
4969         got = PerlLIO_write(sockets[i], &port, sizeof(port));
4970         if (got != sizeof(port)) {
4971             if (got == -1)
4972                 goto tidy_up_and_fail;
4973             goto abort_tidy_up_and_fail;
4974         }
4975     } while (i--);
4976
4977     /* Packets sent. I don't trust them to have arrived though.
4978        (As I understand it Solaris TCP stack is multithreaded. Non-blocking
4979        connect to localhost will use a second kernel thread. In 2.6 the
4980        first thread running the connect() returns before the second completes,
4981        so EINPROGRESS> In 2.7 the improved stack is faster and connect()
4982        returns 0. Poor programs have tripped up. One poor program's authors'
4983        had a 50-1 reverse stock split. Not sure how connected these were.)
4984        So I don't trust someone not to have an unpredictable UDP stack.
4985     */
4986
4987     {
4988         struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */
4989         int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0];
4990         fd_set rset;
4991
4992         FD_ZERO(&rset);
4993         FD_SET((unsigned int)sockets[0], &rset);
4994         FD_SET((unsigned int)sockets[1], &rset);
4995
4996         got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor);
4997         if (got != 2 || !FD_ISSET(sockets[0], &rset)
4998                 || !FD_ISSET(sockets[1], &rset)) {
4999             /* I hope this is portable and appropriate.  */
5000             if (got == -1)
5001                 goto tidy_up_and_fail;
5002             goto abort_tidy_up_and_fail;
5003         }
5004     }
5005
5006     /* And the paranoia department even now doesn't trust it to have arrive
5007        (hence MSG_DONTWAIT). Or that what arrives was sent by us.  */
5008     {
5009         struct sockaddr_in readfrom;
5010         unsigned short buffer[2];
5011
5012         i = 1;
5013         do {
5014 #ifdef MSG_DONTWAIT
5015             got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
5016                     sizeof(buffer), MSG_DONTWAIT,
5017                     (struct sockaddr *) &readfrom, &size);
5018 #else
5019             got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
5020                     sizeof(buffer), 0,
5021                     (struct sockaddr *) &readfrom, &size);
5022 #endif
5023
5024             if (got == -1)
5025                 goto tidy_up_and_fail;
5026             if (got != sizeof(port)
5027                     || size != sizeof(struct sockaddr_in)
5028                     /* Check other socket sent us its port.  */
5029                     || buffer[0] != (unsigned short) addresses[!i].sin_port
5030                     /* Check kernel says we got the datagram from that socket */
5031                     || readfrom.sin_family != addresses[!i].sin_family
5032                     || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr
5033                     || readfrom.sin_port != addresses[!i].sin_port)
5034                 goto abort_tidy_up_and_fail;
5035         } while (i--);
5036     }
5037     /* My caller (my_socketpair) has validated that this is non-NULL  */
5038     fd[0] = sockets[0];
5039     fd[1] = sockets[1];
5040     /* I hereby declare this connection open.  May God bless all who cross
5041        her.  */
5042     return 0;
5043
5044   abort_tidy_up_and_fail:
5045     errno = ECONNABORTED;
5046   tidy_up_and_fail:
5047     {
5048         dSAVE_ERRNO;
5049         if (sockets[0] != -1)
5050             PerlLIO_close(sockets[0]);
5051         if (sockets[1] != -1)
5052             PerlLIO_close(sockets[1]);
5053         RESTORE_ERRNO;
5054         return -1;
5055     }
5056 }
5057 #endif /*  EMULATE_SOCKETPAIR_UDP */
5058
5059 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET)
5060 int
5061 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
5062