3 * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
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.
12 * "Very useful, no doubt, that was to Saruman; yet it seems that he was
13 * not content." --Gandalf
16 /* This file contains assorted utility routines.
17 * Which is a polite way of saying any stuff that people couldn't think of
18 * a better place for. Amongst other things, it includes the warning and
19 * dieing stuff, plus wrappers for malloc code.
23 #define PERL_IN_UTIL_C
29 # define SIG_ERR ((Sighandler_t) -1)
34 /* Missing protos on LynxOS */
39 # include <sys/wait.h>
44 # include <sys/select.h>
50 #if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC)
51 # define FD_CLOEXEC 1 /* NeXT needs this */
54 /* NOTE: Do not call the next three routines directly. Use the macros
55 * in handy.h, so that we can easily redefine everything to do tracking of
56 * allocated hunks back to the original New to track down any memory leaks.
57 * XXX This advice seems to be widely ignored :-( --AD August 1996.
64 /* Can't use PerlIO to write as it allocates memory */
65 PerlLIO_write(PerlIO_fileno(Perl_error_log),
66 PL_no_mem, strlen(PL_no_mem));
68 NORETURN_FUNCTION_END;
71 /* paranoid version of system's malloc() */
74 Perl_safesysmalloc(MEM_SIZE size)
80 PerlIO_printf(Perl_error_log,
81 "Allocation too large: %lx\n", size) FLUSH;
84 #endif /* HAS_64K_LIMIT */
85 #ifdef PERL_TRACK_MEMPOOL
90 Perl_croak_nocontext("panic: malloc");
92 ptr = (Malloc_t)PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */
93 PERL_ALLOC_CHECK(ptr);
94 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
96 #ifdef PERL_TRACK_MEMPOOL
97 struct perl_memory_debug_header *const header
98 = (struct perl_memory_debug_header *)ptr;
102 PoisonNew(((char *)ptr), size, char);
105 #ifdef PERL_TRACK_MEMPOOL
106 header->interpreter = aTHX;
107 /* Link us into the list. */
108 header->prev = &PL_memory_debug_header;
109 header->next = PL_memory_debug_header.next;
110 PL_memory_debug_header.next = header;
111 header->next->prev = header;
115 ptr = (Malloc_t)((char*)ptr+sTHX);
122 return write_no_mem();
127 /* paranoid version of system's realloc() */
130 Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
134 #if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) && !defined(PERL_MICRO)
135 Malloc_t PerlMem_realloc();
136 #endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */
140 PerlIO_printf(Perl_error_log,
141 "Reallocation too large: %lx\n", size) FLUSH;
144 #endif /* HAS_64K_LIMIT */
151 return safesysmalloc(size);
152 #ifdef PERL_TRACK_MEMPOOL
153 where = (Malloc_t)((char*)where-sTHX);
156 struct perl_memory_debug_header *const header
157 = (struct perl_memory_debug_header *)where;
159 if (header->interpreter != aTHX) {
160 Perl_croak_nocontext("panic: realloc from wrong pool");
162 assert(header->next->prev == header);
163 assert(header->prev->next == header);
165 if (header->size > size) {
166 const MEM_SIZE freed_up = header->size - size;
167 char *start_of_freed = ((char *)where) + size;
168 PoisonFree(start_of_freed, freed_up, char);
176 Perl_croak_nocontext("panic: realloc");
178 ptr = (Malloc_t)PerlMem_realloc(where,size);
179 PERL_ALLOC_CHECK(ptr);
181 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++));
182 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
185 #ifdef PERL_TRACK_MEMPOOL
186 struct perl_memory_debug_header *const header
187 = (struct perl_memory_debug_header *)ptr;
190 if (header->size < size) {
191 const MEM_SIZE fresh = size - header->size;
192 char *start_of_fresh = ((char *)ptr) + size;
193 PoisonNew(start_of_fresh, fresh, char);
197 header->next->prev = header;
198 header->prev->next = header;
200 ptr = (Malloc_t)((char*)ptr+sTHX);
207 return write_no_mem();
212 /* safe version of system's free() */
215 Perl_safesysfree(Malloc_t where)
217 #if defined(PERL_IMPLICIT_SYS) || defined(PERL_TRACK_MEMPOOL)
222 DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) free\n",PTR2UV(where),(long)PL_an++));
224 #ifdef PERL_TRACK_MEMPOOL
225 where = (Malloc_t)((char*)where-sTHX);
227 struct perl_memory_debug_header *const header
228 = (struct perl_memory_debug_header *)where;
230 if (header->interpreter != aTHX) {
231 Perl_croak_nocontext("panic: free from wrong pool");
234 Perl_croak_nocontext("panic: duplicate free");
236 if (!(header->next) || header->next->prev != header
237 || header->prev->next != header) {
238 Perl_croak_nocontext("panic: bad free");
240 /* Unlink us from the chain. */
241 header->next->prev = header->prev;
242 header->prev->next = header->next;
244 PoisonNew(where, header->size, char);
246 /* Trigger the duplicate free warning. */
254 /* safe version of system's calloc() */
257 Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
263 if (size * count > 0xffff) {
264 PerlIO_printf(Perl_error_log,
265 "Allocation too large: %lx\n", size * count) FLUSH;
268 #endif /* HAS_64K_LIMIT */
270 if ((long)size < 0 || (long)count < 0)
271 Perl_croak_nocontext("panic: calloc");
274 #ifdef PERL_TRACK_MEMPOOL
277 ptr = (Malloc_t)PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */
278 PERL_ALLOC_CHECK(ptr);
279 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) calloc %ld x %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)count,(long)size));
281 memset((void*)ptr, 0, size);
282 #ifdef PERL_TRACK_MEMPOOL
284 struct perl_memory_debug_header *const header
285 = (struct perl_memory_debug_header *)ptr;
287 header->interpreter = aTHX;
288 /* Link us into the list. */
289 header->prev = &PL_memory_debug_header;
290 header->next = PL_memory_debug_header.next;
291 PL_memory_debug_header.next = header;
292 header->next->prev = header;
296 ptr = (Malloc_t)((char*)ptr+sTHX);
303 return write_no_mem();
306 /* These must be defined when not using Perl's malloc for binary
311 Malloc_t Perl_malloc (MEM_SIZE nbytes)
314 return (Malloc_t)PerlMem_malloc(nbytes);
317 Malloc_t Perl_calloc (MEM_SIZE elements, MEM_SIZE size)
320 return (Malloc_t)PerlMem_calloc(elements, size);
323 Malloc_t Perl_realloc (Malloc_t where, MEM_SIZE nbytes)
326 return (Malloc_t)PerlMem_realloc(where, nbytes);
329 Free_t Perl_mfree (Malloc_t where)
337 /* copy a string up to some (non-backslashed) delimiter, if any */
340 Perl_delimcpy(pTHX_ register char *to, register const char *toend, register const char *from, register const char *fromend, register int delim, I32 *retlen)
344 for (tolen = 0; from < fromend; from++, tolen++) {
346 if (from[1] == delim)
355 else if (*from == delim)
366 /* return ptr to little string in big string, NULL if not found */
367 /* This routine was donated by Corey Satten. */
370 Perl_instr(pTHX_ register const char *big, register const char *little)
381 register const char *s, *x;
384 for (x=big,s=little; *s; /**/ ) {
395 return (char*)(big-1);
400 /* same as instr but allow embedded nulls */
403 Perl_ninstr(pTHX_ const char *big, const char *bigend, const char *little, const char *lend)
409 char first = *little++;
411 bigend -= lend - little;
413 while (big <= bigend) {
416 for (x=big,s=little; s < lend; x++,s++) {
420 return (char*)(big-1);
426 /* reverse of the above--find last substring */
429 Perl_rninstr(pTHX_ register const char *big, const char *bigend, const char *little, const char *lend)
431 register const char *bigbeg;
432 register const I32 first = *little;
433 register const char * const littleend = lend;
436 if (little >= littleend)
437 return (char*)bigend;
439 big = bigend - (littleend - little++);
440 while (big >= bigbeg) {
441 register const char *s, *x;
444 for (x=big+2,s=little; s < littleend; /**/ ) {
453 return (char*)(big+1);
458 #define FBM_TABLE_OFFSET 2 /* Number of bytes between EOS and table*/
460 /* As a space optimization, we do not compile tables for strings of length
461 0 and 1, and for strings of length 2 unless FBMcf_TAIL. These are
462 special-cased in fbm_instr().
464 If FBMcf_TAIL, the table is created as if the string has a trailing \n. */
467 =head1 Miscellaneous Functions
469 =for apidoc fbm_compile
471 Analyses the string in order to make fast searches on it using fbm_instr()
472 -- the Boyer-Moore algorithm.
478 Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
481 register const U8 *s;
487 if (flags & FBMcf_TAIL) {
488 MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
489 sv_catpvs(sv, "\n"); /* Taken into account in fbm_instr() */
490 if (mg && mg->mg_len >= 0)
493 s = (U8*)SvPV_force_mutable(sv, len);
494 SvUPGRADE(sv, SVt_PVBM);
495 if (len == 0) /* TAIL might be on a zero-length string. */
498 const unsigned char *sb;
499 const U8 mlen = (len>255) ? 255 : (U8)len;
502 Sv_Grow(sv, len + 256 + FBM_TABLE_OFFSET);
503 table = (unsigned char*)(SvPVX_mutable(sv) + len + FBM_TABLE_OFFSET);
504 s = table - 1 - FBM_TABLE_OFFSET; /* last char */
505 memset((void*)table, mlen, 256);
506 table[-1] = (U8)flags;
508 sb = s - mlen + 1; /* first char (maybe) */
510 if (table[*s] == mlen)
515 sv_magic(sv, NULL, PERL_MAGIC_bm, NULL, 0); /* deep magic */
518 s = (const unsigned char*)(SvPVX_const(sv)); /* deeper magic */
519 for (i = 0; i < len; i++) {
520 if (PL_freq[s[i]] < frequency) {
522 frequency = PL_freq[s[i]];
525 BmRARE(sv) = s[rarest];
526 BmPREVIOUS(sv) = (U16)rarest;
527 BmUSEFUL(sv) = 100; /* Initial value */
528 if (flags & FBMcf_TAIL)
530 DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %d\n",
531 BmRARE(sv),BmPREVIOUS(sv)));
534 /* If SvTAIL(littlestr), it has a fake '\n' at end. */
535 /* If SvTAIL is actually due to \Z or \z, this gives false positives
539 =for apidoc fbm_instr
541 Returns the location of the SV in the string delimited by C<str> and
542 C<strend>. It returns C<NULL> if the string can't be found. The C<sv>
543 does not have to be fbm_compiled, but the search will not be as fast
550 Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *littlestr, U32 flags)
552 register unsigned char *s;
554 register const unsigned char *little
555 = (const unsigned char *)SvPV_const(littlestr,l);
556 register STRLEN littlelen = l;
557 register const I32 multiline = flags & FBMrf_MULTILINE;
559 if ((STRLEN)(bigend - big) < littlelen) {
560 if ( SvTAIL(littlestr)
561 && ((STRLEN)(bigend - big) == littlelen - 1)
563 || (*big == *little &&
564 memEQ((char *)big, (char *)little, littlelen - 1))))
569 if (littlelen <= 2) { /* Special-cased */
571 if (littlelen == 1) {
572 if (SvTAIL(littlestr) && !multiline) { /* Anchor only! */
573 /* Know that bigend != big. */
574 if (bigend[-1] == '\n')
575 return (char *)(bigend - 1);
576 return (char *) bigend;
584 if (SvTAIL(littlestr))
585 return (char *) bigend;
589 return (char*)big; /* Cannot be SvTAIL! */
592 if (SvTAIL(littlestr) && !multiline) {
593 if (bigend[-1] == '\n' && bigend[-2] == *little)
594 return (char*)bigend - 2;
595 if (bigend[-1] == *little)
596 return (char*)bigend - 1;
600 /* This should be better than FBM if c1 == c2, and almost
601 as good otherwise: maybe better since we do less indirection.
602 And we save a lot of memory by caching no table. */
603 const unsigned char c1 = little[0];
604 const unsigned char c2 = little[1];
609 while (s <= bigend) {
619 goto check_1char_anchor;
630 goto check_1char_anchor;
633 while (s <= bigend) {
638 goto check_1char_anchor;
647 check_1char_anchor: /* One char and anchor! */
648 if (SvTAIL(littlestr) && (*bigend == *little))
649 return (char *)bigend; /* bigend is already decremented. */
652 if (SvTAIL(littlestr) && !multiline) { /* tail anchored? */
653 s = bigend - littlelen;
654 if (s >= big && bigend[-1] == '\n' && *s == *little
655 /* Automatically of length > 2 */
656 && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
658 return (char*)s; /* how sweet it is */
661 && memEQ((char*)s + 2, (char*)little + 1, littlelen - 2))
663 return (char*)s + 1; /* how sweet it is */
667 if (SvTYPE(littlestr) != SVt_PVBM || !SvVALID(littlestr)) {
668 char * const b = ninstr((char*)big,(char*)bigend,
669 (char*)little, (char*)little + littlelen);
671 if (!b && SvTAIL(littlestr)) { /* Automatically multiline! */
672 /* Chop \n from littlestr: */
673 s = bigend - littlelen + 1;
675 && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
684 { /* Do actual FBM. */
685 register const unsigned char * const table = little + littlelen + FBM_TABLE_OFFSET;
686 register const unsigned char *oldlittle;
688 if (littlelen > (STRLEN)(bigend - big))
690 --littlelen; /* Last char found by table lookup */
693 little += littlelen; /* last char */
699 if ((tmp = table[*s])) {
700 if ((s += tmp) < bigend)
704 else { /* less expensive than calling strncmp() */
705 register unsigned char * const olds = s;
710 if (*--s == *--little)
712 s = olds + 1; /* here we pay the price for failure */
714 if (s < bigend) /* fake up continue to outer loop */
722 if ( s == bigend && (table[-1] & FBMcf_TAIL)
723 && memEQ((char *)(bigend - littlelen),
724 (char *)(oldlittle - littlelen), littlelen) )
725 return (char*)bigend - littlelen;
730 /* start_shift, end_shift are positive quantities which give offsets
731 of ends of some substring of bigstr.
732 If "last" we want the last occurrence.
733 old_posp is the way of communication between consequent calls if
734 the next call needs to find the .
735 The initial *old_posp should be -1.
737 Note that we take into account SvTAIL, so one can get extra
738 optimizations if _ALL flag is set.
741 /* If SvTAIL is actually due to \Z or \z, this gives false positives
742 if PL_multiline. In fact if !PL_multiline the authoritative answer
743 is not supported yet. */
746 Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last)
749 register const unsigned char *big;
751 register I32 previous;
753 register const unsigned char *little;
754 register I32 stop_pos;
755 register const unsigned char *littleend;
759 ? (pos = PL_screamfirst[BmRARE(littlestr)]) < 0
760 : (((pos = *old_posp), pos += PL_screamnext[pos]) == 0)) {
762 if ( BmRARE(littlestr) == '\n'
763 && BmPREVIOUS(littlestr) == SvCUR(littlestr) - 1) {
764 little = (const unsigned char *)(SvPVX_const(littlestr));
765 littleend = little + SvCUR(littlestr);
772 little = (const unsigned char *)(SvPVX_const(littlestr));
773 littleend = little + SvCUR(littlestr);
775 /* The value of pos we can start at: */
776 previous = BmPREVIOUS(littlestr);
777 big = (const unsigned char *)(SvPVX_const(bigstr));
778 /* The value of pos we can stop at: */
779 stop_pos = SvCUR(bigstr) - end_shift - (SvCUR(littlestr) - 1 - previous);
780 if (previous + start_shift > stop_pos) {
782 stop_pos does not include SvTAIL in the count, so this check is incorrect
783 (I think) - see [ID 20010618.006] and t/op/study.t. HVDS 2001/06/19
786 if (previous + start_shift == stop_pos + 1) /* A fake '\n'? */
791 while (pos < previous + start_shift) {
792 if (!(pos += PL_screamnext[pos]))
797 register const unsigned char *s, *x;
798 if (pos >= stop_pos) break;
799 if (big[pos] != first)
801 for (x=big+pos+1,s=little; s < littleend; /**/ ) {
807 if (s == littleend) {
809 if (!last) return (char *)(big+pos);
812 } while ( pos += PL_screamnext[pos] );
814 return (char *)(big+(*old_posp));
816 if (!SvTAIL(littlestr) || (end_shift > 0))
818 /* Ignore the trailing "\n". This code is not microoptimized */
819 big = (const unsigned char *)(SvPVX_const(bigstr) + SvCUR(bigstr));
820 stop_pos = littleend - little; /* Actual littlestr len */
825 && ((stop_pos == 1) ||
826 memEQ((char *)(big + 1), (char *)little, stop_pos - 1)))
832 Perl_ibcmp(pTHX_ const char *s1, const char *s2, register I32 len)
834 register const U8 *a = (const U8 *)s1;
835 register const U8 *b = (const U8 *)s2;
839 if (*a != *b && *a != PL_fold[*b])
847 Perl_ibcmp_locale(pTHX_ const char *s1, const char *s2, register I32 len)
850 register const U8 *a = (const U8 *)s1;
851 register const U8 *b = (const U8 *)s2;
855 if (*a != *b && *a != PL_fold_locale[*b])
862 /* copy a string to a safe spot */
865 =head1 Memory Management
869 Perl's version of C<strdup()>. Returns a pointer to a newly allocated
870 string which is a duplicate of C<pv>. The size of the string is
871 determined by C<strlen()>. The memory allocated for the new string can
872 be freed with the C<Safefree()> function.
878 Perl_savepv(pTHX_ const char *pv)
885 const STRLEN pvlen = strlen(pv)+1;
886 Newx(newaddr,pvlen,char);
887 return memcpy(newaddr,pv,pvlen);
891 /* same thing but with a known length */
896 Perl's version of what C<strndup()> would be if it existed. Returns a
897 pointer to a newly allocated string which is a duplicate of the first
898 C<len> bytes from C<pv>. The memory allocated for the new string can be
899 freed with the C<Safefree()> function.
905 Perl_savepvn(pTHX_ const char *pv, register I32 len)
907 register char *newaddr;
910 Newx(newaddr,len+1,char);
911 /* Give a meaning to NULL pointer mainly for the use in sv_magic() */
913 /* might not be null terminated */
915 return (char *) CopyD(pv,newaddr,len,char);
918 return (char *) ZeroD(newaddr,len+1,char);
923 =for apidoc savesharedpv
925 A version of C<savepv()> which allocates the duplicate string in memory
926 which is shared between threads.
931 Perl_savesharedpv(pTHX_ const char *pv)
933 register char *newaddr;
938 pvlen = strlen(pv)+1;
939 newaddr = (char*)PerlMemShared_malloc(pvlen);
941 return write_no_mem();
943 return memcpy(newaddr,pv,pvlen);
949 A version of C<savepv()>/C<savepvn()> which gets the string to duplicate from
950 the passed in SV using C<SvPV()>
956 Perl_savesvpv(pTHX_ SV *sv)
959 const char * const pv = SvPV_const(sv, len);
960 register char *newaddr;
963 Newx(newaddr,len,char);
964 return (char *) CopyD(pv,newaddr,len,char);
968 /* the SV for Perl_form() and mess() is not kept in an arena */
978 return sv_2mortal(newSVpvs(""));
983 /* Create as PVMG now, to avoid any upgrading later */
985 Newxz(any, 1, XPVMG);
986 SvFLAGS(sv) = SVt_PVMG;
987 SvANY(sv) = (void*)any;
989 SvREFCNT(sv) = 1 << 30; /* practically infinite */
994 #if defined(PERL_IMPLICIT_CONTEXT)
996 Perl_form_nocontext(const char* pat, ...)
1001 va_start(args, pat);
1002 retval = vform(pat, &args);
1006 #endif /* PERL_IMPLICIT_CONTEXT */
1009 =head1 Miscellaneous Functions
1012 Takes a sprintf-style format pattern and conventional
1013 (non-SV) arguments and returns the formatted string.
1015 (char *) Perl_form(pTHX_ const char* pat, ...)
1017 can be used any place a string (char *) is required:
1019 char * s = Perl_form("%d.%d",major,minor);
1021 Uses a single private buffer so if you want to format several strings you
1022 must explicitly copy the earlier strings away (and free the copies when you
1029 Perl_form(pTHX_ const char* pat, ...)
1033 va_start(args, pat);
1034 retval = vform(pat, &args);
1040 Perl_vform(pTHX_ const char *pat, va_list *args)
1042 SV * const sv = mess_alloc();
1043 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
1047 #if defined(PERL_IMPLICIT_CONTEXT)
1049 Perl_mess_nocontext(const char *pat, ...)
1054 va_start(args, pat);
1055 retval = vmess(pat, &args);
1059 #endif /* PERL_IMPLICIT_CONTEXT */
1062 Perl_mess(pTHX_ const char *pat, ...)
1066 va_start(args, pat);
1067 retval = vmess(pat, &args);
1073 S_closest_cop(pTHX_ const COP *cop, const OP *o)
1076 /* Look for PL_op starting from o. cop is the last COP we've seen. */
1078 if (!o || o == PL_op)
1081 if (o->op_flags & OPf_KIDS) {
1083 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
1086 /* If the OP_NEXTSTATE has been optimised away we can still use it
1087 * the get the file and line number. */
1089 if (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE)
1090 cop = (const COP *)kid;
1092 /* Keep searching, and return when we've found something. */
1094 new_cop = closest_cop(cop, kid);
1100 /* Nothing found. */
1106 Perl_vmess(pTHX_ const char *pat, va_list *args)
1109 SV * const sv = mess_alloc();
1111 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
1112 if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
1114 * Try and find the file and line for PL_op. This will usually be
1115 * PL_curcop, but it might be a cop that has been optimised away. We
1116 * can try to find such a cop by searching through the optree starting
1117 * from the sibling of PL_curcop.
1120 const COP *cop = closest_cop(PL_curcop, PL_curcop->op_sibling);
1125 Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf,
1126 OutCopFILE(cop), (IV)CopLINE(cop));
1127 if (GvIO(PL_last_in_gv) && IoLINES(GvIOp(PL_last_in_gv))) {
1128 const bool line_mode = (RsSIMPLE(PL_rs) &&
1129 SvCUR(PL_rs) == 1 && *SvPVX_const(PL_rs) == '\n');
1130 Perl_sv_catpvf(aTHX_ sv, ", <%s> %s %"IVdf,
1131 PL_last_in_gv == PL_argvgv ? "" : GvNAME(PL_last_in_gv),
1132 line_mode ? "line" : "chunk",
1133 (IV)IoLINES(GvIOp(PL_last_in_gv)));
1136 sv_catpvs(sv, " during global destruction");
1137 sv_catpvs(sv, ".\n");
1143 Perl_write_to_stderr(pTHX_ const char* message, int msglen)
1149 if (PL_stderrgv && SvREFCNT(PL_stderrgv)
1150 && (io = GvIO(PL_stderrgv))
1151 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
1158 SAVESPTR(PL_stderrgv);
1161 PUSHSTACKi(PERLSI_MAGIC);
1165 PUSHs(SvTIED_obj((SV*)io, mg));
1166 PUSHs(sv_2mortal(newSVpvn(message, msglen)));
1168 call_method("PRINT", G_SCALAR);
1176 /* SFIO can really mess with your errno */
1177 const int e = errno;
1179 PerlIO * const serr = Perl_error_log;
1181 PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
1182 (void)PerlIO_flush(serr);
1189 /* Common code used by vcroak, vdie, vwarn and vwarner */
1192 S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8, bool warn)
1198 SV **const hook = warn ? &PL_warnhook : &PL_diehook;
1199 /* sv_2cv might call Perl_croak() or Perl_warner() */
1200 SV * const oldhook = *hook;
1207 cv = sv_2cv(oldhook, &stash, &gv, 0);
1209 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1219 if (warn || message) {
1220 msg = newSVpvn(message, msglen);
1221 SvFLAGS(msg) |= utf8;
1229 PUSHSTACKi(warn ? PERLSI_WARNHOOK : PERLSI_DIEHOOK);
1233 call_sv((SV*)cv, G_DISCARD);
1242 S_vdie_croak_common(pTHX_ const char* pat, va_list* args, STRLEN* msglen,
1246 const char *message;
1249 SV * const msv = vmess(pat, args);
1250 if (PL_errors && SvCUR(PL_errors)) {
1251 sv_catsv(PL_errors, msv);
1252 message = SvPV_const(PL_errors, *msglen);
1253 SvCUR_set(PL_errors, 0);
1256 message = SvPV_const(msv,*msglen);
1257 *utf8 = SvUTF8(msv);
1263 DEBUG_S(PerlIO_printf(Perl_debug_log,
1264 "%p: die/croak: message = %s\ndiehook = %p\n",
1265 thr, message, PL_diehook));
1267 S_vdie_common(aTHX_ message, *msglen, *utf8, FALSE);
1273 Perl_vdie(pTHX_ const char* pat, va_list *args)
1276 const char *message;
1277 const int was_in_eval = PL_in_eval;
1281 DEBUG_S(PerlIO_printf(Perl_debug_log,
1282 "%p: die: curstack = %p, mainstack = %p\n",
1283 thr, PL_curstack, PL_mainstack));
1285 message = vdie_croak_common(pat, args, &msglen, &utf8);
1287 PL_restartop = die_where(message, msglen);
1288 SvFLAGS(ERRSV) |= utf8;
1289 DEBUG_S(PerlIO_printf(Perl_debug_log,
1290 "%p: die: restartop = %p, was_in_eval = %d, top_env = %p\n",
1291 thr, PL_restartop, was_in_eval, PL_top_env));
1292 if ((!PL_restartop && was_in_eval) || PL_top_env->je_prev)
1294 return PL_restartop;
1297 #if defined(PERL_IMPLICIT_CONTEXT)
1299 Perl_die_nocontext(const char* pat, ...)
1304 va_start(args, pat);
1305 o = vdie(pat, &args);
1309 #endif /* PERL_IMPLICIT_CONTEXT */
1312 Perl_die(pTHX_ const char* pat, ...)
1316 va_start(args, pat);
1317 o = vdie(pat, &args);
1323 Perl_vcroak(pTHX_ const char* pat, va_list *args)
1326 const char *message;
1330 message = S_vdie_croak_common(aTHX_ pat, args, &msglen, &utf8);
1333 PL_restartop = die_where(message, msglen);
1334 SvFLAGS(ERRSV) |= utf8;
1338 message = SvPVx_const(ERRSV, msglen);
1340 write_to_stderr(message, msglen);
1344 #if defined(PERL_IMPLICIT_CONTEXT)
1346 Perl_croak_nocontext(const char *pat, ...)
1350 va_start(args, pat);
1355 #endif /* PERL_IMPLICIT_CONTEXT */
1358 =head1 Warning and Dieing
1362 This is the XSUB-writer's interface to Perl's C<die> function.
1363 Normally call this function the same way you call the C C<printf>
1364 function. Calling C<croak> returns control directly to Perl,
1365 sidestepping the normal C order of execution. See C<warn>.
1367 If you want to throw an exception object, assign the object to
1368 C<$@> and then pass C<NULL> to croak():
1370 errsv = get_sv("@", TRUE);
1371 sv_setsv(errsv, exception_object);
1378 Perl_croak(pTHX_ const char *pat, ...)
1381 va_start(args, pat);
1388 Perl_vwarn(pTHX_ const char* pat, va_list *args)
1392 SV * const msv = vmess(pat, args);
1393 const I32 utf8 = SvUTF8(msv);
1394 const char * const message = SvPV_const(msv, msglen);
1397 if (vdie_common(message, msglen, utf8, TRUE))
1401 write_to_stderr(message, msglen);
1404 #if defined(PERL_IMPLICIT_CONTEXT)
1406 Perl_warn_nocontext(const char *pat, ...)
1410 va_start(args, pat);
1414 #endif /* PERL_IMPLICIT_CONTEXT */
1419 This is the XSUB-writer's interface to Perl's C<warn> function. Call this
1420 function the same way you call the C C<printf> function. See C<croak>.
1426 Perl_warn(pTHX_ const char *pat, ...)
1429 va_start(args, pat);
1434 #if defined(PERL_IMPLICIT_CONTEXT)
1436 Perl_warner_nocontext(U32 err, const char *pat, ...)
1440 va_start(args, pat);
1441 vwarner(err, pat, &args);
1444 #endif /* PERL_IMPLICIT_CONTEXT */
1447 Perl_warner(pTHX_ U32 err, const char* pat,...)
1450 va_start(args, pat);
1451 vwarner(err, pat, &args);
1456 Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args)
1460 SV * const msv = vmess(pat, args);
1462 const char * const message = SvPV_const(msv, msglen);
1463 const I32 utf8 = SvUTF8(msv);
1467 S_vdie_common(aTHX_ message, msglen, utf8, FALSE);
1470 PL_restartop = die_where(message, msglen);
1471 SvFLAGS(ERRSV) |= utf8;
1474 write_to_stderr(message, msglen);
1478 Perl_vwarn(aTHX_ pat, args);
1482 /* implements the ckWARN? macros */
1485 Perl_ckwarn(pTHX_ U32 w)
1491 && PL_curcop->cop_warnings != pWARN_NONE
1493 PL_curcop->cop_warnings == pWARN_ALL
1494 || isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w))
1495 || (unpackWARN2(w) &&
1496 isWARN_on(PL_curcop->cop_warnings, unpackWARN2(w)))
1497 || (unpackWARN3(w) &&
1498 isWARN_on(PL_curcop->cop_warnings, unpackWARN3(w)))
1499 || (unpackWARN4(w) &&
1500 isWARN_on(PL_curcop->cop_warnings, unpackWARN4(w)))
1505 isLEXWARN_off && PL_dowarn & G_WARN_ON
1510 /* implements the ckWARN?_d macro */
1513 Perl_ckwarn_d(pTHX_ U32 w)
1518 || PL_curcop->cop_warnings == pWARN_ALL
1520 PL_curcop->cop_warnings != pWARN_NONE
1522 isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w))
1523 || (unpackWARN2(w) &&
1524 isWARN_on(PL_curcop->cop_warnings, unpackWARN2(w)))
1525 || (unpackWARN3(w) &&
1526 isWARN_on(PL_curcop->cop_warnings, unpackWARN3(w)))
1527 || (unpackWARN4(w) &&
1528 isWARN_on(PL_curcop->cop_warnings, unpackWARN4(w)))
1534 /* Set buffer=NULL to get a new one. */
1536 Perl_new_warnings_bitfield(pTHX_ STRLEN *buffer, const char *const bits,
1538 const MEM_SIZE len_wanted = sizeof(STRLEN) + size;
1540 buffer = specialWARN(buffer) ? PerlMemShared_malloc(len_wanted)
1541 : PerlMemShared_realloc(buffer, len_wanted);
1543 Copy(bits, (buffer + 1), size, char);
1547 /* since we've already done strlen() for both nam and val
1548 * we can use that info to make things faster than
1549 * sprintf(s, "%s=%s", nam, val)
1551 #define my_setenv_format(s, nam, nlen, val, vlen) \
1552 Copy(nam, s, nlen, char); \
1554 Copy(val, s+(nlen+1), vlen, char); \
1555 *(s+(nlen+1+vlen)) = '\0'
1557 #ifdef USE_ENVIRON_ARRAY
1558 /* VMS' my_setenv() is in vms.c */
1559 #if !defined(WIN32) && !defined(NETWARE)
1561 Perl_my_setenv(pTHX_ const char *nam, const char *val)
1565 /* only parent thread can modify process environment */
1566 if (PL_curinterp == aTHX)
1569 #ifndef PERL_USE_SAFE_PUTENV
1570 if (!PL_use_safe_putenv) {
1571 /* most putenv()s leak, so we manipulate environ directly */
1572 register I32 i=setenv_getix(nam); /* where does it go? */
1575 if (environ == PL_origenviron) { /* need we copy environment? */
1580 for (max = i; environ[max]; max++) ;
1581 tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*));
1582 for (j=0; j<max; j++) { /* copy environment */
1583 const int len = strlen(environ[j]);
1584 tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char));
1585 Copy(environ[j], tmpenv[j], len+1, char);
1588 environ = tmpenv; /* tell exec where it is now */
1591 safesysfree(environ[i]);
1592 while (environ[i]) {
1593 environ[i] = environ[i+1];
1598 if (!environ[i]) { /* does not exist yet */
1599 environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
1600 environ[i+1] = NULL; /* make sure it's null terminated */
1603 safesysfree(environ[i]);
1607 environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char));
1608 /* all that work just for this */
1609 my_setenv_format(environ[i], nam, nlen, val, vlen);
1612 # if defined(__CYGWIN__) || defined(EPOC) || defined(__SYMBIAN32__) || defined(__riscos__)
1613 # if defined(HAS_UNSETENV)
1615 (void)unsetenv(nam);
1617 (void)setenv(nam, val, 1);
1619 # else /* ! HAS_UNSETENV */
1620 (void)setenv(nam, val, 1);
1621 # endif /* HAS_UNSETENV */
1623 # if defined(HAS_UNSETENV)
1625 (void)unsetenv(nam);
1627 const int nlen = strlen(nam);
1628 const int vlen = strlen(val);
1629 char * const new_env =
1630 (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
1631 my_setenv_format(new_env, nam, nlen, val, vlen);
1632 (void)putenv(new_env);
1634 # else /* ! HAS_UNSETENV */
1636 const int nlen = strlen(nam);
1642 new_env = (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
1643 /* all that work just for this */
1644 my_setenv_format(new_env, nam, nlen, val, vlen);
1645 (void)putenv(new_env);
1646 # endif /* HAS_UNSETENV */
1647 # endif /* __CYGWIN__ */
1648 #ifndef PERL_USE_SAFE_PUTENV
1654 #else /* WIN32 || NETWARE */
1657 Perl_my_setenv(pTHX_ const char *nam, const char *val)
1660 register char *envstr;
1661 const int nlen = strlen(nam);
1668 Newx(envstr, nlen+vlen+2, char);
1669 my_setenv_format(envstr, nam, nlen, val, vlen);
1670 (void)PerlEnv_putenv(envstr);
1674 #endif /* WIN32 || NETWARE */
1678 Perl_setenv_getix(pTHX_ const char *nam)
1681 register const I32 len = strlen(nam);
1682 PERL_UNUSED_CONTEXT;
1684 for (i = 0; environ[i]; i++) {
1687 strnicmp(environ[i],nam,len) == 0
1689 strnEQ(environ[i],nam,len)
1691 && environ[i][len] == '=')
1692 break; /* strnEQ must come first to avoid */
1693 } /* potential SEGV's */
1696 #endif /* !PERL_MICRO */
1698 #endif /* !VMS && !EPOC*/
1700 #ifdef UNLINK_ALL_VERSIONS
1702 Perl_unlnk(pTHX_ const char *f) /* unlink all versions of a file */
1706 for (i = 0; PerlLIO_unlink(f) >= 0; i++) ;
1711 /* this is a drop-in replacement for bcopy() */
1712 #if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY))
1714 Perl_my_bcopy(register const char *from,register char *to,register I32 len)
1716 char * const retval = to;
1718 if (from - to >= 0) {
1726 *(--to) = *(--from);
1732 /* this is a drop-in replacement for memset() */
1735 Perl_my_memset(register char *loc, register I32 ch, register I32 len)
1737 char * const retval = loc;
1745 /* this is a drop-in replacement for bzero() */
1746 #if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
1748 Perl_my_bzero(register char *loc, register I32 len)
1750 char * const retval = loc;
1758 /* this is a drop-in replacement for memcmp() */
1759 #if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
1761 Perl_my_memcmp(const char *s1, const char *s2, register I32 len)
1763 register const U8 *a = (const U8 *)s1;
1764 register const U8 *b = (const U8 *)s2;
1768 if ((tmp = *a++ - *b++))
1773 #endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */
1777 #ifdef USE_CHAR_VSPRINTF
1782 vsprintf(char *dest, const char *pat, char *args)
1786 fakebuf._ptr = dest;
1787 fakebuf._cnt = 32767;
1791 fakebuf._flag = _IOWRT|_IOSTRG;
1792 _doprnt(pat, args, &fakebuf); /* what a kludge */
1793 (void)putc('\0', &fakebuf);
1794 #ifdef USE_CHAR_VSPRINTF
1797 return 0; /* perl doesn't use return value */
1801 #endif /* HAS_VPRINTF */
1804 #if BYTEORDER != 0x4321
1806 Perl_my_swap(pTHX_ short s)
1808 #if (BYTEORDER & 1) == 0
1811 result = ((s & 255) << 8) + ((s >> 8) & 255);
1819 Perl_my_htonl(pTHX_ long l)
1823 char c[sizeof(long)];
1826 #if BYTEORDER == 0x1234
1827 u.c[0] = (l >> 24) & 255;
1828 u.c[1] = (l >> 16) & 255;
1829 u.c[2] = (l >> 8) & 255;
1833 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
1834 Perl_croak(aTHX_ "Unknown BYTEORDER\n");
1839 for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
1840 u.c[o & 0xf] = (l >> s) & 255;
1848 Perl_my_ntohl(pTHX_ long l)
1852 char c[sizeof(long)];
1855 #if BYTEORDER == 0x1234
1856 u.c[0] = (l >> 24) & 255;
1857 u.c[1] = (l >> 16) & 255;
1858 u.c[2] = (l >> 8) & 255;
1862 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
1863 Perl_croak(aTHX_ "Unknown BYTEORDER\n");
1870 for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
1871 l |= (u.c[o & 0xf] & 255) << s;
1878 #endif /* BYTEORDER != 0x4321 */
1882 * Little-endian byte order functions - 'v' for 'VAX', or 'reVerse'.
1883 * If these functions are defined,
1884 * the BYTEORDER is neither 0x1234 nor 0x4321.
1885 * However, this is not assumed.
1889 #define HTOLE(name,type) \
1891 name (register type n) \
1895 char c[sizeof(type)]; \
1898 register I32 s = 0; \
1899 for (i = 0; i < sizeof(u.c); i++, s += 8) { \
1900 u.c[i] = (n >> s) & 0xFF; \
1905 #define LETOH(name,type) \
1907 name (register type n) \
1911 char c[sizeof(type)]; \
1914 register I32 s = 0; \
1917 for (i = 0; i < sizeof(u.c); i++, s += 8) { \
1918 n |= ((type)(u.c[i] & 0xFF)) << s; \
1924 * Big-endian byte order functions.
1927 #define HTOBE(name,type) \
1929 name (register type n) \
1933 char c[sizeof(type)]; \
1936 register I32 s = 8*(sizeof(u.c)-1); \
1937 for (i = 0; i < sizeof(u.c); i++, s -= 8) { \
1938 u.c[i] = (n >> s) & 0xFF; \
1943 #define BETOH(name,type) \
1945 name (register type n) \
1949 char c[sizeof(type)]; \
1952 register I32 s = 8*(sizeof(u.c)-1); \
1955 for (i = 0; i < sizeof(u.c); i++, s -= 8) { \
1956 n |= ((type)(u.c[i] & 0xFF)) << s; \
1962 * If we just can't do it...
1965 #define NOT_AVAIL(name,type) \
1967 name (register type n) \
1969 Perl_croak_nocontext(#name "() not available"); \
1970 return n; /* not reached */ \
1974 #if defined(HAS_HTOVS) && !defined(htovs)
1977 #if defined(HAS_HTOVL) && !defined(htovl)
1980 #if defined(HAS_VTOHS) && !defined(vtohs)
1983 #if defined(HAS_VTOHL) && !defined(vtohl)
1987 #ifdef PERL_NEED_MY_HTOLE16
1989 HTOLE(Perl_my_htole16,U16)
1991 NOT_AVAIL(Perl_my_htole16,U16)
1994 #ifdef PERL_NEED_MY_LETOH16
1996 LETOH(Perl_my_letoh16,U16)
1998 NOT_AVAIL(Perl_my_letoh16,U16)
2001 #ifdef PERL_NEED_MY_HTOBE16
2003 HTOBE(Perl_my_htobe16,U16)
2005 NOT_AVAIL(Perl_my_htobe16,U16)
2008 #ifdef PERL_NEED_MY_BETOH16
2010 BETOH(Perl_my_betoh16,U16)
2012 NOT_AVAIL(Perl_my_betoh16,U16)
2016 #ifdef PERL_NEED_MY_HTOLE32
2018 HTOLE(Perl_my_htole32,U32)
2020 NOT_AVAIL(Perl_my_htole32,U32)
2023 #ifdef PERL_NEED_MY_LETOH32
2025 LETOH(Perl_my_letoh32,U32)
2027 NOT_AVAIL(Perl_my_letoh32,U32)
2030 #ifdef PERL_NEED_MY_HTOBE32
2032 HTOBE(Perl_my_htobe32,U32)
2034 NOT_AVAIL(Perl_my_htobe32,U32)
2037 #ifdef PERL_NEED_MY_BETOH32
2039 BETOH(Perl_my_betoh32,U32)
2041 NOT_AVAIL(Perl_my_betoh32,U32)
2045 #ifdef PERL_NEED_MY_HTOLE64
2047 HTOLE(Perl_my_htole64,U64)
2049 NOT_AVAIL(Perl_my_htole64,U64)
2052 #ifdef PERL_NEED_MY_LETOH64
2054 LETOH(Perl_my_letoh64,U64)
2056 NOT_AVAIL(Perl_my_letoh64,U64)
2059 #ifdef PERL_NEED_MY_HTOBE64
2061 HTOBE(Perl_my_htobe64,U64)
2063 NOT_AVAIL(Perl_my_htobe64,U64)
2066 #ifdef PERL_NEED_MY_BETOH64
2068 BETOH(Perl_my_betoh64,U64)
2070 NOT_AVAIL(Perl_my_betoh64,U64)
2074 #ifdef PERL_NEED_MY_HTOLES
2075 HTOLE(Perl_my_htoles,short)
2077 #ifdef PERL_NEED_MY_LETOHS
2078 LETOH(Perl_my_letohs,short)
2080 #ifdef PERL_NEED_MY_HTOBES
2081 HTOBE(Perl_my_htobes,short)
2083 #ifdef PERL_NEED_MY_BETOHS
2084 BETOH(Perl_my_betohs,short)
2087 #ifdef PERL_NEED_MY_HTOLEI
2088 HTOLE(Perl_my_htolei,int)
2090 #ifdef PERL_NEED_MY_LETOHI
2091 LETOH(Perl_my_letohi,int)
2093 #ifdef PERL_NEED_MY_HTOBEI
2094 HTOBE(Perl_my_htobei,int)
2096 #ifdef PERL_NEED_MY_BETOHI
2097 BETOH(Perl_my_betohi,int)
2100 #ifdef PERL_NEED_MY_HTOLEL
2101 HTOLE(Perl_my_htolel,long)
2103 #ifdef PERL_NEED_MY_LETOHL
2104 LETOH(Perl_my_letohl,long)
2106 #ifdef PERL_NEED_MY_HTOBEL
2107 HTOBE(Perl_my_htobel,long)
2109 #ifdef PERL_NEED_MY_BETOHL
2110 BETOH(Perl_my_betohl,long)
2114 Perl_my_swabn(void *ptr, int n)
2116 register char *s = (char *)ptr;
2117 register char *e = s + (n-1);
2120 for (n /= 2; n > 0; s++, e--, n--) {
2128 Perl_my_popen_list(pTHX_ char *mode, int n, SV **args)
2130 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) && !defined(NETWARE)
2133 register I32 This, that;
2139 PERL_FLUSHALL_FOR_CHILD;
2140 This = (*mode == 'w');
2144 taint_proper("Insecure %s%s", "EXEC");
2146 if (PerlProc_pipe(p) < 0)
2148 /* Try for another pipe pair for error return */
2149 if (PerlProc_pipe(pp) >= 0)
2151 while ((pid = PerlProc_fork()) < 0) {
2152 if (errno != EAGAIN) {
2153 PerlLIO_close(p[This]);
2154 PerlLIO_close(p[that]);
2156 PerlLIO_close(pp[0]);
2157 PerlLIO_close(pp[1]);
2169 /* Close parent's end of error status pipe (if any) */
2171 PerlLIO_close(pp[0]);
2172 #if defined(HAS_FCNTL) && defined(F_SETFD)
2173 /* Close error pipe automatically if exec works */
2174 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2177 /* Now dup our end of _the_ pipe to right position */
2178 if (p[THIS] != (*mode == 'r')) {
2179 PerlLIO_dup2(p[THIS], *mode == 'r');
2180 PerlLIO_close(p[THIS]);
2181 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2182 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
2185 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
2186 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2187 /* No automatic close - do it by hand */
2194 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) {
2200 do_aexec5(NULL, args-1, args-1+n, pp[1], did_pipes);
2206 do_execfree(); /* free any memory malloced by child on fork */
2208 PerlLIO_close(pp[1]);
2209 /* Keep the lower of the two fd numbers */
2210 if (p[that] < p[This]) {
2211 PerlLIO_dup2(p[This], p[that]);
2212 PerlLIO_close(p[This]);
2216 PerlLIO_close(p[that]); /* close child's end of pipe */
2219 sv = *av_fetch(PL_fdpid,p[This],TRUE);
2221 SvUPGRADE(sv,SVt_IV);
2223 PL_forkprocess = pid;
2224 /* If we managed to get status pipe check for exec fail */
2225 if (did_pipes && pid > 0) {
2229 while (n < sizeof(int)) {
2230 n1 = PerlLIO_read(pp[0],
2231 (void*)(((char*)&errkid)+n),
2237 PerlLIO_close(pp[0]);
2239 if (n) { /* Error */
2241 PerlLIO_close(p[This]);
2242 if (n != sizeof(int))
2243 Perl_croak(aTHX_ "panic: kid popen errno read");
2245 pid2 = wait4pid(pid, &status, 0);
2246 } while (pid2 == -1 && errno == EINTR);
2247 errno = errkid; /* Propagate errno from kid */
2252 PerlLIO_close(pp[0]);
2253 return PerlIO_fdopen(p[This], mode);
2255 Perl_croak(aTHX_ "List form of piped open not implemented");
2256 return (PerlIO *) NULL;
2260 /* VMS' my_popen() is in VMS.c, same with OS/2. */
2261 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
2263 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2267 register I32 This, that;
2270 const I32 doexec = !(*cmd == '-' && cmd[1] == '\0');
2274 PERL_FLUSHALL_FOR_CHILD;
2277 return my_syspopen(aTHX_ cmd,mode);
2280 This = (*mode == 'w');
2282 if (doexec && PL_tainting) {
2284 taint_proper("Insecure %s%s", "EXEC");
2286 if (PerlProc_pipe(p) < 0)
2288 if (doexec && PerlProc_pipe(pp) >= 0)
2290 while ((pid = PerlProc_fork()) < 0) {
2291 if (errno != EAGAIN) {
2292 PerlLIO_close(p[This]);
2293 PerlLIO_close(p[that]);
2295 PerlLIO_close(pp[0]);
2296 PerlLIO_close(pp[1]);
2299 Perl_croak(aTHX_ "Can't fork");
2312 PerlLIO_close(pp[0]);
2313 #if defined(HAS_FCNTL) && defined(F_SETFD)
2314 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2317 if (p[THIS] != (*mode == 'r')) {
2318 PerlLIO_dup2(p[THIS], *mode == 'r');
2319 PerlLIO_close(p[THIS]);
2320 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2321 PerlLIO_close(p[THAT]);
2324 PerlLIO_close(p[THAT]);
2327 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2334 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
2339 /* may or may not use the shell */
2340 do_exec3(cmd, pp[1], did_pipes);
2343 #endif /* defined OS2 */
2344 if ((tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV))) {
2345 SvREADONLY_off(GvSV(tmpgv));
2346 sv_setiv(GvSV(tmpgv), PerlProc_getpid());
2347 SvREADONLY_on(GvSV(tmpgv));
2349 #ifdef THREADS_HAVE_PIDS
2350 PL_ppid = (IV)getppid();
2353 #ifdef PERL_USES_PL_PIDSTATUS
2354 hv_clear(PL_pidstatus); /* we have no children */
2360 do_execfree(); /* free any memory malloced by child on vfork */
2362 PerlLIO_close(pp[1]);
2363 if (p[that] < p[This]) {
2364 PerlLIO_dup2(p[This], p[that]);
2365 PerlLIO_close(p[This]);
2369 PerlLIO_close(p[that]);
2372 sv = *av_fetch(PL_fdpid,p[This],TRUE);
2374 SvUPGRADE(sv,SVt_IV);
2376 PL_forkprocess = pid;
2377 if (did_pipes && pid > 0) {
2381 while (n < sizeof(int)) {
2382 n1 = PerlLIO_read(pp[0],
2383 (void*)(((char*)&errkid)+n),
2389 PerlLIO_close(pp[0]);
2391 if (n) { /* Error */
2393 PerlLIO_close(p[This]);
2394 if (n != sizeof(int))
2395 Perl_croak(aTHX_ "panic: kid popen errno read");
2397 pid2 = wait4pid(pid, &status, 0);
2398 } while (pid2 == -1 && errno == EINTR);
2399 errno = errkid; /* Propagate errno from kid */
2404 PerlLIO_close(pp[0]);
2405 return PerlIO_fdopen(p[This], mode);
2408 #if defined(atarist) || defined(EPOC)
2411 Perl_my_popen(pTHX_ char *cmd, char *mode)
2413 PERL_FLUSHALL_FOR_CHILD;
2414 /* Call system's popen() to get a FILE *, then import it.
2415 used 0 for 2nd parameter to PerlIO_importFILE;
2418 return PerlIO_importFILE(popen(cmd, mode), 0);
2422 FILE *djgpp_popen();
2424 Perl_my_popen(pTHX_ char *cmd, char *mode)
2426 PERL_FLUSHALL_FOR_CHILD;
2427 /* Call system's popen() to get a FILE *, then import it.
2428 used 0 for 2nd parameter to PerlIO_importFILE;
2431 return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
2436 #endif /* !DOSISH */
2438 /* this is called in parent before the fork() */
2440 Perl_atfork_lock(void)
2443 #if defined(USE_ITHREADS)
2444 /* locks must be held in locking order (if any) */
2446 MUTEX_LOCK(&PL_malloc_mutex);
2452 /* this is called in both parent and child after the fork() */
2454 Perl_atfork_unlock(void)
2457 #if defined(USE_ITHREADS)
2458 /* locks must be released in same order as in atfork_lock() */
2460 MUTEX_UNLOCK(&PL_malloc_mutex);
2469 #if defined(HAS_FORK)
2471 #if defined(USE_ITHREADS) && !defined(HAS_PTHREAD_ATFORK)
2476 /* atfork_lock() and atfork_unlock() are installed as pthread_atfork()
2477 * handlers elsewhere in the code */
2482 /* this "canna happen" since nothing should be calling here if !HAS_FORK */
2483 Perl_croak_nocontext("fork() not available");
2485 #endif /* HAS_FORK */
2490 Perl_dump_fds(pTHX_ char *s)
2495 PerlIO_printf(Perl_debug_log,"%s", s);
2496 for (fd = 0; fd < 32; fd++) {
2497 if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0)
2498 PerlIO_printf(Perl_debug_log," %d",fd);
2500 PerlIO_printf(Perl_debug_log,"\n");
2503 #endif /* DUMP_FDS */
2507 dup2(int oldfd, int newfd)
2509 #if defined(HAS_FCNTL) && defined(F_DUPFD)
2512 PerlLIO_close(newfd);
2513 return fcntl(oldfd, F_DUPFD, newfd);
2515 #define DUP2_MAX_FDS 256
2516 int fdtmp[DUP2_MAX_FDS];
2522 PerlLIO_close(newfd);
2523 /* good enough for low fd's... */
2524 while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
2525 if (fdx >= DUP2_MAX_FDS) {
2533 PerlLIO_close(fdtmp[--fdx]);
2540 #ifdef HAS_SIGACTION
2542 #ifdef MACOS_TRADITIONAL
2543 /* We don't want restart behavior on MacOS */
2548 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2551 struct sigaction act, oact;
2554 /* only "parent" interpreter can diddle signals */
2555 if (PL_curinterp != aTHX)
2556 return (Sighandler_t) SIG_ERR;
2559 act.sa_handler = (void(*)(int))handler;
2560 sigemptyset(&act.sa_mask);
2563 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2564 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
2566 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2567 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
2568 act.sa_flags |= SA_NOCLDWAIT;
2570 if (sigaction(signo, &act, &oact) == -1)
2571 return (Sighandler_t) SIG_ERR;
2573 return (Sighandler_t) oact.sa_handler;
2577 Perl_rsignal_state(pTHX_ int signo)
2579 struct sigaction oact;
2580 PERL_UNUSED_CONTEXT;
2582 if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
2583 return (Sighandler_t) SIG_ERR;
2585 return (Sighandler_t) oact.sa_handler;
2589 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2592 struct sigaction act;
2595 /* only "parent" interpreter can diddle signals */
2596 if (PL_curinterp != aTHX)
2600 act.sa_handler = (void(*)(int))handler;
2601 sigemptyset(&act.sa_mask);
2604 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2605 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
2607 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2608 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
2609 act.sa_flags |= SA_NOCLDWAIT;
2611 return sigaction(signo, &act, save);
2615 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2619 /* only "parent" interpreter can diddle signals */
2620 if (PL_curinterp != aTHX)
2624 return sigaction(signo, save, (struct sigaction *)NULL);
2627 #else /* !HAS_SIGACTION */
2630 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2632 #if defined(USE_ITHREADS) && !defined(WIN32)
2633 /* only "parent" interpreter can diddle signals */
2634 if (PL_curinterp != aTHX)
2635 return (Sighandler_t) SIG_ERR;
2638 return PerlProc_signal(signo, handler);
2649 Perl_rsignal_state(pTHX_ int signo)
2652 Sighandler_t oldsig;
2654 #if defined(USE_ITHREADS) && !defined(WIN32)
2655 /* only "parent" interpreter can diddle signals */
2656 if (PL_curinterp != aTHX)
2657 return (Sighandler_t) SIG_ERR;
2661 oldsig = PerlProc_signal(signo, sig_trap);
2662 PerlProc_signal(signo, oldsig);
2664 PerlProc_kill(PerlProc_getpid(), signo);
2669 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2671 #if defined(USE_ITHREADS) && !defined(WIN32)
2672 /* only "parent" interpreter can diddle signals */
2673 if (PL_curinterp != aTHX)
2676 *save = PerlProc_signal(signo, handler);
2677 return (*save == (Sighandler_t) SIG_ERR) ? -1 : 0;
2681 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2683 #if defined(USE_ITHREADS) && !defined(WIN32)
2684 /* only "parent" interpreter can diddle signals */
2685 if (PL_curinterp != aTHX)
2688 return (PerlProc_signal(signo, *save) == (Sighandler_t) SIG_ERR) ? -1 : 0;
2691 #endif /* !HAS_SIGACTION */
2692 #endif /* !PERL_MICRO */
2694 /* VMS' my_pclose() is in VMS.c; same with OS/2 */
2695 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
2697 Perl_my_pclose(pTHX_ PerlIO *ptr)
2700 Sigsave_t hstat, istat, qstat;
2706 int saved_errno = 0;
2708 int saved_win32_errno;
2712 svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE);
2714 pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
2716 *svp = &PL_sv_undef;
2718 if (pid == -1) { /* Opened by popen. */
2719 return my_syspclose(ptr);
2722 if ((close_failed = (PerlIO_close(ptr) == EOF))) {
2723 saved_errno = errno;
2725 saved_win32_errno = GetLastError();
2729 if(PerlProc_kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */
2732 rsignal_save(SIGHUP, (Sighandler_t) SIG_IGN, &hstat);
2733 rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &istat);
2734 rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qstat);
2737 pid2 = wait4pid(pid, &status, 0);
2738 } while (pid2 == -1 && errno == EINTR);
2740 rsignal_restore(SIGHUP, &hstat);
2741 rsignal_restore(SIGINT, &istat);
2742 rsignal_restore(SIGQUIT, &qstat);
2745 SETERRNO(saved_errno, 0);
2748 return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status));
2750 #endif /* !DOSISH */
2752 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(MACOS_TRADITIONAL)
2754 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
2760 #ifdef PERL_USES_PL_PIDSTATUS
2763 /* The keys in PL_pidstatus are now the raw 4 (or 8) bytes of the
2764 pid, rather than a string form. */
2765 SV * const * const svp = hv_fetch(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),FALSE);
2766 if (svp && *svp != &PL_sv_undef) {
2767 *statusp = SvIVX(*svp);
2768 (void)hv_delete(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),
2776 hv_iterinit(PL_pidstatus);
2777 if ((entry = hv_iternext(PL_pidstatus))) {
2778 SV * const sv = hv_iterval(PL_pidstatus,entry);
2780 const char * const spid = hv_iterkey(entry,&len);
2782 assert (len == sizeof(Pid_t));
2783 memcpy((char *)&pid, spid, len);
2784 *statusp = SvIVX(sv);
2785 /* The hash iterator is currently on this entry, so simply
2786 calling hv_delete would trigger the lazy delete, which on
2787 aggregate does more work, beacuse next call to hv_iterinit()
2788 would spot the flag, and have to call the delete routine,
2789 while in the meantime any new entries can't re-use that
2791 hv_iterinit(PL_pidstatus);
2792 (void)hv_delete(PL_pidstatus,spid,len,G_DISCARD);
2799 # ifdef HAS_WAITPID_RUNTIME
2800 if (!HAS_WAITPID_RUNTIME)
2803 result = PerlProc_waitpid(pid,statusp,flags);
2806 #if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
2807 result = wait4((pid==-1)?0:pid,statusp,flags,NULL);
2810 #ifdef PERL_USES_PL_PIDSTATUS
2811 #if defined(HAS_WAITPID) && defined(HAS_WAITPID_RUNTIME)
2816 Perl_croak(aTHX_ "Can't do waitpid with flags");
2818 while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
2819 pidgone(result,*statusp);
2825 #if defined(HAS_WAITPID) || defined(HAS_WAIT4)
2828 if (result < 0 && errno == EINTR) {
2833 #endif /* !DOSISH || OS2 || WIN32 || NETWARE */
2835 #ifdef PERL_USES_PL_PIDSTATUS
2837 Perl_pidgone(pTHX_ Pid_t pid, int status)
2841 sv = *hv_fetch(PL_pidstatus,(const char*)&pid,sizeof(Pid_t),TRUE);
2842 SvUPGRADE(sv,SVt_IV);
2843 SvIV_set(sv, status);
2848 #if defined(atarist) || defined(OS2) || defined(EPOC)
2851 int /* Cannot prototype with I32
2853 my_syspclose(PerlIO *ptr)
2856 Perl_my_pclose(pTHX_ PerlIO *ptr)
2859 /* Needs work for PerlIO ! */
2860 FILE * const f = PerlIO_findFILE(ptr);
2861 const I32 result = pclose(f);
2862 PerlIO_releaseFILE(ptr,f);
2870 Perl_my_pclose(pTHX_ PerlIO *ptr)
2872 /* Needs work for PerlIO ! */
2873 FILE * const f = PerlIO_findFILE(ptr);
2874 I32 result = djgpp_pclose(f);
2875 result = (result << 8) & 0xff00;
2876 PerlIO_releaseFILE(ptr,f);
2882 Perl_repeatcpy(pTHX_ register char *to, register const char *from, I32 len, register I32 count)
2885 register const char * const frombase = from;
2886 PERL_UNUSED_CONTEXT;
2889 register const char c = *from;
2894 while (count-- > 0) {
2895 for (todo = len; todo > 0; todo--) {
2904 Perl_same_dirent(pTHX_ const char *a, const char *b)
2906 char *fa = strrchr(a,'/');
2907 char *fb = strrchr(b,'/');
2910 SV * const tmpsv = sv_newmortal();
2923 sv_setpvn(tmpsv, ".", 1);
2925 sv_setpvn(tmpsv, a, fa - a);
2926 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0)
2929 sv_setpvn(tmpsv, ".", 1);
2931 sv_setpvn(tmpsv, b, fb - b);
2932 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0)
2934 return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
2935 tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
2937 #endif /* !HAS_RENAME */
2940 Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
2941 const char *const *const search_ext, I32 flags)
2944 const char *xfound = NULL;
2945 char *xfailed = NULL;
2946 char tmpbuf[MAXPATHLEN];
2950 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
2951 # define SEARCH_EXTS ".bat", ".cmd", NULL
2952 # define MAX_EXT_LEN 4
2955 # define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
2956 # define MAX_EXT_LEN 4
2959 # define SEARCH_EXTS ".pl", ".com", NULL
2960 # define MAX_EXT_LEN 4
2962 /* additional extensions to try in each dir if scriptname not found */
2964 static const char *const exts[] = { SEARCH_EXTS };
2965 const char *const *const ext = search_ext ? search_ext : exts;
2966 int extidx = 0, i = 0;
2967 const char *curext = NULL;
2969 PERL_UNUSED_ARG(search_ext);
2970 # define MAX_EXT_LEN 0
2974 * If dosearch is true and if scriptname does not contain path
2975 * delimiters, search the PATH for scriptname.
2977 * If SEARCH_EXTS is also defined, will look for each
2978 * scriptname{SEARCH_EXTS} whenever scriptname is not found
2979 * while searching the PATH.
2981 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
2982 * proceeds as follows:
2983 * If DOSISH or VMSISH:
2984 * + look for ./scriptname{,.foo,.bar}
2985 * + search the PATH for scriptname{,.foo,.bar}
2988 * + look *only* in the PATH for scriptname{,.foo,.bar} (note
2989 * this will not look in '.' if it's not in the PATH)
2994 # ifdef ALWAYS_DEFTYPES
2995 len = strlen(scriptname);
2996 if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
2997 int idx = 0, deftypes = 1;
3000 const int hasdir = !dosearch || (strpbrk(scriptname,":[</") != NULL);
3003 int idx = 0, deftypes = 1;
3006 const int hasdir = (strpbrk(scriptname,":[</") != NULL);
3008 /* The first time through, just add SEARCH_EXTS to whatever we
3009 * already have, so we can check for default file types. */
3011 (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
3017 if ((strlen(tmpbuf) + strlen(scriptname)
3018 + MAX_EXT_LEN) >= sizeof tmpbuf)
3019 continue; /* don't search dir with too-long name */
3020 strcat(tmpbuf, scriptname);
3024 if (strEQ(scriptname, "-"))
3026 if (dosearch) { /* Look in '.' first. */
3027 const char *cur = scriptname;
3029 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
3031 if (strEQ(ext[i++],curext)) {
3032 extidx = -1; /* already has an ext */
3037 DEBUG_p(PerlIO_printf(Perl_debug_log,
3038 "Looking for %s\n",cur));
3039 if (PerlLIO_stat(cur,&PL_statbuf) >= 0
3040 && !S_ISDIR(PL_statbuf.st_mode)) {
3048 if (cur == scriptname) {
3049 len = strlen(scriptname);
3050 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
3052 /* FIXME? Convert to memcpy */
3053 cur = strcpy(tmpbuf, scriptname);
3055 } while (extidx >= 0 && ext[extidx] /* try an extension? */
3056 && strcpy(tmpbuf+len, ext[extidx++]));
3061 #ifdef MACOS_TRADITIONAL
3062 if (dosearch && !strchr(scriptname, ':') &&
3063 (s = PerlEnv_getenv("Commands")))
3065 if (dosearch && !strchr(scriptname, '/')
3067 && !strchr(scriptname, '\\')
3069 && (s = PerlEnv_getenv("PATH")))
3074 PL_bufend = s + strlen(s);
3075 while (s < PL_bufend) {
3076 #ifdef MACOS_TRADITIONAL
3077 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
3081 #if defined(atarist) || defined(DOSISH)
3086 && *s != ';'; len++, s++) {
3087 if (len < sizeof tmpbuf)
3090 if (len < sizeof tmpbuf)
3092 #else /* ! (atarist || DOSISH) */
3093 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
3096 #endif /* ! (atarist || DOSISH) */
3097 #endif /* MACOS_TRADITIONAL */
3100 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
3101 continue; /* don't search dir with too-long name */
3102 #ifdef MACOS_TRADITIONAL
3103 if (len && tmpbuf[len - 1] != ':')
3104 tmpbuf[len++] = ':';
3107 # if defined(atarist) || defined(__MINT__) || defined(DOSISH)
3108 && tmpbuf[len - 1] != '/'
3109 && tmpbuf[len - 1] != '\\'
3112 tmpbuf[len++] = '/';
3113 if (len == 2 && tmpbuf[0] == '.')
3116 /* FIXME? Convert to memcpy by storing previous strlen(scriptname)
3118 (void)strcpy(tmpbuf + len, scriptname);
3122 len = strlen(tmpbuf);
3123 if (extidx > 0) /* reset after previous loop */
3127 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
3128 retval = PerlLIO_stat(tmpbuf,&PL_statbuf);
3129 if (S_ISDIR(PL_statbuf.st_mode)) {
3133 } while ( retval < 0 /* not there */
3134 && extidx>=0 && ext[extidx] /* try an extension? */
3135 && strcpy(tmpbuf+len, ext[extidx++])
3140 if (S_ISREG(PL_statbuf.st_mode)
3141 && cando(S_IRUSR,TRUE,&PL_statbuf)
3142 #if !defined(DOSISH) && !defined(MACOS_TRADITIONAL)
3143 && cando(S_IXUSR,TRUE,&PL_statbuf)
3147 xfound = tmpbuf; /* bingo! */
3151 xfailed = savepv(tmpbuf);
3154 if (!xfound && !seen_dot && !xfailed &&
3155 (PerlLIO_stat(scriptname,&PL_statbuf) < 0
3156 || S_ISDIR(PL_statbuf.st_mode)))
3158 seen_dot = 1; /* Disable message. */
3160 if (flags & 1) { /* do or die? */
3161 Perl_croak(aTHX_ "Can't %s %s%s%s",
3162 (xfailed ? "execute" : "find"),
3163 (xfailed ? xfailed : scriptname),
3164 (xfailed ? "" : " on PATH"),
3165 (xfailed || seen_dot) ? "" : ", '.' not in PATH");
3170 scriptname = xfound;
3172 return (scriptname ? savepv(scriptname) : NULL);
3175 #ifndef PERL_GET_CONTEXT_DEFINED
3178 Perl_get_context(void)
3181 #if defined(USE_ITHREADS)
3182 # ifdef OLD_PTHREADS_API
3184 if (pthread_getspecific(PL_thr_key, &t))
3185 Perl_croak_nocontext("panic: pthread_getspecific");
3188 # ifdef I_MACH_CTHREADS
3189 return (void*)cthread_data(cthread_self());
3191 return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
3200 Perl_set_context(void *t)
3203 #if defined(USE_ITHREADS)
3204 # ifdef I_MACH_CTHREADS
3205 cthread_set_data(cthread_self(), t);
3207 if (pthread_setspecific(PL_thr_key, t))
3208 Perl_croak_nocontext("panic: pthread_setspecific");
3215 #endif /* !PERL_GET_CONTEXT_DEFINED */
3217 #if defined(PERL_GLOBAL_STRUCT) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
3226 Perl_get_op_names(pTHX)
3228 PERL_UNUSED_CONTEXT;
3229 return (char **)PL_op_name;
3233 Perl_get_op_descs(pTHX)
3235 PERL_UNUSED_CONTEXT;
3236 return (char **)PL_op_desc;
3240 Perl_get_no_modify(pTHX)
3242 PERL_UNUSED_CONTEXT;
3243 return PL_no_modify;
3247 Perl_get_opargs(pTHX)
3249 PERL_UNUSED_CONTEXT;
3250 return (U32 *)PL_opargs;
3254 Perl_get_ppaddr(pTHX)
3257 PERL_UNUSED_CONTEXT;
3258 return (PPADDR_t*)PL_ppaddr;
3261 #ifndef HAS_GETENV_LEN
3263 Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
3265 char * const env_trans = PerlEnv_getenv(env_elem);
3266 PERL_UNUSED_CONTEXT;
3268 *len = strlen(env_trans);
3275 Perl_get_vtbl(pTHX_ int vtbl_id)
3277 const MGVTBL* result;
3278 PERL_UNUSED_CONTEXT;
3282 result = &PL_vtbl_sv;
3285 result = &PL_vtbl_env;
3287 case want_vtbl_envelem:
3288 result = &PL_vtbl_envelem;
3291 result = &PL_vtbl_sig;
3293 case want_vtbl_sigelem:
3294 result = &PL_vtbl_sigelem;
3296 case want_vtbl_pack:
3297 result = &PL_vtbl_pack;
3299 case want_vtbl_packelem:
3300 result = &PL_vtbl_packelem;
3302 case want_vtbl_dbline:
3303 result = &PL_vtbl_dbline;
3306 result = &PL_vtbl_isa;
3308 case want_vtbl_isaelem:
3309 result = &PL_vtbl_isaelem;
3311 case want_vtbl_arylen:
3312 result = &PL_vtbl_arylen;
3314 case want_vtbl_mglob:
3315 result = &PL_vtbl_mglob;
3317 case want_vtbl_nkeys:
3318 result = &PL_vtbl_nkeys;
3320 case want_vtbl_taint:
3321 result = &PL_vtbl_taint;
3323 case want_vtbl_substr:
3324 result = &PL_vtbl_substr;
3327 result = &PL_vtbl_vec;
3330 result = &PL_vtbl_pos;
3333 result = &PL_vtbl_bm;
3336 result = &PL_vtbl_fm;
3338 case want_vtbl_uvar:
3339 result = &PL_vtbl_uvar;
3341 case want_vtbl_defelem:
3342 result = &PL_vtbl_defelem;
3344 case want_vtbl_regexp:
3345 result = &PL_vtbl_regexp;
3347 case want_vtbl_regdata:
3348 result = &PL_vtbl_regdata;
3350 case want_vtbl_regdatum:
3351 result = &PL_vtbl_regdatum;
3353 #ifdef USE_LOCALE_COLLATE
3354 case want_vtbl_collxfrm:
3355 result = &PL_vtbl_collxfrm;
3358 case want_vtbl_amagic:
3359 result = &PL_vtbl_amagic;
3361 case want_vtbl_amagicelem:
3362 result = &PL_vtbl_amagicelem;
3364 case want_vtbl_backref:
3365 result = &PL_vtbl_backref;
3367 case want_vtbl_utf8:
3368 result = &PL_vtbl_utf8;
3374 return (MGVTBL*)result;
3378 Perl_my_fflush_all(pTHX)
3380 #if defined(USE_PERLIO) || defined(FFLUSH_NULL) || defined(USE_SFIO)
3381 return PerlIO_flush(NULL);
3383 # if defined(HAS__FWALK)
3384 extern int fflush(FILE *);
3385 /* undocumented, unprototyped, but very useful BSDism */
3386 extern void _fwalk(int (*)(FILE *));
3390 # if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
3392 # ifdef PERL_FFLUSH_ALL_FOPEN_MAX
3393 open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
3395 # if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
3396 open_max = sysconf(_SC_OPEN_MAX);
3399 open_max = FOPEN_MAX;
3402 open_max = OPEN_MAX;
3413 for (i = 0; i < open_max; i++)
3414 if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
3415 STDIO_STREAM_ARRAY[i]._file < open_max &&
3416 STDIO_STREAM_ARRAY[i]._flag)
3417 PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
3421 SETERRNO(EBADF,RMS_IFI);
3428 Perl_report_evil_fh(pTHX_ const GV *gv, const IO *io, I32 op)
3430 const char * const func =
3431 op == OP_READLINE ? "readline" : /* "<HANDLE>" not nice */
3432 op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */
3433 op < 0 ? "" : /* handle phoney cases */
3435 const char * const pars = OP_IS_FILETEST(op) ? "" : "()";
3436 const char * const type = OP_IS_SOCKET(op)
3437 || (gv && io && IoTYPE(io) == IoTYPE_SOCKET)
3438 ? "socket" : "filehandle";
3439 const char * const name = gv && isGV(gv) ? GvENAME(gv) : NULL;
3441 if (op == OP_phoney_OUTPUT_ONLY || op == OP_phoney_INPUT_ONLY) {
3442 if (ckWARN(WARN_IO)) {
3443 const char * const direction = (op == OP_phoney_INPUT_ONLY) ? "in" : "out";
3445 Perl_warner(aTHX_ packWARN(WARN_IO),
3446 "Filehandle %s opened only for %sput",
3449 Perl_warner(aTHX_ packWARN(WARN_IO),
3450 "Filehandle opened only for %sput", direction);
3457 if (gv && io && IoTYPE(io) == IoTYPE_CLOSED) {
3459 warn_type = WARN_CLOSED;
3463 warn_type = WARN_UNOPENED;
3466 if (ckWARN(warn_type)) {
3467 if (name && *name) {
3468 Perl_warner(aTHX_ packWARN(warn_type),
3469 "%s%s on %s %s %s", func, pars, vile, type, name);
3470 if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3472 aTHX_ packWARN(warn_type),
3473 "\t(Are you trying to call %s%s on dirhandle %s?)\n",
3478 Perl_warner(aTHX_ packWARN(warn_type),
3479 "%s%s on %s %s", func, pars, vile, type);
3480 if (gv && io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3482 aTHX_ packWARN(warn_type),
3483 "\t(Are you trying to call %s%s on dirhandle?)\n",
3492 /* in ASCII order, not that it matters */
3493 static const char controllablechars[] = "?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_";
3496 Perl_ebcdic_control(pTHX_ int ch)
3504 if ((ctlp = strchr(controllablechars, ch)) == 0) {
3505 Perl_die(aTHX_ "unrecognised control character '%c'\n", ch);
3508 if (ctlp == controllablechars)
3509 return('\177'); /* DEL */
3511 return((unsigned char)(ctlp - controllablechars - 1));
3512 } else { /* Want uncontrol */
3513 if (ch == '\177' || ch == -1)
3515 else if (ch == '\157')
3517 else if (ch == '\174')
3519 else if (ch == '^') /* '\137' in 1047, '\260' in 819 */
3521 else if (ch == '\155')
3523 else if (0 < ch && ch < (sizeof(controllablechars) - 1))
3524 return(controllablechars[ch+1]);
3526 Perl_die(aTHX_ "invalid control request: '\\%03o'\n", ch & 0xFF);
3531 /* To workaround core dumps from the uninitialised tm_zone we get the
3532 * system to give us a reasonable struct to copy. This fix means that
3533 * strftime uses the tm_zone and tm_gmtoff values returned by
3534 * localtime(time()). That should give the desired result most of the
3535 * time. But probably not always!
3537 * This does not address tzname aspects of NETaa14816.
3542 # ifndef STRUCT_TM_HASZONE
3543 # define STRUCT_TM_HASZONE
3547 #ifdef STRUCT_TM_HASZONE /* Backward compat */
3548 # ifndef HAS_TM_TM_ZONE
3549 # define HAS_TM_TM_ZONE
3554 Perl_init_tm(pTHX_ struct tm *ptm) /* see mktime, strftime and asctime */
3556 #ifdef HAS_TM_TM_ZONE
3558 const struct tm* my_tm;
3560 my_tm = localtime(&now);
3562 Copy(my_tm, ptm, 1, struct tm);
3564 PERL_UNUSED_ARG(ptm);
3569 * mini_mktime - normalise struct tm values without the localtime()
3570 * semantics (and overhead) of mktime().
3573 Perl_mini_mktime(pTHX_ struct tm *ptm)
3577 int month, mday, year, jday;
3578 int odd_cent, odd_year;
3579 PERL_UNUSED_CONTEXT;
3581 #define DAYS_PER_YEAR 365
3582 #define DAYS_PER_QYEAR (4*DAYS_PER_YEAR+1)
3583 #define DAYS_PER_CENT (25*DAYS_PER_QYEAR-1)
3584 #define DAYS_PER_QCENT (4*DAYS_PER_CENT+1)
3585 #define SECS_PER_HOUR (60*60)
3586 #define SECS_PER_DAY (24*SECS_PER_HOUR)
3587 /* parentheses deliberately absent on these two, otherwise they don't work */
3588 #define MONTH_TO_DAYS 153/5
3589 #define DAYS_TO_MONTH 5/153
3590 /* offset to bias by March (month 4) 1st between month/mday & year finding */
3591 #define YEAR_ADJUST (4*MONTH_TO_DAYS+1)
3592 /* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */
3593 #define WEEKDAY_BIAS 6 /* (1+6)%7 makes Sunday 0 again */
3596 * Year/day algorithm notes:
3598 * With a suitable offset for numeric value of the month, one can find
3599 * an offset into the year by considering months to have 30.6 (153/5) days,
3600 * using integer arithmetic (i.e., with truncation). To avoid too much
3601 * messing about with leap days, we consider January and February to be
3602 * the 13th and 14th month of the previous year. After that transformation,
3603 * we need the month index we use to be high by 1 from 'normal human' usage,
3604 * so the month index values we use run from 4 through 15.
3606 * Given that, and the rules for the Gregorian calendar (leap years are those
3607 * divisible by 4 unless also divisible by 100, when they must be divisible
3608 * by 400 instead), we can simply calculate the number of days since some
3609 * arbitrary 'beginning of time' by futzing with the (adjusted) year number,
3610 * the days we derive from our month index, and adding in the day of the
3611 * month. The value used here is not adjusted for the actual origin which
3612 * it normally would use (1 January A.D. 1), since we're not exposing it.
3613 * We're only building the value so we can turn around and get the
3614 * normalised values for the year, month, day-of-month, and day-of-year.
3616 * For going backward, we need to bias the value we're using so that we find
3617 * the right year value. (Basically, we don't want the contribution of
3618 * March 1st to the number to apply while deriving the year). Having done
3619 * that, we 'count up' the contribution to the year number by accounting for
3620 * full quadracenturies (400-year periods) with their extra leap days, plus
3621 * the contribution from full centuries (to avoid counting in the lost leap
3622 * days), plus the contribution from full quad-years (to count in the normal
3623 * leap days), plus the leftover contribution from any non-leap years.
3624 * At this point, if we were working with an actual leap day, we'll have 0
3625 * days left over. This is also true for March 1st, however. So, we have
3626 * to special-case that result, and (earlier) keep track of the 'odd'
3627 * century and year contributions. If we got 4 extra centuries in a qcent,
3628 * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb.
3629 * Otherwise, we add back in the earlier bias we removed (the 123 from
3630 * figuring in March 1st), find the month index (integer division by 30.6),
3631 * and the remainder is the day-of-month. We then have to convert back to
3632 * 'real' months (including fixing January and February from being 14/15 in
3633 * the previous year to being in the proper year). After that, to get
3634 * tm_yday, we work with the normalised year and get a new yearday value for
3635 * January 1st, which we subtract from the yearday value we had earlier,
3636 * representing the date we've re-built. This is done from January 1
3637 * because tm_yday is 0-origin.
3639 * Since POSIX time routines are only guaranteed to work for times since the
3640 * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm
3641 * applies Gregorian calendar rules even to dates before the 16th century
3642 * doesn't bother me. Besides, you'd need cultural context for a given
3643 * date to know whether it was Julian or Gregorian calendar, and that's
3644 * outside the scope for this routine. Since we convert back based on the
3645 * same rules we used to build the yearday, you'll only get strange results
3646 * for input which needed normalising, or for the 'odd' century years which
3647 * were leap years in the Julian calander but not in the Gregorian one.
3648 * I can live with that.
3650 * This algorithm also fails to handle years before A.D. 1 gracefully, but
3651 * that's still outside the scope for POSIX time manipulation, so I don't
3655 year = 1900 + ptm->tm_year;
3656 month = ptm->tm_mon;
3657 mday = ptm->tm_mday;
3658 /* allow given yday with no month & mday to dominate the result */
3659 if (ptm->tm_yday >= 0 && mday <= 0 && month <= 0) {
3662 jday = 1 + ptm->tm_yday;
3671 yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400;
3672 yearday += month*MONTH_TO_DAYS + mday + jday;
3674 * Note that we don't know when leap-seconds were or will be,
3675 * so we have to trust the user if we get something which looks
3676 * like a sensible leap-second. Wild values for seconds will
3677 * be rationalised, however.
3679 if ((unsigned) ptm->tm_sec <= 60) {
3686 secs += 60 * ptm->tm_min;
3687 secs += SECS_PER_HOUR * ptm->tm_hour;
3689 if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) {
3690 /* got negative remainder, but need positive time */
3691 /* back off an extra day to compensate */
3692 yearday += (secs/SECS_PER_DAY)-1;
3693 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1);
3696 yearday += (secs/SECS_PER_DAY);
3697 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY);
3700 else if (secs >= SECS_PER_DAY) {
3701 yearday += (secs/SECS_PER_DAY);
3702 secs %= SECS_PER_DAY;
3704 ptm->tm_hour = secs/SECS_PER_HOUR;
3705 secs %= SECS_PER_HOUR;
3706 ptm->tm_min = secs/60;
3708 ptm->tm_sec += secs;
3709 /* done with time of day effects */
3711 * The algorithm for yearday has (so far) left it high by 428.
3712 * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to
3713 * bias it by 123 while trying to figure out what year it
3714 * really represents. Even with this tweak, the reverse
3715 * translation fails for years before A.D. 0001.
3716 * It would still fail for Feb 29, but we catch that one below.
3718 jday = yearday; /* save for later fixup vis-a-vis Jan 1 */
3719 yearday -= YEAR_ADJUST;
3720 year = (yearday / DAYS_PER_QCENT) * 400;
3721 yearday %= DAYS_PER_QCENT;
3722 odd_cent = yearday / DAYS_PER_CENT;
3723 year += odd_cent * 100;
3724 yearday %= DAYS_PER_CENT;
3725 year += (yearday / DAYS_PER_QYEAR) * 4;
3726 yearday %= DAYS_PER_QYEAR;
3727 odd_year = yearday / DAYS_PER_YEAR;
3729 yearday %= DAYS_PER_YEAR;
3730 if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */
3735 yearday += YEAR_ADJUST; /* recover March 1st crock */
3736 month = yearday*DAYS_TO_MONTH;
3737 yearday -= month*MONTH_TO_DAYS;
3738 /* recover other leap-year adjustment */
3747 ptm->tm_year = year - 1900;
3749 ptm->tm_mday = yearday;
3750 ptm->tm_mon = month;
3754 ptm->tm_mon = month - 1;
3756 /* re-build yearday based on Jan 1 to get tm_yday */
3758 yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400;
3759 yearday += 14*MONTH_TO_DAYS + 1;
3760 ptm->tm_yday = jday - yearday;
3761 /* fix tm_wday if not overridden by caller */
3762 if ((unsigned)ptm->tm_wday > 6)
3763 ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
3767 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)
3775 init_tm(&mytm); /* XXX workaround - see init_tm() above */
3778 mytm.tm_hour = hour;
3779 mytm.tm_mday = mday;
3781 mytm.tm_year = year;
3782 mytm.tm_wday = wday;
3783 mytm.tm_yday = yday;
3784 mytm.tm_isdst = isdst;
3786 /* use libc to get the values for tm_gmtoff and tm_zone [perl #18238] */
3787 #if defined(HAS_MKTIME) && (defined(HAS_TM_TM_GMTOFF) || defined(HAS_TM_TM_ZONE))
3792 #ifdef HAS_TM_TM_GMTOFF
3793 mytm.tm_gmtoff = mytm2.tm_gmtoff;
3795 #ifdef HAS_TM_TM_ZONE
3796 mytm.tm_zone = mytm2.tm_zone;
3801 Newx(buf, buflen, char);
3802 len = strftime(buf, buflen, fmt, &mytm);
3804 ** The following is needed to handle to the situation where
3805 ** tmpbuf overflows. Basically we want to allocate a buffer
3806 ** and try repeatedly. The reason why it is so complicated
3807 ** is that getting a return value of 0 from strftime can indicate
3808 ** one of the following:
3809 ** 1. buffer overflowed,
3810 ** 2. illegal conversion specifier, or
3811 ** 3. the format string specifies nothing to be returned(not
3812 ** an error). This could be because format is an empty string
3813 ** or it specifies %p that yields an empty string in some locale.
3814 ** If there is a better way to make it portable, go ahead by
3817 if ((len > 0 && len < buflen) || (len == 0 && *fmt == '\0'))
3820 /* Possibly buf overflowed - try again with a bigger buf */
3821 const int fmtlen = strlen(fmt);
3822 const int bufsize = fmtlen + buflen;
3824 Newx(buf, bufsize, char);
3826 buflen = strftime(buf, bufsize, fmt, &mytm);
3827 if (buflen > 0 && buflen < bufsize)
3829 /* heuristic to prevent out-of-memory errors */
3830 if (bufsize > 100*fmtlen) {
3835 Renew(buf, bufsize*2, char);
3840 Perl_croak(aTHX_ "panic: no strftime");
3846 #define SV_CWD_RETURN_UNDEF \
3847 sv_setsv(sv, &PL_sv_undef); \
3850 #define SV_CWD_ISDOT(dp) \
3851 (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
3852 (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
3855 =head1 Miscellaneous Functions
3857 =for apidoc getcwd_sv
3859 Fill the sv with current working directory
3864 /* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars.
3865 * rewritten again by dougm, optimized for use with xs TARG, and to prefer
3866 * getcwd(3) if available
3867 * Comments from the orignal:
3868 * This is a faster version of getcwd. It's also more dangerous
3869 * because you might chdir out of a directory that you can't chdir
3873 Perl_getcwd_sv(pTHX_ register SV *sv)
3877 #ifndef INCOMPLETE_TAINTS
3883 char buf[MAXPATHLEN];
3885 /* Some getcwd()s automatically allocate a buffer of the given
3886 * size from the heap if they are given a NULL buffer pointer.
3887 * The problem is that this behaviour is not portable. */
3888 if (getcwd(buf, sizeof(buf) - 1)) {
3893 sv_setsv(sv, &PL_sv_undef);
3901 int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
3905 SvUPGRADE(sv, SVt_PV);
3907 if (PerlLIO_lstat(".", &statbuf) < 0) {
3908 SV_CWD_RETURN_UNDEF;
3911 orig_cdev = statbuf.st_dev;
3912 orig_cino = statbuf.st_ino;
3921 if (PerlDir_chdir("..") < 0) {
3922 SV_CWD_RETURN_UNDEF;
3924 if (PerlLIO_stat(".", &statbuf) < 0) {
3925 SV_CWD_RETURN_UNDEF;
3928 cdev = statbuf.st_dev;
3929 cino = statbuf.st_ino;
3931 if (odev == cdev && oino == cino) {
3934 if (!(dir = PerlDir_open("."))) {
3935 SV_CWD_RETURN_UNDEF;
3938 while ((dp = PerlDir_read(dir)) != NULL) {
3940 const int namelen = dp->d_namlen;
3942 const int namelen = strlen(dp->d_name);
3945 if (SV_CWD_ISDOT(dp)) {
3949 if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
3950 SV_CWD_RETURN_UNDEF;
3953 tdev = statbuf.st_dev;
3954 tino = statbuf.st_ino;
3955 if (tino == oino && tdev == odev) {
3961 SV_CWD_RETURN_UNDEF;
3964 if (pathlen + namelen + 1 >= MAXPATHLEN) {
3965 SV_CWD_RETURN_UNDEF;
3968 SvGROW(sv, pathlen + namelen + 1);
3972 Move(SvPVX_const(sv), SvPVX(sv) + namelen + 1, pathlen, char);
3975 /* prepend current directory to the front */
3977 Move(dp->d_name, SvPVX(sv)+1, namelen, char);
3978 pathlen += (namelen + 1);
3980 #ifdef VOID_CLOSEDIR
3983 if (PerlDir_close(dir) < 0) {
3984 SV_CWD_RETURN_UNDEF;
3990 SvCUR_set(sv, pathlen);
3994 if (PerlDir_chdir(SvPVX_const(sv)) < 0) {
3995 SV_CWD_RETURN_UNDEF;
3998 if (PerlLIO_stat(".", &statbuf) < 0) {
3999 SV_CWD_RETURN_UNDEF;
4002 cdev = statbuf.st_dev;
4003 cino = statbuf.st_ino;
4005 if (cdev != orig_cdev || cino != orig_cino) {
4006 Perl_croak(aTHX_ "Unstable directory path, "
4007 "current directory changed unexpectedly");
4019 =for apidoc scan_version
4021 Returns a pointer to the next character after the parsed
4022 version string, as well as upgrading the passed in SV to
4025 Function must be called with an already existing SV like
4028 s = scan_version(s,SV *sv, bool qv);
4030 Performs some preprocessing to the string to ensure that
4031 it has the correct characteristics of a version. Flags the
4032 object if it contains an underscore (which denotes this
4033 is a alpha version). The boolean qv denotes that the version
4034 should be interpreted as if it had multiple decimals, even if
4041 Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
4049 AV * const av = newAV();
4050 SV * const hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
4051 (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
4053 #ifndef NODEFAULT_SHAREKEYS
4054 HvSHAREKEYS_on(hv); /* key-sharing on by default */
4057 while (isSPACE(*s)) /* leading whitespace is OK */
4061 s++; /* get past 'v' */
4062 qv = 1; /* force quoted version processing */
4065 start = last = pos = s;
4067 /* pre-scan the input string to check for decimals/underbars */
4068 while ( *pos == '.' || *pos == '_' || isDIGIT(*pos) )
4073 Perl_croak(aTHX_ "Invalid version format (underscores before decimal)");
4077 else if ( *pos == '_' )
4080 Perl_croak(aTHX_ "Invalid version format (multiple underscores)");
4082 width = pos - last - 1; /* natural width of sub-version */
4087 if ( alpha && !saw_period )
4088 Perl_croak(aTHX_ "Invalid version format (alpha without decimal)");
4090 if ( saw_period > 1 )
4091 qv = 1; /* force quoted version processing */
4096 hv_store((HV *)hv, "qv", 2, newSViv(qv), 0);
4098 hv_store((HV *)hv, "alpha", 5, newSViv(alpha), 0);
4099 if ( !qv && width < 3 )
4100 hv_store((HV *)hv, "width", 5, newSViv(width), 0);
4102 while (isDIGIT(*pos))
4104 if (!isALPHA(*pos)) {
4110 /* this is atoi() that delimits on underscores */
4111 const char *end = pos;
4115 /* the following if() will only be true after the decimal
4116 * point of a version originally created with a bare
4117 * floating point number, i.e. not quoted in any way
4119 if ( !qv && s > start && saw_period == 1 ) {
4123 rev += (*s - '0') * mult;
4125 if ( PERL_ABS(orev) > PERL_ABS(rev) )
4126 Perl_croak(aTHX_ "Integer overflow in version");
4133 while (--end >= s) {
4135 rev += (*end - '0') * mult;
4137 if ( PERL_ABS(orev) > PERL_ABS(rev) )
4138 Perl_croak(aTHX_ "Integer overflow in version");
4143 /* Append revision */
4144 av_push(av, newSViv(rev));
4145 if ( *pos == '.' && isDIGIT(pos[1]) )
4147 else if ( *pos == '_' && isDIGIT(pos[1]) )
4149 else if ( isDIGIT(*pos) )
4156 while ( isDIGIT(*pos) )
4161 while ( ( isDIGIT(*pos) || *pos == '_' ) && digits < 3 ) {
4169 if ( qv ) { /* quoted versions always get at least three terms*/
4170 I32 len = av_len(av);
4171 /* This for loop appears to trigger a compiler bug on OS X, as it
4172 loops infinitely. Yes, len is negative. No, it makes no sense.
4173 Compiler in question is:
4174 gcc version 3.3 20030304 (Apple Computer, Inc. build 1640)
4175 for ( len = 2 - len; len > 0; len-- )
4176 av_push((AV *)sv, newSViv(0));
4180 av_push(av, newSViv(0));
4183 if ( av_len(av) == -1 ) /* oops, someone forgot to pass a value */
4184 av_push(av, newSViv(0));
4186 /* And finally, store the AV in the hash */
4187 hv_store((HV *)hv, "version", 7, newRV_noinc((SV *)av), 0);
4192 =for apidoc new_version
4194 Returns a new version object based on the passed in SV:
4196 SV *sv = new_version(SV *ver);
4198 Does not alter the passed in ver SV. See "upg_version" if you
4199 want to upgrade the SV.
4205 Perl_new_version(pTHX_ SV *ver)
4208 SV * const rv = newSV(0);
4209 if ( sv_derived_from(ver,"version") ) /* can just copy directly */
4212 AV * const av = newAV();
4214 /* This will get reblessed later if a derived class*/
4215 SV * const hv = newSVrv(rv, "version");
4216 (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
4217 #ifndef NODEFAULT_SHAREKEYS
4218 HvSHAREKEYS_on(hv); /* key-sharing on by default */
4224 /* Begin copying all of the elements */
4225 if ( hv_exists((HV *)ver, "qv", 2) )
4226 hv_store((HV *)hv, "qv", 2, &PL_sv_yes, 0);
4228 if ( hv_exists((HV *)ver, "alpha", 5) )
4229 hv_store((HV *)hv, "alpha", 5, &PL_sv_yes, 0);
4231 if ( hv_exists((HV*)ver, "width", 5 ) )
4233 const I32 width = SvIV(*hv_fetchs((HV*)ver, "width", FALSE));
4234 hv_store((HV *)hv, "width", 5, newSViv(width), 0);
4237 sav = (AV *)SvRV(*hv_fetchs((HV*)ver, "version", FALSE));
4238 /* This will get reblessed later if a derived class*/
4239 for ( key = 0; key <= av_len(sav); key++ )
4241 const I32 rev = SvIV(*av_fetch(sav, key, FALSE));
4242 av_push(av, newSViv(rev));
4245 hv_store((HV *)hv, "version", 7, newRV_noinc((SV *)av), 0);
4250 const MAGIC* const mg = SvVOK(ver);
4251 if ( mg ) { /* already a v-string */
4252 const STRLEN len = mg->mg_len;
4253 char * const version = savepvn( (const char*)mg->mg_ptr, len);
4254 sv_setpvn(rv,version,len);
4259 sv_setsv(rv,ver); /* make a duplicate */
4264 return upg_version(rv);
4268 =for apidoc upg_version
4270 In-place upgrade of the supplied SV to a version object.
4272 SV *sv = upg_version(SV *sv);
4274 Returns a pointer to the upgraded SV.
4280 Perl_upg_version(pTHX_ SV *ver)
4282 const char *version, *s;
4288 if ( SvNOK(ver) ) /* may get too much accuracy */
4291 const STRLEN len = my_sprintf(tbuf,"%.9"NVgf, SvNVX(ver));
4292 version = savepvn(tbuf, len);
4295 else if ( (mg = SvVOK(ver)) ) { /* already a v-string */
4296 version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
4300 else /* must be a string or something like a string */
4302 version = savepv(SvPV_nolen(ver));
4304 s = scan_version(version, ver, qv);
4306 if(ckWARN(WARN_MISC))
4307 Perl_warner(aTHX_ packWARN(WARN_MISC),
4308 "Version string '%s' contains invalid data; "
4309 "ignoring: '%s'", version, s);
4317 Validates that the SV contains a valid version object.
4319 bool vverify(SV *vobj);
4321 Note that it only confirms the bare minimum structure (so as not to get
4322 confused by derived classes which may contain additional hash entries):
4326 =item * The SV contains a [reference to a] hash
4328 =item * The hash contains a "version" key
4330 =item * The "version" key has [a reference to] an AV as its value
4338 Perl_vverify(pTHX_ SV *vs)
4344 /* see if the appropriate elements exist */
4345 if ( SvTYPE(vs) == SVt_PVHV
4346 && hv_exists((HV*)vs, "version", 7)
4347 && (sv = SvRV(*hv_fetchs((HV*)vs, "version", FALSE)))
4348 && SvTYPE(sv) == SVt_PVAV )
4357 Accepts a version object and returns the normalized floating
4358 point representation. Call like:
4362 NOTE: you can pass either the object directly or the SV
4363 contained within the RV.
4369 Perl_vnumify(pTHX_ SV *vs)
4374 SV * const sv = newSV(0);
4380 Perl_croak(aTHX_ "Invalid version object");
4382 /* see if various flags exist */
4383 if ( hv_exists((HV*)vs, "alpha", 5 ) )
4385 if ( hv_exists((HV*)vs, "width", 5 ) )
4386 width = SvIV(*hv_fetchs((HV*)vs, "width", FALSE));
4391 /* attempt to retrieve the version array */
4392 if ( !(av = (AV *)SvRV(*hv_fetchs((HV*)vs, "version", FALSE)) ) ) {
4404 digit = SvIV(*av_fetch(av, 0, 0));
4405 Perl_sv_setpvf(aTHX_ sv, "%d.", (int)PERL_ABS(digit));
4406 for ( i = 1 ; i < len ; i++ )
4408 digit = SvIV(*av_fetch(av, i, 0));
4410 const int denom = (width == 2 ? 10 : 100);
4411 const div_t term = div((int)PERL_ABS(digit),denom);
4412 Perl_sv_catpvf(aTHX_ sv, "%0*d_%d", width, term.quot, term.rem);
4415 Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
4421 digit = SvIV(*av_fetch(av, len, 0));
4422 if ( alpha && width == 3 ) /* alpha version */
4424 Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
4428 sv_catpvs(sv, "000");
4436 Accepts a version object and returns the normalized string
4437 representation. Call like:
4441 NOTE: you can pass either the object directly or the SV
4442 contained within the RV.
4448 Perl_vnormal(pTHX_ SV *vs)
4452 SV * const sv = newSV(0);
4458 Perl_croak(aTHX_ "Invalid version object");
4460 if ( hv_exists((HV*)vs, "alpha", 5 ) )
4462 av = (AV *)SvRV(*hv_fetchs((HV*)vs, "version", FALSE));
4470 digit = SvIV(*av_fetch(av, 0, 0));
4471 Perl_sv_setpvf(aTHX_ sv, "v%"IVdf, (IV)digit);
4472 for ( i = 1 ; i < len ; i++ ) {
4473 digit = SvIV(*av_fetch(av, i, 0));
4474 Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
4479 /* handle last digit specially */
4480 digit = SvIV(*av_fetch(av, len, 0));
4482 Perl_sv_catpvf(aTHX_ sv, "_%"IVdf, (IV)digit);
4484 Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
4487 if ( len <= 2 ) { /* short version, must be at least three */
4488 for ( len = 2 - len; len != 0; len-- )
4495 =for apidoc vstringify
4497 In order to maintain maximum compatibility with earlier versions
4498 of Perl, this function will return either the floating point
4499 notation or the multiple dotted notation, depending on whether
4500 the original version contained 1 or more dots, respectively
4506 Perl_vstringify(pTHX_ SV *vs)
4512 Perl_croak(aTHX_ "Invalid version object");
4514 if ( hv_exists((HV *)vs, "qv", 2) )
4523 Version object aware cmp. Both operands must already have been
4524 converted into version objects.
4530 Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
4533 bool lalpha = FALSE;
4534 bool ralpha = FALSE;
4543 if ( !vverify(lhv) )
4544 Perl_croak(aTHX_ "Invalid version object");
4546 if ( !vverify(rhv) )
4547 Perl_croak(aTHX_ "Invalid version object");
4549 /* get the left hand term */
4550 lav = (AV *)SvRV(*hv_fetchs((HV*)lhv, "version", FALSE));
4551 if ( hv_exists((HV*)lhv, "alpha", 5 ) )
4554 /* and the right hand term */
4555 rav = (AV *)SvRV(*hv_fetchs((HV*)rhv, "version", FALSE));
4556 if ( hv_exists((HV*)rhv, "alpha", 5 ) )
4564 while ( i <= m && retval == 0 )
4566 left = SvIV(*av_fetch(lav,i,0));
4567 right = SvIV(*av_fetch(rav,i,0));
4575 /* tiebreaker for alpha with identical terms */
4576 if ( retval == 0 && l == r && left == right && ( lalpha || ralpha ) )
4578 if ( lalpha && !ralpha )
4582 else if ( ralpha && !lalpha)
4588 if ( l != r && retval == 0 ) /* possible match except for trailing 0's */
4592 while ( i <= r && retval == 0 )
4594 if ( SvIV(*av_fetch(rav,i,0)) != 0 )
4595 retval = -1; /* not a match after all */
4601 while ( i <= l && retval == 0 )
4603 if ( SvIV(*av_fetch(lav,i,0)) != 0 )
4604 retval = +1; /* not a match after all */
4612 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT)
4613 # define EMULATE_SOCKETPAIR_UDP
4616 #ifdef EMULATE_SOCKETPAIR_UDP
4618 S_socketpair_udp (int fd[2]) {
4620 /* Fake a datagram socketpair using UDP to localhost. */
4621 int sockets[2] = {-1, -1};
4622 struct sockaddr_in addresses[2];
4624 Sock_size_t size = sizeof(struct sockaddr_in);
4625 unsigned short port;
4628 memset(&addresses, 0, sizeof(addresses));
4631 sockets[i] = PerlSock_socket(AF_INET, SOCK_DGRAM, PF_INET);
4632 if (sockets[i] == -1)
4633 goto tidy_up_and_fail;
4635 addresses[i].sin_family = AF_INET;
4636 addresses[i].sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4637 addresses[i].sin_port = 0; /* kernel choses port. */
4638 if (PerlSock_bind(sockets[i], (struct sockaddr *) &addresses[i],
4639 sizeof(struct sockaddr_in)) == -1)
4640 goto tidy_up_and_fail;
4643 /* Now have 2 UDP sockets. Find out which port each is connected to, and
4644 for each connect the other socket to it. */
4647 if (PerlSock_getsockname(sockets[i], (struct sockaddr *) &addresses[i],
4649 goto tidy_up_and_fail;
4650 if (size != sizeof(struct sockaddr_in))
4651 goto abort_tidy_up_and_fail;
4652 /* !1 is 0, !0 is 1 */
4653 if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i],
4654 sizeof(struct sockaddr_in)) == -1)
4655 goto tidy_up_and_fail;
4658 /* Now we have 2 sockets connected to each other. I don't trust some other
4659 process not to have already sent a packet to us (by random) so send
4660 a packet from each to the other. */
4663 /* I'm going to send my own port number. As a short.
4664 (Who knows if someone somewhere has sin_port as a bitfield and needs
4665 this routine. (I'm assuming crays have socketpair)) */
4666 port = addresses[i].sin_port;
4667 got = PerlLIO_write(sockets[i], &port, sizeof(port));
4668 if (got != sizeof(port)) {
4670 goto tidy_up_and_fail;
4671 goto abort_tidy_up_and_fail;
4675 /* Packets sent. I don't trust them to have arrived though.
4676 (As I understand it Solaris TCP stack is multithreaded. Non-blocking
4677 connect to localhost will use a second kernel thread. In 2.6 the
4678 first thread running the connect() returns before the second completes,
4679 so EINPROGRESS> In 2.7 the improved stack is faster and connect()
4680 returns 0. Poor programs have tripped up. One poor program's authors'
4681 had a 50-1 reverse stock split. Not sure how connected these were.)
4682 So I don't trust someone not to have an unpredictable UDP stack.
4686 struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */
4687 int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0];
4691 FD_SET((unsigned int)sockets[0], &rset);
4692 FD_SET((unsigned int)sockets[1], &rset);
4694 got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor);
4695 if (got != 2 || !FD_ISSET(sockets[0], &rset)
4696 || !FD_ISSET(sockets[1], &rset)) {
4697 /* I hope this is portable and appropriate. */
4699 goto tidy_up_and_fail;
4700 goto abort_tidy_up_and_fail;
4704 /* And the paranoia department even now doesn't trust it to have arrive
4705 (hence MSG_DONTWAIT). Or that what arrives was sent by us. */
4707 struct sockaddr_in readfrom;
4708 unsigned short buffer[2];
4713 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4714 sizeof(buffer), MSG_DONTWAIT,
4715 (struct sockaddr *) &readfrom, &size);
4717 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4719 (struct sockaddr *) &readfrom, &size);
4723 goto tidy_up_and_fail;
4724 if (got != sizeof(port)
4725 || size != sizeof(struct sockaddr_in)
4726 /* Check other socket sent us its port. */
4727 || buffer[0] != (unsigned short) addresses[!i].sin_port
4728 /* Check kernel says we got the datagram from that socket */
4729 || readfrom.sin_family != addresses[!i].sin_family
4730 || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr
4731 || readfrom.sin_port != addresses[!i].sin_port)
4732 goto abort_tidy_up_and_fail;
4735 /* My caller (my_socketpair) has validated that this is non-NULL */
4738 /* I hereby declare this connection open. May God bless all who cross
4742 abort_tidy_up_and_fail:
4743 errno = ECONNABORTED;
4746 const int save_errno = errno;
4747 if (sockets[0] != -1)
4748 PerlLIO_close(sockets[0]);
4749 if (sockets[1] != -1)
4750 PerlLIO_close(sockets[1]);
4755 #endif /* EMULATE_SOCKETPAIR_UDP */
4757 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET)
4759 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4760 /* Stevens says that family must be AF_LOCAL, protocol 0.
4761 I'm going to enforce that, then ignore it, and use TCP (or UDP). */
4766 struct sockaddr_in listen_addr;
4767 struct sockaddr_in connect_addr;
4772 || family != AF_UNIX
4775 errno = EAFNOSUPPORT;
4783 #ifdef EMULATE_SOCKETPAIR_UDP
4784 if (type == SOCK_DGRAM)
4785 return S_socketpair_udp(fd);
4788 listener = PerlSock_socket(AF_INET, type, 0);
4791 memset(&listen_addr, 0, sizeof(listen_addr));
4792 listen_addr.sin_family = AF_INET;
4793 listen_addr.sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4794 listen_addr.sin_port = 0; /* kernel choses port. */
4795 if (PerlSock_bind(listener, (struct sockaddr *) &listen_addr,
4796 sizeof(listen_addr)) == -1)
4797 goto tidy_up_and_fail;
4798 if (PerlSock_listen(listener, 1) == -1)
4799 goto tidy_up_and_fail;
4801 connector = PerlSock_socket(AF_INET, type, 0);
4802 if (connector == -1)
4803 goto tidy_up_and_fail;
4804 /* We want to find out the port number to connect to. */
4805 size = sizeof(connect_addr);
4806 if (PerlSock_getsockname(listener, (struct sockaddr *) &connect_addr,
4808 goto tidy_up_and_fail;
4809 if (size != sizeof(connect_addr))
4810 goto abort_tidy_up_and_fail;
4811 if (PerlSock_connect(connector, (struct sockaddr *) &connect_addr,
4812 sizeof(connect_addr)) == -1)
4813 goto tidy_up_and_fail;
4815 size = sizeof(listen_addr);
4816 acceptor = PerlSock_accept(listener, (struct sockaddr *) &listen_addr,
4819 goto tidy_up_and_fail;
4820 if (size != sizeof(listen_addr))
4821 goto abort_tidy_up_and_fail;
4822 PerlLIO_close(listener);
4823 /* Now check we are talking to ourself by matching port and host on the
4825 if (PerlSock_getsockname(connector, (struct sockaddr *) &connect_addr,
4827 goto tidy_up_and_fail;
4828 if (size != sizeof(connect_addr)
4829 || listen_addr.sin_family != connect_addr.sin_family
4830 || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr
4831 || listen_addr.sin_port != connect_addr.sin_port) {
4832 goto abort_tidy_up_and_fail;
4838 abort_tidy_up_and_fail:
4840 errno = ECONNABORTED; /* This would be the standard thing to do. */
4842 # ifdef ECONNREFUSED
4843 errno = ECONNREFUSED; /* E.g. Symbian does not have ECONNABORTED. */
4845 errno = ETIMEDOUT; /* Desperation time. */
4850 const int save_errno = errno;
4852 PerlLIO_close(listener);
4853 if (connector != -1)
4854 PerlLIO_close(connector);
4856 PerlLIO_close(acceptor);
4862 /* In any case have a stub so that there's code corresponding
4863 * to the my_socketpair in global.sym. */
4865 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4866 #ifdef HAS_SOCKETPAIR
4867 return socketpair(family, type, protocol, fd);
4876 =for apidoc sv_nosharing
4878 Dummy routine which "shares" an SV when there is no sharing module present.
4879 Or "locks" it. Or "unlocks" it. In other words, ignores its single SV argument.
4880 Exists to avoid test for a NULL function pointer and because it could
4881 potentially warn under some level of strict-ness.
4887 Perl_sv_nosharing(pTHX_ SV *sv)
4889 PERL_UNUSED_CONTEXT;
4890 PERL_UNUSED_ARG(sv);
4894 Perl_parse_unicode_opts(pTHX_ const char **popt)
4896 const char *p = *popt;
4901 opt = (U32) atoi(p);
4902 while (isDIGIT(*p)) p++;
4903 if (*p && *p != '\n' && *p != '\r')
4904 Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
4909 case PERL_UNICODE_STDIN:
4910 opt |= PERL_UNICODE_STDIN_FLAG; break;
4911 case PERL_UNICODE_STDOUT:
4912 opt |= PERL_UNICODE_STDOUT_FLAG; break;
4913 case PERL_UNICODE_STDERR:
4914 opt |= PERL_UNICODE_STDERR_FLAG; break;
4915 case PERL_UNICODE_STD:
4916 opt |= PERL_UNICODE_STD_FLAG; break;
4917 case PERL_UNICODE_IN:
4918 opt |= PERL_UNICODE_IN_FLAG; break;
4919 case PERL_UNICODE_OUT:
4920 opt |= PERL_UNICODE_OUT_FLAG; break;
4921 case PERL_UNICODE_INOUT:
4922 opt |= PERL_UNICODE_INOUT_FLAG; break;
4923 case PERL_UNICODE_LOCALE:
4924 opt |= PERL_UNICODE_LOCALE_FLAG; break;
4925 case PERL_UNICODE_ARGV:
4926 opt |= PERL_UNICODE_ARGV_FLAG; break;
4927 case PERL_UNICODE_UTF8CACHEASSERT:
4928 opt |= PERL_UNICODE_UTF8CACHEASSERT_FLAG; break;
4930 if (*p != '\n' && *p != '\r')
4932 "Unknown Unicode option letter '%c'", *p);
4938 opt = PERL_UNICODE_DEFAULT_FLAGS;
4940 if (opt & ~PERL_UNICODE_ALL_FLAGS)
4941 Perl_croak(aTHX_ "Unknown Unicode option value %"UVuf,
4942 (UV) (opt & ~PERL_UNICODE_ALL_FLAGS));
4954 * This is really just a quick hack which grabs various garbage
4955 * values. It really should be a real hash algorithm which
4956 * spreads the effect of every input bit onto every output bit,
4957 * if someone who knows about such things would bother to write it.
4958 * Might be a good idea to add that function to CORE as well.
4959 * No numbers below come from careful analysis or anything here,
4960 * except they are primes and SEED_C1 > 1E6 to get a full-width
4961 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
4962 * probably be bigger too.
4965 # define SEED_C1 1000003
4966 #define SEED_C4 73819
4968 # define SEED_C1 25747
4969 #define SEED_C4 20639
4973 #define SEED_C5 26107
4975 #ifndef PERL_NO_DEV_RANDOM
4980 # include <starlet.h>
4981 /* when[] = (low 32 bits, high 32 bits) of time since epoch
4982 * in 100-ns units, typically incremented ever 10 ms. */
4983 unsigned int when[2];
4985 # ifdef HAS_GETTIMEOFDAY
4986 struct timeval when;
4992 /* This test is an escape hatch, this symbol isn't set by Configure. */
4993 #ifndef PERL_NO_DEV_RANDOM
4994 #ifndef PERL_RANDOM_DEVICE
4995 /* /dev/random isn't used by default because reads from it will block
4996 * if there isn't enough entropy available. You can compile with
4997 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
4998 * is enough real entropy to fill the seed. */
4999 # define PERL_RANDOM_DEVICE "/dev/urandom"
5001 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
5003 if (PerlLIO_read(fd, (void*)&u, sizeof u) != sizeof u)
5012 _ckvmssts(sys$gettim(when));
5013 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
5015 # ifdef HAS_GETTIMEOFDAY
5016 PerlProc_gettimeofday(&when,NULL);
5017 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
5020 u = (U32)SEED_C1 * when;
5023 u += SEED_C3 * (U32)PerlProc_getpid();
5024 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
5025 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
5026 u += SEED_C5 * (U32)PTR2UV(&when);
5032 Perl_get_hash_seed(pTHX)
5035 const char *s = PerlEnv_getenv("PERL_HASH_SEED");
5039 while (isSPACE(*s)) s++;
5040 if (s && isDIGIT(*s))
5041 myseed = (UV)Atoul(s);
5043 #ifdef USE_HASH_SEED_EXPLICIT
5047 /* Compute a random seed */
5048 (void)seedDrand01((Rand_seed_t)seed());
5049 myseed = (UV)(Drand01() * (NV)UV_MAX);
5050 #if RANDBITS < (UVSIZE * 8)
5051 /* Since there are not enough randbits to to reach all
5052 * the bits of a UV, the low bits might need extra
5053 * help. Sum in another random number that will
5054 * fill in the low bits. */
5056 (UV)(Drand01() * (NV)((1 << ((UVSIZE * 8 - RANDBITS))) - 1));
5057 #endif /* RANDBITS < (UVSIZE * 8) */
5058 if (myseed == 0) { /* Superparanoia. */
5059 myseed = (UV)(Drand01() * (NV)UV_MAX); /* One more chance. */
5061 Perl_croak(aTHX_ "Your random numbers are not that random");
5064 PL_rehash_seed_set = TRUE;
5071 Perl_stashpv_hvname_match(pTHX_ const COP *c, const HV *hv)
5073 const char * const stashpv = CopSTASHPV(c);
5074 const char * const name = HvNAME_get(hv);
5075 PERL_UNUSED_CONTEXT;
5077 if (stashpv == name)
5079 if (stashpv && name)
5080 if (strEQ(stashpv, name))
5087 #ifdef PERL_GLOBAL_STRUCT
5090 Perl_init_global_struct(pTHX)
5092 struct perl_vars *plvarsp = NULL;
5093 #ifdef PERL_GLOBAL_STRUCT
5094 # define PERL_GLOBAL_STRUCT_INIT
5095 # include "opcode.h" /* the ppaddr and check */
5096 const IV nppaddr = sizeof(Gppaddr)/sizeof(Perl_ppaddr_t);
5097 const IV ncheck = sizeof(Gcheck) /sizeof(Perl_check_t);
5098 # ifdef PERL_GLOBAL_STRUCT_PRIVATE
5099 /* PerlMem_malloc() because can't use even safesysmalloc() this early. */
5100 plvarsp = (struct perl_vars*)PerlMem_malloc(sizeof(struct perl_vars));
5104 plvarsp = PL_VarsPtr;
5105 # endif /* PERL_GLOBAL_STRUCT_PRIVATE */
5111 # define PERLVAR(var,type) /**/
5112 # define PERLVARA(var,n,type) /**/
5113 # define PERLVARI(var,type,init) plvarsp->var = init;
5114 # define PERLVARIC(var,type,init) plvarsp->var = init;
5115 # define PERLVARISC(var,init) Copy(init, plvarsp->var, sizeof(init), char);
5116 # include "perlvars.h"
5122 # ifdef PERL_GLOBAL_STRUCT
5123 plvarsp->Gppaddr = PerlMem_malloc(nppaddr * sizeof(Perl_ppaddr_t));
5124 if (!plvarsp->Gppaddr)
5126 plvarsp->Gcheck = PerlMem_malloc(ncheck * sizeof(Perl_check_t));
5127 if (!plvarsp->Gcheck)
5129 Copy(Gppaddr, plvarsp->Gppaddr, nppaddr, Perl_ppaddr_t);
5130 Copy(Gcheck, plvarsp->Gcheck, ncheck, Perl_check_t);
5132 # ifdef PERL_SET_VARS
5133 PERL_SET_VARS(plvarsp);
5135 # undef PERL_GLOBAL_STRUCT_INIT
5140 #endif /* PERL_GLOBAL_STRUCT */
5142 #ifdef PERL_GLOBAL_STRUCT
5145 Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp)
5147 #ifdef PERL_GLOBAL_STRUCT
5148 # ifdef PERL_UNSET_VARS
5149 PERL_UNSET_VARS(plvarsp);
5151 free(plvarsp->Gppaddr);
5152 free(plvarsp->Gcheck);
5153 # ifdef PERL_GLOBAL_STRUCT_PRIVATE
5159 #endif /* PERL_GLOBAL_STRUCT */
5163 #define PERL_MEM_LOG_SPRINTF_BUF_SIZE 128
5166 Perl_mem_log_alloc(const UV n, const UV typesize, const char *typename, Malloc_t newalloc, const char *filename, const int linenumber, const char *funcname)
5168 #ifdef PERL_MEM_LOG_STDERR
5169 /* We can't use PerlIO for obvious reasons. */
5170 char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
5171 const STRLEN len = my_sprintf(buf,
5172 "alloc: %s:%d:%s: %"IVdf" %"UVuf
5173 " %s = %"IVdf": %"UVxf"\n",
5174 filename, linenumber, funcname, n, typesize,
5175 typename, n * typesize, PTR2UV(newalloc));
5176 PerlLIO_write(2, buf, len);
5182 Perl_mem_log_realloc(const UV n, const UV typesize, const char *typename, Malloc_t oldalloc, Malloc_t newalloc, const char *filename, const int linenumber, const char *funcname)
5184 #ifdef PERL_MEM_LOG_STDERR
5185 /* We can't use PerlIO for obvious reasons. */
5186 char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
5187 const STRLEN len = my_sprintf(buf, "realloc: %s:%d:%s: %"IVdf" %"UVuf
5188 " %s = %"IVdf": %"UVxf" -> %"UVxf"\n",
5189 filename, linenumber, funcname, n, typesize,
5190 typename, n * typesize, PTR2UV(oldalloc),
5192 PerlLIO_write(2, buf, len);
5198 Perl_mem_log_free(Malloc_t oldalloc, const char *filename, const int linenumber, const char *funcname)
5200 #ifdef PERL_MEM_LOG_STDERR
5201 /* We can't use PerlIO for obvious reasons. */
5202 char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
5203 const STRLEN len = my_sprintf(buf, "free: %s:%d:%s: %"UVxf"\n",
5204 filename, linenumber, funcname,
5206 PerlLIO_write(2, buf, len);
5211 #endif /* PERL_MEM_LOG */
5214 =for apidoc my_sprintf
5216 The C library C<sprintf>, wrapped if necessary, to ensure that it will return
5217 the length of the string written to the buffer. Only rare pre-ANSI systems
5218 need the wrapper function - usually this is a direct call to C<sprintf>.
5222 #ifndef SPRINTF_RETURNS_STRLEN
5224 Perl_my_sprintf(char *buffer, const char* pat, ...)
5227 va_start(args, pat);
5228 vsprintf(buffer, pat, args);
5230 return strlen(buffer);
5235 Perl_my_clearenv(pTHX)
5238 #if ! defined(PERL_MICRO)
5239 # if defined(PERL_IMPLICIT_SYS) || defined(WIN32)
5241 # else /* ! (PERL_IMPLICIT_SYS || WIN32) */
5242 # if defined(USE_ENVIRON_ARRAY)
5243 # if defined(USE_ITHREADS)
5244 /* only the parent thread can clobber the process environment */
5245 if (PL_curinterp == aTHX)
5246 # endif /* USE_ITHREADS */
5248 # if ! defined(PERL_USE_SAFE_PUTENV)
5249 if ( !PL_use_safe_putenv) {
5251 if (environ == PL_origenviron)
5252 environ = (char**)safesysmalloc(sizeof(char*));
5254 for (i = 0; environ[i]; i++)
5255 (void)safesysfree(environ[i]);
5258 # else /* PERL_USE_SAFE_PUTENV */
5259 # if defined(HAS_CLEARENV)
5261 # elif defined(HAS_UNSETENV)
5262 int bsiz = 80; /* Most envvar names will be shorter than this. */
5263 char *buf = (char*)safesysmalloc(bsiz * sizeof(char));
5264 while (*environ != NULL) {
5265 char *e = strchr(*environ, '=');
5266 int l = e ? e - *environ : strlen(*environ);
5268 (void)safesysfree(buf);
5270 buf = (char*)safesysmalloc(bsiz * sizeof(char));
5272 strncpy(buf, *environ, l);
5274 (void)unsetenv(buf);
5276 (void)safesysfree(buf);
5277 # else /* ! HAS_CLEARENV && ! HAS_UNSETENV */
5278 /* Just null environ and accept the leakage. */
5280 # endif /* HAS_CLEARENV || HAS_UNSETENV */
5281 # endif /* ! PERL_USE_SAFE_PUTENV */
5283 # endif /* USE_ENVIRON_ARRAY */
5284 # endif /* PERL_IMPLICIT_SYS || WIN32 */
5285 #endif /* PERL_MICRO */
5288 #ifdef PERL_IMPLICIT_CONTEXT
5290 /* implements the MY_CXT_INIT macro. The first time a module is loaded,
5291 the global PL_my_cxt_index is incremented, and that value is assigned to
5292 that module's static my_cxt_index (who's address is passed as an arg).
5293 Then, for each interpreter this function is called for, it makes sure a
5294 void* slot is available to hang the static data off, by allocating or
5295 extending the interpreter's PL_my_cxt_list array */
5298 Perl_my_cxt_init(pTHX_ int *index, size_t size)
5303 /* this module hasn't been allocated an index yet */
5304 MUTEX_LOCK(&PL_my_ctx_mutex);
5305 *index = PL_my_cxt_index++;
5306 MUTEX_UNLOCK(&PL_my_ctx_mutex);
5309 /* make sure the array is big enough */
5310 if (PL_my_cxt_size <= *index) {
5311 if (PL_my_cxt_size) {
5312 while (PL_my_cxt_size <= *index)
5313 PL_my_cxt_size *= 2;
5314 Renew(PL_my_cxt_list, PL_my_cxt_size, void *);
5317 PL_my_cxt_size = 16;
5318 Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
5321 /* newSV() allocates one more than needed */
5322 p = (void*)SvPVX(newSV(size-1));
5323 PL_my_cxt_list[*index] = p;
5324 Zero(p, size, char);
5331 * c-indentation-style: bsd
5333 * indent-tabs-mode: t
5336 * ex: set ts=8 sts=4 sw=4 noet: