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.
63 /* Can't use PerlIO to write as it allocates memory */
64 PerlLIO_write(PerlIO_fileno(Perl_error_log),
65 PL_no_mem, strlen(PL_no_mem));
67 NORETURN_FUNCTION_END;
70 /* paranoid version of system's malloc() */
73 Perl_safesysmalloc(MEM_SIZE size)
79 PerlIO_printf(Perl_error_log,
80 "Allocation too large: %lx\n", size) FLUSH;
83 #endif /* HAS_64K_LIMIT */
84 #ifdef PERL_TRACK_MEMPOOL
89 Perl_croak_nocontext("panic: malloc");
91 ptr = (Malloc_t)PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */
92 PERL_ALLOC_CHECK(ptr);
93 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
95 #ifdef PERL_TRACK_MEMPOOL
96 ((struct perl_memory_debug_header *)ptr)->interpreter = aTHX;
98 ((struct perl_memory_debug_header *)ptr)->size = size;
99 ((struct perl_memory_debug_header *)ptr)->in_use = PERL_POISON_INUSE;
101 ptr = (Malloc_t)((char*)ptr+sTHX);
108 return write_no_mem();
113 /* paranoid version of system's realloc() */
116 Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
120 #if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) && !defined(PERL_MICRO)
121 Malloc_t PerlMem_realloc();
122 #endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */
126 PerlIO_printf(Perl_error_log,
127 "Reallocation too large: %lx\n", size) FLUSH;
130 #endif /* HAS_64K_LIMIT */
137 return safesysmalloc(size);
138 #ifdef PERL_TRACK_MEMPOOL
139 where = (Malloc_t)((char*)where-sTHX);
141 if (((struct perl_memory_debug_header *)where)->interpreter != aTHX) {
142 Perl_croak_nocontext("panic: realloc from wrong pool");
145 if (((struct perl_memory_debug_header *)where)->size > size) {
146 const MEM_SIZE freed_up =
147 ((struct perl_memory_debug_header *)where)->size - size;
148 char *start_of_freed = ((char *)where) + size;
149 Poison(start_of_freed, freed_up, char);
151 ((struct perl_memory_debug_header *)where)->size = size;
156 Perl_croak_nocontext("panic: realloc");
158 ptr = (Malloc_t)PerlMem_realloc(where,size);
159 PERL_ALLOC_CHECK(ptr);
161 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++));
162 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
165 #ifdef PERL_TRACK_MEMPOOL
166 ptr = (Malloc_t)((char*)ptr+sTHX);
173 return write_no_mem();
178 /* safe version of system's free() */
181 Perl_safesysfree(Malloc_t where)
184 #if defined(PERL_IMPLICIT_SYS) || defined(PERL_TRACK_MEMPOOL)
187 DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) free\n",PTR2UV(where),(long)PL_an++));
189 #ifdef PERL_TRACK_MEMPOOL
190 where = (Malloc_t)((char*)where-sTHX);
191 if (((struct perl_memory_debug_header *)where)->interpreter != aTHX) {
192 Perl_croak_nocontext("panic: free from wrong pool");
196 if (((struct perl_memory_debug_header *)where)->in_use
197 == PERL_POISON_FREE) {
198 Perl_croak_nocontext("panic: duplicate free");
200 if (((struct perl_memory_debug_header *)where)->in_use
201 != PERL_POISON_INUSE) {
202 Perl_croak_nocontext("panic: bad free ");
204 ((struct perl_memory_debug_header *)where)->in_use
207 Poison(where, ((struct perl_memory_debug_header *)where)->size, char);
214 /* safe version of system's calloc() */
217 Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
223 if (size * count > 0xffff) {
224 PerlIO_printf(Perl_error_log,
225 "Allocation too large: %lx\n", size * count) FLUSH;
228 #endif /* HAS_64K_LIMIT */
230 if ((long)size < 0 || (long)count < 0)
231 Perl_croak_nocontext("panic: calloc");
234 #ifdef PERL_TRACK_MEMPOOL
237 ptr = (Malloc_t)PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */
238 PERL_ALLOC_CHECK(ptr);
239 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));
241 memset((void*)ptr, 0, size);
242 #ifdef PERL_TRACK_MEMPOOL
243 ((struct perl_memory_debug_header *)ptr)->interpreter = aTHX;
245 ((struct perl_memory_debug_header *)ptr)->size = size;
246 ((struct perl_memory_debug_header *)ptr)->in_use = PERL_POISON_INUSE;
248 ptr = (Malloc_t)((char*)ptr+sTHX);
254 return write_no_mem();
257 /* These must be defined when not using Perl's malloc for binary
262 Malloc_t Perl_malloc (MEM_SIZE nbytes)
265 return (Malloc_t)PerlMem_malloc(nbytes);
268 Malloc_t Perl_calloc (MEM_SIZE elements, MEM_SIZE size)
271 return (Malloc_t)PerlMem_calloc(elements, size);
274 Malloc_t Perl_realloc (Malloc_t where, MEM_SIZE nbytes)
277 return (Malloc_t)PerlMem_realloc(where, nbytes);
280 Free_t Perl_mfree (Malloc_t where)
288 /* copy a string up to some (non-backslashed) delimiter, if any */
291 Perl_delimcpy(pTHX_ register char *to, register const char *toend, register const char *from, register const char *fromend, register int delim, I32 *retlen)
294 for (tolen = 0; from < fromend; from++, tolen++) {
296 if (from[1] == delim)
305 else if (*from == delim)
316 /* return ptr to little string in big string, NULL if not found */
317 /* This routine was donated by Corey Satten. */
320 Perl_instr(pTHX_ register const char *big, register const char *little)
330 register const char *s, *x;
333 for (x=big,s=little; *s; /**/ ) {
344 return (char*)(big-1);
349 /* same as instr but allow embedded nulls */
352 Perl_ninstr(pTHX_ const char *big, const char *bigend, const char *little, const char *lend)
357 char first = *little++;
359 bigend -= lend - little;
361 while (big <= bigend) {
364 for (x=big,s=little; s < lend; x++,s++) {
368 return (char*)(big-1);
374 /* reverse of the above--find last substring */
377 Perl_rninstr(pTHX_ register const char *big, const char *bigend, const char *little, const char *lend)
379 register const char *bigbeg;
380 register const I32 first = *little;
381 register const char * const littleend = lend;
383 if (little >= littleend)
384 return (char*)bigend;
386 big = bigend - (littleend - little++);
387 while (big >= bigbeg) {
388 register const char *s, *x;
391 for (x=big+2,s=little; s < littleend; /**/ ) {
400 return (char*)(big+1);
405 #define FBM_TABLE_OFFSET 2 /* Number of bytes between EOS and table*/
407 /* As a space optimization, we do not compile tables for strings of length
408 0 and 1, and for strings of length 2 unless FBMcf_TAIL. These are
409 special-cased in fbm_instr().
411 If FBMcf_TAIL, the table is created as if the string has a trailing \n. */
414 =head1 Miscellaneous Functions
416 =for apidoc fbm_compile
418 Analyses the string in order to make fast searches on it using fbm_instr()
419 -- the Boyer-Moore algorithm.
425 Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
427 register const U8 *s;
433 if (flags & FBMcf_TAIL) {
434 MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
435 sv_catpvs(sv, "\n"); /* Taken into account in fbm_instr() */
436 if (mg && mg->mg_len >= 0)
439 s = (U8*)SvPV_force_mutable(sv, len);
440 SvUPGRADE(sv, SVt_PVBM);
441 if (len == 0) /* TAIL might be on a zero-length string. */
444 const unsigned char *sb;
445 const U8 mlen = (len>255) ? 255 : (U8)len;
448 Sv_Grow(sv, len + 256 + FBM_TABLE_OFFSET);
449 table = (unsigned char*)(SvPVX_mutable(sv) + len + FBM_TABLE_OFFSET);
450 s = table - 1 - FBM_TABLE_OFFSET; /* last char */
451 memset((void*)table, mlen, 256);
452 table[-1] = (U8)flags;
454 sb = s - mlen + 1; /* first char (maybe) */
456 if (table[*s] == mlen)
461 sv_magic(sv, Nullsv, PERL_MAGIC_bm, Nullch, 0); /* deep magic */
464 s = (const unsigned char*)(SvPVX_const(sv)); /* deeper magic */
465 for (i = 0; i < len; i++) {
466 if (PL_freq[s[i]] < frequency) {
468 frequency = PL_freq[s[i]];
471 BmRARE(sv) = s[rarest];
472 BmPREVIOUS(sv) = (U16)rarest;
473 BmUSEFUL(sv) = 100; /* Initial value */
474 if (flags & FBMcf_TAIL)
476 DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %d\n",
477 BmRARE(sv),BmPREVIOUS(sv)));
480 /* If SvTAIL(littlestr), it has a fake '\n' at end. */
481 /* If SvTAIL is actually due to \Z or \z, this gives false positives
485 =for apidoc fbm_instr
487 Returns the location of the SV in the string delimited by C<str> and
488 C<strend>. It returns C<Nullch> if the string can't be found. The C<sv>
489 does not have to be fbm_compiled, but the search will not be as fast
496 Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *littlestr, U32 flags)
498 register unsigned char *s;
500 register const unsigned char *little
501 = (const unsigned char *)SvPV_const(littlestr,l);
502 register STRLEN littlelen = l;
503 register const I32 multiline = flags & FBMrf_MULTILINE;
505 if ((STRLEN)(bigend - big) < littlelen) {
506 if ( SvTAIL(littlestr)
507 && ((STRLEN)(bigend - big) == littlelen - 1)
509 || (*big == *little &&
510 memEQ((char *)big, (char *)little, littlelen - 1))))
515 if (littlelen <= 2) { /* Special-cased */
517 if (littlelen == 1) {
518 if (SvTAIL(littlestr) && !multiline) { /* Anchor only! */
519 /* Know that bigend != big. */
520 if (bigend[-1] == '\n')
521 return (char *)(bigend - 1);
522 return (char *) bigend;
530 if (SvTAIL(littlestr))
531 return (char *) bigend;
535 return (char*)big; /* Cannot be SvTAIL! */
538 if (SvTAIL(littlestr) && !multiline) {
539 if (bigend[-1] == '\n' && bigend[-2] == *little)
540 return (char*)bigend - 2;
541 if (bigend[-1] == *little)
542 return (char*)bigend - 1;
546 /* This should be better than FBM if c1 == c2, and almost
547 as good otherwise: maybe better since we do less indirection.
548 And we save a lot of memory by caching no table. */
549 const unsigned char c1 = little[0];
550 const unsigned char c2 = little[1];
555 while (s <= bigend) {
565 goto check_1char_anchor;
576 goto check_1char_anchor;
579 while (s <= bigend) {
584 goto check_1char_anchor;
593 check_1char_anchor: /* One char and anchor! */
594 if (SvTAIL(littlestr) && (*bigend == *little))
595 return (char *)bigend; /* bigend is already decremented. */
598 if (SvTAIL(littlestr) && !multiline) { /* tail anchored? */
599 s = bigend - littlelen;
600 if (s >= big && bigend[-1] == '\n' && *s == *little
601 /* Automatically of length > 2 */
602 && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
604 return (char*)s; /* how sweet it is */
607 && memEQ((char*)s + 2, (char*)little + 1, littlelen - 2))
609 return (char*)s + 1; /* how sweet it is */
613 if (SvTYPE(littlestr) != SVt_PVBM || !SvVALID(littlestr)) {
614 char * const b = ninstr((char*)big,(char*)bigend,
615 (char*)little, (char*)little + littlelen);
617 if (!b && SvTAIL(littlestr)) { /* Automatically multiline! */
618 /* Chop \n from littlestr: */
619 s = bigend - littlelen + 1;
621 && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
630 { /* Do actual FBM. */
631 register const unsigned char * const table = little + littlelen + FBM_TABLE_OFFSET;
632 register const unsigned char *oldlittle;
634 if (littlelen > (STRLEN)(bigend - big))
636 --littlelen; /* Last char found by table lookup */
639 little += littlelen; /* last char */
645 if ((tmp = table[*s])) {
646 if ((s += tmp) < bigend)
650 else { /* less expensive than calling strncmp() */
651 register unsigned char * const olds = s;
656 if (*--s == *--little)
658 s = olds + 1; /* here we pay the price for failure */
660 if (s < bigend) /* fake up continue to outer loop */
668 if ( s == bigend && (table[-1] & FBMcf_TAIL)
669 && memEQ((char *)(bigend - littlelen),
670 (char *)(oldlittle - littlelen), littlelen) )
671 return (char*)bigend - littlelen;
676 /* start_shift, end_shift are positive quantities which give offsets
677 of ends of some substring of bigstr.
678 If "last" we want the last occurrence.
679 old_posp is the way of communication between consequent calls if
680 the next call needs to find the .
681 The initial *old_posp should be -1.
683 Note that we take into account SvTAIL, so one can get extra
684 optimizations if _ALL flag is set.
687 /* If SvTAIL is actually due to \Z or \z, this gives false positives
688 if PL_multiline. In fact if !PL_multiline the authoritative answer
689 is not supported yet. */
692 Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last)
694 register const unsigned char *big;
696 register I32 previous;
698 register const unsigned char *little;
699 register I32 stop_pos;
700 register const unsigned char *littleend;
704 ? (pos = PL_screamfirst[BmRARE(littlestr)]) < 0
705 : (((pos = *old_posp), pos += PL_screamnext[pos]) == 0)) {
707 if ( BmRARE(littlestr) == '\n'
708 && BmPREVIOUS(littlestr) == SvCUR(littlestr) - 1) {
709 little = (const unsigned char *)(SvPVX_const(littlestr));
710 littleend = little + SvCUR(littlestr);
717 little = (const unsigned char *)(SvPVX_const(littlestr));
718 littleend = little + SvCUR(littlestr);
720 /* The value of pos we can start at: */
721 previous = BmPREVIOUS(littlestr);
722 big = (const unsigned char *)(SvPVX_const(bigstr));
723 /* The value of pos we can stop at: */
724 stop_pos = SvCUR(bigstr) - end_shift - (SvCUR(littlestr) - 1 - previous);
725 if (previous + start_shift > stop_pos) {
727 stop_pos does not include SvTAIL in the count, so this check is incorrect
728 (I think) - see [ID 20010618.006] and t/op/study.t. HVDS 2001/06/19
731 if (previous + start_shift == stop_pos + 1) /* A fake '\n'? */
736 while (pos < previous + start_shift) {
737 if (!(pos += PL_screamnext[pos]))
742 register const unsigned char *s, *x;
743 if (pos >= stop_pos) break;
744 if (big[pos] != first)
746 for (x=big+pos+1,s=little; s < littleend; /**/ ) {
752 if (s == littleend) {
754 if (!last) return (char *)(big+pos);
757 } while ( pos += PL_screamnext[pos] );
759 return (char *)(big+(*old_posp));
761 if (!SvTAIL(littlestr) || (end_shift > 0))
763 /* Ignore the trailing "\n". This code is not microoptimized */
764 big = (const unsigned char *)(SvPVX_const(bigstr) + SvCUR(bigstr));
765 stop_pos = littleend - little; /* Actual littlestr len */
770 && ((stop_pos == 1) ||
771 memEQ((char *)(big + 1), (char *)little, stop_pos - 1)))
777 Perl_ibcmp(pTHX_ const char *s1, const char *s2, register I32 len)
779 register const U8 *a = (const U8 *)s1;
780 register const U8 *b = (const U8 *)s2;
782 if (*a != *b && *a != PL_fold[*b])
790 Perl_ibcmp_locale(pTHX_ const char *s1, const char *s2, register I32 len)
793 register const U8 *a = (const U8 *)s1;
794 register const U8 *b = (const U8 *)s2;
796 if (*a != *b && *a != PL_fold_locale[*b])
803 /* copy a string to a safe spot */
806 =head1 Memory Management
810 Perl's version of C<strdup()>. Returns a pointer to a newly allocated
811 string which is a duplicate of C<pv>. The size of the string is
812 determined by C<strlen()>. The memory allocated for the new string can
813 be freed with the C<Safefree()> function.
819 Perl_savepv(pTHX_ const char *pv)
825 const STRLEN pvlen = strlen(pv)+1;
826 Newx(newaddr,pvlen,char);
827 return memcpy(newaddr,pv,pvlen);
832 /* same thing but with a known length */
837 Perl's version of what C<strndup()> would be if it existed. Returns a
838 pointer to a newly allocated string which is a duplicate of the first
839 C<len> bytes from C<pv>. The memory allocated for the new string can be
840 freed with the C<Safefree()> function.
846 Perl_savepvn(pTHX_ const char *pv, register I32 len)
848 register char *newaddr;
850 Newx(newaddr,len+1,char);
851 /* Give a meaning to NULL pointer mainly for the use in sv_magic() */
853 /* might not be null terminated */
855 return (char *) CopyD(pv,newaddr,len,char);
858 return (char *) ZeroD(newaddr,len+1,char);
863 =for apidoc savesharedpv
865 A version of C<savepv()> which allocates the duplicate string in memory
866 which is shared between threads.
871 Perl_savesharedpv(pTHX_ const char *pv)
873 register char *newaddr;
878 pvlen = strlen(pv)+1;
879 newaddr = (char*)PerlMemShared_malloc(pvlen);
881 return write_no_mem();
883 return memcpy(newaddr,pv,pvlen);
889 A version of C<savepv()>/C<savepvn()> which gets the string to duplicate from
890 the passed in SV using C<SvPV()>
896 Perl_savesvpv(pTHX_ SV *sv)
899 const char * const pv = SvPV_const(sv, len);
900 register char *newaddr;
903 Newx(newaddr,len,char);
904 return (char *) CopyD(pv,newaddr,len,char);
908 /* the SV for Perl_form() and mess() is not kept in an arena */
917 return sv_2mortal(newSVpvs(""));
922 /* Create as PVMG now, to avoid any upgrading later */
924 Newxz(any, 1, XPVMG);
925 SvFLAGS(sv) = SVt_PVMG;
926 SvANY(sv) = (void*)any;
928 SvREFCNT(sv) = 1 << 30; /* practically infinite */
933 #if defined(PERL_IMPLICIT_CONTEXT)
935 Perl_form_nocontext(const char* pat, ...)
941 retval = vform(pat, &args);
945 #endif /* PERL_IMPLICIT_CONTEXT */
948 =head1 Miscellaneous Functions
951 Takes a sprintf-style format pattern and conventional
952 (non-SV) arguments and returns the formatted string.
954 (char *) Perl_form(pTHX_ const char* pat, ...)
956 can be used any place a string (char *) is required:
958 char * s = Perl_form("%d.%d",major,minor);
960 Uses a single private buffer so if you want to format several strings you
961 must explicitly copy the earlier strings away (and free the copies when you
968 Perl_form(pTHX_ const char* pat, ...)
973 retval = vform(pat, &args);
979 Perl_vform(pTHX_ const char *pat, va_list *args)
981 SV * const sv = mess_alloc();
982 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
986 #if defined(PERL_IMPLICIT_CONTEXT)
988 Perl_mess_nocontext(const char *pat, ...)
994 retval = vmess(pat, &args);
998 #endif /* PERL_IMPLICIT_CONTEXT */
1001 Perl_mess(pTHX_ const char *pat, ...)
1005 va_start(args, pat);
1006 retval = vmess(pat, &args);
1012 S_closest_cop(pTHX_ COP *cop, const OP *o)
1014 /* Look for PL_op starting from o. cop is the last COP we've seen. */
1016 if (!o || o == PL_op)
1019 if (o->op_flags & OPf_KIDS) {
1021 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
1024 /* If the OP_NEXTSTATE has been optimised away we can still use it
1025 * the get the file and line number. */
1027 if (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE)
1030 /* Keep searching, and return when we've found something. */
1032 new_cop = closest_cop(cop, kid);
1038 /* Nothing found. */
1044 Perl_vmess(pTHX_ const char *pat, va_list *args)
1046 SV * const sv = mess_alloc();
1047 static const char dgd[] = " during global destruction.\n";
1049 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
1050 if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
1053 * Try and find the file and line for PL_op. This will usually be
1054 * PL_curcop, but it might be a cop that has been optimised away. We
1055 * can try to find such a cop by searching through the optree starting
1056 * from the sibling of PL_curcop.
1059 const COP *cop = closest_cop(PL_curcop, PL_curcop->op_sibling);
1060 if (!cop) cop = PL_curcop;
1063 Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf,
1064 OutCopFILE(cop), (IV)CopLINE(cop));
1065 if (GvIO(PL_last_in_gv) && IoLINES(GvIOp(PL_last_in_gv))) {
1066 const bool line_mode = (RsSIMPLE(PL_rs) &&
1067 SvCUR(PL_rs) == 1 && *SvPVX_const(PL_rs) == '\n');
1068 Perl_sv_catpvf(aTHX_ sv, ", <%s> %s %"IVdf,
1069 PL_last_in_gv == PL_argvgv ?
1070 "" : GvNAME(PL_last_in_gv),
1071 line_mode ? "line" : "chunk",
1072 (IV)IoLINES(GvIOp(PL_last_in_gv)));
1074 sv_catpv(sv, PL_dirty ? dgd : ".\n");
1080 Perl_write_to_stderr(pTHX_ const char* message, int msglen)
1086 if (PL_stderrgv && SvREFCNT(PL_stderrgv)
1087 && (io = GvIO(PL_stderrgv))
1088 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
1095 SAVESPTR(PL_stderrgv);
1096 PL_stderrgv = Nullgv;
1098 PUSHSTACKi(PERLSI_MAGIC);
1102 PUSHs(SvTIED_obj((SV*)io, mg));
1103 PUSHs(sv_2mortal(newSVpvn(message, msglen)));
1105 call_method("PRINT", G_SCALAR);
1113 /* SFIO can really mess with your errno */
1114 const int e = errno;
1116 PerlIO * const serr = Perl_error_log;
1118 PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
1119 (void)PerlIO_flush(serr);
1126 /* Common code used by vcroak, vdie and vwarner */
1129 S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8)
1134 /* sv_2cv might call Perl_croak() */
1135 SV * const olddiehook = PL_diehook;
1139 SAVESPTR(PL_diehook);
1140 PL_diehook = Nullsv;
1141 cv = sv_2cv(olddiehook, &stash, &gv, 0);
1143 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1150 msg = newSVpvn(message, msglen);
1151 SvFLAGS(msg) |= utf8;
1159 PUSHSTACKi(PERLSI_DIEHOOK);
1163 call_sv((SV*)cv, G_DISCARD);
1170 S_vdie_croak_common(pTHX_ const char* pat, va_list* args, STRLEN* msglen,
1174 const char *message;
1177 SV * const msv = vmess(pat, args);
1178 if (PL_errors && SvCUR(PL_errors)) {
1179 sv_catsv(PL_errors, msv);
1180 message = SvPV_const(PL_errors, *msglen);
1181 SvCUR_set(PL_errors, 0);
1184 message = SvPV_const(msv,*msglen);
1185 *utf8 = SvUTF8(msv);
1191 DEBUG_S(PerlIO_printf(Perl_debug_log,
1192 "%p: die/croak: message = %s\ndiehook = %p\n",
1193 thr, message, PL_diehook));
1195 S_vdie_common(aTHX_ message, *msglen, *utf8);
1201 Perl_vdie(pTHX_ const char* pat, va_list *args)
1203 const char *message;
1204 const int was_in_eval = PL_in_eval;
1208 DEBUG_S(PerlIO_printf(Perl_debug_log,
1209 "%p: die: curstack = %p, mainstack = %p\n",
1210 thr, PL_curstack, PL_mainstack));
1212 message = vdie_croak_common(pat, args, &msglen, &utf8);
1214 PL_restartop = die_where(message, msglen);
1215 SvFLAGS(ERRSV) |= utf8;
1216 DEBUG_S(PerlIO_printf(Perl_debug_log,
1217 "%p: die: restartop = %p, was_in_eval = %d, top_env = %p\n",
1218 thr, PL_restartop, was_in_eval, PL_top_env));
1219 if ((!PL_restartop && was_in_eval) || PL_top_env->je_prev)
1221 return PL_restartop;
1224 #if defined(PERL_IMPLICIT_CONTEXT)
1226 Perl_die_nocontext(const char* pat, ...)
1231 va_start(args, pat);
1232 o = vdie(pat, &args);
1236 #endif /* PERL_IMPLICIT_CONTEXT */
1239 Perl_die(pTHX_ const char* pat, ...)
1243 va_start(args, pat);
1244 o = vdie(pat, &args);
1250 Perl_vcroak(pTHX_ const char* pat, va_list *args)
1252 const char *message;
1256 message = S_vdie_croak_common(aTHX_ pat, args, &msglen, &utf8);
1259 PL_restartop = die_where(message, msglen);
1260 SvFLAGS(ERRSV) |= utf8;
1264 message = SvPVx_const(ERRSV, msglen);
1266 write_to_stderr(message, msglen);
1270 #if defined(PERL_IMPLICIT_CONTEXT)
1272 Perl_croak_nocontext(const char *pat, ...)
1276 va_start(args, pat);
1281 #endif /* PERL_IMPLICIT_CONTEXT */
1284 =head1 Warning and Dieing
1288 This is the XSUB-writer's interface to Perl's C<die> function.
1289 Normally call this function the same way you call the C C<printf>
1290 function. Calling C<croak> returns control directly to Perl,
1291 sidestepping the normal C order of execution. See C<warn>.
1293 If you want to throw an exception object, assign the object to
1294 C<$@> and then pass C<Nullch> to croak():
1296 errsv = get_sv("@", TRUE);
1297 sv_setsv(errsv, exception_object);
1304 Perl_croak(pTHX_ const char *pat, ...)
1307 va_start(args, pat);
1314 Perl_vwarn(pTHX_ const char* pat, va_list *args)
1318 SV * const msv = vmess(pat, args);
1319 const I32 utf8 = SvUTF8(msv);
1320 const char * const message = SvPV_const(msv, msglen);
1323 /* sv_2cv might call Perl_warn() */
1324 SV * const oldwarnhook = PL_warnhook;
1330 SAVESPTR(PL_warnhook);
1331 PL_warnhook = Nullsv;
1332 cv = sv_2cv(oldwarnhook, &stash, &gv, 0);
1334 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1339 SAVESPTR(PL_warnhook);
1340 PL_warnhook = Nullsv;
1342 msg = newSVpvn(message, msglen);
1343 SvFLAGS(msg) |= utf8;
1347 PUSHSTACKi(PERLSI_WARNHOOK);
1351 call_sv((SV*)cv, G_DISCARD);
1358 write_to_stderr(message, msglen);
1361 #if defined(PERL_IMPLICIT_CONTEXT)
1363 Perl_warn_nocontext(const char *pat, ...)
1367 va_start(args, pat);
1371 #endif /* PERL_IMPLICIT_CONTEXT */
1376 This is the XSUB-writer's interface to Perl's C<warn> function. Call this
1377 function the same way you call the C C<printf> function. See C<croak>.
1383 Perl_warn(pTHX_ const char *pat, ...)
1386 va_start(args, pat);
1391 #if defined(PERL_IMPLICIT_CONTEXT)
1393 Perl_warner_nocontext(U32 err, const char *pat, ...)
1397 va_start(args, pat);
1398 vwarner(err, pat, &args);
1401 #endif /* PERL_IMPLICIT_CONTEXT */
1404 Perl_warner(pTHX_ U32 err, const char* pat,...)
1407 va_start(args, pat);
1408 vwarner(err, pat, &args);
1413 Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args)
1417 SV * const msv = vmess(pat, args);
1419 const char * const message = SvPV_const(msv, msglen);
1420 const I32 utf8 = SvUTF8(msv);
1424 S_vdie_common(aTHX_ message, msglen, utf8);
1427 PL_restartop = die_where(message, msglen);
1428 SvFLAGS(ERRSV) |= utf8;
1431 write_to_stderr(message, msglen);
1435 Perl_vwarn(aTHX_ pat, args);
1439 /* implements the ckWARN? macros */
1442 Perl_ckwarn(pTHX_ U32 w)
1447 && PL_curcop->cop_warnings != pWARN_NONE
1449 PL_curcop->cop_warnings == pWARN_ALL
1450 || isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w))
1451 || (unpackWARN2(w) &&
1452 isWARN_on(PL_curcop->cop_warnings, unpackWARN2(w)))
1453 || (unpackWARN3(w) &&
1454 isWARN_on(PL_curcop->cop_warnings, unpackWARN3(w)))
1455 || (unpackWARN4(w) &&
1456 isWARN_on(PL_curcop->cop_warnings, unpackWARN4(w)))
1461 isLEXWARN_off && PL_dowarn & G_WARN_ON
1466 /* implements the ckWARN?_d macro */
1469 Perl_ckwarn_d(pTHX_ U32 w)
1473 || PL_curcop->cop_warnings == pWARN_ALL
1475 PL_curcop->cop_warnings != pWARN_NONE
1477 isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w))
1478 || (unpackWARN2(w) &&
1479 isWARN_on(PL_curcop->cop_warnings, unpackWARN2(w)))
1480 || (unpackWARN3(w) &&
1481 isWARN_on(PL_curcop->cop_warnings, unpackWARN3(w)))
1482 || (unpackWARN4(w) &&
1483 isWARN_on(PL_curcop->cop_warnings, unpackWARN4(w)))
1491 /* since we've already done strlen() for both nam and val
1492 * we can use that info to make things faster than
1493 * sprintf(s, "%s=%s", nam, val)
1495 #define my_setenv_format(s, nam, nlen, val, vlen) \
1496 Copy(nam, s, nlen, char); \
1498 Copy(val, s+(nlen+1), vlen, char); \
1499 *(s+(nlen+1+vlen)) = '\0'
1501 #ifdef USE_ENVIRON_ARRAY
1502 /* VMS' my_setenv() is in vms.c */
1503 #if !defined(WIN32) && !defined(NETWARE)
1505 Perl_my_setenv(pTHX_ const char *nam, const char *val)
1509 /* only parent thread can modify process environment */
1510 if (PL_curinterp == aTHX)
1513 #ifndef PERL_USE_SAFE_PUTENV
1514 if (!PL_use_safe_putenv) {
1515 /* most putenv()s leak, so we manipulate environ directly */
1516 register I32 i=setenv_getix(nam); /* where does it go? */
1519 if (environ == PL_origenviron) { /* need we copy environment? */
1524 for (max = i; environ[max]; max++) ;
1525 tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*));
1526 for (j=0; j<max; j++) { /* copy environment */
1527 const int len = strlen(environ[j]);
1528 tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char));
1529 Copy(environ[j], tmpenv[j], len+1, char);
1531 tmpenv[max] = Nullch;
1532 environ = tmpenv; /* tell exec where it is now */
1535 safesysfree(environ[i]);
1536 while (environ[i]) {
1537 environ[i] = environ[i+1];
1542 if (!environ[i]) { /* does not exist yet */
1543 environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
1544 environ[i+1] = Nullch; /* make sure it's null terminated */
1547 safesysfree(environ[i]);
1551 environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char));
1552 /* all that work just for this */
1553 my_setenv_format(environ[i], nam, nlen, val, vlen);
1556 # if defined(__CYGWIN__) || defined(EPOC) || defined(__SYMBIAN32__)
1557 # if defined(HAS_UNSETENV)
1559 (void)unsetenv(nam);
1561 (void)setenv(nam, val, 1);
1563 # else /* ! HAS_UNSETENV */
1564 (void)setenv(nam, val, 1);
1565 # endif /* HAS_UNSETENV */
1567 # if defined(HAS_UNSETENV)
1569 (void)unsetenv(nam);
1571 const int nlen = strlen(nam);
1572 const int vlen = strlen(val);
1573 char * const new_env =
1574 (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
1575 my_setenv_format(new_env, nam, nlen, val, vlen);
1576 (void)putenv(new_env);
1578 # else /* ! HAS_UNSETENV */
1580 const int nlen = strlen(nam);
1586 new_env = (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
1587 /* all that work just for this */
1588 my_setenv_format(new_env, nam, nlen, val, vlen);
1589 (void)putenv(new_env);
1590 # endif /* HAS_UNSETENV */
1591 # endif /* __CYGWIN__ */
1592 #ifndef PERL_USE_SAFE_PUTENV
1598 #else /* WIN32 || NETWARE */
1601 Perl_my_setenv(pTHX_ const char *nam, const char *val)
1604 register char *envstr;
1605 const int nlen = strlen(nam);
1612 Newx(envstr, nlen+vlen+2, char);
1613 my_setenv_format(envstr, nam, nlen, val, vlen);
1614 (void)PerlEnv_putenv(envstr);
1618 #endif /* WIN32 || NETWARE */
1622 Perl_setenv_getix(pTHX_ const char *nam)
1625 register const I32 len = strlen(nam);
1627 for (i = 0; environ[i]; i++) {
1630 strnicmp(environ[i],nam,len) == 0
1632 strnEQ(environ[i],nam,len)
1634 && environ[i][len] == '=')
1635 break; /* strnEQ must come first to avoid */
1636 } /* potential SEGV's */
1639 #endif /* !PERL_MICRO */
1641 #endif /* !VMS && !EPOC*/
1643 #ifdef UNLINK_ALL_VERSIONS
1645 Perl_unlnk(pTHX_ const char *f) /* unlink all versions of a file */
1649 for (i = 0; PerlLIO_unlink(f) >= 0; i++) ;
1654 /* this is a drop-in replacement for bcopy() */
1655 #if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY))
1657 Perl_my_bcopy(register const char *from,register char *to,register I32 len)
1659 char * const retval = to;
1661 if (from - to >= 0) {
1669 *(--to) = *(--from);
1675 /* this is a drop-in replacement for memset() */
1678 Perl_my_memset(register char *loc, register I32 ch, register I32 len)
1680 char * const retval = loc;
1688 /* this is a drop-in replacement for bzero() */
1689 #if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
1691 Perl_my_bzero(register char *loc, register I32 len)
1693 char * const retval = loc;
1701 /* this is a drop-in replacement for memcmp() */
1702 #if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
1704 Perl_my_memcmp(const char *s1, const char *s2, register I32 len)
1706 register const U8 *a = (const U8 *)s1;
1707 register const U8 *b = (const U8 *)s2;
1711 if ((tmp = *a++ - *b++))
1716 #endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */
1720 #ifdef USE_CHAR_VSPRINTF
1725 vsprintf(char *dest, const char *pat, char *args)
1729 fakebuf._ptr = dest;
1730 fakebuf._cnt = 32767;
1734 fakebuf._flag = _IOWRT|_IOSTRG;
1735 _doprnt(pat, args, &fakebuf); /* what a kludge */
1736 (void)putc('\0', &fakebuf);
1737 #ifdef USE_CHAR_VSPRINTF
1740 return 0; /* perl doesn't use return value */
1744 #endif /* HAS_VPRINTF */
1747 #if BYTEORDER != 0x4321
1749 Perl_my_swap(pTHX_ short s)
1751 #if (BYTEORDER & 1) == 0
1754 result = ((s & 255) << 8) + ((s >> 8) & 255);
1762 Perl_my_htonl(pTHX_ long l)
1766 char c[sizeof(long)];
1769 #if BYTEORDER == 0x1234
1770 u.c[0] = (l >> 24) & 255;
1771 u.c[1] = (l >> 16) & 255;
1772 u.c[2] = (l >> 8) & 255;
1776 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
1777 Perl_croak(aTHX_ "Unknown BYTEORDER\n");
1782 for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
1783 u.c[o & 0xf] = (l >> s) & 255;
1791 Perl_my_ntohl(pTHX_ long l)
1795 char c[sizeof(long)];
1798 #if BYTEORDER == 0x1234
1799 u.c[0] = (l >> 24) & 255;
1800 u.c[1] = (l >> 16) & 255;
1801 u.c[2] = (l >> 8) & 255;
1805 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
1806 Perl_croak(aTHX_ "Unknown BYTEORDER\n");
1813 for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
1814 l |= (u.c[o & 0xf] & 255) << s;
1821 #endif /* BYTEORDER != 0x4321 */
1825 * Little-endian byte order functions - 'v' for 'VAX', or 'reVerse'.
1826 * If these functions are defined,
1827 * the BYTEORDER is neither 0x1234 nor 0x4321.
1828 * However, this is not assumed.
1832 #define HTOLE(name,type) \
1834 name (register type n) \
1838 char c[sizeof(type)]; \
1841 register I32 s = 0; \
1842 for (i = 0; i < sizeof(u.c); i++, s += 8) { \
1843 u.c[i] = (n >> s) & 0xFF; \
1848 #define LETOH(name,type) \
1850 name (register type n) \
1854 char c[sizeof(type)]; \
1857 register I32 s = 0; \
1860 for (i = 0; i < sizeof(u.c); i++, s += 8) { \
1861 n |= ((type)(u.c[i] & 0xFF)) << s; \
1867 * Big-endian byte order functions.
1870 #define HTOBE(name,type) \
1872 name (register type n) \
1876 char c[sizeof(type)]; \
1879 register I32 s = 8*(sizeof(u.c)-1); \
1880 for (i = 0; i < sizeof(u.c); i++, s -= 8) { \
1881 u.c[i] = (n >> s) & 0xFF; \
1886 #define BETOH(name,type) \
1888 name (register type n) \
1892 char c[sizeof(type)]; \
1895 register I32 s = 8*(sizeof(u.c)-1); \
1898 for (i = 0; i < sizeof(u.c); i++, s -= 8) { \
1899 n |= ((type)(u.c[i] & 0xFF)) << s; \
1905 * If we just can't do it...
1908 #define NOT_AVAIL(name,type) \
1910 name (register type n) \
1912 Perl_croak_nocontext(#name "() not available"); \
1913 return n; /* not reached */ \
1917 #if defined(HAS_HTOVS) && !defined(htovs)
1920 #if defined(HAS_HTOVL) && !defined(htovl)
1923 #if defined(HAS_VTOHS) && !defined(vtohs)
1926 #if defined(HAS_VTOHL) && !defined(vtohl)
1930 #ifdef PERL_NEED_MY_HTOLE16
1932 HTOLE(Perl_my_htole16,U16)
1934 NOT_AVAIL(Perl_my_htole16,U16)
1937 #ifdef PERL_NEED_MY_LETOH16
1939 LETOH(Perl_my_letoh16,U16)
1941 NOT_AVAIL(Perl_my_letoh16,U16)
1944 #ifdef PERL_NEED_MY_HTOBE16
1946 HTOBE(Perl_my_htobe16,U16)
1948 NOT_AVAIL(Perl_my_htobe16,U16)
1951 #ifdef PERL_NEED_MY_BETOH16
1953 BETOH(Perl_my_betoh16,U16)
1955 NOT_AVAIL(Perl_my_betoh16,U16)
1959 #ifdef PERL_NEED_MY_HTOLE32
1961 HTOLE(Perl_my_htole32,U32)
1963 NOT_AVAIL(Perl_my_htole32,U32)
1966 #ifdef PERL_NEED_MY_LETOH32
1968 LETOH(Perl_my_letoh32,U32)
1970 NOT_AVAIL(Perl_my_letoh32,U32)
1973 #ifdef PERL_NEED_MY_HTOBE32
1975 HTOBE(Perl_my_htobe32,U32)
1977 NOT_AVAIL(Perl_my_htobe32,U32)
1980 #ifdef PERL_NEED_MY_BETOH32
1982 BETOH(Perl_my_betoh32,U32)
1984 NOT_AVAIL(Perl_my_betoh32,U32)
1988 #ifdef PERL_NEED_MY_HTOLE64
1990 HTOLE(Perl_my_htole64,U64)
1992 NOT_AVAIL(Perl_my_htole64,U64)
1995 #ifdef PERL_NEED_MY_LETOH64
1997 LETOH(Perl_my_letoh64,U64)
1999 NOT_AVAIL(Perl_my_letoh64,U64)
2002 #ifdef PERL_NEED_MY_HTOBE64
2004 HTOBE(Perl_my_htobe64,U64)
2006 NOT_AVAIL(Perl_my_htobe64,U64)
2009 #ifdef PERL_NEED_MY_BETOH64
2011 BETOH(Perl_my_betoh64,U64)
2013 NOT_AVAIL(Perl_my_betoh64,U64)
2017 #ifdef PERL_NEED_MY_HTOLES
2018 HTOLE(Perl_my_htoles,short)
2020 #ifdef PERL_NEED_MY_LETOHS
2021 LETOH(Perl_my_letohs,short)
2023 #ifdef PERL_NEED_MY_HTOBES
2024 HTOBE(Perl_my_htobes,short)
2026 #ifdef PERL_NEED_MY_BETOHS
2027 BETOH(Perl_my_betohs,short)
2030 #ifdef PERL_NEED_MY_HTOLEI
2031 HTOLE(Perl_my_htolei,int)
2033 #ifdef PERL_NEED_MY_LETOHI
2034 LETOH(Perl_my_letohi,int)
2036 #ifdef PERL_NEED_MY_HTOBEI
2037 HTOBE(Perl_my_htobei,int)
2039 #ifdef PERL_NEED_MY_BETOHI
2040 BETOH(Perl_my_betohi,int)
2043 #ifdef PERL_NEED_MY_HTOLEL
2044 HTOLE(Perl_my_htolel,long)
2046 #ifdef PERL_NEED_MY_LETOHL
2047 LETOH(Perl_my_letohl,long)
2049 #ifdef PERL_NEED_MY_HTOBEL
2050 HTOBE(Perl_my_htobel,long)
2052 #ifdef PERL_NEED_MY_BETOHL
2053 BETOH(Perl_my_betohl,long)
2057 Perl_my_swabn(void *ptr, int n)
2059 register char *s = (char *)ptr;
2060 register char *e = s + (n-1);
2063 for (n /= 2; n > 0; s++, e--, n--) {
2071 Perl_my_popen_list(pTHX_ char *mode, int n, SV **args)
2073 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) && !defined(NETWARE)
2075 register I32 This, that;
2081 PERL_FLUSHALL_FOR_CHILD;
2082 This = (*mode == 'w');
2086 taint_proper("Insecure %s%s", "EXEC");
2088 if (PerlProc_pipe(p) < 0)
2090 /* Try for another pipe pair for error return */
2091 if (PerlProc_pipe(pp) >= 0)
2093 while ((pid = PerlProc_fork()) < 0) {
2094 if (errno != EAGAIN) {
2095 PerlLIO_close(p[This]);
2096 PerlLIO_close(p[that]);
2098 PerlLIO_close(pp[0]);
2099 PerlLIO_close(pp[1]);
2111 /* Close parent's end of error status pipe (if any) */
2113 PerlLIO_close(pp[0]);
2114 #if defined(HAS_FCNTL) && defined(F_SETFD)
2115 /* Close error pipe automatically if exec works */
2116 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2119 /* Now dup our end of _the_ pipe to right position */
2120 if (p[THIS] != (*mode == 'r')) {
2121 PerlLIO_dup2(p[THIS], *mode == 'r');
2122 PerlLIO_close(p[THIS]);
2123 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2124 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
2127 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
2128 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2129 /* No automatic close - do it by hand */
2136 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) {
2142 do_aexec5(Nullsv, args-1, args-1+n, pp[1], did_pipes);
2148 do_execfree(); /* free any memory malloced by child on fork */
2150 PerlLIO_close(pp[1]);
2151 /* Keep the lower of the two fd numbers */
2152 if (p[that] < p[This]) {
2153 PerlLIO_dup2(p[This], p[that]);
2154 PerlLIO_close(p[This]);
2158 PerlLIO_close(p[that]); /* close child's end of pipe */
2161 sv = *av_fetch(PL_fdpid,p[This],TRUE);
2163 SvUPGRADE(sv,SVt_IV);
2165 PL_forkprocess = pid;
2166 /* If we managed to get status pipe check for exec fail */
2167 if (did_pipes && pid > 0) {
2171 while (n < sizeof(int)) {
2172 n1 = PerlLIO_read(pp[0],
2173 (void*)(((char*)&errkid)+n),
2179 PerlLIO_close(pp[0]);
2181 if (n) { /* Error */
2183 PerlLIO_close(p[This]);
2184 if (n != sizeof(int))
2185 Perl_croak(aTHX_ "panic: kid popen errno read");
2187 pid2 = wait4pid(pid, &status, 0);
2188 } while (pid2 == -1 && errno == EINTR);
2189 errno = errkid; /* Propagate errno from kid */
2194 PerlLIO_close(pp[0]);
2195 return PerlIO_fdopen(p[This], mode);
2197 Perl_croak(aTHX_ "List form of piped open not implemented");
2198 return (PerlIO *) NULL;
2202 /* VMS' my_popen() is in VMS.c, same with OS/2. */
2203 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
2205 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2208 register I32 This, that;
2211 const I32 doexec = !(*cmd == '-' && cmd[1] == '\0');
2215 PERL_FLUSHALL_FOR_CHILD;
2218 return my_syspopen(aTHX_ cmd,mode);
2221 This = (*mode == 'w');
2223 if (doexec && PL_tainting) {
2225 taint_proper("Insecure %s%s", "EXEC");
2227 if (PerlProc_pipe(p) < 0)
2229 if (doexec && PerlProc_pipe(pp) >= 0)
2231 while ((pid = PerlProc_fork()) < 0) {
2232 if (errno != EAGAIN) {
2233 PerlLIO_close(p[This]);
2234 PerlLIO_close(p[that]);
2236 PerlLIO_close(pp[0]);
2237 PerlLIO_close(pp[1]);
2240 Perl_croak(aTHX_ "Can't fork");
2253 PerlLIO_close(pp[0]);
2254 #if defined(HAS_FCNTL) && defined(F_SETFD)
2255 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2258 if (p[THIS] != (*mode == 'r')) {
2259 PerlLIO_dup2(p[THIS], *mode == 'r');
2260 PerlLIO_close(p[THIS]);
2261 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2262 PerlLIO_close(p[THAT]);
2265 PerlLIO_close(p[THAT]);
2268 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2275 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
2280 /* may or may not use the shell */
2281 do_exec3(cmd, pp[1], did_pipes);
2284 #endif /* defined OS2 */
2285 if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) {
2286 SvREADONLY_off(GvSV(tmpgv));
2287 sv_setiv(GvSV(tmpgv), PerlProc_getpid());
2288 SvREADONLY_on(GvSV(tmpgv));
2290 #ifdef THREADS_HAVE_PIDS
2291 PL_ppid = (IV)getppid();
2294 #ifdef PERL_USES_PL_PIDSTATUS
2295 hv_clear(PL_pidstatus); /* we have no children */
2301 do_execfree(); /* free any memory malloced by child on vfork */
2303 PerlLIO_close(pp[1]);
2304 if (p[that] < p[This]) {
2305 PerlLIO_dup2(p[This], p[that]);
2306 PerlLIO_close(p[This]);
2310 PerlLIO_close(p[that]);
2313 sv = *av_fetch(PL_fdpid,p[This],TRUE);
2315 SvUPGRADE(sv,SVt_IV);
2317 PL_forkprocess = pid;
2318 if (did_pipes && pid > 0) {
2322 while (n < sizeof(int)) {
2323 n1 = PerlLIO_read(pp[0],
2324 (void*)(((char*)&errkid)+n),
2330 PerlLIO_close(pp[0]);
2332 if (n) { /* Error */
2334 PerlLIO_close(p[This]);
2335 if (n != sizeof(int))
2336 Perl_croak(aTHX_ "panic: kid popen errno read");
2338 pid2 = wait4pid(pid, &status, 0);
2339 } while (pid2 == -1 && errno == EINTR);
2340 errno = errkid; /* Propagate errno from kid */
2345 PerlLIO_close(pp[0]);
2346 return PerlIO_fdopen(p[This], mode);
2349 #if defined(atarist) || defined(EPOC)
2352 Perl_my_popen(pTHX_ char *cmd, char *mode)
2354 PERL_FLUSHALL_FOR_CHILD;
2355 /* Call system's popen() to get a FILE *, then import it.
2356 used 0 for 2nd parameter to PerlIO_importFILE;
2359 return PerlIO_importFILE(popen(cmd, mode), 0);
2363 FILE *djgpp_popen();
2365 Perl_my_popen(pTHX_ char *cmd, char *mode)
2367 PERL_FLUSHALL_FOR_CHILD;
2368 /* Call system's popen() to get a FILE *, then import it.
2369 used 0 for 2nd parameter to PerlIO_importFILE;
2372 return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
2377 #endif /* !DOSISH */
2379 /* this is called in parent before the fork() */
2381 Perl_atfork_lock(void)
2384 #if defined(USE_ITHREADS)
2385 /* locks must be held in locking order (if any) */
2387 MUTEX_LOCK(&PL_malloc_mutex);
2393 /* this is called in both parent and child after the fork() */
2395 Perl_atfork_unlock(void)
2398 #if defined(USE_ITHREADS)
2399 /* locks must be released in same order as in atfork_lock() */
2401 MUTEX_UNLOCK(&PL_malloc_mutex);
2410 #if defined(HAS_FORK)
2412 #if defined(USE_ITHREADS) && !defined(HAS_PTHREAD_ATFORK)
2417 /* atfork_lock() and atfork_unlock() are installed as pthread_atfork()
2418 * handlers elsewhere in the code */
2423 /* this "canna happen" since nothing should be calling here if !HAS_FORK */
2424 Perl_croak_nocontext("fork() not available");
2426 #endif /* HAS_FORK */
2431 Perl_dump_fds(pTHX_ char *s)
2436 PerlIO_printf(Perl_debug_log,"%s", s);
2437 for (fd = 0; fd < 32; fd++) {
2438 if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0)
2439 PerlIO_printf(Perl_debug_log," %d",fd);
2441 PerlIO_printf(Perl_debug_log,"\n");
2444 #endif /* DUMP_FDS */
2448 dup2(int oldfd, int newfd)
2450 #if defined(HAS_FCNTL) && defined(F_DUPFD)
2453 PerlLIO_close(newfd);
2454 return fcntl(oldfd, F_DUPFD, newfd);
2456 #define DUP2_MAX_FDS 256
2457 int fdtmp[DUP2_MAX_FDS];
2463 PerlLIO_close(newfd);
2464 /* good enough for low fd's... */
2465 while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
2466 if (fdx >= DUP2_MAX_FDS) {
2474 PerlLIO_close(fdtmp[--fdx]);
2481 #ifdef HAS_SIGACTION
2483 #ifdef MACOS_TRADITIONAL
2484 /* We don't want restart behavior on MacOS */
2489 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2492 struct sigaction act, oact;
2495 /* only "parent" interpreter can diddle signals */
2496 if (PL_curinterp != aTHX)
2497 return (Sighandler_t) SIG_ERR;
2500 act.sa_handler = (void(*)(int))handler;
2501 sigemptyset(&act.sa_mask);
2504 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2505 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
2507 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2508 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
2509 act.sa_flags |= SA_NOCLDWAIT;
2511 if (sigaction(signo, &act, &oact) == -1)
2512 return (Sighandler_t) SIG_ERR;
2514 return (Sighandler_t) oact.sa_handler;
2518 Perl_rsignal_state(pTHX_ int signo)
2520 struct sigaction oact;
2522 if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
2523 return (Sighandler_t) SIG_ERR;
2525 return (Sighandler_t) oact.sa_handler;
2529 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2532 struct sigaction act;
2535 /* only "parent" interpreter can diddle signals */
2536 if (PL_curinterp != aTHX)
2540 act.sa_handler = (void(*)(int))handler;
2541 sigemptyset(&act.sa_mask);
2544 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2545 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
2547 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2548 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
2549 act.sa_flags |= SA_NOCLDWAIT;
2551 return sigaction(signo, &act, save);
2555 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2559 /* only "parent" interpreter can diddle signals */
2560 if (PL_curinterp != aTHX)
2564 return sigaction(signo, save, (struct sigaction *)NULL);
2567 #else /* !HAS_SIGACTION */
2570 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2572 #if defined(USE_ITHREADS) && !defined(WIN32)
2573 /* only "parent" interpreter can diddle signals */
2574 if (PL_curinterp != aTHX)
2575 return (Sighandler_t) SIG_ERR;
2578 return PerlProc_signal(signo, handler);
2589 Perl_rsignal_state(pTHX_ int signo)
2592 Sighandler_t oldsig;
2594 #if defined(USE_ITHREADS) && !defined(WIN32)
2595 /* only "parent" interpreter can diddle signals */
2596 if (PL_curinterp != aTHX)
2597 return (Sighandler_t) SIG_ERR;
2601 oldsig = PerlProc_signal(signo, sig_trap);
2602 PerlProc_signal(signo, oldsig);
2604 PerlProc_kill(PerlProc_getpid(), signo);
2609 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2611 #if defined(USE_ITHREADS) && !defined(WIN32)
2612 /* only "parent" interpreter can diddle signals */
2613 if (PL_curinterp != aTHX)
2616 *save = PerlProc_signal(signo, handler);
2617 return (*save == (Sighandler_t) SIG_ERR) ? -1 : 0;
2621 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2623 #if defined(USE_ITHREADS) && !defined(WIN32)
2624 /* only "parent" interpreter can diddle signals */
2625 if (PL_curinterp != aTHX)
2628 return (PerlProc_signal(signo, *save) == (Sighandler_t) SIG_ERR) ? -1 : 0;
2631 #endif /* !HAS_SIGACTION */
2632 #endif /* !PERL_MICRO */
2634 /* VMS' my_pclose() is in VMS.c; same with OS/2 */
2635 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
2637 Perl_my_pclose(pTHX_ PerlIO *ptr)
2639 Sigsave_t hstat, istat, qstat;
2645 int saved_errno = 0;
2647 int saved_win32_errno;
2651 svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE);
2653 pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
2655 *svp = &PL_sv_undef;
2657 if (pid == -1) { /* Opened by popen. */
2658 return my_syspclose(ptr);
2661 if ((close_failed = (PerlIO_close(ptr) == EOF))) {
2662 saved_errno = errno;
2664 saved_win32_errno = GetLastError();
2668 if(PerlProc_kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */
2671 rsignal_save(SIGHUP, (Sighandler_t) SIG_IGN, &hstat);
2672 rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &istat);
2673 rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qstat);
2676 pid2 = wait4pid(pid, &status, 0);
2677 } while (pid2 == -1 && errno == EINTR);
2679 rsignal_restore(SIGHUP, &hstat);
2680 rsignal_restore(SIGINT, &istat);
2681 rsignal_restore(SIGQUIT, &qstat);
2684 SETERRNO(saved_errno, 0);
2687 return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status));
2689 #endif /* !DOSISH */
2691 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(MACOS_TRADITIONAL)
2693 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
2698 #ifdef PERL_USES_PL_PIDSTATUS
2701 /* The keys in PL_pidstatus are now the raw 4 (or 8) bytes of the
2702 pid, rather than a string form. */
2703 SV * const * const svp = hv_fetch(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),FALSE);
2704 if (svp && *svp != &PL_sv_undef) {
2705 *statusp = SvIVX(*svp);
2706 (void)hv_delete(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),
2714 hv_iterinit(PL_pidstatus);
2715 if ((entry = hv_iternext(PL_pidstatus))) {
2716 SV * const sv = hv_iterval(PL_pidstatus,entry);
2718 const char * const spid = hv_iterkey(entry,&len);
2720 assert (len == sizeof(Pid_t));
2721 memcpy((char *)&pid, spid, len);
2722 *statusp = SvIVX(sv);
2723 /* The hash iterator is currently on this entry, so simply
2724 calling hv_delete would trigger the lazy delete, which on
2725 aggregate does more work, beacuse next call to hv_iterinit()
2726 would spot the flag, and have to call the delete routine,
2727 while in the meantime any new entries can't re-use that
2729 hv_iterinit(PL_pidstatus);
2730 (void)hv_delete(PL_pidstatus,spid,len,G_DISCARD);
2737 # ifdef HAS_WAITPID_RUNTIME
2738 if (!HAS_WAITPID_RUNTIME)
2741 result = PerlProc_waitpid(pid,statusp,flags);
2744 #if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
2745 result = wait4((pid==-1)?0:pid,statusp,flags,Null(struct rusage *));
2748 #ifdef PERL_USES_PL_PIDSTATUS
2749 #if defined(HAS_WAITPID) && defined(HAS_WAITPID_RUNTIME)
2754 Perl_croak(aTHX_ "Can't do waitpid with flags");
2756 while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
2757 pidgone(result,*statusp);
2763 #if defined(HAS_WAITPID) || defined(HAS_WAIT4)
2766 if (result < 0 && errno == EINTR) {
2771 #endif /* !DOSISH || OS2 || WIN32 || NETWARE */
2773 #ifdef PERL_USES_PL_PIDSTATUS
2775 Perl_pidgone(pTHX_ Pid_t pid, int status)
2779 sv = *hv_fetch(PL_pidstatus,(const char*)&pid,sizeof(Pid_t),TRUE);
2780 SvUPGRADE(sv,SVt_IV);
2781 SvIV_set(sv, status);
2786 #if defined(atarist) || defined(OS2) || defined(EPOC)
2789 int /* Cannot prototype with I32
2791 my_syspclose(PerlIO *ptr)
2794 Perl_my_pclose(pTHX_ PerlIO *ptr)
2797 /* Needs work for PerlIO ! */
2798 FILE * const f = PerlIO_findFILE(ptr);
2799 const I32 result = pclose(f);
2800 PerlIO_releaseFILE(ptr,f);
2808 Perl_my_pclose(pTHX_ PerlIO *ptr)
2810 /* Needs work for PerlIO ! */
2811 FILE * const f = PerlIO_findFILE(ptr);
2812 I32 result = djgpp_pclose(f);
2813 result = (result << 8) & 0xff00;
2814 PerlIO_releaseFILE(ptr,f);
2820 Perl_repeatcpy(pTHX_ register char *to, register const char *from, I32 len, register I32 count)
2823 register const char * const frombase = from;
2826 register const char c = *from;
2831 while (count-- > 0) {
2832 for (todo = len; todo > 0; todo--) {
2841 Perl_same_dirent(pTHX_ const char *a, const char *b)
2843 char *fa = strrchr(a,'/');
2844 char *fb = strrchr(b,'/');
2847 SV * const tmpsv = sv_newmortal();
2860 sv_setpvn(tmpsv, ".", 1);
2862 sv_setpvn(tmpsv, a, fa - a);
2863 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0)
2866 sv_setpvn(tmpsv, ".", 1);
2868 sv_setpvn(tmpsv, b, fb - b);
2869 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0)
2871 return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
2872 tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
2874 #endif /* !HAS_RENAME */
2877 Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
2878 const char *const *const search_ext, I32 flags)
2880 const char *xfound = Nullch;
2881 char *xfailed = Nullch;
2882 char tmpbuf[MAXPATHLEN];
2886 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
2887 # define SEARCH_EXTS ".bat", ".cmd", NULL
2888 # define MAX_EXT_LEN 4
2891 # define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
2892 # define MAX_EXT_LEN 4
2895 # define SEARCH_EXTS ".pl", ".com", NULL
2896 # define MAX_EXT_LEN 4
2898 /* additional extensions to try in each dir if scriptname not found */
2900 static const char *const exts[] = { SEARCH_EXTS };
2901 const char *const *const ext = search_ext ? search_ext : exts;
2902 int extidx = 0, i = 0;
2903 const char *curext = Nullch;
2905 PERL_UNUSED_ARG(search_ext);
2906 # define MAX_EXT_LEN 0
2910 * If dosearch is true and if scriptname does not contain path
2911 * delimiters, search the PATH for scriptname.
2913 * If SEARCH_EXTS is also defined, will look for each
2914 * scriptname{SEARCH_EXTS} whenever scriptname is not found
2915 * while searching the PATH.
2917 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
2918 * proceeds as follows:
2919 * If DOSISH or VMSISH:
2920 * + look for ./scriptname{,.foo,.bar}
2921 * + search the PATH for scriptname{,.foo,.bar}
2924 * + look *only* in the PATH for scriptname{,.foo,.bar} (note
2925 * this will not look in '.' if it's not in the PATH)
2930 # ifdef ALWAYS_DEFTYPES
2931 len = strlen(scriptname);
2932 if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
2933 int idx = 0, deftypes = 1;
2936 const int hasdir = !dosearch || (strpbrk(scriptname,":[</") != Nullch);
2939 int idx = 0, deftypes = 1;
2942 const int hasdir = (strpbrk(scriptname,":[</") != Nullch);
2944 /* The first time through, just add SEARCH_EXTS to whatever we
2945 * already have, so we can check for default file types. */
2947 (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
2953 if ((strlen(tmpbuf) + strlen(scriptname)
2954 + MAX_EXT_LEN) >= sizeof tmpbuf)
2955 continue; /* don't search dir with too-long name */
2956 strcat(tmpbuf, scriptname);
2960 if (strEQ(scriptname, "-"))
2962 if (dosearch) { /* Look in '.' first. */
2963 const char *cur = scriptname;
2965 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
2967 if (strEQ(ext[i++],curext)) {
2968 extidx = -1; /* already has an ext */
2973 DEBUG_p(PerlIO_printf(Perl_debug_log,
2974 "Looking for %s\n",cur));
2975 if (PerlLIO_stat(cur,&PL_statbuf) >= 0
2976 && !S_ISDIR(PL_statbuf.st_mode)) {
2984 if (cur == scriptname) {
2985 len = strlen(scriptname);
2986 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
2988 /* FIXME? Convert to memcpy */
2989 cur = strcpy(tmpbuf, scriptname);
2991 } while (extidx >= 0 && ext[extidx] /* try an extension? */
2992 && strcpy(tmpbuf+len, ext[extidx++]));
2997 #ifdef MACOS_TRADITIONAL
2998 if (dosearch && !strchr(scriptname, ':') &&
2999 (s = PerlEnv_getenv("Commands")))
3001 if (dosearch && !strchr(scriptname, '/')
3003 && !strchr(scriptname, '\\')
3005 && (s = PerlEnv_getenv("PATH")))
3010 PL_bufend = s + strlen(s);
3011 while (s < PL_bufend) {
3012 #ifdef MACOS_TRADITIONAL
3013 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
3017 #if defined(atarist) || defined(DOSISH)
3022 && *s != ';'; len++, s++) {
3023 if (len < sizeof tmpbuf)
3026 if (len < sizeof tmpbuf)
3028 #else /* ! (atarist || DOSISH) */
3029 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
3032 #endif /* ! (atarist || DOSISH) */
3033 #endif /* MACOS_TRADITIONAL */
3036 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
3037 continue; /* don't search dir with too-long name */
3038 #ifdef MACOS_TRADITIONAL
3039 if (len && tmpbuf[len - 1] != ':')
3040 tmpbuf[len++] = ':';
3043 # if defined(atarist) || defined(__MINT__) || defined(DOSISH)
3044 && tmpbuf[len - 1] != '/'
3045 && tmpbuf[len - 1] != '\\'
3048 tmpbuf[len++] = '/';
3049 if (len == 2 && tmpbuf[0] == '.')
3052 /* FIXME? Convert to memcpy by storing previous strlen(scriptname)
3054 (void)strcpy(tmpbuf + len, scriptname);
3058 len = strlen(tmpbuf);
3059 if (extidx > 0) /* reset after previous loop */
3063 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
3064 retval = PerlLIO_stat(tmpbuf,&PL_statbuf);
3065 if (S_ISDIR(PL_statbuf.st_mode)) {
3069 } while ( retval < 0 /* not there */
3070 && extidx>=0 && ext[extidx] /* try an extension? */
3071 && strcpy(tmpbuf+len, ext[extidx++])
3076 if (S_ISREG(PL_statbuf.st_mode)
3077 && cando(S_IRUSR,TRUE,&PL_statbuf)
3078 #if !defined(DOSISH) && !defined(MACOS_TRADITIONAL)
3079 && cando(S_IXUSR,TRUE,&PL_statbuf)
3083 xfound = tmpbuf; /* bingo! */
3087 xfailed = savepv(tmpbuf);
3090 if (!xfound && !seen_dot && !xfailed &&
3091 (PerlLIO_stat(scriptname,&PL_statbuf) < 0
3092 || S_ISDIR(PL_statbuf.st_mode)))
3094 seen_dot = 1; /* Disable message. */
3096 if (flags & 1) { /* do or die? */
3097 Perl_croak(aTHX_ "Can't %s %s%s%s",
3098 (xfailed ? "execute" : "find"),
3099 (xfailed ? xfailed : scriptname),
3100 (xfailed ? "" : " on PATH"),
3101 (xfailed || seen_dot) ? "" : ", '.' not in PATH");
3103 scriptname = Nullch;
3106 scriptname = xfound;
3108 return (scriptname ? savepv(scriptname) : Nullch);
3111 #ifndef PERL_GET_CONTEXT_DEFINED
3114 Perl_get_context(void)
3117 #if defined(USE_ITHREADS)
3118 # ifdef OLD_PTHREADS_API
3120 if (pthread_getspecific(PL_thr_key, &t))
3121 Perl_croak_nocontext("panic: pthread_getspecific");
3124 # ifdef I_MACH_CTHREADS
3125 return (void*)cthread_data(cthread_self());
3127 return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
3136 Perl_set_context(void *t)
3139 #if defined(USE_ITHREADS)
3140 # ifdef I_MACH_CTHREADS
3141 cthread_set_data(cthread_self(), t);
3143 if (pthread_setspecific(PL_thr_key, t))
3144 Perl_croak_nocontext("panic: pthread_setspecific");
3151 #endif /* !PERL_GET_CONTEXT_DEFINED */
3153 #if defined(PERL_GLOBAL_STRUCT) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
3162 Perl_get_op_names(pTHX)
3164 return (char **)PL_op_name;
3168 Perl_get_op_descs(pTHX)
3170 return (char **)PL_op_desc;
3174 Perl_get_no_modify(pTHX)
3176 return PL_no_modify;
3180 Perl_get_opargs(pTHX)
3182 return (U32 *)PL_opargs;
3186 Perl_get_ppaddr(pTHX)
3189 return (PPADDR_t*)PL_ppaddr;
3192 #ifndef HAS_GETENV_LEN
3194 Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
3196 char * const env_trans = PerlEnv_getenv(env_elem);
3198 *len = strlen(env_trans);
3205 Perl_get_vtbl(pTHX_ int vtbl_id)
3207 const MGVTBL* result;
3211 result = &PL_vtbl_sv;
3214 result = &PL_vtbl_env;
3216 case want_vtbl_envelem:
3217 result = &PL_vtbl_envelem;
3220 result = &PL_vtbl_sig;
3222 case want_vtbl_sigelem:
3223 result = &PL_vtbl_sigelem;
3225 case want_vtbl_pack:
3226 result = &PL_vtbl_pack;
3228 case want_vtbl_packelem:
3229 result = &PL_vtbl_packelem;
3231 case want_vtbl_dbline:
3232 result = &PL_vtbl_dbline;
3235 result = &PL_vtbl_isa;
3237 case want_vtbl_isaelem:
3238 result = &PL_vtbl_isaelem;
3240 case want_vtbl_arylen:
3241 result = &PL_vtbl_arylen;
3243 case want_vtbl_glob:
3244 result = &PL_vtbl_glob;
3246 case want_vtbl_mglob:
3247 result = &PL_vtbl_mglob;
3249 case want_vtbl_nkeys:
3250 result = &PL_vtbl_nkeys;
3252 case want_vtbl_taint:
3253 result = &PL_vtbl_taint;
3255 case want_vtbl_substr:
3256 result = &PL_vtbl_substr;
3259 result = &PL_vtbl_vec;
3262 result = &PL_vtbl_pos;
3265 result = &PL_vtbl_bm;
3268 result = &PL_vtbl_fm;
3270 case want_vtbl_uvar:
3271 result = &PL_vtbl_uvar;
3273 case want_vtbl_defelem:
3274 result = &PL_vtbl_defelem;
3276 case want_vtbl_regexp:
3277 result = &PL_vtbl_regexp;
3279 case want_vtbl_regdata:
3280 result = &PL_vtbl_regdata;
3282 case want_vtbl_regdatum:
3283 result = &PL_vtbl_regdatum;
3285 #ifdef USE_LOCALE_COLLATE
3286 case want_vtbl_collxfrm:
3287 result = &PL_vtbl_collxfrm;
3290 case want_vtbl_amagic:
3291 result = &PL_vtbl_amagic;
3293 case want_vtbl_amagicelem:
3294 result = &PL_vtbl_amagicelem;
3296 case want_vtbl_backref:
3297 result = &PL_vtbl_backref;
3299 case want_vtbl_utf8:
3300 result = &PL_vtbl_utf8;
3303 result = Null(MGVTBL*);
3306 return (MGVTBL*)result;
3310 Perl_my_fflush_all(pTHX)
3312 #if defined(USE_PERLIO) || defined(FFLUSH_NULL) || defined(USE_SFIO)
3313 return PerlIO_flush(NULL);
3315 # if defined(HAS__FWALK)
3316 extern int fflush(FILE *);
3317 /* undocumented, unprototyped, but very useful BSDism */
3318 extern void _fwalk(int (*)(FILE *));
3322 # if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
3324 # ifdef PERL_FFLUSH_ALL_FOPEN_MAX
3325 open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
3327 # if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
3328 open_max = sysconf(_SC_OPEN_MAX);
3331 open_max = FOPEN_MAX;
3334 open_max = OPEN_MAX;
3345 for (i = 0; i < open_max; i++)
3346 if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
3347 STDIO_STREAM_ARRAY[i]._file < open_max &&
3348 STDIO_STREAM_ARRAY[i]._flag)
3349 PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
3353 SETERRNO(EBADF,RMS_IFI);
3360 Perl_report_evil_fh(pTHX_ const GV *gv, const IO *io, I32 op)
3362 const char * const func =
3363 op == OP_READLINE ? "readline" : /* "<HANDLE>" not nice */
3364 op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */
3366 const char * const pars = OP_IS_FILETEST(op) ? "" : "()";
3367 const char * const type = OP_IS_SOCKET(op)
3368 || (gv && io && IoTYPE(io) == IoTYPE_SOCKET)
3369 ? "socket" : "filehandle";
3370 const char * const name = gv && isGV(gv) ? GvENAME(gv) : NULL;
3372 if (op == OP_phoney_OUTPUT_ONLY || op == OP_phoney_INPUT_ONLY) {
3373 if (ckWARN(WARN_IO)) {
3374 const char * const direction = (op == OP_phoney_INPUT_ONLY) ? "in" : "out";
3376 Perl_warner(aTHX_ packWARN(WARN_IO),
3377 "Filehandle %s opened only for %sput",
3380 Perl_warner(aTHX_ packWARN(WARN_IO),
3381 "Filehandle opened only for %sput", direction);
3388 if (gv && io && IoTYPE(io) == IoTYPE_CLOSED) {
3390 warn_type = WARN_CLOSED;
3394 warn_type = WARN_UNOPENED;
3397 if (ckWARN(warn_type)) {
3398 if (name && *name) {
3399 Perl_warner(aTHX_ packWARN(warn_type),
3400 "%s%s on %s %s %s", func, pars, vile, type, name);
3401 if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3403 aTHX_ packWARN(warn_type),
3404 "\t(Are you trying to call %s%s on dirhandle %s?)\n",
3409 Perl_warner(aTHX_ packWARN(warn_type),
3410 "%s%s on %s %s", func, pars, vile, type);
3411 if (gv && io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3413 aTHX_ packWARN(warn_type),
3414 "\t(Are you trying to call %s%s on dirhandle?)\n",
3423 /* in ASCII order, not that it matters */
3424 static const char controllablechars[] = "?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_";
3427 Perl_ebcdic_control(pTHX_ int ch)
3435 if ((ctlp = strchr(controllablechars, ch)) == 0) {
3436 Perl_die(aTHX_ "unrecognised control character '%c'\n", ch);
3439 if (ctlp == controllablechars)
3440 return('\177'); /* DEL */
3442 return((unsigned char)(ctlp - controllablechars - 1));
3443 } else { /* Want uncontrol */
3444 if (ch == '\177' || ch == -1)
3446 else if (ch == '\157')
3448 else if (ch == '\174')
3450 else if (ch == '^') /* '\137' in 1047, '\260' in 819 */
3452 else if (ch == '\155')
3454 else if (0 < ch && ch < (sizeof(controllablechars) - 1))
3455 return(controllablechars[ch+1]);
3457 Perl_die(aTHX_ "invalid control request: '\\%03o'\n", ch & 0xFF);
3462 /* To workaround core dumps from the uninitialised tm_zone we get the
3463 * system to give us a reasonable struct to copy. This fix means that
3464 * strftime uses the tm_zone and tm_gmtoff values returned by
3465 * localtime(time()). That should give the desired result most of the
3466 * time. But probably not always!
3468 * This does not address tzname aspects of NETaa14816.
3473 # ifndef STRUCT_TM_HASZONE
3474 # define STRUCT_TM_HASZONE
3478 #ifdef STRUCT_TM_HASZONE /* Backward compat */
3479 # ifndef HAS_TM_TM_ZONE
3480 # define HAS_TM_TM_ZONE
3485 Perl_init_tm(pTHX_ struct tm *ptm) /* see mktime, strftime and asctime */
3487 #ifdef HAS_TM_TM_ZONE
3489 const struct tm* my_tm;
3491 my_tm = localtime(&now);
3493 Copy(my_tm, ptm, 1, struct tm);
3495 PERL_UNUSED_ARG(ptm);
3500 * mini_mktime - normalise struct tm values without the localtime()
3501 * semantics (and overhead) of mktime().
3504 Perl_mini_mktime(pTHX_ struct tm *ptm)
3508 int month, mday, year, jday;
3509 int odd_cent, odd_year;
3511 #define DAYS_PER_YEAR 365
3512 #define DAYS_PER_QYEAR (4*DAYS_PER_YEAR+1)
3513 #define DAYS_PER_CENT (25*DAYS_PER_QYEAR-1)
3514 #define DAYS_PER_QCENT (4*DAYS_PER_CENT+1)
3515 #define SECS_PER_HOUR (60*60)
3516 #define SECS_PER_DAY (24*SECS_PER_HOUR)
3517 /* parentheses deliberately absent on these two, otherwise they don't work */
3518 #define MONTH_TO_DAYS 153/5
3519 #define DAYS_TO_MONTH 5/153
3520 /* offset to bias by March (month 4) 1st between month/mday & year finding */
3521 #define YEAR_ADJUST (4*MONTH_TO_DAYS+1)
3522 /* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */
3523 #define WEEKDAY_BIAS 6 /* (1+6)%7 makes Sunday 0 again */
3526 * Year/day algorithm notes:
3528 * With a suitable offset for numeric value of the month, one can find
3529 * an offset into the year by considering months to have 30.6 (153/5) days,
3530 * using integer arithmetic (i.e., with truncation). To avoid too much
3531 * messing about with leap days, we consider January and February to be
3532 * the 13th and 14th month of the previous year. After that transformation,
3533 * we need the month index we use to be high by 1 from 'normal human' usage,
3534 * so the month index values we use run from 4 through 15.
3536 * Given that, and the rules for the Gregorian calendar (leap years are those
3537 * divisible by 4 unless also divisible by 100, when they must be divisible
3538 * by 400 instead), we can simply calculate the number of days since some
3539 * arbitrary 'beginning of time' by futzing with the (adjusted) year number,
3540 * the days we derive from our month index, and adding in the day of the
3541 * month. The value used here is not adjusted for the actual origin which
3542 * it normally would use (1 January A.D. 1), since we're not exposing it.
3543 * We're only building the value so we can turn around and get the
3544 * normalised values for the year, month, day-of-month, and day-of-year.
3546 * For going backward, we need to bias the value we're using so that we find
3547 * the right year value. (Basically, we don't want the contribution of
3548 * March 1st to the number to apply while deriving the year). Having done
3549 * that, we 'count up' the contribution to the year number by accounting for
3550 * full quadracenturies (400-year periods) with their extra leap days, plus
3551 * the contribution from full centuries (to avoid counting in the lost leap
3552 * days), plus the contribution from full quad-years (to count in the normal
3553 * leap days), plus the leftover contribution from any non-leap years.
3554 * At this point, if we were working with an actual leap day, we'll have 0
3555 * days left over. This is also true for March 1st, however. So, we have
3556 * to special-case that result, and (earlier) keep track of the 'odd'
3557 * century and year contributions. If we got 4 extra centuries in a qcent,
3558 * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb.
3559 * Otherwise, we add back in the earlier bias we removed (the 123 from
3560 * figuring in March 1st), find the month index (integer division by 30.6),
3561 * and the remainder is the day-of-month. We then have to convert back to
3562 * 'real' months (including fixing January and February from being 14/15 in
3563 * the previous year to being in the proper year). After that, to get
3564 * tm_yday, we work with the normalised year and get a new yearday value for
3565 * January 1st, which we subtract from the yearday value we had earlier,
3566 * representing the date we've re-built. This is done from January 1
3567 * because tm_yday is 0-origin.
3569 * Since POSIX time routines are only guaranteed to work for times since the
3570 * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm
3571 * applies Gregorian calendar rules even to dates before the 16th century
3572 * doesn't bother me. Besides, you'd need cultural context for a given
3573 * date to know whether it was Julian or Gregorian calendar, and that's
3574 * outside the scope for this routine. Since we convert back based on the
3575 * same rules we used to build the yearday, you'll only get strange results
3576 * for input which needed normalising, or for the 'odd' century years which
3577 * were leap years in the Julian calander but not in the Gregorian one.
3578 * I can live with that.
3580 * This algorithm also fails to handle years before A.D. 1 gracefully, but
3581 * that's still outside the scope for POSIX time manipulation, so I don't
3585 year = 1900 + ptm->tm_year;
3586 month = ptm->tm_mon;
3587 mday = ptm->tm_mday;
3588 /* allow given yday with no month & mday to dominate the result */
3589 if (ptm->tm_yday >= 0 && mday <= 0 && month <= 0) {
3592 jday = 1 + ptm->tm_yday;
3601 yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400;
3602 yearday += month*MONTH_TO_DAYS + mday + jday;
3604 * Note that we don't know when leap-seconds were or will be,
3605 * so we have to trust the user if we get something which looks
3606 * like a sensible leap-second. Wild values for seconds will
3607 * be rationalised, however.
3609 if ((unsigned) ptm->tm_sec <= 60) {
3616 secs += 60 * ptm->tm_min;
3617 secs += SECS_PER_HOUR * ptm->tm_hour;
3619 if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) {
3620 /* got negative remainder, but need positive time */
3621 /* back off an extra day to compensate */
3622 yearday += (secs/SECS_PER_DAY)-1;
3623 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1);
3626 yearday += (secs/SECS_PER_DAY);
3627 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY);
3630 else if (secs >= SECS_PER_DAY) {
3631 yearday += (secs/SECS_PER_DAY);
3632 secs %= SECS_PER_DAY;
3634 ptm->tm_hour = secs/SECS_PER_HOUR;
3635 secs %= SECS_PER_HOUR;
3636 ptm->tm_min = secs/60;
3638 ptm->tm_sec += secs;
3639 /* done with time of day effects */
3641 * The algorithm for yearday has (so far) left it high by 428.
3642 * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to
3643 * bias it by 123 while trying to figure out what year it
3644 * really represents. Even with this tweak, the reverse
3645 * translation fails for years before A.D. 0001.
3646 * It would still fail for Feb 29, but we catch that one below.
3648 jday = yearday; /* save for later fixup vis-a-vis Jan 1 */
3649 yearday -= YEAR_ADJUST;
3650 year = (yearday / DAYS_PER_QCENT) * 400;
3651 yearday %= DAYS_PER_QCENT;
3652 odd_cent = yearday / DAYS_PER_CENT;
3653 year += odd_cent * 100;
3654 yearday %= DAYS_PER_CENT;
3655 year += (yearday / DAYS_PER_QYEAR) * 4;
3656 yearday %= DAYS_PER_QYEAR;
3657 odd_year = yearday / DAYS_PER_YEAR;
3659 yearday %= DAYS_PER_YEAR;
3660 if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */
3665 yearday += YEAR_ADJUST; /* recover March 1st crock */
3666 month = yearday*DAYS_TO_MONTH;
3667 yearday -= month*MONTH_TO_DAYS;
3668 /* recover other leap-year adjustment */
3677 ptm->tm_year = year - 1900;
3679 ptm->tm_mday = yearday;
3680 ptm->tm_mon = month;
3684 ptm->tm_mon = month - 1;
3686 /* re-build yearday based on Jan 1 to get tm_yday */
3688 yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400;
3689 yearday += 14*MONTH_TO_DAYS + 1;
3690 ptm->tm_yday = jday - yearday;
3691 /* fix tm_wday if not overridden by caller */
3692 if ((unsigned)ptm->tm_wday > 6)
3693 ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
3697 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)
3705 init_tm(&mytm); /* XXX workaround - see init_tm() above */
3708 mytm.tm_hour = hour;
3709 mytm.tm_mday = mday;
3711 mytm.tm_year = year;
3712 mytm.tm_wday = wday;
3713 mytm.tm_yday = yday;
3714 mytm.tm_isdst = isdst;
3716 /* use libc to get the values for tm_gmtoff and tm_zone [perl #18238] */
3717 #if defined(HAS_MKTIME) && (defined(HAS_TM_TM_GMTOFF) || defined(HAS_TM_TM_ZONE))
3722 #ifdef HAS_TM_TM_GMTOFF
3723 mytm.tm_gmtoff = mytm2.tm_gmtoff;
3725 #ifdef HAS_TM_TM_ZONE
3726 mytm.tm_zone = mytm2.tm_zone;
3731 Newx(buf, buflen, char);
3732 len = strftime(buf, buflen, fmt, &mytm);
3734 ** The following is needed to handle to the situation where
3735 ** tmpbuf overflows. Basically we want to allocate a buffer
3736 ** and try repeatedly. The reason why it is so complicated
3737 ** is that getting a return value of 0 from strftime can indicate
3738 ** one of the following:
3739 ** 1. buffer overflowed,
3740 ** 2. illegal conversion specifier, or
3741 ** 3. the format string specifies nothing to be returned(not
3742 ** an error). This could be because format is an empty string
3743 ** or it specifies %p that yields an empty string in some locale.
3744 ** If there is a better way to make it portable, go ahead by
3747 if ((len > 0 && len < buflen) || (len == 0 && *fmt == '\0'))
3750 /* Possibly buf overflowed - try again with a bigger buf */
3751 const int fmtlen = strlen(fmt);
3752 const int bufsize = fmtlen + buflen;
3754 Newx(buf, bufsize, char);
3756 buflen = strftime(buf, bufsize, fmt, &mytm);
3757 if (buflen > 0 && buflen < bufsize)
3759 /* heuristic to prevent out-of-memory errors */
3760 if (bufsize > 100*fmtlen) {
3765 Renew(buf, bufsize*2, char);
3770 Perl_croak(aTHX_ "panic: no strftime");
3776 #define SV_CWD_RETURN_UNDEF \
3777 sv_setsv(sv, &PL_sv_undef); \
3780 #define SV_CWD_ISDOT(dp) \
3781 (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
3782 (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
3785 =head1 Miscellaneous Functions
3787 =for apidoc getcwd_sv
3789 Fill the sv with current working directory
3794 /* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars.
3795 * rewritten again by dougm, optimized for use with xs TARG, and to prefer
3796 * getcwd(3) if available
3797 * Comments from the orignal:
3798 * This is a faster version of getcwd. It's also more dangerous
3799 * because you might chdir out of a directory that you can't chdir
3803 Perl_getcwd_sv(pTHX_ register SV *sv)
3807 #ifndef INCOMPLETE_TAINTS
3813 char buf[MAXPATHLEN];
3815 /* Some getcwd()s automatically allocate a buffer of the given
3816 * size from the heap if they are given a NULL buffer pointer.
3817 * The problem is that this behaviour is not portable. */
3818 if (getcwd(buf, sizeof(buf) - 1)) {
3823 sv_setsv(sv, &PL_sv_undef);
3831 int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
3835 SvUPGRADE(sv, SVt_PV);
3837 if (PerlLIO_lstat(".", &statbuf) < 0) {
3838 SV_CWD_RETURN_UNDEF;
3841 orig_cdev = statbuf.st_dev;
3842 orig_cino = statbuf.st_ino;
3851 if (PerlDir_chdir("..") < 0) {
3852 SV_CWD_RETURN_UNDEF;
3854 if (PerlLIO_stat(".", &statbuf) < 0) {
3855 SV_CWD_RETURN_UNDEF;
3858 cdev = statbuf.st_dev;
3859 cino = statbuf.st_ino;
3861 if (odev == cdev && oino == cino) {
3864 if (!(dir = PerlDir_open("."))) {
3865 SV_CWD_RETURN_UNDEF;
3868 while ((dp = PerlDir_read(dir)) != NULL) {
3870 const int namelen = dp->d_namlen;
3872 const int namelen = strlen(dp->d_name);
3875 if (SV_CWD_ISDOT(dp)) {
3879 if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
3880 SV_CWD_RETURN_UNDEF;
3883 tdev = statbuf.st_dev;
3884 tino = statbuf.st_ino;
3885 if (tino == oino && tdev == odev) {
3891 SV_CWD_RETURN_UNDEF;
3894 if (pathlen + namelen + 1 >= MAXPATHLEN) {
3895 SV_CWD_RETURN_UNDEF;
3898 SvGROW(sv, pathlen + namelen + 1);
3902 Move(SvPVX_const(sv), SvPVX(sv) + namelen + 1, pathlen, char);
3905 /* prepend current directory to the front */
3907 Move(dp->d_name, SvPVX(sv)+1, namelen, char);
3908 pathlen += (namelen + 1);
3910 #ifdef VOID_CLOSEDIR
3913 if (PerlDir_close(dir) < 0) {
3914 SV_CWD_RETURN_UNDEF;
3920 SvCUR_set(sv, pathlen);
3924 if (PerlDir_chdir(SvPVX_const(sv)) < 0) {
3925 SV_CWD_RETURN_UNDEF;
3928 if (PerlLIO_stat(".", &statbuf) < 0) {
3929 SV_CWD_RETURN_UNDEF;
3932 cdev = statbuf.st_dev;
3933 cino = statbuf.st_ino;
3935 if (cdev != orig_cdev || cino != orig_cino) {
3936 Perl_croak(aTHX_ "Unstable directory path, "
3937 "current directory changed unexpectedly");
3949 =for apidoc scan_version
3951 Returns a pointer to the next character after the parsed
3952 version string, as well as upgrading the passed in SV to
3955 Function must be called with an already existing SV like
3958 s = scan_version(s,SV *sv, bool qv);
3960 Performs some preprocessing to the string to ensure that
3961 it has the correct characteristics of a version. Flags the
3962 object if it contains an underscore (which denotes this
3963 is a alpha version). The boolean qv denotes that the version
3964 should be interpreted as if it had multiple decimals, even if
3971 Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
3979 AV * const av = newAV();
3980 SV * const hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
3981 (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
3983 #ifndef NODEFAULT_SHAREKEYS
3984 HvSHAREKEYS_on(hv); /* key-sharing on by default */
3987 while (isSPACE(*s)) /* leading whitespace is OK */
3991 s++; /* get past 'v' */
3992 qv = 1; /* force quoted version processing */
3995 start = last = pos = s;
3997 /* pre-scan the input string to check for decimals/underbars */
3998 while ( *pos == '.' || *pos == '_' || isDIGIT(*pos) )
4003 Perl_croak(aTHX_ "Invalid version format (underscores before decimal)");
4007 else if ( *pos == '_' )
4010 Perl_croak(aTHX_ "Invalid version format (multiple underscores)");
4012 width = pos - last - 1; /* natural width of sub-version */
4017 if ( saw_period > 1 )
4018 qv = 1; /* force quoted version processing */
4023 hv_store((HV *)hv, "qv", 2, newSViv(qv), 0);
4025 hv_store((HV *)hv, "alpha", 5, newSViv(alpha), 0);
4026 if ( !qv && width < 3 )
4027 hv_store((HV *)hv, "width", 5, newSViv(width), 0);
4029 while (isDIGIT(*pos))
4031 if (!isALPHA(*pos)) {
4037 /* this is atoi() that delimits on underscores */
4038 const char *end = pos;
4042 /* the following if() will only be true after the decimal
4043 * point of a version originally created with a bare
4044 * floating point number, i.e. not quoted in any way
4046 if ( !qv && s > start && saw_period == 1 ) {
4050 rev += (*s - '0') * mult;
4052 if ( PERL_ABS(orev) > PERL_ABS(rev) )
4053 Perl_croak(aTHX_ "Integer overflow in version");
4060 while (--end >= s) {
4062 rev += (*end - '0') * mult;
4064 if ( PERL_ABS(orev) > PERL_ABS(rev) )
4065 Perl_croak(aTHX_ "Integer overflow in version");
4070 /* Append revision */
4071 av_push(av, newSViv(rev));
4072 if ( *pos == '.' && isDIGIT(pos[1]) )
4074 else if ( *pos == '_' && isDIGIT(pos[1]) )
4076 else if ( isDIGIT(*pos) )
4083 while ( isDIGIT(*pos) )
4088 while ( ( isDIGIT(*pos) || *pos == '_' ) && digits < 3 ) {
4096 if ( qv ) { /* quoted versions always get at least three terms*/
4097 I32 len = av_len(av);
4098 /* This for loop appears to trigger a compiler bug on OS X, as it
4099 loops infinitely. Yes, len is negative. No, it makes no sense.
4100 Compiler in question is:
4101 gcc version 3.3 20030304 (Apple Computer, Inc. build 1640)
4102 for ( len = 2 - len; len > 0; len-- )
4103 av_push((AV *)sv, newSViv(0));
4107 av_push(av, newSViv(0));
4110 if ( av_len(av) == -1 ) /* oops, someone forgot to pass a value */
4111 av_push(av, newSViv(0));
4113 /* And finally, store the AV in the hash */
4114 hv_store((HV *)hv, "version", 7, newRV_noinc((SV *)av), 0);
4119 =for apidoc new_version
4121 Returns a new version object based on the passed in SV:
4123 SV *sv = new_version(SV *ver);
4125 Does not alter the passed in ver SV. See "upg_version" if you
4126 want to upgrade the SV.
4132 Perl_new_version(pTHX_ SV *ver)
4134 SV * const rv = newSV(0);
4135 if ( sv_derived_from(ver,"version") ) /* can just copy directly */
4138 AV * const av = newAV();
4140 /* This will get reblessed later if a derived class*/
4141 SV * const hv = newSVrv(rv, "version");
4142 (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
4143 #ifndef NODEFAULT_SHAREKEYS
4144 HvSHAREKEYS_on(hv); /* key-sharing on by default */
4150 /* Begin copying all of the elements */
4151 if ( hv_exists((HV *)ver, "qv", 2) )
4152 hv_store((HV *)hv, "qv", 2, &PL_sv_yes, 0);
4154 if ( hv_exists((HV *)ver, "alpha", 5) )
4155 hv_store((HV *)hv, "alpha", 5, &PL_sv_yes, 0);
4157 if ( hv_exists((HV*)ver, "width", 5 ) )
4159 const I32 width = SvIV(*hv_fetch((HV*)ver, "width", 5, FALSE));
4160 hv_store((HV *)hv, "width", 5, newSViv(width), 0);
4163 sav = (AV *)SvRV(*hv_fetch((HV*)ver, "version", 7, FALSE));
4164 /* This will get reblessed later if a derived class*/
4165 for ( key = 0; key <= av_len(sav); key++ )
4167 const I32 rev = SvIV(*av_fetch(sav, key, FALSE));
4168 av_push(av, newSViv(rev));
4171 hv_store((HV *)hv, "version", 7, newRV_noinc((SV *)av), 0);
4175 if ( SvVOK(ver) ) { /* already a v-string */
4176 const MAGIC* const mg = mg_find(ver,PERL_MAGIC_vstring);
4177 const STRLEN len = mg->mg_len;
4178 char * const version = savepvn( (const char*)mg->mg_ptr, len);
4179 sv_setpvn(rv,version,len);
4184 sv_setsv(rv,ver); /* make a duplicate */
4193 =for apidoc upg_version
4195 In-place upgrade of the supplied SV to a version object.
4197 SV *sv = upg_version(SV *sv);
4199 Returns a pointer to the upgraded SV.
4205 Perl_upg_version(pTHX_ SV *ver)
4210 if ( SvNOK(ver) ) /* may get too much accuracy */
4213 const STRLEN len = my_sprintf(tbuf,"%.9"NVgf, SvNVX(ver));
4214 version = savepvn(tbuf, len);
4217 else if ( SvVOK(ver) ) { /* already a v-string */
4218 const MAGIC* const mg = mg_find(ver,PERL_MAGIC_vstring);
4219 version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
4223 else /* must be a string or something like a string */
4225 version = savepv(SvPV_nolen(ver));
4227 (void)scan_version(version, ver, qv);
4235 Validates that the SV contains a valid version object.
4237 bool vverify(SV *vobj);
4239 Note that it only confirms the bare minimum structure (so as not to get
4240 confused by derived classes which may contain additional hash entries):
4244 =item * The SV contains a [reference to a] hash
4246 =item * The hash contains a "version" key
4248 =item * The "version" key has [a reference to] an AV as its value
4256 Perl_vverify(pTHX_ SV *vs)
4262 /* see if the appropriate elements exist */
4263 if ( SvTYPE(vs) == SVt_PVHV
4264 && hv_exists((HV*)vs, "version", 7)
4265 && (sv = SvRV(*hv_fetch((HV*)vs, "version", 7, FALSE)))
4266 && SvTYPE(sv) == SVt_PVAV )
4275 Accepts a version object and returns the normalized floating
4276 point representation. Call like:
4280 NOTE: you can pass either the object directly or the SV
4281 contained within the RV.
4287 Perl_vnumify(pTHX_ SV *vs)
4292 SV * const sv = newSV(0);
4298 Perl_croak(aTHX_ "Invalid version object");
4300 /* see if various flags exist */
4301 if ( hv_exists((HV*)vs, "alpha", 5 ) )
4303 if ( hv_exists((HV*)vs, "width", 5 ) )
4304 width = SvIV(*hv_fetch((HV*)vs, "width", 5, FALSE));
4309 /* attempt to retrieve the version array */
4310 if ( !(av = (AV *)SvRV(*hv_fetch((HV*)vs, "version", 7, FALSE)) ) ) {
4322 digit = SvIV(*av_fetch(av, 0, 0));
4323 Perl_sv_setpvf(aTHX_ sv, "%d.", (int)PERL_ABS(digit));
4324 for ( i = 1 ; i < len ; i++ )
4326 digit = SvIV(*av_fetch(av, i, 0));
4328 const int denom = (width == 2 ? 10 : 100);
4329 const div_t term = div((int)PERL_ABS(digit),denom);
4330 Perl_sv_catpvf(aTHX_ sv, "%0*d_%d", width, term.quot, term.rem);
4333 Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
4339 digit = SvIV(*av_fetch(av, len, 0));
4340 if ( alpha && width == 3 ) /* alpha version */
4342 Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
4346 sv_catpvs(sv, "000");
4354 Accepts a version object and returns the normalized string
4355 representation. Call like:
4359 NOTE: you can pass either the object directly or the SV
4360 contained within the RV.
4366 Perl_vnormal(pTHX_ SV *vs)
4370 SV * const sv = newSV(0);
4376 Perl_croak(aTHX_ "Invalid version object");
4378 if ( hv_exists((HV*)vs, "alpha", 5 ) )
4380 av = (AV *)SvRV(*hv_fetch((HV*)vs, "version", 7, FALSE));
4388 digit = SvIV(*av_fetch(av, 0, 0));
4389 Perl_sv_setpvf(aTHX_ sv, "v%"IVdf, (IV)digit);
4390 for ( i = 1 ; i < len ; i++ ) {
4391 digit = SvIV(*av_fetch(av, i, 0));
4392 Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
4397 /* handle last digit specially */
4398 digit = SvIV(*av_fetch(av, len, 0));
4400 Perl_sv_catpvf(aTHX_ sv, "_%"IVdf, (IV)digit);
4402 Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
4405 if ( len <= 2 ) { /* short version, must be at least three */
4406 for ( len = 2 - len; len != 0; len-- )
4413 =for apidoc vstringify
4415 In order to maintain maximum compatibility with earlier versions
4416 of Perl, this function will return either the floating point
4417 notation or the multiple dotted notation, depending on whether
4418 the original version contained 1 or more dots, respectively
4424 Perl_vstringify(pTHX_ SV *vs)
4430 Perl_croak(aTHX_ "Invalid version object");
4432 if ( hv_exists((HV *)vs, "qv", 2) )
4441 Version object aware cmp. Both operands must already have been
4442 converted into version objects.
4448 Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
4451 bool lalpha = FALSE;
4452 bool ralpha = FALSE;
4461 if ( !vverify(lhv) )
4462 Perl_croak(aTHX_ "Invalid version object");
4464 if ( !vverify(rhv) )
4465 Perl_croak(aTHX_ "Invalid version object");
4467 /* get the left hand term */
4468 lav = (AV *)SvRV(*hv_fetch((HV*)lhv, "version", 7, FALSE));
4469 if ( hv_exists((HV*)lhv, "alpha", 5 ) )
4472 /* and the right hand term */
4473 rav = (AV *)SvRV(*hv_fetch((HV*)rhv, "version", 7, FALSE));
4474 if ( hv_exists((HV*)rhv, "alpha", 5 ) )
4482 while ( i <= m && retval == 0 )
4484 left = SvIV(*av_fetch(lav,i,0));
4485 right = SvIV(*av_fetch(rav,i,0));
4493 /* tiebreaker for alpha with identical terms */
4494 if ( retval == 0 && l == r && left == right && ( lalpha || ralpha ) )
4496 if ( lalpha && !ralpha )
4500 else if ( ralpha && !lalpha)
4506 if ( l != r && retval == 0 ) /* possible match except for trailing 0's */
4510 while ( i <= r && retval == 0 )
4512 if ( SvIV(*av_fetch(rav,i,0)) != 0 )
4513 retval = -1; /* not a match after all */
4519 while ( i <= l && retval == 0 )
4521 if ( SvIV(*av_fetch(lav,i,0)) != 0 )
4522 retval = +1; /* not a match after all */
4530 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT)
4531 # define EMULATE_SOCKETPAIR_UDP
4534 #ifdef EMULATE_SOCKETPAIR_UDP
4536 S_socketpair_udp (int fd[2]) {
4538 /* Fake a datagram socketpair using UDP to localhost. */
4539 int sockets[2] = {-1, -1};
4540 struct sockaddr_in addresses[2];
4542 Sock_size_t size = sizeof(struct sockaddr_in);
4543 unsigned short port;
4546 memset(&addresses, 0, sizeof(addresses));
4549 sockets[i] = PerlSock_socket(AF_INET, SOCK_DGRAM, PF_INET);
4550 if (sockets[i] == -1)
4551 goto tidy_up_and_fail;
4553 addresses[i].sin_family = AF_INET;
4554 addresses[i].sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4555 addresses[i].sin_port = 0; /* kernel choses port. */
4556 if (PerlSock_bind(sockets[i], (struct sockaddr *) &addresses[i],
4557 sizeof(struct sockaddr_in)) == -1)
4558 goto tidy_up_and_fail;
4561 /* Now have 2 UDP sockets. Find out which port each is connected to, and
4562 for each connect the other socket to it. */
4565 if (PerlSock_getsockname(sockets[i], (struct sockaddr *) &addresses[i],
4567 goto tidy_up_and_fail;
4568 if (size != sizeof(struct sockaddr_in))
4569 goto abort_tidy_up_and_fail;
4570 /* !1 is 0, !0 is 1 */
4571 if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i],
4572 sizeof(struct sockaddr_in)) == -1)
4573 goto tidy_up_and_fail;
4576 /* Now we have 2 sockets connected to each other. I don't trust some other
4577 process not to have already sent a packet to us (by random) so send
4578 a packet from each to the other. */
4581 /* I'm going to send my own port number. As a short.
4582 (Who knows if someone somewhere has sin_port as a bitfield and needs
4583 this routine. (I'm assuming crays have socketpair)) */
4584 port = addresses[i].sin_port;
4585 got = PerlLIO_write(sockets[i], &port, sizeof(port));
4586 if (got != sizeof(port)) {
4588 goto tidy_up_and_fail;
4589 goto abort_tidy_up_and_fail;
4593 /* Packets sent. I don't trust them to have arrived though.
4594 (As I understand it Solaris TCP stack is multithreaded. Non-blocking
4595 connect to localhost will use a second kernel thread. In 2.6 the
4596 first thread running the connect() returns before the second completes,
4597 so EINPROGRESS> In 2.7 the improved stack is faster and connect()
4598 returns 0. Poor programs have tripped up. One poor program's authors'
4599 had a 50-1 reverse stock split. Not sure how connected these were.)
4600 So I don't trust someone not to have an unpredictable UDP stack.
4604 struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */
4605 int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0];
4609 FD_SET(sockets[0], &rset);
4610 FD_SET(sockets[1], &rset);
4612 got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor);
4613 if (got != 2 || !FD_ISSET(sockets[0], &rset)
4614 || !FD_ISSET(sockets[1], &rset)) {
4615 /* I hope this is portable and appropriate. */
4617 goto tidy_up_and_fail;
4618 goto abort_tidy_up_and_fail;
4622 /* And the paranoia department even now doesn't trust it to have arrive
4623 (hence MSG_DONTWAIT). Or that what arrives was sent by us. */
4625 struct sockaddr_in readfrom;
4626 unsigned short buffer[2];
4631 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4632 sizeof(buffer), MSG_DONTWAIT,
4633 (struct sockaddr *) &readfrom, &size);
4635 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4637 (struct sockaddr *) &readfrom, &size);
4641 goto tidy_up_and_fail;
4642 if (got != sizeof(port)
4643 || size != sizeof(struct sockaddr_in)
4644 /* Check other socket sent us its port. */
4645 || buffer[0] != (unsigned short) addresses[!i].sin_port
4646 /* Check kernel says we got the datagram from that socket */
4647 || readfrom.sin_family != addresses[!i].sin_family
4648 || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr
4649 || readfrom.sin_port != addresses[!i].sin_port)
4650 goto abort_tidy_up_and_fail;
4653 /* My caller (my_socketpair) has validated that this is non-NULL */
4656 /* I hereby declare this connection open. May God bless all who cross
4660 abort_tidy_up_and_fail:
4661 errno = ECONNABORTED;
4664 const int save_errno = errno;
4665 if (sockets[0] != -1)
4666 PerlLIO_close(sockets[0]);
4667 if (sockets[1] != -1)
4668 PerlLIO_close(sockets[1]);
4673 #endif /* EMULATE_SOCKETPAIR_UDP */
4675 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET)
4677 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4678 /* Stevens says that family must be AF_LOCAL, protocol 0.
4679 I'm going to enforce that, then ignore it, and use TCP (or UDP). */
4684 struct sockaddr_in listen_addr;
4685 struct sockaddr_in connect_addr;
4690 || family != AF_UNIX
4693 errno = EAFNOSUPPORT;
4701 #ifdef EMULATE_SOCKETPAIR_UDP
4702 if (type == SOCK_DGRAM)
4703 return S_socketpair_udp(fd);
4706 listener = PerlSock_socket(AF_INET, type, 0);
4709 memset(&listen_addr, 0, sizeof(listen_addr));
4710 listen_addr.sin_family = AF_INET;
4711 listen_addr.sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4712 listen_addr.sin_port = 0; /* kernel choses port. */
4713 if (PerlSock_bind(listener, (struct sockaddr *) &listen_addr,
4714 sizeof(listen_addr)) == -1)
4715 goto tidy_up_and_fail;
4716 if (PerlSock_listen(listener, 1) == -1)
4717 goto tidy_up_and_fail;
4719 connector = PerlSock_socket(AF_INET, type, 0);
4720 if (connector == -1)
4721 goto tidy_up_and_fail;
4722 /* We want to find out the port number to connect to. */
4723 size = sizeof(connect_addr);
4724 if (PerlSock_getsockname(listener, (struct sockaddr *) &connect_addr,
4726 goto tidy_up_and_fail;
4727 if (size != sizeof(connect_addr))
4728 goto abort_tidy_up_and_fail;
4729 if (PerlSock_connect(connector, (struct sockaddr *) &connect_addr,
4730 sizeof(connect_addr)) == -1)
4731 goto tidy_up_and_fail;
4733 size = sizeof(listen_addr);
4734 acceptor = PerlSock_accept(listener, (struct sockaddr *) &listen_addr,
4737 goto tidy_up_and_fail;
4738 if (size != sizeof(listen_addr))
4739 goto abort_tidy_up_and_fail;
4740 PerlLIO_close(listener);
4741 /* Now check we are talking to ourself by matching port and host on the
4743 if (PerlSock_getsockname(connector, (struct sockaddr *) &connect_addr,
4745 goto tidy_up_and_fail;
4746 if (size != sizeof(connect_addr)
4747 || listen_addr.sin_family != connect_addr.sin_family
4748 || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr
4749 || listen_addr.sin_port != connect_addr.sin_port) {
4750 goto abort_tidy_up_and_fail;
4756 abort_tidy_up_and_fail:
4758 errno = ECONNABORTED; /* This would be the standard thing to do. */
4760 # ifdef ECONNREFUSED
4761 errno = ECONNREFUSED; /* E.g. Symbian does not have ECONNABORTED. */
4763 errno = ETIMEDOUT; /* Desperation time. */
4768 const int save_errno = errno;
4770 PerlLIO_close(listener);
4771 if (connector != -1)
4772 PerlLIO_close(connector);
4774 PerlLIO_close(acceptor);
4780 /* In any case have a stub so that there's code corresponding
4781 * to the my_socketpair in global.sym. */
4783 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4784 #ifdef HAS_SOCKETPAIR
4785 return socketpair(family, type, protocol, fd);
4794 =for apidoc sv_nosharing
4796 Dummy routine which "shares" an SV when there is no sharing module present.
4797 Or "locks" it. Or "unlocks" it. In other words, ignores its single SV argument.
4798 Exists to avoid test for a NULL function pointer and because it could
4799 potentially warn under some level of strict-ness.
4805 Perl_sv_nosharing(pTHX_ SV *sv)
4807 PERL_UNUSED_ARG(sv);
4811 Perl_parse_unicode_opts(pTHX_ const char **popt)
4813 const char *p = *popt;
4818 opt = (U32) atoi(p);
4819 while (isDIGIT(*p)) p++;
4820 if (*p && *p != '\n' && *p != '\r')
4821 Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
4826 case PERL_UNICODE_STDIN:
4827 opt |= PERL_UNICODE_STDIN_FLAG; break;
4828 case PERL_UNICODE_STDOUT:
4829 opt |= PERL_UNICODE_STDOUT_FLAG; break;
4830 case PERL_UNICODE_STDERR:
4831 opt |= PERL_UNICODE_STDERR_FLAG; break;
4832 case PERL_UNICODE_STD:
4833 opt |= PERL_UNICODE_STD_FLAG; break;
4834 case PERL_UNICODE_IN:
4835 opt |= PERL_UNICODE_IN_FLAG; break;
4836 case PERL_UNICODE_OUT:
4837 opt |= PERL_UNICODE_OUT_FLAG; break;
4838 case PERL_UNICODE_INOUT:
4839 opt |= PERL_UNICODE_INOUT_FLAG; break;
4840 case PERL_UNICODE_LOCALE:
4841 opt |= PERL_UNICODE_LOCALE_FLAG; break;
4842 case PERL_UNICODE_ARGV:
4843 opt |= PERL_UNICODE_ARGV_FLAG; break;
4845 if (*p != '\n' && *p != '\r')
4847 "Unknown Unicode option letter '%c'", *p);
4853 opt = PERL_UNICODE_DEFAULT_FLAGS;
4855 if (opt & ~PERL_UNICODE_ALL_FLAGS)
4856 Perl_croak(aTHX_ "Unknown Unicode option value %"UVuf,
4857 (UV) (opt & ~PERL_UNICODE_ALL_FLAGS));
4868 * This is really just a quick hack which grabs various garbage
4869 * values. It really should be a real hash algorithm which
4870 * spreads the effect of every input bit onto every output bit,
4871 * if someone who knows about such things would bother to write it.
4872 * Might be a good idea to add that function to CORE as well.
4873 * No numbers below come from careful analysis or anything here,
4874 * except they are primes and SEED_C1 > 1E6 to get a full-width
4875 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
4876 * probably be bigger too.
4879 # define SEED_C1 1000003
4880 #define SEED_C4 73819
4882 # define SEED_C1 25747
4883 #define SEED_C4 20639
4887 #define SEED_C5 26107
4889 #ifndef PERL_NO_DEV_RANDOM
4894 # include <starlet.h>
4895 /* when[] = (low 32 bits, high 32 bits) of time since epoch
4896 * in 100-ns units, typically incremented ever 10 ms. */
4897 unsigned int when[2];
4899 # ifdef HAS_GETTIMEOFDAY
4900 struct timeval when;
4906 /* This test is an escape hatch, this symbol isn't set by Configure. */
4907 #ifndef PERL_NO_DEV_RANDOM
4908 #ifndef PERL_RANDOM_DEVICE
4909 /* /dev/random isn't used by default because reads from it will block
4910 * if there isn't enough entropy available. You can compile with
4911 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
4912 * is enough real entropy to fill the seed. */
4913 # define PERL_RANDOM_DEVICE "/dev/urandom"
4915 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
4917 if (PerlLIO_read(fd, (void*)&u, sizeof u) != sizeof u)
4926 _ckvmssts(sys$gettim(when));
4927 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
4929 # ifdef HAS_GETTIMEOFDAY
4930 PerlProc_gettimeofday(&when,NULL);
4931 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
4934 u = (U32)SEED_C1 * when;
4937 u += SEED_C3 * (U32)PerlProc_getpid();
4938 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
4939 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
4940 u += SEED_C5 * (U32)PTR2UV(&when);
4946 Perl_get_hash_seed(pTHX)
4948 const char *s = PerlEnv_getenv("PERL_HASH_SEED");
4952 while (isSPACE(*s)) s++;
4953 if (s && isDIGIT(*s))
4954 myseed = (UV)Atoul(s);
4956 #ifdef USE_HASH_SEED_EXPLICIT
4960 /* Compute a random seed */
4961 (void)seedDrand01((Rand_seed_t)seed());
4962 myseed = (UV)(Drand01() * (NV)UV_MAX);
4963 #if RANDBITS < (UVSIZE * 8)
4964 /* Since there are not enough randbits to to reach all
4965 * the bits of a UV, the low bits might need extra
4966 * help. Sum in another random number that will
4967 * fill in the low bits. */
4969 (UV)(Drand01() * (NV)((1 << ((UVSIZE * 8 - RANDBITS))) - 1));
4970 #endif /* RANDBITS < (UVSIZE * 8) */
4971 if (myseed == 0) { /* Superparanoia. */
4972 myseed = (UV)(Drand01() * (NV)UV_MAX); /* One more chance. */
4974 Perl_croak(aTHX_ "Your random numbers are not that random");
4977 PL_rehash_seed_set = TRUE;
4984 Perl_stashpv_hvname_match(pTHX_ const COP *c, const HV *hv)
4986 const char * const stashpv = CopSTASHPV(c);
4987 const char * const name = HvNAME_get(hv);
4989 if (stashpv == name)
4991 if (stashpv && name)
4992 if (strEQ(stashpv, name))
4999 #ifdef PERL_GLOBAL_STRUCT
5002 Perl_init_global_struct(pTHX)
5004 struct perl_vars *plvarsp = NULL;
5005 #ifdef PERL_GLOBAL_STRUCT
5006 # define PERL_GLOBAL_STRUCT_INIT
5007 # include "opcode.h" /* the ppaddr and check */
5008 const IV nppaddr = sizeof(Gppaddr)/sizeof(Perl_ppaddr_t);
5009 const IV ncheck = sizeof(Gcheck) /sizeof(Perl_check_t);
5010 # ifdef PERL_GLOBAL_STRUCT_PRIVATE
5011 /* PerlMem_malloc() because can't use even safesysmalloc() this early. */
5012 plvarsp = (struct perl_vars*)PerlMem_malloc(sizeof(struct perl_vars));
5016 plvarsp = PL_VarsPtr;
5017 # endif /* PERL_GLOBAL_STRUCT_PRIVATE */
5023 # define PERLVAR(var,type) /**/
5024 # define PERLVARA(var,n,type) /**/
5025 # define PERLVARI(var,type,init) plvarsp->var = init;
5026 # define PERLVARIC(var,type,init) plvarsp->var = init;
5027 # define PERLVARISC(var,init) Copy(init, plvarsp->var, sizeof(init), char);
5028 # include "perlvars.h"
5034 # ifdef PERL_GLOBAL_STRUCT
5035 plvarsp->Gppaddr = PerlMem_malloc(nppaddr * sizeof(Perl_ppaddr_t));
5036 if (!plvarsp->Gppaddr)
5038 plvarsp->Gcheck = PerlMem_malloc(ncheck * sizeof(Perl_check_t));
5039 if (!plvarsp->Gcheck)
5041 Copy(Gppaddr, plvarsp->Gppaddr, nppaddr, Perl_ppaddr_t);
5042 Copy(Gcheck, plvarsp->Gcheck, ncheck, Perl_check_t);
5044 # ifdef PERL_SET_VARS
5045 PERL_SET_VARS(plvarsp);
5047 # undef PERL_GLOBAL_STRUCT_INIT
5052 #endif /* PERL_GLOBAL_STRUCT */
5054 #ifdef PERL_GLOBAL_STRUCT
5057 Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp)
5059 #ifdef PERL_GLOBAL_STRUCT
5060 # ifdef PERL_UNSET_VARS
5061 PERL_UNSET_VARS(plvarsp);
5063 free(plvarsp->Gppaddr);
5064 free(plvarsp->Gcheck);
5065 # ifdef PERL_GLOBAL_STRUCT_PRIVATE
5071 #endif /* PERL_GLOBAL_STRUCT */
5075 #define PERL_MEM_LOG_SPRINTF_BUF_SIZE 128
5078 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)
5080 #ifdef PERL_MEM_LOG_STDERR
5081 /* We can't use PerlIO for obvious reasons. */
5082 char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
5083 const STRLEN len = my_sprintf(buf,
5084 "alloc: %s:%d:%s: %"IVdf" %"UVuf
5085 " %s = %"IVdf": %"UVxf"\n",
5086 filename, linenumber, funcname, n, typesize,
5087 typename, n * typesize, PTR2UV(newalloc));
5088 PerlLIO_write(2, buf, len);
5094 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)
5096 #ifdef PERL_MEM_LOG_STDERR
5097 /* We can't use PerlIO for obvious reasons. */
5098 char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
5099 const STRLEN len = my_sprintf(buf, "realloc: %s:%d:%s: %"IVdf" %"UVuf
5100 " %s = %"IVdf": %"UVxf" -> %"UVxf"\n",
5101 filename, linenumber, funcname, n, typesize,
5102 typename, n * typesize, PTR2UV(oldalloc),
5104 PerlLIO_write(2, buf, len);
5110 Perl_mem_log_free(Malloc_t oldalloc, const char *filename, const int linenumber, const char *funcname)
5112 #ifdef PERL_MEM_LOG_STDERR
5113 /* We can't use PerlIO for obvious reasons. */
5114 char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
5115 const STRLEN len = my_sprintf(buf, "free: %s:%d:%s: %"UVxf"\n",
5116 filename, linenumber, funcname,
5118 PerlLIO_write(2, buf, len);
5123 #endif /* PERL_MEM_LOG */
5126 =for apidoc my_sprintf
5128 The C library C<sprintf>, wrapped if necessary, to ensure that it will return
5129 the length of the string written to the buffer. Only rare pre-ANSI systems
5130 need the wrapper function - usually this is a direct call to C<sprintf>.
5134 #ifndef SPRINTF_RETURNS_STRLEN
5136 Perl_my_sprintf(char *buffer, const char* pat, ...)
5139 va_start(args, pat);
5140 vsprintf(buffer, pat, args);
5142 return strlen(buffer);
5147 Perl_my_clearenv(pTHX)
5150 #if ! defined(PERL_MICRO)
5151 # if defined(PERL_IMPLICIT_SYS) || defined(WIN32)
5153 # else /* ! (PERL_IMPLICIT_SYS || WIN32) */
5154 # if defined(USE_ENVIRON_ARRAY)
5155 # if defined(USE_ITHREADS)
5156 /* only the parent thread can clobber the process environment */
5157 if (PL_curinterp == aTHX)
5158 # endif /* USE_ITHREADS */
5160 # if ! defined(PERL_USE_SAFE_PUTENV)
5161 if ( !PL_use_safe_putenv) {
5163 if (environ == PL_origenviron)
5164 environ = (char**)safesysmalloc(sizeof(char*));
5166 for (i = 0; environ[i]; i++)
5167 (void)safesysfree(environ[i]);
5170 # else /* PERL_USE_SAFE_PUTENV */
5171 # if defined(HAS_CLEARENV)
5173 # elif defined(HAS_UNSETENV)
5174 int bsiz = 80; /* Most envvar names will be shorter than this. */
5175 char *buf = (char*)safesysmalloc(bsiz * sizeof(char));
5176 while (*environ != NULL) {
5177 char *e = strchr(*environ, '=');
5178 int l = e ? e - *environ : strlen(*environ);
5180 (void)safesysfree(buf);
5182 buf = (char*)safesysmalloc(bsiz * sizeof(char));
5184 strncpy(buf, *environ, l);
5186 (void)unsetenv(buf);
5188 (void)safesysfree(buf);
5189 # else /* ! HAS_CLEARENV && ! HAS_UNSETENV */
5190 /* Just null environ and accept the leakage. */
5192 # endif /* HAS_CLEARENV || HAS_UNSETENV */
5193 # endif /* ! PERL_USE_SAFE_PUTENV */
5195 # endif /* USE_ENVIRON_ARRAY */
5196 # endif /* PERL_IMPLICIT_SYS || WIN32 */
5197 #endif /* PERL_MICRO */
5200 #ifdef PERL_IMPLICIT_CONTEXT
5202 /* implements the MY_CXT_INIT macro. The first time a module is loaded,
5203 the global PL_my_cxt_index is incremented, and that value is assigned to
5204 that module's static my_cxt_index (who's address is passed as an arg).
5205 Then, for each interpreter this function is called for, it makes sure a
5206 void* slot is available to hang the static data off, by allocating or
5207 extending the interpreter's PL_my_cxt_list array */
5210 Perl_my_cxt_init(pTHX_ int *index, size_t size)
5214 /* this module hasn't been allocated an index yet */
5215 MUTEX_LOCK(&PL_my_ctx_mutex);
5216 *index = PL_my_cxt_index++;
5217 MUTEX_UNLOCK(&PL_my_ctx_mutex);
5220 /* make sure the array is big enough */
5221 if (PL_my_cxt_size <= *index) {
5222 if (PL_my_cxt_size) {
5223 while (PL_my_cxt_size <= *index)
5224 PL_my_cxt_size *= 2;
5225 Renew(PL_my_cxt_list, PL_my_cxt_size, void *);
5228 PL_my_cxt_size = 16;
5229 Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
5232 /* newSV() allocates one more than needed */
5233 p = (void*)SvPVX(newSV(size-1));
5234 PL_my_cxt_list[*index] = p;
5235 Zero(p, size, char);
5242 * c-indentation-style: bsd
5244 * indent-tabs-mode: t
5247 * ex: set ts=8 sts=4 sw=4 noet: