File Coverage

util.c
Criterion Covered Total %
statement 37 60 61.7
branch 0 40 0.0
condition n/a
subroutine n/a
total 37 100 37.0


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