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