3 * Copyright (c) 1991-2002, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * "Very useful, no doubt, that was to Saruman; yet it seems that he was
12 * not content." --Gandalf
16 #define PERL_IN_UTIL_C
20 #if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
25 # define SIG_ERR ((Sighandler_t) -1)
30 # include <sys/wait.h>
35 # include <sys/select.h>
43 long xcount[MAXXCOUNT];
44 long lastxcount[MAXXCOUNT];
45 long xycount[MAXXCOUNT][MAXYCOUNT];
46 long lastxycount[MAXXCOUNT][MAXYCOUNT];
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.
60 /* paranoid version of system's malloc() */
63 Perl_safesysmalloc(MEM_SIZE size)
69 PerlIO_printf(Perl_error_log,
70 "Allocation too large: %lx\n", size) FLUSH;
73 #endif /* HAS_64K_LIMIT */
76 Perl_croak_nocontext("panic: malloc");
78 ptr = (Malloc_t)PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */
79 PERL_ALLOC_CHECK(ptr);
80 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
86 PerlIO_puts(Perl_error_log,PL_no_mem) FLUSH;
93 /* paranoid version of system's realloc() */
96 Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
100 #if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) && !defined(PERL_MICRO)
101 Malloc_t PerlMem_realloc();
102 #endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */
106 PerlIO_printf(Perl_error_log,
107 "Reallocation too large: %lx\n", size) FLUSH;
110 #endif /* HAS_64K_LIMIT */
117 return safesysmalloc(size);
120 Perl_croak_nocontext("panic: realloc");
122 ptr = (Malloc_t)PerlMem_realloc(where,size);
123 PERL_ALLOC_CHECK(ptr);
125 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++));
126 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
133 PerlIO_puts(Perl_error_log,PL_no_mem) FLUSH;
140 /* safe version of system's free() */
143 Perl_safesysfree(Malloc_t where)
145 #ifdef PERL_IMPLICIT_SYS
148 DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) free\n",PTR2UV(where),(long)PL_an++));
155 /* safe version of system's calloc() */
158 Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
164 if (size * count > 0xffff) {
165 PerlIO_printf(Perl_error_log,
166 "Allocation too large: %lx\n", size * count) FLUSH;
169 #endif /* HAS_64K_LIMIT */
171 if ((long)size < 0 || (long)count < 0)
172 Perl_croak_nocontext("panic: calloc");
175 ptr = (Malloc_t)PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */
176 PERL_ALLOC_CHECK(ptr);
177 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));
179 memset((void*)ptr, 0, size);
185 PerlIO_puts(Perl_error_log,PL_no_mem) FLUSH;
194 struct mem_test_strut {
202 # define ALIGN sizeof(struct mem_test_strut)
204 # define sizeof_chunk(ch) (((struct mem_test_strut*) (ch))->size)
205 # define typeof_chunk(ch) \
206 (((struct mem_test_strut*) (ch))->u.c[0] + ((struct mem_test_strut*) (ch))->u.c[1]*100)
207 # define set_typeof_chunk(ch,t) \
208 (((struct mem_test_strut*) (ch))->u.c[0] = t % 100, ((struct mem_test_strut*) (ch))->u.c[1] = t / 100)
209 #define SIZE_TO_Y(size) ( (size) > MAXY_SIZE \
212 ? ((size) - 1)/8 + 5 \
216 Perl_safexmalloc(I32 x, MEM_SIZE size)
218 register char* where = (char*)safemalloc(size + ALIGN);
221 xycount[x][SIZE_TO_Y(size)]++;
222 set_typeof_chunk(where, x);
223 sizeof_chunk(where) = size;
224 return (Malloc_t)(where + ALIGN);
228 Perl_safexrealloc(Malloc_t wh, MEM_SIZE size)
230 char *where = (char*)wh;
233 return safexmalloc(0,size);
236 MEM_SIZE old = sizeof_chunk(where - ALIGN);
237 int t = typeof_chunk(where - ALIGN);
238 register char* new = (char*)saferealloc(where - ALIGN, size + ALIGN);
240 xycount[t][SIZE_TO_Y(old)]--;
241 xycount[t][SIZE_TO_Y(size)]++;
242 xcount[t] += size - old;
243 sizeof_chunk(new) = size;
244 return (Malloc_t)(new + ALIGN);
249 Perl_safexfree(Malloc_t wh)
252 char *where = (char*)wh;
258 size = sizeof_chunk(where);
259 x = where[0] + 100 * where[1];
261 xycount[x][SIZE_TO_Y(size)]--;
266 Perl_safexcalloc(I32 x,MEM_SIZE count, MEM_SIZE size)
268 register char * where = (char*)safexmalloc(x, size * count + ALIGN);
270 xycount[x][SIZE_TO_Y(size)]++;
271 memset((void*)(where + ALIGN), 0, size * count);
272 set_typeof_chunk(where, x);
273 sizeof_chunk(where) = size;
274 return (Malloc_t)(where + ALIGN);
278 S_xstat(pTHX_ int flag)
280 register I32 i, j, total = 0;
281 I32 subtot[MAXYCOUNT];
283 for (j = 0; j < MAXYCOUNT; j++) {
287 PerlIO_printf(Perl_debug_log, " Id subtot 4 8 12 16 20 24 28 32 36 40 48 56 64 72 80 80+\n", total);
288 for (i = 0; i < MAXXCOUNT; i++) {
290 for (j = 0; j < MAXYCOUNT; j++) {
291 subtot[j] += xycount[i][j];
294 ? xcount[i] /* Have something */
296 ? xcount[i] != lastxcount[i] /* Changed */
297 : xcount[i] > lastxcount[i])) { /* Growed */
298 PerlIO_printf(Perl_debug_log,"%2d %02d %7ld ", i / 100, i % 100,
299 flag == 2 ? xcount[i] - lastxcount[i] : xcount[i]);
300 lastxcount[i] = xcount[i];
301 for (j = 0; j < MAXYCOUNT; j++) {
303 ? xycount[i][j] /* Have something */
305 ? xycount[i][j] != lastxycount[i][j] /* Changed */
306 : xycount[i][j] > lastxycount[i][j])) { /* Growed */
307 PerlIO_printf(Perl_debug_log,"%3ld ",
309 ? xycount[i][j] - lastxycount[i][j]
311 lastxycount[i][j] = xycount[i][j];
313 PerlIO_printf(Perl_debug_log, " . ", xycount[i][j]);
316 PerlIO_printf(Perl_debug_log, "\n");
320 PerlIO_printf(Perl_debug_log, "Total %7ld ", total);
321 for (j = 0; j < MAXYCOUNT; j++) {
323 PerlIO_printf(Perl_debug_log, "%3ld ", subtot[j]);
325 PerlIO_printf(Perl_debug_log, " . ");
328 PerlIO_printf(Perl_debug_log, "\n");
332 #endif /* LEAKTEST */
334 /* These must be defined when not using Perl's malloc for binary
339 Malloc_t Perl_malloc (MEM_SIZE nbytes)
342 return (Malloc_t)PerlMem_malloc(nbytes);
345 Malloc_t Perl_calloc (MEM_SIZE elements, MEM_SIZE size)
348 return (Malloc_t)PerlMem_calloc(elements, size);
351 Malloc_t Perl_realloc (Malloc_t where, MEM_SIZE nbytes)
354 return (Malloc_t)PerlMem_realloc(where, nbytes);
357 Free_t Perl_mfree (Malloc_t where)
365 /* copy a string up to some (non-backslashed) delimiter, if any */
368 Perl_delimcpy(pTHX_ register char *to, register char *toend, register char *from, register char *fromend, register int delim, I32 *retlen)
371 for (tolen = 0; from < fromend; from++, tolen++) {
373 if (from[1] == delim)
382 else if (*from == delim)
393 /* return ptr to little string in big string, NULL if not found */
394 /* This routine was donated by Corey Satten. */
397 Perl_instr(pTHX_ register const char *big, register const char *little)
399 register const char *s, *x;
410 for (x=big,s=little; *s; /**/ ) {
419 return (char*)(big-1);
424 /* same as instr but allow embedded nulls */
427 Perl_ninstr(pTHX_ register const char *big, register const char *bigend, const char *little, const char *lend)
429 register const char *s, *x;
430 register I32 first = *little;
431 register const char *littleend = lend;
433 if (!first && little >= littleend)
435 if (bigend - big < littleend - little)
437 bigend -= littleend - little++;
438 while (big <= bigend) {
441 for (x=big,s=little; s < littleend; /**/ ) {
448 return (char*)(big-1);
453 /* reverse of the above--find last substring */
456 Perl_rninstr(pTHX_ register const char *big, const char *bigend, const char *little, const char *lend)
458 register const char *bigbeg;
459 register const char *s, *x;
460 register I32 first = *little;
461 register const char *littleend = lend;
463 if (!first && little >= littleend)
464 return (char*)bigend;
466 big = bigend - (littleend - little++);
467 while (big >= bigbeg) {
470 for (x=big+2,s=little; s < littleend; /**/ ) {
477 return (char*)(big+1);
482 #define FBM_TABLE_OFFSET 2 /* Number of bytes between EOS and table*/
484 /* As a space optimization, we do not compile tables for strings of length
485 0 and 1, and for strings of length 2 unless FBMcf_TAIL. These are
486 special-cased in fbm_instr().
488 If FBMcf_TAIL, the table is created as if the string has a trailing \n. */
491 =head1 Miscellaneous Functions
493 =for apidoc fbm_compile
495 Analyses the string in order to make fast searches on it using fbm_instr()
496 -- the Boyer-Moore algorithm.
502 Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
511 if (flags & FBMcf_TAIL)
512 sv_catpvn(sv, "\n", 1); /* Taken into account in fbm_instr() */
513 s = (U8*)SvPV_force(sv, len);
514 (void)SvUPGRADE(sv, SVt_PVBM);
515 if (len == 0) /* TAIL might be on a zero-length string. */
525 Sv_Grow(sv, len + 256 + FBM_TABLE_OFFSET);
526 table = (unsigned char*)(SvPVX(sv) + len + FBM_TABLE_OFFSET);
527 s = table - 1 - FBM_TABLE_OFFSET; /* last char */
528 memset((void*)table, mlen, 256);
529 table[-1] = (U8)flags;
531 sb = s - mlen + 1; /* first char (maybe) */
533 if (table[*s] == mlen)
538 sv_magic(sv, Nullsv, PERL_MAGIC_bm, Nullch, 0); /* deep magic */
541 s = (unsigned char*)(SvPVX(sv)); /* deeper magic */
542 for (i = 0; i < len; i++) {
543 if (PL_freq[s[i]] < frequency) {
545 frequency = PL_freq[s[i]];
548 BmRARE(sv) = s[rarest];
549 BmPREVIOUS(sv) = (U16)rarest;
550 BmUSEFUL(sv) = 100; /* Initial value */
551 if (flags & FBMcf_TAIL)
553 DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %d\n",
554 BmRARE(sv),BmPREVIOUS(sv)));
557 /* If SvTAIL(littlestr), it has a fake '\n' at end. */
558 /* If SvTAIL is actually due to \Z or \z, this gives false positives
562 =for apidoc fbm_instr
564 Returns the location of the SV in the string delimited by C<str> and
565 C<strend>. It returns C<Nullch> if the string can't be found. The C<sv>
566 does not have to be fbm_compiled, but the search will not be as fast
573 Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *littlestr, U32 flags)
575 register unsigned char *s;
577 register unsigned char *little = (unsigned char *)SvPV(littlestr,l);
578 register STRLEN littlelen = l;
579 register I32 multiline = flags & FBMrf_MULTILINE;
581 if ((STRLEN)(bigend - big) < littlelen) {
582 if ( SvTAIL(littlestr)
583 && ((STRLEN)(bigend - big) == littlelen - 1)
585 || (*big == *little &&
586 memEQ((char *)big, (char *)little, littlelen - 1))))
591 if (littlelen <= 2) { /* Special-cased */
593 if (littlelen == 1) {
594 if (SvTAIL(littlestr) && !multiline) { /* Anchor only! */
595 /* Know that bigend != big. */
596 if (bigend[-1] == '\n')
597 return (char *)(bigend - 1);
598 return (char *) bigend;
606 if (SvTAIL(littlestr))
607 return (char *) bigend;
611 return (char*)big; /* Cannot be SvTAIL! */
614 if (SvTAIL(littlestr) && !multiline) {
615 if (bigend[-1] == '\n' && bigend[-2] == *little)
616 return (char*)bigend - 2;
617 if (bigend[-1] == *little)
618 return (char*)bigend - 1;
622 /* This should be better than FBM if c1 == c2, and almost
623 as good otherwise: maybe better since we do less indirection.
624 And we save a lot of memory by caching no table. */
625 register unsigned char c1 = little[0];
626 register unsigned char c2 = little[1];
631 while (s <= bigend) {
641 goto check_1char_anchor;
652 goto check_1char_anchor;
655 while (s <= bigend) {
660 goto check_1char_anchor;
669 check_1char_anchor: /* One char and anchor! */
670 if (SvTAIL(littlestr) && (*bigend == *little))
671 return (char *)bigend; /* bigend is already decremented. */
674 if (SvTAIL(littlestr) && !multiline) { /* tail anchored? */
675 s = bigend - littlelen;
676 if (s >= big && bigend[-1] == '\n' && *s == *little
677 /* Automatically of length > 2 */
678 && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
680 return (char*)s; /* how sweet it is */
683 && memEQ((char*)s + 2, (char*)little + 1, littlelen - 2))
685 return (char*)s + 1; /* how sweet it is */
689 if (SvTYPE(littlestr) != SVt_PVBM || !SvVALID(littlestr)) {
690 char *b = ninstr((char*)big,(char*)bigend,
691 (char*)little, (char*)little + littlelen);
693 if (!b && SvTAIL(littlestr)) { /* Automatically multiline! */
694 /* Chop \n from littlestr: */
695 s = bigend - littlelen + 1;
697 && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
706 { /* Do actual FBM. */
707 register unsigned char *table = little + littlelen + FBM_TABLE_OFFSET;
708 register unsigned char *oldlittle;
710 if (littlelen > (STRLEN)(bigend - big))
712 --littlelen; /* Last char found by table lookup */
715 little += littlelen; /* last char */
722 if ((tmp = table[*s])) {
723 if ((s += tmp) < bigend)
727 else { /* less expensive than calling strncmp() */
728 register unsigned char *olds = s;
733 if (*--s == *--little)
735 s = olds + 1; /* here we pay the price for failure */
737 if (s < bigend) /* fake up continue to outer loop */
745 if ( s == bigend && (table[-1] & FBMcf_TAIL)
746 && memEQ((char *)(bigend - littlelen),
747 (char *)(oldlittle - littlelen), littlelen) )
748 return (char*)bigend - littlelen;
753 /* start_shift, end_shift are positive quantities which give offsets
754 of ends of some substring of bigstr.
755 If `last' we want the last occurrence.
756 old_posp is the way of communication between consequent calls if
757 the next call needs to find the .
758 The initial *old_posp should be -1.
760 Note that we take into account SvTAIL, so one can get extra
761 optimizations if _ALL flag is set.
764 /* If SvTAIL is actually due to \Z or \z, this gives false positives
765 if PL_multiline. In fact if !PL_multiline the authoritative answer
766 is not supported yet. */
769 Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last)
771 register unsigned char *s, *x;
772 register unsigned char *big;
774 register I32 previous;
776 register unsigned char *little;
777 register I32 stop_pos;
778 register unsigned char *littleend;
782 ? (pos = PL_screamfirst[BmRARE(littlestr)]) < 0
783 : (((pos = *old_posp), pos += PL_screamnext[pos]) == 0)) {
785 if ( BmRARE(littlestr) == '\n'
786 && BmPREVIOUS(littlestr) == SvCUR(littlestr) - 1) {
787 little = (unsigned char *)(SvPVX(littlestr));
788 littleend = little + SvCUR(littlestr);
795 little = (unsigned char *)(SvPVX(littlestr));
796 littleend = little + SvCUR(littlestr);
798 /* The value of pos we can start at: */
799 previous = BmPREVIOUS(littlestr);
800 big = (unsigned char *)(SvPVX(bigstr));
801 /* The value of pos we can stop at: */
802 stop_pos = SvCUR(bigstr) - end_shift - (SvCUR(littlestr) - 1 - previous);
803 if (previous + start_shift > stop_pos) {
805 stop_pos does not include SvTAIL in the count, so this check is incorrect
806 (I think) - see [ID 20010618.006] and t/op/study.t. HVDS 2001/06/19
809 if (previous + start_shift == stop_pos + 1) /* A fake '\n'? */
814 while (pos < previous + start_shift) {
815 if (!(pos += PL_screamnext[pos]))
820 if (pos >= stop_pos) break;
821 if (big[pos] != first)
823 for (x=big+pos+1,s=little; s < littleend; /**/ ) {
829 if (s == littleend) {
831 if (!last) return (char *)(big+pos);
834 } while ( pos += PL_screamnext[pos] );
836 return (char *)(big+(*old_posp));
838 if (!SvTAIL(littlestr) || (end_shift > 0))
840 /* Ignore the trailing "\n". This code is not microoptimized */
841 big = (unsigned char *)(SvPVX(bigstr) + SvCUR(bigstr));
842 stop_pos = littleend - little; /* Actual littlestr len */
847 && ((stop_pos == 1) ||
848 memEQ((char *)(big + 1), (char *)little, stop_pos - 1)))
854 Perl_ibcmp(pTHX_ const char *s1, const char *s2, register I32 len)
856 register U8 *a = (U8 *)s1;
857 register U8 *b = (U8 *)s2;
859 if (*a != *b && *a != PL_fold[*b])
867 Perl_ibcmp_locale(pTHX_ const char *s1, const char *s2, register I32 len)
869 register U8 *a = (U8 *)s1;
870 register U8 *b = (U8 *)s2;
872 if (*a != *b && *a != PL_fold_locale[*b])
879 /* copy a string to a safe spot */
882 =head1 Memory Management
886 Perl's version of C<strdup()>. Returns a pointer to a newly allocated
887 string which is a duplicate of C<pv>. The size of the string is
888 determined by C<strlen()>. The memory allocated for the new string can
889 be freed with the C<Safefree()> function.
895 Perl_savepv(pTHX_ const char *pv)
897 register char *newaddr = Nullch;
899 New(902,newaddr,strlen(pv)+1,char);
900 (void)strcpy(newaddr,pv);
905 /* same thing but with a known length */
910 Perl's version of what C<strndup()> would be if it existed. Returns a
911 pointer to a newly allocated string which is a duplicate of the first
912 C<len> bytes from C<pv>. The memory allocated for the new string can be
913 freed with the C<Safefree()> function.
919 Perl_savepvn(pTHX_ const char *pv, register I32 len)
921 register char *newaddr;
923 New(903,newaddr,len+1,char);
924 /* Give a meaning to NULL pointer mainly for the use in sv_magic() */
926 Copy(pv,newaddr,len,char); /* might not be null terminated */
927 newaddr[len] = '\0'; /* is now */
930 Zero(newaddr,len+1,char);
936 =for apidoc savesharedpv
938 A version of C<savepv()> which allocates the duplicate string in memory
939 which is shared between threads.
944 Perl_savesharedpv(pTHX_ const char *pv)
946 register char *newaddr = Nullch;
948 newaddr = (char*)PerlMemShared_malloc(strlen(pv)+1);
949 (void)strcpy(newaddr,pv);
956 /* the SV for Perl_form() and mess() is not kept in an arena */
965 return sv_2mortal(newSVpvn("",0));
970 /* Create as PVMG now, to avoid any upgrading later */
972 Newz(905, any, 1, XPVMG);
973 SvFLAGS(sv) = SVt_PVMG;
974 SvANY(sv) = (void*)any;
975 SvREFCNT(sv) = 1 << 30; /* practically infinite */
980 #if defined(PERL_IMPLICIT_CONTEXT)
982 Perl_form_nocontext(const char* pat, ...)
988 retval = vform(pat, &args);
992 #endif /* PERL_IMPLICIT_CONTEXT */
995 =head1 Miscellaneous Functions
998 Takes a sprintf-style format pattern and conventional
999 (non-SV) arguments and returns the formatted string.
1001 (char *) Perl_form(pTHX_ const char* pat, ...)
1003 can be used any place a string (char *) is required:
1005 char * s = Perl_form("%d.%d",major,minor);
1007 Uses a single private buffer so if you want to format several strings you
1008 must explicitly copy the earlier strings away (and free the copies when you
1015 Perl_form(pTHX_ const char* pat, ...)
1019 va_start(args, pat);
1020 retval = vform(pat, &args);
1026 Perl_vform(pTHX_ const char *pat, va_list *args)
1028 SV *sv = mess_alloc();
1029 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
1033 #if defined(PERL_IMPLICIT_CONTEXT)
1035 Perl_mess_nocontext(const char *pat, ...)
1040 va_start(args, pat);
1041 retval = vmess(pat, &args);
1045 #endif /* PERL_IMPLICIT_CONTEXT */
1048 Perl_mess(pTHX_ const char *pat, ...)
1052 va_start(args, pat);
1053 retval = vmess(pat, &args);
1059 S_closest_cop(pTHX_ COP *cop, OP *o)
1061 /* Look for PL_op starting from o. cop is the last COP we've seen. */
1063 if (!o || o == PL_op) return cop;
1065 if (o->op_flags & OPf_KIDS) {
1067 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1071 /* If the OP_NEXTSTATE has been optimised away we can still use it
1072 * the get the file and line number. */
1074 if (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE)
1077 /* Keep searching, and return when we've found something. */
1079 new_cop = closest_cop(cop, kid);
1080 if (new_cop) return new_cop;
1084 /* Nothing found. */
1090 Perl_vmess(pTHX_ const char *pat, va_list *args)
1092 SV *sv = mess_alloc();
1093 static char dgd[] = " during global destruction.\n";
1096 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
1097 if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
1100 * Try and find the file and line for PL_op. This will usually be
1101 * PL_curcop, but it might be a cop that has been optimised away. We
1102 * can try to find such a cop by searching through the optree starting
1103 * from the sibling of PL_curcop.
1106 cop = closest_cop(PL_curcop, PL_curcop->op_sibling);
1107 if (!cop) cop = PL_curcop;
1110 Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf,
1111 OutCopFILE(cop), (IV)CopLINE(cop));
1112 if (GvIO(PL_last_in_gv) && IoLINES(GvIOp(PL_last_in_gv))) {
1113 bool line_mode = (RsSIMPLE(PL_rs) &&
1114 SvCUR(PL_rs) == 1 && *SvPVX(PL_rs) == '\n');
1115 Perl_sv_catpvf(aTHX_ sv, ", <%s> %s %"IVdf,
1116 PL_last_in_gv == PL_argvgv ?
1117 "" : GvNAME(PL_last_in_gv),
1118 line_mode ? "line" : "chunk",
1119 (IV)IoLINES(GvIOp(PL_last_in_gv)));
1121 #ifdef USE_5005THREADS
1123 Perl_sv_catpvf(aTHX_ sv, " thread %ld", thr->tid);
1125 sv_catpv(sv, PL_dirty ? dgd : ".\n");
1131 Perl_vdie(pTHX_ const char* pat, va_list *args)
1134 int was_in_eval = PL_in_eval;
1141 DEBUG_S(PerlIO_printf(Perl_debug_log,
1142 "%p: die: curstack = %p, mainstack = %p\n",
1143 thr, PL_curstack, PL_mainstack));
1146 msv = vmess(pat, args);
1147 if (PL_errors && SvCUR(PL_errors)) {
1148 sv_catsv(PL_errors, msv);
1149 message = SvPV(PL_errors, msglen);
1150 SvCUR_set(PL_errors, 0);
1153 message = SvPV(msv,msglen);
1160 DEBUG_S(PerlIO_printf(Perl_debug_log,
1161 "%p: die: message = %s\ndiehook = %p\n",
1162 thr, message, PL_diehook));
1164 /* sv_2cv might call Perl_croak() */
1165 SV *olddiehook = PL_diehook;
1167 SAVESPTR(PL_diehook);
1168 PL_diehook = Nullsv;
1169 cv = sv_2cv(olddiehook, &stash, &gv, 0);
1171 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1178 msg = newSVpvn(message, msglen);
1186 PUSHSTACKi(PERLSI_DIEHOOK);
1190 call_sv((SV*)cv, G_DISCARD);
1196 PL_restartop = die_where(message, msglen);
1197 DEBUG_S(PerlIO_printf(Perl_debug_log,
1198 "%p: die: restartop = %p, was_in_eval = %d, top_env = %p\n",
1199 thr, PL_restartop, was_in_eval, PL_top_env));
1200 if ((!PL_restartop && was_in_eval) || PL_top_env->je_prev)
1202 return PL_restartop;
1205 #if defined(PERL_IMPLICIT_CONTEXT)
1207 Perl_die_nocontext(const char* pat, ...)
1212 va_start(args, pat);
1213 o = vdie(pat, &args);
1217 #endif /* PERL_IMPLICIT_CONTEXT */
1220 Perl_die(pTHX_ const char* pat, ...)
1224 va_start(args, pat);
1225 o = vdie(pat, &args);
1231 Perl_vcroak(pTHX_ const char* pat, va_list *args)
1241 msv = vmess(pat, args);
1242 if (PL_errors && SvCUR(PL_errors)) {
1243 sv_catsv(PL_errors, msv);
1244 message = SvPV(PL_errors, msglen);
1245 SvCUR_set(PL_errors, 0);
1248 message = SvPV(msv,msglen);
1255 DEBUG_S(PerlIO_printf(Perl_debug_log, "croak: 0x%"UVxf" %s",
1256 PTR2UV(thr), message));
1259 /* sv_2cv might call Perl_croak() */
1260 SV *olddiehook = PL_diehook;
1262 SAVESPTR(PL_diehook);
1263 PL_diehook = Nullsv;
1264 cv = sv_2cv(olddiehook, &stash, &gv, 0);
1266 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1273 msg = newSVpvn(message, msglen);
1281 PUSHSTACKi(PERLSI_DIEHOOK);
1285 call_sv((SV*)cv, G_DISCARD);
1291 PL_restartop = die_where(message, msglen);
1295 message = SvPVx(ERRSV, msglen);
1299 /* SFIO can really mess with your errno */
1302 PerlIO *serr = Perl_error_log;
1304 PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
1305 (void)PerlIO_flush(serr);
1313 #if defined(PERL_IMPLICIT_CONTEXT)
1315 Perl_croak_nocontext(const char *pat, ...)
1319 va_start(args, pat);
1324 #endif /* PERL_IMPLICIT_CONTEXT */
1327 =head1 Warning and Dieing
1331 This is the XSUB-writer's interface to Perl's C<die> function.
1332 Normally use this function the same way you use the C C<printf>
1333 function. See C<warn>.
1335 If you want to throw an exception object, assign the object to
1336 C<$@> and then pass C<Nullch> to croak():
1338 errsv = get_sv("@", TRUE);
1339 sv_setsv(errsv, exception_object);
1346 Perl_croak(pTHX_ const char *pat, ...)
1349 va_start(args, pat);
1356 Perl_vwarn(pTHX_ const char* pat, va_list *args)
1367 msv = vmess(pat, args);
1368 message = SvPV(msv, msglen);
1371 /* sv_2cv might call Perl_warn() */
1372 SV *oldwarnhook = PL_warnhook;
1374 SAVESPTR(PL_warnhook);
1375 PL_warnhook = Nullsv;
1376 cv = sv_2cv(oldwarnhook, &stash, &gv, 0);
1378 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1384 msg = newSVpvn(message, msglen);
1388 PUSHSTACKi(PERLSI_WARNHOOK);
1392 call_sv((SV*)cv, G_DISCARD);
1399 /* if STDERR is tied, use it instead */
1400 if (PL_stderrgv && (io = GvIOp(PL_stderrgv))
1401 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
1404 XPUSHs(SvTIED_obj((SV*)io, mg));
1405 XPUSHs(sv_2mortal(newSVpvn(message, msglen)));
1407 call_method("PRINT", G_SCALAR);
1413 PerlIO *serr = Perl_error_log;
1415 PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
1417 DEBUG_L(*message == '!'
1418 ? (xstat(message[1]=='!'
1419 ? (message[2]=='!' ? 2 : 1)
1424 (void)PerlIO_flush(serr);
1428 #if defined(PERL_IMPLICIT_CONTEXT)
1430 Perl_warn_nocontext(const char *pat, ...)
1434 va_start(args, pat);
1438 #endif /* PERL_IMPLICIT_CONTEXT */
1443 This is the XSUB-writer's interface to Perl's C<warn> function. Use this
1444 function the same way you use the C C<printf> function. See
1451 Perl_warn(pTHX_ const char *pat, ...)
1454 va_start(args, pat);
1459 #if defined(PERL_IMPLICIT_CONTEXT)
1461 Perl_warner_nocontext(U32 err, const char *pat, ...)
1465 va_start(args, pat);
1466 vwarner(err, pat, &args);
1469 #endif /* PERL_IMPLICIT_CONTEXT */
1472 Perl_warner(pTHX_ U32 err, const char* pat,...)
1475 va_start(args, pat);
1476 vwarner(err, pat, &args);
1481 Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args)
1490 msv = vmess(pat, args);
1491 message = SvPV(msv, msglen);
1494 #ifdef USE_5005THREADS
1495 DEBUG_S(PerlIO_printf(Perl_debug_log, "croak: 0x%"UVxf" %s", PTR2UV(thr), message));
1496 #endif /* USE_5005THREADS */
1498 /* sv_2cv might call Perl_croak() */
1499 SV *olddiehook = PL_diehook;
1501 SAVESPTR(PL_diehook);
1502 PL_diehook = Nullsv;
1503 cv = sv_2cv(olddiehook, &stash, &gv, 0);
1505 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1511 msg = newSVpvn(message, msglen);
1515 PUSHSTACKi(PERLSI_DIEHOOK);
1519 call_sv((SV*)cv, G_DISCARD);
1525 PL_restartop = die_where(message, msglen);
1529 PerlIO *serr = Perl_error_log;
1530 PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
1531 (void)PerlIO_flush(serr);
1538 /* sv_2cv might call Perl_warn() */
1539 SV *oldwarnhook = PL_warnhook;
1541 SAVESPTR(PL_warnhook);
1542 PL_warnhook = Nullsv;
1543 cv = sv_2cv(oldwarnhook, &stash, &gv, 0);
1545 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1551 msg = newSVpvn(message, msglen);
1555 PUSHSTACKi(PERLSI_WARNHOOK);
1559 call_sv((SV*)cv, G_DISCARD);
1566 PerlIO *serr = Perl_error_log;
1567 PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
1569 DEBUG_L(*message == '!'
1570 ? (xstat(message[1]=='!'
1571 ? (message[2]=='!' ? 2 : 1)
1576 (void)PerlIO_flush(serr);
1581 /* since we've already done strlen() for both nam and val
1582 * we can use that info to make things faster than
1583 * sprintf(s, "%s=%s", nam, val)
1585 #define my_setenv_format(s, nam, nlen, val, vlen) \
1586 Copy(nam, s, nlen, char); \
1588 Copy(val, s+(nlen+1), vlen, char); \
1589 *(s+(nlen+1+vlen)) = '\0'
1591 #ifdef USE_ENVIRON_ARRAY
1592 /* VMS' my_setenv() is in vms.c */
1593 #if !defined(WIN32) && !defined(NETWARE)
1595 Perl_my_setenv(pTHX_ char *nam, char *val)
1598 /* only parent thread can modify process environment */
1599 if (PL_curinterp == aTHX)
1602 #ifndef PERL_USE_SAFE_PUTENV
1603 /* most putenv()s leak, so we manipulate environ directly */
1604 register I32 i=setenv_getix(nam); /* where does it go? */
1607 if (environ == PL_origenviron) { /* need we copy environment? */
1613 for (max = i; environ[max]; max++) ;
1614 tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*));
1615 for (j=0; j<max; j++) { /* copy environment */
1616 int len = strlen(environ[j]);
1617 tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char));
1618 Copy(environ[j], tmpenv[j], len+1, char);
1620 tmpenv[max] = Nullch;
1621 environ = tmpenv; /* tell exec where it is now */
1624 safesysfree(environ[i]);
1625 while (environ[i]) {
1626 environ[i] = environ[i+1];
1631 if (!environ[i]) { /* does not exist yet */
1632 environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
1633 environ[i+1] = Nullch; /* make sure it's null terminated */
1636 safesysfree(environ[i]);
1640 environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char));
1641 /* all that work just for this */
1642 my_setenv_format(environ[i], nam, nlen, val, vlen);
1644 #else /* PERL_USE_SAFE_PUTENV */
1645 # if defined(__CYGWIN__) || defined( EPOC)
1646 setenv(nam, val, 1);
1649 int nlen = strlen(nam), vlen;
1654 new_env = (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
1655 /* all that work just for this */
1656 my_setenv_format(new_env, nam, nlen, val, vlen);
1657 (void)putenv(new_env);
1658 # endif /* __CYGWIN__ */
1659 #endif /* PERL_USE_SAFE_PUTENV */
1663 #else /* WIN32 || NETWARE */
1666 Perl_my_setenv(pTHX_ char *nam,char *val)
1668 register char *envstr;
1669 int nlen = strlen(nam), vlen;
1675 New(904, envstr, nlen+vlen+2, char);
1676 my_setenv_format(envstr, nam, nlen, val, vlen);
1677 (void)PerlEnv_putenv(envstr);
1681 #endif /* WIN32 || NETWARE */
1684 Perl_setenv_getix(pTHX_ char *nam)
1686 register I32 i, len = strlen(nam);
1688 for (i = 0; environ[i]; i++) {
1691 strnicmp(environ[i],nam,len) == 0
1693 strnEQ(environ[i],nam,len)
1695 && environ[i][len] == '=')
1696 break; /* strnEQ must come first to avoid */
1697 } /* potential SEGV's */
1701 #endif /* !VMS && !EPOC*/
1703 #ifdef UNLINK_ALL_VERSIONS
1705 Perl_unlnk(pTHX_ char *f) /* unlink all versions of a file */
1709 for (i = 0; PerlLIO_unlink(f) >= 0; i++) ;
1714 /* this is a drop-in replacement for bcopy() */
1715 #if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY))
1717 Perl_my_bcopy(register const char *from,register char *to,register I32 len)
1721 if (from - to >= 0) {
1729 *(--to) = *(--from);
1735 /* this is a drop-in replacement for memset() */
1738 Perl_my_memset(register char *loc, register I32 ch, register I32 len)
1748 /* this is a drop-in replacement for bzero() */
1749 #if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
1751 Perl_my_bzero(register char *loc, register I32 len)
1761 /* this is a drop-in replacement for memcmp() */
1762 #if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
1764 Perl_my_memcmp(const char *s1, const char *s2, register I32 len)
1766 register U8 *a = (U8 *)s1;
1767 register U8 *b = (U8 *)s2;
1771 if (tmp = *a++ - *b++)
1776 #endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */
1780 #ifdef USE_CHAR_VSPRINTF
1785 vsprintf(char *dest, const char *pat, char *args)
1789 fakebuf._ptr = dest;
1790 fakebuf._cnt = 32767;
1794 fakebuf._flag = _IOWRT|_IOSTRG;
1795 _doprnt(pat, args, &fakebuf); /* what a kludge */
1796 (void)putc('\0', &fakebuf);
1797 #ifdef USE_CHAR_VSPRINTF
1800 return 0; /* perl doesn't use return value */
1804 #endif /* HAS_VPRINTF */
1807 #if BYTEORDER != 0x4321
1809 Perl_my_swap(pTHX_ short s)
1811 #if (BYTEORDER & 1) == 0
1814 result = ((s & 255) << 8) + ((s >> 8) & 255);
1822 Perl_my_htonl(pTHX_ long l)
1826 char c[sizeof(long)];
1829 #if BYTEORDER == 0x1234
1830 u.c[0] = (l >> 24) & 255;
1831 u.c[1] = (l >> 16) & 255;
1832 u.c[2] = (l >> 8) & 255;
1836 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
1837 Perl_croak(aTHX_ "Unknown BYTEORDER\n");
1842 for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
1843 u.c[o & 0xf] = (l >> s) & 255;
1851 Perl_my_ntohl(pTHX_ long l)
1855 char c[sizeof(long)];
1858 #if BYTEORDER == 0x1234
1859 u.c[0] = (l >> 24) & 255;
1860 u.c[1] = (l >> 16) & 255;
1861 u.c[2] = (l >> 8) & 255;
1865 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
1866 Perl_croak(aTHX_ "Unknown BYTEORDER\n");
1873 for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
1874 l |= (u.c[o & 0xf] & 255) << s;
1881 #endif /* BYTEORDER != 0x4321 */
1885 * Little-endian byte order functions - 'v' for 'VAX', or 'reVerse'.
1886 * If these functions are defined,
1887 * the BYTEORDER is neither 0x1234 nor 0x4321.
1888 * However, this is not assumed.
1892 #define HTOV(name,type) \
1894 name (register type n) \
1898 char c[sizeof(type)]; \
1902 for (i = 0, s = 0; i < sizeof(u.c); i++, s += 8) { \
1903 u.c[i] = (n >> s) & 0xFF; \
1908 #define VTOH(name,type) \
1910 name (register type n) \
1914 char c[sizeof(type)]; \
1920 for (i = 0, s = 0; i < sizeof(u.c); i++, s += 8) { \
1921 n += (u.c[i] & 0xFF) << s; \
1926 #if defined(HAS_HTOVS) && !defined(htovs)
1929 #if defined(HAS_HTOVL) && !defined(htovl)
1932 #if defined(HAS_VTOHS) && !defined(vtohs)
1935 #if defined(HAS_VTOHL) && !defined(vtohl)
1940 Perl_my_popen_list(pTHX_ char *mode, int n, SV **args)
1942 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) && !defined(NETWARE)
1944 register I32 This, that;
1950 PERL_FLUSHALL_FOR_CHILD;
1951 This = (*mode == 'w');
1955 taint_proper("Insecure %s%s", "EXEC");
1957 if (PerlProc_pipe(p) < 0)
1959 /* Try for another pipe pair for error return */
1960 if (PerlProc_pipe(pp) >= 0)
1962 while ((pid = PerlProc_fork()) < 0) {
1963 if (errno != EAGAIN) {
1964 PerlLIO_close(p[This]);
1965 PerlLIO_close(p[that]);
1967 PerlLIO_close(pp[0]);
1968 PerlLIO_close(pp[1]);
1980 /* Close parent's end of error status pipe (if any) */
1982 PerlLIO_close(pp[0]);
1983 #if defined(HAS_FCNTL) && defined(F_SETFD)
1984 /* Close error pipe automatically if exec works */
1985 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
1988 /* Now dup our end of _the_ pipe to right position */
1989 if (p[THIS] != (*mode == 'r')) {
1990 PerlLIO_dup2(p[THIS], *mode == 'r');
1991 PerlLIO_close(p[THIS]);
1992 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
1993 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
1996 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
1997 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
1998 /* No automatic close - do it by hand */
2005 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) {
2011 do_aexec5(Nullsv, args-1, args-1+n, pp[1], did_pipes);
2017 do_execfree(); /* free any memory malloced by child on fork */
2019 PerlLIO_close(pp[1]);
2020 /* Keep the lower of the two fd numbers */
2021 if (p[that] < p[This]) {
2022 PerlLIO_dup2(p[This], p[that]);
2023 PerlLIO_close(p[This]);
2027 PerlLIO_close(p[that]); /* close child's end of pipe */
2030 sv = *av_fetch(PL_fdpid,p[This],TRUE);
2032 (void)SvUPGRADE(sv,SVt_IV);
2034 PL_forkprocess = pid;
2035 /* If we managed to get status pipe check for exec fail */
2036 if (did_pipes && pid > 0) {
2040 while (n < sizeof(int)) {
2041 n1 = PerlLIO_read(pp[0],
2042 (void*)(((char*)&errkid)+n),
2048 PerlLIO_close(pp[0]);
2050 if (n) { /* Error */
2052 PerlLIO_close(p[This]);
2053 if (n != sizeof(int))
2054 Perl_croak(aTHX_ "panic: kid popen errno read");
2056 pid2 = wait4pid(pid, &status, 0);
2057 } while (pid2 == -1 && errno == EINTR);
2058 errno = errkid; /* Propagate errno from kid */
2063 PerlLIO_close(pp[0]);
2064 return PerlIO_fdopen(p[This], mode);
2066 Perl_croak(aTHX_ "List form of piped open not implemented");
2067 return (PerlIO *) NULL;
2071 /* VMS' my_popen() is in VMS.c, same with OS/2. */
2072 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
2074 Perl_my_popen(pTHX_ char *cmd, char *mode)
2077 register I32 This, that;
2080 I32 doexec = strNE(cmd,"-");
2084 PERL_FLUSHALL_FOR_CHILD;
2087 return my_syspopen(aTHX_ cmd,mode);
2090 This = (*mode == 'w');
2092 if (doexec && PL_tainting) {
2094 taint_proper("Insecure %s%s", "EXEC");
2096 if (PerlProc_pipe(p) < 0)
2098 if (doexec && PerlProc_pipe(pp) >= 0)
2100 while ((pid = PerlProc_fork()) < 0) {
2101 if (errno != EAGAIN) {
2102 PerlLIO_close(p[This]);
2103 PerlLIO_close(p[that]);
2105 PerlLIO_close(pp[0]);
2106 PerlLIO_close(pp[1]);
2109 Perl_croak(aTHX_ "Can't fork");
2122 PerlLIO_close(pp[0]);
2123 #if defined(HAS_FCNTL) && defined(F_SETFD)
2124 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2127 if (p[THIS] != (*mode == 'r')) {
2128 PerlLIO_dup2(p[THIS], *mode == 'r');
2129 PerlLIO_close(p[THIS]);
2130 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2131 PerlLIO_close(p[THAT]);
2134 PerlLIO_close(p[THAT]);
2137 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2146 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
2151 /* may or may not use the shell */
2152 do_exec3(cmd, pp[1], did_pipes);
2155 #endif /* defined OS2 */
2157 if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) {
2158 SvREADONLY_off(GvSV(tmpgv));
2159 sv_setiv(GvSV(tmpgv), PerlProc_getpid());
2160 SvREADONLY_on(GvSV(tmpgv));
2162 #ifdef THREADS_HAVE_PIDS
2163 PL_ppid = (IV)getppid();
2166 hv_clear(PL_pidstatus); /* we have no children */
2171 do_execfree(); /* free any memory malloced by child on vfork */
2173 PerlLIO_close(pp[1]);
2174 if (p[that] < p[This]) {
2175 PerlLIO_dup2(p[This], p[that]);
2176 PerlLIO_close(p[This]);
2180 PerlLIO_close(p[that]);
2183 sv = *av_fetch(PL_fdpid,p[This],TRUE);
2185 (void)SvUPGRADE(sv,SVt_IV);
2187 PL_forkprocess = pid;
2188 if (did_pipes && pid > 0) {
2192 while (n < sizeof(int)) {
2193 n1 = PerlLIO_read(pp[0],
2194 (void*)(((char*)&errkid)+n),
2200 PerlLIO_close(pp[0]);
2202 if (n) { /* Error */
2204 PerlLIO_close(p[This]);
2205 if (n != sizeof(int))
2206 Perl_croak(aTHX_ "panic: kid popen errno read");
2208 pid2 = wait4pid(pid, &status, 0);
2209 } while (pid2 == -1 && errno == EINTR);
2210 errno = errkid; /* Propagate errno from kid */
2215 PerlLIO_close(pp[0]);
2216 return PerlIO_fdopen(p[This], mode);
2219 #if defined(atarist) || defined(EPOC)
2222 Perl_my_popen(pTHX_ char *cmd, char *mode)
2224 PERL_FLUSHALL_FOR_CHILD;
2225 /* Call system's popen() to get a FILE *, then import it.
2226 used 0 for 2nd parameter to PerlIO_importFILE;
2229 return PerlIO_importFILE(popen(cmd, mode), 0);
2233 FILE *djgpp_popen();
2235 Perl_my_popen(pTHX_ char *cmd, char *mode)
2237 PERL_FLUSHALL_FOR_CHILD;
2238 /* Call system's popen() to get a FILE *, then import it.
2239 used 0 for 2nd parameter to PerlIO_importFILE;
2242 return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
2247 #endif /* !DOSISH */
2249 /* this is called in parent before the fork() */
2251 Perl_atfork_lock(void)
2253 #if defined(USE_5005THREADS) || defined(USE_ITHREADS)
2254 /* locks must be held in locking order (if any) */
2256 MUTEX_LOCK(&PL_malloc_mutex);
2262 /* this is called in both parent and child after the fork() */
2264 Perl_atfork_unlock(void)
2266 #if defined(USE_5005THREADS) || defined(USE_ITHREADS)
2267 /* locks must be released in same order as in atfork_lock() */
2269 MUTEX_UNLOCK(&PL_malloc_mutex);
2278 #if defined(HAS_FORK)
2280 #if (defined(USE_5005THREADS) || defined(USE_ITHREADS)) && !defined(HAS_PTHREAD_ATFORK)
2285 /* atfork_lock() and atfork_unlock() are installed as pthread_atfork()
2286 * handlers elsewhere in the code */
2291 /* this "canna happen" since nothing should be calling here if !HAS_FORK */
2292 Perl_croak_nocontext("fork() not available");
2294 #endif /* HAS_FORK */
2299 Perl_dump_fds(pTHX_ char *s)
2304 PerlIO_printf(Perl_debug_log,"%s", s);
2305 for (fd = 0; fd < 32; fd++) {
2306 if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0)
2307 PerlIO_printf(Perl_debug_log," %d",fd);
2309 PerlIO_printf(Perl_debug_log,"\n");
2311 #endif /* DUMP_FDS */
2315 dup2(int oldfd, int newfd)
2317 #if defined(HAS_FCNTL) && defined(F_DUPFD)
2320 PerlLIO_close(newfd);
2321 return fcntl(oldfd, F_DUPFD, newfd);
2323 #define DUP2_MAX_FDS 256
2324 int fdtmp[DUP2_MAX_FDS];
2330 PerlLIO_close(newfd);
2331 /* good enough for low fd's... */
2332 while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
2333 if (fdx >= DUP2_MAX_FDS) {
2341 PerlLIO_close(fdtmp[--fdx]);
2348 #ifdef HAS_SIGACTION
2351 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2353 struct sigaction act, oact;
2356 /* only "parent" interpreter can diddle signals */
2357 if (PL_curinterp != aTHX)
2361 act.sa_handler = handler;
2362 sigemptyset(&act.sa_mask);
2365 #if defined(PERL_OLD_SIGNALS)
2366 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
2370 if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN)
2371 act.sa_flags |= SA_NOCLDWAIT;
2373 if (sigaction(signo, &act, &oact) == -1)
2376 return oact.sa_handler;
2380 Perl_rsignal_state(pTHX_ int signo)
2382 struct sigaction oact;
2384 if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
2387 return oact.sa_handler;
2391 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2393 struct sigaction act;
2396 /* only "parent" interpreter can diddle signals */
2397 if (PL_curinterp != aTHX)
2401 act.sa_handler = handler;
2402 sigemptyset(&act.sa_mask);
2405 #if defined(PERL_OLD_SIGNALS)
2406 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
2410 if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN)
2411 act.sa_flags |= SA_NOCLDWAIT;
2413 return sigaction(signo, &act, save);
2417 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2420 /* only "parent" interpreter can diddle signals */
2421 if (PL_curinterp != aTHX)
2425 return sigaction(signo, save, (struct sigaction *)NULL);
2428 #else /* !HAS_SIGACTION */
2431 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2433 #if defined(USE_ITHREADS) && !defined(WIN32)
2434 /* only "parent" interpreter can diddle signals */
2435 if (PL_curinterp != aTHX)
2439 return PerlProc_signal(signo, handler);
2442 static int sig_trapped; /* XXX signals are process-wide anyway, so we
2443 ignore the implications of this for threading */
2453 Perl_rsignal_state(pTHX_ int signo)
2455 Sighandler_t oldsig;
2457 #if defined(USE_ITHREADS) && !defined(WIN32)
2458 /* only "parent" interpreter can diddle signals */
2459 if (PL_curinterp != aTHX)
2464 oldsig = PerlProc_signal(signo, sig_trap);
2465 PerlProc_signal(signo, oldsig);
2467 PerlProc_kill(PerlProc_getpid(), signo);
2472 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2474 #if defined(USE_ITHREADS) && !defined(WIN32)
2475 /* only "parent" interpreter can diddle signals */
2476 if (PL_curinterp != aTHX)
2479 *save = PerlProc_signal(signo, handler);
2480 return (*save == SIG_ERR) ? -1 : 0;
2484 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2486 #if defined(USE_ITHREADS) && !defined(WIN32)
2487 /* only "parent" interpreter can diddle signals */
2488 if (PL_curinterp != aTHX)
2491 return (PerlProc_signal(signo, *save) == SIG_ERR) ? -1 : 0;
2494 #endif /* !HAS_SIGACTION */
2495 #endif /* !PERL_MICRO */
2497 /* VMS' my_pclose() is in VMS.c; same with OS/2 */
2498 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
2500 Perl_my_pclose(pTHX_ PerlIO *ptr)
2502 Sigsave_t hstat, istat, qstat;
2508 int saved_errno = 0;
2510 int saved_vaxc_errno;
2513 int saved_win32_errno;
2517 svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE);
2519 pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
2521 *svp = &PL_sv_undef;
2523 if (pid == -1) { /* Opened by popen. */
2524 return my_syspclose(ptr);
2527 if ((close_failed = (PerlIO_close(ptr) == EOF))) {
2528 saved_errno = errno;
2530 saved_vaxc_errno = vaxc$errno;
2533 saved_win32_errno = GetLastError();
2537 if(PerlProc_kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */
2540 rsignal_save(SIGHUP, SIG_IGN, &hstat);
2541 rsignal_save(SIGINT, SIG_IGN, &istat);
2542 rsignal_save(SIGQUIT, SIG_IGN, &qstat);
2545 pid2 = wait4pid(pid, &status, 0);
2546 } while (pid2 == -1 && errno == EINTR);
2548 rsignal_restore(SIGHUP, &hstat);
2549 rsignal_restore(SIGINT, &istat);
2550 rsignal_restore(SIGQUIT, &qstat);
2553 SETERRNO(saved_errno, saved_vaxc_errno);
2556 return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status));
2558 #endif /* !DOSISH */
2560 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(MACOS_TRADITIONAL)
2562 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
2567 #if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME)
2571 char spid[TYPE_CHARS(int)];
2574 sprintf(spid, "%"IVdf, (IV)pid);
2575 svp = hv_fetch(PL_pidstatus,spid,strlen(spid),FALSE);
2576 if (svp && *svp != &PL_sv_undef) {
2577 *statusp = SvIVX(*svp);
2578 (void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD);
2585 hv_iterinit(PL_pidstatus);
2586 if ((entry = hv_iternext(PL_pidstatus))) {
2588 char spid[TYPE_CHARS(int)];
2590 pid = atoi(hv_iterkey(entry,(I32*)statusp));
2591 sv = hv_iterval(PL_pidstatus,entry);
2592 *statusp = SvIVX(sv);
2593 sprintf(spid, "%"IVdf, (IV)pid);
2594 (void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD);
2601 # ifdef HAS_WAITPID_RUNTIME
2602 if (!HAS_WAITPID_RUNTIME)
2605 result = PerlProc_waitpid(pid,statusp,flags);
2608 #if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
2609 result = wait4((pid==-1)?0:pid,statusp,flags,Null(struct rusage *));
2612 #if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME)
2616 Perl_croak(aTHX_ "Can't do waitpid with flags");
2618 while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
2619 pidgone(result,*statusp);
2626 if (result < 0 && errno == EINTR) {
2631 #endif /* !DOSISH || OS2 || WIN32 || NETWARE */
2635 Perl_pidgone(pTHX_ Pid_t pid, int status)
2638 char spid[TYPE_CHARS(int)];
2640 sprintf(spid, "%"IVdf, (IV)pid);
2641 sv = *hv_fetch(PL_pidstatus,spid,strlen(spid),TRUE);
2642 (void)SvUPGRADE(sv,SVt_IV);
2647 #if defined(atarist) || defined(OS2) || defined(EPOC)
2650 int /* Cannot prototype with I32
2652 my_syspclose(PerlIO *ptr)
2655 Perl_my_pclose(pTHX_ PerlIO *ptr)
2658 /* Needs work for PerlIO ! */
2659 FILE *f = PerlIO_findFILE(ptr);
2660 I32 result = pclose(f);
2661 PerlIO_releaseFILE(ptr,f);
2669 Perl_my_pclose(pTHX_ PerlIO *ptr)
2671 /* Needs work for PerlIO ! */
2672 FILE *f = PerlIO_findFILE(ptr);
2673 I32 result = djgpp_pclose(f);
2674 result = (result << 8) & 0xff00;
2675 PerlIO_releaseFILE(ptr,f);
2681 Perl_repeatcpy(pTHX_ register char *to, register const char *from, I32 len, register I32 count)
2684 register const char *frombase = from;
2687 register const char c = *from;
2692 while (count-- > 0) {
2693 for (todo = len; todo > 0; todo--) {
2702 Perl_same_dirent(pTHX_ char *a, char *b)
2704 char *fa = strrchr(a,'/');
2705 char *fb = strrchr(b,'/');
2708 SV *tmpsv = sv_newmortal();
2721 sv_setpv(tmpsv, ".");
2723 sv_setpvn(tmpsv, a, fa - a);
2724 if (PerlLIO_stat(SvPVX(tmpsv), &tmpstatbuf1) < 0)
2727 sv_setpv(tmpsv, ".");
2729 sv_setpvn(tmpsv, b, fb - b);
2730 if (PerlLIO_stat(SvPVX(tmpsv), &tmpstatbuf2) < 0)
2732 return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
2733 tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
2735 #endif /* !HAS_RENAME */
2738 Perl_find_script(pTHX_ char *scriptname, bool dosearch, char **search_ext, I32 flags)
2740 char *xfound = Nullch;
2741 char *xfailed = Nullch;
2742 char tmpbuf[MAXPATHLEN];
2746 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
2747 # define SEARCH_EXTS ".bat", ".cmd", NULL
2748 # define MAX_EXT_LEN 4
2751 # define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
2752 # define MAX_EXT_LEN 4
2755 # define SEARCH_EXTS ".pl", ".com", NULL
2756 # define MAX_EXT_LEN 4
2758 /* additional extensions to try in each dir if scriptname not found */
2760 char *exts[] = { SEARCH_EXTS };
2761 char **ext = search_ext ? search_ext : exts;
2762 int extidx = 0, i = 0;
2763 char *curext = Nullch;
2765 # define MAX_EXT_LEN 0
2769 * If dosearch is true and if scriptname does not contain path
2770 * delimiters, search the PATH for scriptname.
2772 * If SEARCH_EXTS is also defined, will look for each
2773 * scriptname{SEARCH_EXTS} whenever scriptname is not found
2774 * while searching the PATH.
2776 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
2777 * proceeds as follows:
2778 * If DOSISH or VMSISH:
2779 * + look for ./scriptname{,.foo,.bar}
2780 * + search the PATH for scriptname{,.foo,.bar}
2783 * + look *only* in the PATH for scriptname{,.foo,.bar} (note
2784 * this will not look in '.' if it's not in the PATH)
2789 # ifdef ALWAYS_DEFTYPES
2790 len = strlen(scriptname);
2791 if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
2792 int hasdir, idx = 0, deftypes = 1;
2795 hasdir = !dosearch || (strpbrk(scriptname,":[</") != Nullch) ;
2798 int hasdir, idx = 0, deftypes = 1;
2801 hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
2803 /* The first time through, just add SEARCH_EXTS to whatever we
2804 * already have, so we can check for default file types. */
2806 (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
2812 if ((strlen(tmpbuf) + strlen(scriptname)
2813 + MAX_EXT_LEN) >= sizeof tmpbuf)
2814 continue; /* don't search dir with too-long name */
2815 strcat(tmpbuf, scriptname);
2819 if (strEQ(scriptname, "-"))
2821 if (dosearch) { /* Look in '.' first. */
2822 char *cur = scriptname;
2824 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
2826 if (strEQ(ext[i++],curext)) {
2827 extidx = -1; /* already has an ext */
2832 DEBUG_p(PerlIO_printf(Perl_debug_log,
2833 "Looking for %s\n",cur));
2834 if (PerlLIO_stat(cur,&PL_statbuf) >= 0
2835 && !S_ISDIR(PL_statbuf.st_mode)) {
2843 if (cur == scriptname) {
2844 len = strlen(scriptname);
2845 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
2847 cur = strcpy(tmpbuf, scriptname);
2849 } while (extidx >= 0 && ext[extidx] /* try an extension? */
2850 && strcpy(tmpbuf+len, ext[extidx++]));
2855 #ifdef MACOS_TRADITIONAL
2856 if (dosearch && !strchr(scriptname, ':') &&
2857 (s = PerlEnv_getenv("Commands")))
2859 if (dosearch && !strchr(scriptname, '/')
2861 && !strchr(scriptname, '\\')
2863 && (s = PerlEnv_getenv("PATH")))
2868 PL_bufend = s + strlen(s);
2869 while (s < PL_bufend) {
2870 #ifdef MACOS_TRADITIONAL
2871 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
2875 #if defined(atarist) || defined(DOSISH)
2880 && *s != ';'; len++, s++) {
2881 if (len < sizeof tmpbuf)
2884 if (len < sizeof tmpbuf)
2886 #else /* ! (atarist || DOSISH) */
2887 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
2890 #endif /* ! (atarist || DOSISH) */
2891 #endif /* MACOS_TRADITIONAL */
2894 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
2895 continue; /* don't search dir with too-long name */
2896 #ifdef MACOS_TRADITIONAL
2897 if (len && tmpbuf[len - 1] != ':')
2898 tmpbuf[len++] = ':';
2901 #if defined(atarist) || defined(__MINT__) || defined(DOSISH)
2902 && tmpbuf[len - 1] != '/'
2903 && tmpbuf[len - 1] != '\\'
2906 tmpbuf[len++] = '/';
2907 if (len == 2 && tmpbuf[0] == '.')
2910 (void)strcpy(tmpbuf + len, scriptname);
2914 len = strlen(tmpbuf);
2915 if (extidx > 0) /* reset after previous loop */
2919 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
2920 retval = PerlLIO_stat(tmpbuf,&PL_statbuf);
2921 if (S_ISDIR(PL_statbuf.st_mode)) {
2925 } while ( retval < 0 /* not there */
2926 && extidx>=0 && ext[extidx] /* try an extension? */
2927 && strcpy(tmpbuf+len, ext[extidx++])
2932 if (S_ISREG(PL_statbuf.st_mode)
2933 && cando(S_IRUSR,TRUE,&PL_statbuf)
2934 #if !defined(DOSISH) && !defined(MACOS_TRADITIONAL)
2935 && cando(S_IXUSR,TRUE,&PL_statbuf)
2939 xfound = tmpbuf; /* bingo! */
2943 xfailed = savepv(tmpbuf);
2946 if (!xfound && !seen_dot && !xfailed &&
2947 (PerlLIO_stat(scriptname,&PL_statbuf) < 0
2948 || S_ISDIR(PL_statbuf.st_mode)))
2950 seen_dot = 1; /* Disable message. */
2952 if (flags & 1) { /* do or die? */
2953 Perl_croak(aTHX_ "Can't %s %s%s%s",
2954 (xfailed ? "execute" : "find"),
2955 (xfailed ? xfailed : scriptname),
2956 (xfailed ? "" : " on PATH"),
2957 (xfailed || seen_dot) ? "" : ", '.' not in PATH");
2959 scriptname = Nullch;
2963 scriptname = xfound;
2965 return (scriptname ? savepv(scriptname) : Nullch);
2968 #ifndef PERL_GET_CONTEXT_DEFINED
2971 Perl_get_context(void)
2973 #if defined(USE_5005THREADS) || defined(USE_ITHREADS)
2974 # ifdef OLD_PTHREADS_API
2976 if (pthread_getspecific(PL_thr_key, &t))
2977 Perl_croak_nocontext("panic: pthread_getspecific");
2980 # ifdef I_MACH_CTHREADS
2981 return (void*)cthread_data(cthread_self());
2983 return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
2992 Perl_set_context(void *t)
2994 #if defined(USE_5005THREADS) || defined(USE_ITHREADS)
2995 # ifdef I_MACH_CTHREADS
2996 cthread_set_data(cthread_self(), t);
2998 if (pthread_setspecific(PL_thr_key, t))
2999 Perl_croak_nocontext("panic: pthread_setspecific");
3004 #endif /* !PERL_GET_CONTEXT_DEFINED */
3006 #ifdef USE_5005THREADS
3009 /* Very simplistic scheduler for now */
3013 thr = thr->i.next_run;
3017 Perl_cond_init(pTHX_ perl_cond *cp)
3023 Perl_cond_signal(pTHX_ perl_cond *cp)
3026 perl_cond cond = *cp;
3031 /* Insert t in the runnable queue just ahead of us */
3032 t->i.next_run = thr->i.next_run;
3033 thr->i.next_run->i.prev_run = t;
3034 t->i.prev_run = thr;
3035 thr->i.next_run = t;
3036 thr->i.wait_queue = 0;
3037 /* Remove from the wait queue */
3043 Perl_cond_broadcast(pTHX_ perl_cond *cp)
3046 perl_cond cond, cond_next;
3048 for (cond = *cp; cond; cond = cond_next) {
3050 /* Insert t in the runnable queue just ahead of us */
3051 t->i.next_run = thr->i.next_run;
3052 thr->i.next_run->i.prev_run = t;
3053 t->i.prev_run = thr;
3054 thr->i.next_run = t;
3055 thr->i.wait_queue = 0;
3056 /* Remove from the wait queue */
3057 cond_next = cond->next;
3064 Perl_cond_wait(pTHX_ perl_cond *cp)
3068 if (thr->i.next_run == thr)
3069 Perl_croak(aTHX_ "panic: perl_cond_wait called by last runnable thread");
3071 New(666, cond, 1, struct perl_wait_queue);
3075 thr->i.wait_queue = cond;
3076 /* Remove ourselves from runnable queue */
3077 thr->i.next_run->i.prev_run = thr->i.prev_run;
3078 thr->i.prev_run->i.next_run = thr->i.next_run;
3080 #endif /* FAKE_THREADS */
3083 Perl_condpair_magic(pTHX_ SV *sv)
3087 (void)SvUPGRADE(sv, SVt_PVMG);
3088 mg = mg_find(sv, PERL_MAGIC_mutex);
3092 New(53, cp, 1, condpair_t);
3093 MUTEX_INIT(&cp->mutex);
3094 COND_INIT(&cp->owner_cond);
3095 COND_INIT(&cp->cond);
3097 LOCK_CRED_MUTEX; /* XXX need separate mutex? */
3098 mg = mg_find(sv, PERL_MAGIC_mutex);
3100 /* someone else beat us to initialising it */
3101 UNLOCK_CRED_MUTEX; /* XXX need separate mutex? */
3102 MUTEX_DESTROY(&cp->mutex);
3103 COND_DESTROY(&cp->owner_cond);
3104 COND_DESTROY(&cp->cond);
3108 sv_magic(sv, Nullsv, PERL_MAGIC_mutex, 0, 0);
3110 mg->mg_ptr = (char *)cp;
3111 mg->mg_len = sizeof(cp);
3112 UNLOCK_CRED_MUTEX; /* XXX need separate mutex? */
3113 DEBUG_S(WITH_THR(PerlIO_printf(Perl_debug_log,
3114 "%p: condpair_magic %p\n", thr, sv)));
3121 Perl_sv_lock(pTHX_ SV *osv)
3131 mg = condpair_magic(sv);
3132 MUTEX_LOCK(MgMUTEXP(mg));
3133 if (MgOWNER(mg) == thr)
3134 MUTEX_UNLOCK(MgMUTEXP(mg));
3137 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
3139 DEBUG_S(PerlIO_printf(Perl_debug_log,
3140 "0x%"UVxf": Perl_lock lock 0x%"UVxf"\n",
3141 PTR2UV(thr), PTR2UV(sv)));
3142 MUTEX_UNLOCK(MgMUTEXP(mg));
3143 SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv);
3145 UNLOCK_SV_LOCK_MUTEX;
3150 * Make a new perl thread structure using t as a prototype. Some of the
3151 * fields for the new thread are copied from the prototype thread, t,
3152 * so t should not be running in perl at the time this function is
3153 * called. The use by ext/Thread/Thread.xs in core perl (where t is the
3154 * thread calling new_struct_thread) clearly satisfies this constraint.
3156 struct perl_thread *
3157 Perl_new_struct_thread(pTHX_ struct perl_thread *t)
3159 #if !defined(PERL_IMPLICIT_CONTEXT)
3160 struct perl_thread *thr;
3166 sv = newSVpvn("", 0);
3167 SvGROW(sv, sizeof(struct perl_thread) + 1);
3168 SvCUR_set(sv, sizeof(struct perl_thread));
3169 thr = (Thread) SvPVX(sv);
3171 Poison(thr, 1, struct perl_thread);
3178 Zero(&PL_hv_fetch_ent_mh, 1, HE);
3179 PL_efloatbuf = (char*)NULL;
3182 Zero(thr, 1, struct perl_thread);
3188 PL_curcop = &PL_compiling;
3189 thr->interp = t->interp;
3190 thr->cvcache = newHV();
3191 thr->threadsv = newAV();
3192 thr->specific = newAV();
3193 thr->errsv = newSVpvn("", 0);
3194 thr->flags = THRf_R_JOINABLE;
3196 MUTEX_INIT(&thr->mutex);
3200 PL_in_eval = EVAL_NULL; /* ~(EVAL_INEVAL|EVAL_WARNONLY|EVAL_KEEPERR|EVAL_INREQUIRE) */
3203 PL_statname = NEWSV(66,0);
3204 PL_errors = newSVpvn("", 0);
3206 PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
3207 PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
3208 PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
3209 PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
3210 PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
3212 PL_reginterp_cnt = 0;
3213 PL_lastscream = Nullsv;
3216 PL_reg_start_tmp = 0;
3217 PL_reg_start_tmpl = 0;
3218 PL_reg_poscache = Nullch;
3220 PL_peepp = MEMBER_TO_FPTR(Perl_peep);
3222 /* parent thread's data needs to be locked while we make copy */
3223 MUTEX_LOCK(&t->mutex);
3225 #ifdef PERL_FLEXIBLE_EXCEPTIONS
3226 PL_protect = t->Tprotect;
3229 PL_curcop = t->Tcurcop; /* XXX As good a guess as any? */
3230 PL_defstash = t->Tdefstash; /* XXX maybe these should */
3231 PL_curstash = t->Tcurstash; /* always be set to main? */
3233 PL_tainted = t->Ttainted;
3234 PL_curpm = t->Tcurpm; /* XXX No PMOP ref count */
3235 PL_rs = newSVsv(t->Trs);
3236 PL_last_in_gv = Nullgv;
3237 PL_ofs_sv = t->Tofs_sv ? SvREFCNT_inc(PL_ofs_sv) : Nullsv;
3238 PL_defoutgv = (GV*)SvREFCNT_inc(t->Tdefoutgv);
3239 PL_chopset = t->Tchopset;
3240 PL_bodytarget = newSVsv(t->Tbodytarget);
3241 PL_toptarget = newSVsv(t->Ttoptarget);
3242 if (t->Tformtarget == t->Ttoptarget)
3243 PL_formtarget = PL_toptarget;
3245 PL_formtarget = PL_bodytarget;
3247 /* Initialise all per-thread SVs that the template thread used */
3248 svp = AvARRAY(t->threadsv);
3249 for (i = 0; i <= AvFILLp(t->threadsv); i++, svp++) {
3250 if (*svp && *svp != &PL_sv_undef) {
3251 SV *sv = newSVsv(*svp);
3252 av_store(thr->threadsv, i, sv);
3253 sv_magic(sv, 0, PERL_MAGIC_sv, &PL_threadsv_names[i], 1);
3254 DEBUG_S(PerlIO_printf(Perl_debug_log,
3255 "new_struct_thread: copied threadsv %"IVdf" %p->%p\n",
3259 thr->threadsvp = AvARRAY(thr->threadsv);
3261 MUTEX_LOCK(&PL_threads_mutex);
3263 thr->tid = ++PL_threadnum;
3264 thr->next = t->next;
3267 thr->next->prev = thr;
3268 MUTEX_UNLOCK(&PL_threads_mutex);
3270 /* done copying parent's state */
3271 MUTEX_UNLOCK(&t->mutex);
3273 #ifdef HAVE_THREAD_INTERN
3274 Perl_init_thread_intern(thr);
3275 #endif /* HAVE_THREAD_INTERN */
3278 #endif /* USE_5005THREADS */
3280 #ifdef PERL_GLOBAL_STRUCT
3289 Perl_get_op_names(pTHX)
3295 Perl_get_op_descs(pTHX)
3301 Perl_get_no_modify(pTHX)
3303 return (char*)PL_no_modify;
3307 Perl_get_opargs(pTHX)
3313 Perl_get_ppaddr(pTHX)
3315 return (PPADDR_t*)PL_ppaddr;
3318 #ifndef HAS_GETENV_LEN
3320 Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
3322 char *env_trans = PerlEnv_getenv(env_elem);
3324 *len = strlen(env_trans);
3331 Perl_get_vtbl(pTHX_ int vtbl_id)
3333 MGVTBL* result = Null(MGVTBL*);
3337 result = &PL_vtbl_sv;
3340 result = &PL_vtbl_env;
3342 case want_vtbl_envelem:
3343 result = &PL_vtbl_envelem;
3346 result = &PL_vtbl_sig;
3348 case want_vtbl_sigelem:
3349 result = &PL_vtbl_sigelem;
3351 case want_vtbl_pack:
3352 result = &PL_vtbl_pack;
3354 case want_vtbl_packelem:
3355 result = &PL_vtbl_packelem;
3357 case want_vtbl_dbline:
3358 result = &PL_vtbl_dbline;
3361 result = &PL_vtbl_isa;
3363 case want_vtbl_isaelem:
3364 result = &PL_vtbl_isaelem;
3366 case want_vtbl_arylen:
3367 result = &PL_vtbl_arylen;
3369 case want_vtbl_glob:
3370 result = &PL_vtbl_glob;
3372 case want_vtbl_mglob:
3373 result = &PL_vtbl_mglob;
3375 case want_vtbl_nkeys:
3376 result = &PL_vtbl_nkeys;
3378 case want_vtbl_taint:
3379 result = &PL_vtbl_taint;
3381 case want_vtbl_substr:
3382 result = &PL_vtbl_substr;
3385 result = &PL_vtbl_vec;
3388 result = &PL_vtbl_pos;
3391 result = &PL_vtbl_bm;
3394 result = &PL_vtbl_fm;
3396 case want_vtbl_uvar:
3397 result = &PL_vtbl_uvar;
3399 #ifdef USE_5005THREADS
3400 case want_vtbl_mutex:
3401 result = &PL_vtbl_mutex;
3404 case want_vtbl_defelem:
3405 result = &PL_vtbl_defelem;
3407 case want_vtbl_regexp:
3408 result = &PL_vtbl_regexp;
3410 case want_vtbl_regdata:
3411 result = &PL_vtbl_regdata;
3413 case want_vtbl_regdatum:
3414 result = &PL_vtbl_regdatum;
3416 #ifdef USE_LOCALE_COLLATE
3417 case want_vtbl_collxfrm:
3418 result = &PL_vtbl_collxfrm;
3421 case want_vtbl_amagic:
3422 result = &PL_vtbl_amagic;
3424 case want_vtbl_amagicelem:
3425 result = &PL_vtbl_amagicelem;
3427 case want_vtbl_backref:
3428 result = &PL_vtbl_backref;
3435 Perl_my_fflush_all(pTHX)
3437 #if defined(FFLUSH_NULL)
3438 return PerlIO_flush(NULL);
3440 # if defined(HAS__FWALK)
3441 extern int fflush(FILE *);
3442 /* undocumented, unprototyped, but very useful BSDism */
3443 extern void _fwalk(int (*)(FILE *));
3447 # if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
3449 # ifdef PERL_FFLUSH_ALL_FOPEN_MAX
3450 open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
3452 # if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
3453 open_max = sysconf(_SC_OPEN_MAX);
3456 open_max = FOPEN_MAX;
3459 open_max = OPEN_MAX;
3470 for (i = 0; i < open_max; i++)
3471 if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
3472 STDIO_STREAM_ARRAY[i]._file < open_max &&
3473 STDIO_STREAM_ARRAY[i]._flag)
3474 PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
3478 SETERRNO(EBADF,RMS$_IFI);
3485 Perl_report_evil_fh(pTHX_ GV *gv, IO *io, I32 op)
3488 op == OP_READLINE ? "readline" : /* "<HANDLE>" not nice */
3489 op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */
3491 char *pars = OP_IS_FILETEST(op) ? "" : "()";
3492 char *type = OP_IS_SOCKET(op) ||
3493 (gv && io && IoTYPE(io) == IoTYPE_SOCKET) ?
3494 "socket" : "filehandle";
3497 if (gv && isGV(gv)) {
3501 if (op == OP_phoney_OUTPUT_ONLY || op == OP_phoney_INPUT_ONLY) {
3502 if (ckWARN(WARN_IO)) {
3504 Perl_warner(aTHX_ packWARN(WARN_IO),
3505 "Filehandle %s opened only for %sput",
3506 name, (op == OP_phoney_INPUT_ONLY ? "in" : "out"));
3508 Perl_warner(aTHX_ packWARN(WARN_IO),
3509 "Filehandle opened only for %sput",
3510 (op == OP_phoney_INPUT_ONLY ? "in" : "out"));
3517 if (gv && io && IoTYPE(io) == IoTYPE_CLOSED) {
3519 warn_type = WARN_CLOSED;
3523 warn_type = WARN_UNOPENED;
3526 if (ckWARN(warn_type)) {
3527 if (name && *name) {
3528 Perl_warner(aTHX_ packWARN(warn_type),
3529 "%s%s on %s %s %s", func, pars, vile, type, name);
3530 if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3531 Perl_warner(aTHX_ packWARN(warn_type),
3532 "\t(Are you trying to call %s%s on dirhandle %s?)\n",
3536 Perl_warner(aTHX_ packWARN(warn_type),
3537 "%s%s on %s %s", func, pars, vile, type);
3538 if (gv && io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3539 Perl_warner(aTHX_ packWARN(warn_type),
3540 "\t(Are you trying to call %s%s on dirhandle?)\n",
3548 /* in ASCII order, not that it matters */
3549 static const char controllablechars[] = "?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_";
3552 Perl_ebcdic_control(pTHX_ int ch)
3560 if ((ctlp = strchr(controllablechars, ch)) == 0) {
3561 Perl_die(aTHX_ "unrecognised control character '%c'\n", ch);
3564 if (ctlp == controllablechars)
3565 return('\177'); /* DEL */
3567 return((unsigned char)(ctlp - controllablechars - 1));
3568 } else { /* Want uncontrol */
3569 if (ch == '\177' || ch == -1)
3571 else if (ch == '\157')
3573 else if (ch == '\174')
3575 else if (ch == '^') /* '\137' in 1047, '\260' in 819 */
3577 else if (ch == '\155')
3579 else if (0 < ch && ch < (sizeof(controllablechars) - 1))
3580 return(controllablechars[ch+1]);
3582 Perl_die(aTHX_ "invalid control request: '\\%03o'\n", ch & 0xFF);
3587 /* To workaround core dumps from the uninitialised tm_zone we get the
3588 * system to give us a reasonable struct to copy. This fix means that
3589 * strftime uses the tm_zone and tm_gmtoff values returned by
3590 * localtime(time()). That should give the desired result most of the
3591 * time. But probably not always!
3593 * This does not address tzname aspects of NETaa14816.
3598 # ifndef STRUCT_TM_HASZONE
3599 # define STRUCT_TM_HASZONE
3603 #ifdef STRUCT_TM_HASZONE /* Backward compat */
3604 # ifndef HAS_TM_TM_ZONE
3605 # define HAS_TM_TM_ZONE
3610 Perl_init_tm(pTHX_ struct tm *ptm) /* see mktime, strftime and asctime */
3612 #ifdef HAS_TM_TM_ZONE
3615 Copy(localtime(&now), ptm, 1, struct tm);
3620 * mini_mktime - normalise struct tm values without the localtime()
3621 * semantics (and overhead) of mktime().
3624 Perl_mini_mktime(pTHX_ struct tm *ptm)
3628 int month, mday, year, jday;
3629 int odd_cent, odd_year;
3631 #define DAYS_PER_YEAR 365
3632 #define DAYS_PER_QYEAR (4*DAYS_PER_YEAR+1)
3633 #define DAYS_PER_CENT (25*DAYS_PER_QYEAR-1)
3634 #define DAYS_PER_QCENT (4*DAYS_PER_CENT+1)
3635 #define SECS_PER_HOUR (60*60)
3636 #define SECS_PER_DAY (24*SECS_PER_HOUR)
3637 /* parentheses deliberately absent on these two, otherwise they don't work */
3638 #define MONTH_TO_DAYS 153/5
3639 #define DAYS_TO_MONTH 5/153
3640 /* offset to bias by March (month 4) 1st between month/mday & year finding */
3641 #define YEAR_ADJUST (4*MONTH_TO_DAYS+1)
3642 /* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */
3643 #define WEEKDAY_BIAS 6 /* (1+6)%7 makes Sunday 0 again */
3646 * Year/day algorithm notes:
3648 * With a suitable offset for numeric value of the month, one can find
3649 * an offset into the year by considering months to have 30.6 (153/5) days,
3650 * using integer arithmetic (i.e., with truncation). To avoid too much
3651 * messing about with leap days, we consider January and February to be
3652 * the 13th and 14th month of the previous year. After that transformation,
3653 * we need the month index we use to be high by 1 from 'normal human' usage,
3654 * so the month index values we use run from 4 through 15.
3656 * Given that, and the rules for the Gregorian calendar (leap years are those
3657 * divisible by 4 unless also divisible by 100, when they must be divisible
3658 * by 400 instead), we can simply calculate the number of days since some
3659 * arbitrary 'beginning of time' by futzing with the (adjusted) year number,
3660 * the days we derive from our month index, and adding in the day of the
3661 * month. The value used here is not adjusted for the actual origin which
3662 * it normally would use (1 January A.D. 1), since we're not exposing it.
3663 * We're only building the value so we can turn around and get the
3664 * normalised values for the year, month, day-of-month, and day-of-year.
3666 * For going backward, we need to bias the value we're using so that we find
3667 * the right year value. (Basically, we don't want the contribution of
3668 * March 1st to the number to apply while deriving the year). Having done
3669 * that, we 'count up' the contribution to the year number by accounting for
3670 * full quadracenturies (400-year periods) with their extra leap days, plus
3671 * the contribution from full centuries (to avoid counting in the lost leap
3672 * days), plus the contribution from full quad-years (to count in the normal
3673 * leap days), plus the leftover contribution from any non-leap years.
3674 * At this point, if we were working with an actual leap day, we'll have 0
3675 * days left over. This is also true for March 1st, however. So, we have
3676 * to special-case that result, and (earlier) keep track of the 'odd'
3677 * century and year contributions. If we got 4 extra centuries in a qcent,
3678 * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb.
3679 * Otherwise, we add back in the earlier bias we removed (the 123 from
3680 * figuring in March 1st), find the month index (integer division by 30.6),
3681 * and the remainder is the day-of-month. We then have to convert back to
3682 * 'real' months (including fixing January and February from being 14/15 in
3683 * the previous year to being in the proper year). After that, to get
3684 * tm_yday, we work with the normalised year and get a new yearday value for
3685 * January 1st, which we subtract from the yearday value we had earlier,
3686 * representing the date we've re-built. This is done from January 1
3687 * because tm_yday is 0-origin.
3689 * Since POSIX time routines are only guaranteed to work for times since the
3690 * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm
3691 * applies Gregorian calendar rules even to dates before the 16th century
3692 * doesn't bother me. Besides, you'd need cultural context for a given
3693 * date to know whether it was Julian or Gregorian calendar, and that's
3694 * outside the scope for this routine. Since we convert back based on the
3695 * same rules we used to build the yearday, you'll only get strange results
3696 * for input which needed normalising, or for the 'odd' century years which
3697 * were leap years in the Julian calander but not in the Gregorian one.
3698 * I can live with that.
3700 * This algorithm also fails to handle years before A.D. 1 gracefully, but
3701 * that's still outside the scope for POSIX time manipulation, so I don't
3705 year = 1900 + ptm->tm_year;
3706 month = ptm->tm_mon;
3707 mday = ptm->tm_mday;
3708 /* allow given yday with no month & mday to dominate the result */
3709 if (ptm->tm_yday >= 0 && mday <= 0 && month <= 0) {
3712 jday = 1 + ptm->tm_yday;
3721 yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400;
3722 yearday += month*MONTH_TO_DAYS + mday + jday;
3724 * Note that we don't know when leap-seconds were or will be,
3725 * so we have to trust the user if we get something which looks
3726 * like a sensible leap-second. Wild values for seconds will
3727 * be rationalised, however.
3729 if ((unsigned) ptm->tm_sec <= 60) {
3736 secs += 60 * ptm->tm_min;
3737 secs += SECS_PER_HOUR * ptm->tm_hour;
3739 if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) {
3740 /* got negative remainder, but need positive time */
3741 /* back off an extra day to compensate */
3742 yearday += (secs/SECS_PER_DAY)-1;
3743 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1);
3746 yearday += (secs/SECS_PER_DAY);
3747 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY);
3750 else if (secs >= SECS_PER_DAY) {
3751 yearday += (secs/SECS_PER_DAY);
3752 secs %= SECS_PER_DAY;
3754 ptm->tm_hour = secs/SECS_PER_HOUR;
3755 secs %= SECS_PER_HOUR;
3756 ptm->tm_min = secs/60;
3758 ptm->tm_sec += secs;
3759 /* done with time of day effects */
3761 * The algorithm for yearday has (so far) left it high by 428.
3762 * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to
3763 * bias it by 123 while trying to figure out what year it
3764 * really represents. Even with this tweak, the reverse
3765 * translation fails for years before A.D. 0001.
3766 * It would still fail for Feb 29, but we catch that one below.
3768 jday = yearday; /* save for later fixup vis-a-vis Jan 1 */
3769 yearday -= YEAR_ADJUST;
3770 year = (yearday / DAYS_PER_QCENT) * 400;
3771 yearday %= DAYS_PER_QCENT;
3772 odd_cent = yearday / DAYS_PER_CENT;
3773 year += odd_cent * 100;
3774 yearday %= DAYS_PER_CENT;
3775 year += (yearday / DAYS_PER_QYEAR) * 4;
3776 yearday %= DAYS_PER_QYEAR;
3777 odd_year = yearday / DAYS_PER_YEAR;
3779 yearday %= DAYS_PER_YEAR;
3780 if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */
3785 yearday += YEAR_ADJUST; /* recover March 1st crock */
3786 month = yearday*DAYS_TO_MONTH;
3787 yearday -= month*MONTH_TO_DAYS;
3788 /* recover other leap-year adjustment */
3797 ptm->tm_year = year - 1900;
3799 ptm->tm_mday = yearday;
3800 ptm->tm_mon = month;
3804 ptm->tm_mon = month - 1;
3806 /* re-build yearday based on Jan 1 to get tm_yday */
3808 yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400;
3809 yearday += 14*MONTH_TO_DAYS + 1;
3810 ptm->tm_yday = jday - yearday;
3811 /* fix tm_wday if not overridden by caller */
3812 if ((unsigned)ptm->tm_wday > 6)
3813 ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
3817 Perl_my_strftime(pTHX_ char *fmt, int sec, int min, int hour, int mday, int mon, int year, int wday, int yday, int isdst)
3825 init_tm(&mytm); /* XXX workaround - see init_tm() above */
3828 mytm.tm_hour = hour;
3829 mytm.tm_mday = mday;
3831 mytm.tm_year = year;
3832 mytm.tm_wday = wday;
3833 mytm.tm_yday = yday;
3834 mytm.tm_isdst = isdst;
3837 New(0, buf, buflen, char);
3838 len = strftime(buf, buflen, fmt, &mytm);
3840 ** The following is needed to handle to the situation where
3841 ** tmpbuf overflows. Basically we want to allocate a buffer
3842 ** and try repeatedly. The reason why it is so complicated
3843 ** is that getting a return value of 0 from strftime can indicate
3844 ** one of the following:
3845 ** 1. buffer overflowed,
3846 ** 2. illegal conversion specifier, or
3847 ** 3. the format string specifies nothing to be returned(not
3848 ** an error). This could be because format is an empty string
3849 ** or it specifies %p that yields an empty string in some locale.
3850 ** If there is a better way to make it portable, go ahead by
3853 if ((len > 0 && len < buflen) || (len == 0 && *fmt == '\0'))
3856 /* Possibly buf overflowed - try again with a bigger buf */
3857 int fmtlen = strlen(fmt);
3858 int bufsize = fmtlen + buflen;
3860 New(0, buf, bufsize, char);
3862 buflen = strftime(buf, bufsize, fmt, &mytm);
3863 if (buflen > 0 && buflen < bufsize)
3865 /* heuristic to prevent out-of-memory errors */
3866 if (bufsize > 100*fmtlen) {
3872 Renew(buf, bufsize, char);
3877 Perl_croak(aTHX_ "panic: no strftime");
3882 #define SV_CWD_RETURN_UNDEF \
3883 sv_setsv(sv, &PL_sv_undef); \
3886 #define SV_CWD_ISDOT(dp) \
3887 (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
3888 (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
3891 =head1 Miscellaneous Functions
3893 =for apidoc getcwd_sv
3895 Fill the sv with current working directory
3900 /* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars.
3901 * rewritten again by dougm, optimized for use with xs TARG, and to prefer
3902 * getcwd(3) if available
3903 * Comments from the orignal:
3904 * This is a faster version of getcwd. It's also more dangerous
3905 * because you might chdir out of a directory that you can't chdir
3909 Perl_getcwd_sv(pTHX_ register SV *sv)
3913 #ifndef INCOMPLETE_TAINTS
3919 char buf[MAXPATHLEN];
3921 /* Some getcwd()s automatically allocate a buffer of the given
3922 * size from the heap if they are given a NULL buffer pointer.
3923 * The problem is that this behaviour is not portable. */
3924 if (getcwd(buf, sizeof(buf) - 1)) {
3925 STRLEN len = strlen(buf);
3926 sv_setpvn(sv, buf, len);
3930 sv_setsv(sv, &PL_sv_undef);
3938 int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
3939 int namelen, pathlen=0;
3943 (void)SvUPGRADE(sv, SVt_PV);
3945 if (PerlLIO_lstat(".", &statbuf) < 0) {
3946 SV_CWD_RETURN_UNDEF;
3949 orig_cdev = statbuf.st_dev;
3950 orig_cino = statbuf.st_ino;
3958 if (PerlDir_chdir("..") < 0) {
3959 SV_CWD_RETURN_UNDEF;
3961 if (PerlLIO_stat(".", &statbuf) < 0) {
3962 SV_CWD_RETURN_UNDEF;
3965 cdev = statbuf.st_dev;
3966 cino = statbuf.st_ino;
3968 if (odev == cdev && oino == cino) {
3971 if (!(dir = PerlDir_open("."))) {
3972 SV_CWD_RETURN_UNDEF;
3975 while ((dp = PerlDir_read(dir)) != NULL) {
3977 namelen = dp->d_namlen;
3979 namelen = strlen(dp->d_name);
3982 if (SV_CWD_ISDOT(dp)) {
3986 if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
3987 SV_CWD_RETURN_UNDEF;
3990 tdev = statbuf.st_dev;
3991 tino = statbuf.st_ino;
3992 if (tino == oino && tdev == odev) {
3998 SV_CWD_RETURN_UNDEF;
4001 if (pathlen + namelen + 1 >= MAXPATHLEN) {
4002 SV_CWD_RETURN_UNDEF;
4005 SvGROW(sv, pathlen + namelen + 1);
4009 Move(SvPVX(sv), SvPVX(sv) + namelen + 1, pathlen, char);
4012 /* prepend current directory to the front */
4014 Move(dp->d_name, SvPVX(sv)+1, namelen, char);
4015 pathlen += (namelen + 1);
4017 #ifdef VOID_CLOSEDIR
4020 if (PerlDir_close(dir) < 0) {
4021 SV_CWD_RETURN_UNDEF;
4027 SvCUR_set(sv, pathlen);
4031 if (PerlDir_chdir(SvPVX(sv)) < 0) {
4032 SV_CWD_RETURN_UNDEF;
4035 if (PerlLIO_stat(".", &statbuf) < 0) {
4036 SV_CWD_RETURN_UNDEF;
4039 cdev = statbuf.st_dev;
4040 cino = statbuf.st_ino;
4042 if (cdev != orig_cdev || cino != orig_cino) {
4043 Perl_croak(aTHX_ "Unstable directory path, "
4044 "current directory changed unexpectedly");
4056 =head1 SV Manipulation Functions
4058 =for apidoc scan_vstring
4060 Returns a pointer to the next character after the parsed
4061 vstring, as well as updating the passed in sv.
4063 Function must be called like
4066 s = scan_vstring(s,sv);
4068 The sv should already be large enough to store the vstring
4069 passed in, for performance reasons.
4075 Perl_scan_vstring(pTHX_ char *s, SV *sv)
4079 if (*pos == 'v') pos++; /* get past 'v' */
4080 while (isDIGIT(*pos) || *pos == '_')
4082 if (!isALPHA(*pos)) {
4084 U8 tmpbuf[UTF8_MAXLEN+1];
4087 if (*s == 'v') s++; /* get past 'v' */
4089 sv_setpvn(sv, "", 0);
4094 /* this is atoi() that tolerates underscores */
4097 while (--end >= s) {
4102 rev += (*end - '0') * mult;
4104 if (orev > rev && ckWARN_d(WARN_OVERFLOW))
4105 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
4106 "Integer overflow in decimal number");
4110 if (rev > 0x7FFFFFFF)
4111 Perl_croak(aTHX "In EBCDIC the v-string components cannot exceed 2147483647");
4113 /* Append native character for the rev point */
4114 tmpend = uvchr_to_utf8(tmpbuf, rev);
4115 sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
4116 if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(rev)))
4118 if (*pos == '.' && isDIGIT(pos[1]))
4124 while (isDIGIT(*pos) || *pos == '_')
4128 sv_magicext(sv,NULL,PERL_MAGIC_vstring,NULL,(const char*)start, pos-start);
4136 =for apidoc scan_version
4138 Returns a pointer to the next character after the parsed
4139 version string, as well as upgrading the passed in SV to
4142 Function must be called with an already existing SV like
4145 s = scan_version(s,sv);
4147 Performs some preprocessing to the string to ensure that
4148 it has the correct characteristics of a version. Flags the
4149 object if it contains an underscore (which denotes this
4156 Perl_scan_version(pTHX_ char *version, SV *rv)
4160 SV * sv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
4165 while (isDIGIT(*d) || *d == '.')
4169 if ( *(d+1) == '0' && *(d+2) != '0' ) { /* perl-style version */
4178 version = scan_vstring(version,sv); /* store the v-string in the object */
4184 =for apidoc new_version
4186 Returns a new version object based on the passed in SV:
4188 SV *sv = new_version(SV *ver);
4190 Does not alter the passed in ver SV. See "upg_version" if you
4191 want to upgrade the SV.
4197 Perl_new_version(pTHX_ SV *ver)
4199 SV *rv = NEWSV(92,5);
4202 if ( SvMAGICAL(ver) ) { /* already a v-string */
4203 MAGIC* mg = mg_find(ver,PERL_MAGIC_vstring);
4204 version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
4207 version = (char *)SvPV_nolen(ver);
4209 version = scan_version(version,rv);
4214 =for apidoc upg_version
4216 In-place upgrade of the supplied SV to a version object.
4218 SV *sv = upg_version(SV *sv);
4220 Returns a pointer to the upgraded SV.
4226 Perl_upg_version(pTHX_ SV *sv)
4228 char *version = (char *)SvPV_nolen(sv_mortalcopy(sv));
4229 bool utf8 = SvUTF8(sv);
4230 if ( SvVOK(sv) ) { /* already a v-string */
4231 SV * ver = newSVrv(sv, "version");
4232 sv_setpv(ver,version);
4237 version = scan_version(version,sv);
4246 Accepts a version (or vstring) object and returns the
4247 normalized floating point representation. Call like:
4249 sv = vnumify(sv,SvRV(rv));
4251 NOTE: no checking is done to see if the object is of the
4252 correct type (for speed).
4258 Perl_vnumify(pTHX_ SV *sv, SV *vs)
4260 U8* pv = (U8*)SvPVX(vs);
4261 STRLEN len = SvCUR(vs);
4263 UV digit = utf8_to_uvchr(pv,&retlen);
4264 Perl_sv_setpvf(aTHX_ sv,"%"UVf".",digit);
4265 for (pv += retlen, len -= retlen;
4267 pv += retlen, len -= retlen)
4269 digit = utf8_to_uvchr(pv,&retlen);
4270 Perl_sv_catpvf(aTHX_ sv,"%03"UVf,digit);
4276 =for apidoc vstringify
4278 Accepts a version (or vstring) object and returns the
4279 normalized representation. Call like:
4281 sv = vstringify(sv,SvRV(rv));
4283 NOTE: no checking is done to see if the object is of the
4284 correct type (for speed).
4290 Perl_vstringify(pTHX_ SV *sv, SV *vs)
4292 U8* pv = (U8*)SvPVX(vs);
4293 STRLEN len = SvCUR(vs);
4295 UV digit = utf8_to_uvchr(pv,&retlen);
4296 Perl_sv_setpvf(aTHX_ sv,"%"UVf,digit);
4297 for (pv += retlen, len -= retlen;
4299 pv += retlen, len -= retlen)
4301 digit = utf8_to_uvchr(pv,&retlen);
4302 Perl_sv_catpvf(aTHX_ sv,".%03"UVf,digit);
4304 if ( SvIVX(vs) < 0 )
4305 sv_catpv(sv,"beta");
4309 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT)
4310 # define EMULATE_SOCKETPAIR_UDP
4313 #ifdef EMULATE_SOCKETPAIR_UDP
4315 S_socketpair_udp (int fd[2]) {
4317 /* Fake a datagram socketpair using UDP to localhost. */
4318 int sockets[2] = {-1, -1};
4319 struct sockaddr_in addresses[2];
4321 Sock_size_t size = sizeof (struct sockaddr_in);
4322 unsigned short port;
4325 memset (&addresses, 0, sizeof (addresses));
4328 sockets[i] = PerlSock_socket (AF_INET, SOCK_DGRAM, PF_INET);
4329 if (sockets[i] == -1)
4330 goto tidy_up_and_fail;
4332 addresses[i].sin_family = AF_INET;
4333 addresses[i].sin_addr.s_addr = htonl (INADDR_LOOPBACK);
4334 addresses[i].sin_port = 0; /* kernel choses port. */
4335 if (PerlSock_bind (sockets[i], (struct sockaddr *) &addresses[i],
4336 sizeof (struct sockaddr_in))
4338 goto tidy_up_and_fail;
4341 /* Now have 2 UDP sockets. Find out which port each is connected to, and
4342 for each connect the other socket to it. */
4345 if (PerlSock_getsockname (sockets[i], (struct sockaddr *) &addresses[i], &size)
4347 goto tidy_up_and_fail;
4348 if (size != sizeof (struct sockaddr_in))
4349 goto abort_tidy_up_and_fail;
4350 /* !1 is 0, !0 is 1 */
4351 if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i],
4352 sizeof (struct sockaddr_in)) == -1)
4353 goto tidy_up_and_fail;
4356 /* Now we have 2 sockets connected to each other. I don't trust some other
4357 process not to have already sent a packet to us (by random) so send
4358 a packet from each to the other. */
4361 /* I'm going to send my own port number. As a short.
4362 (Who knows if someone somewhere has sin_port as a bitfield and needs
4363 this routine. (I'm assuming crays have socketpair)) */
4364 port = addresses[i].sin_port;
4365 got = PerlLIO_write (sockets[i], &port, sizeof(port));
4366 if (got != sizeof(port)) {
4368 goto tidy_up_and_fail;
4369 goto abort_tidy_up_and_fail;
4373 /* Packets sent. I don't trust them to have arrived though.
4374 (As I understand it Solaris TCP stack is multithreaded. Non-blocking
4375 connect to localhost will use a second kernel thread. In 2.6 the
4376 first thread running the connect() returns before the second completes,
4377 so EINPROGRESS> In 2.7 the improved stack is faster and connect()
4378 returns 0. Poor programs have tripped up. One poor program's authors'
4379 had a 50-1 reverse stock split. Not sure how connected these were.)
4380 So I don't trust someone not to have an unpredictable UDP stack.
4384 struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */
4385 int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0];
4389 FD_SET (sockets[0], &rset);
4390 FD_SET (sockets[1], &rset);
4392 got = PerlSock_select (max + 1, &rset, NULL, NULL, &waitfor);
4393 if (got != 2 || !FD_ISSET (sockets[0], &rset)
4394 || !FD_ISSET (sockets[1], &rset)) {
4395 /* I hope this is portable and appropriate. */
4397 goto tidy_up_and_fail;
4398 goto abort_tidy_up_and_fail;
4402 /* And the paranoia department even now doesn't trust it to have arrive
4403 (hence MSG_DONTWAIT). Or that what arrives was sent by us. */
4405 struct sockaddr_in readfrom;
4406 unsigned short buffer[2];
4411 got = PerlSock_recvfrom (sockets[i], (char *) &buffer, sizeof(buffer),
4413 (struct sockaddr *) &readfrom, &size);
4415 got = PerlSock_recvfrom (sockets[i], (char *) &buffer, sizeof(buffer),
4417 (struct sockaddr *) &readfrom, &size);
4421 goto tidy_up_and_fail;
4422 if (got != sizeof(port)
4423 || size != sizeof (struct sockaddr_in)
4424 /* Check other socket sent us its port. */
4425 || buffer[0] != (unsigned short) addresses[!i].sin_port
4426 /* Check kernel says we got the datagram from that socket. */
4427 || readfrom.sin_family != addresses[!i].sin_family
4428 || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr
4429 || readfrom.sin_port != addresses[!i].sin_port)
4430 goto abort_tidy_up_and_fail;
4433 /* My caller (my_socketpair) has validated that this is non-NULL */
4436 /* I hereby declare this connection open. May God bless all who cross
4440 abort_tidy_up_and_fail:
4441 errno = ECONNABORTED;
4444 int save_errno = errno;
4445 if (sockets[0] != -1)
4446 PerlLIO_close (sockets[0]);
4447 if (sockets[1] != -1)
4448 PerlLIO_close (sockets[1]);
4453 #endif /* EMULATE_SOCKETPAIR_UDP */
4455 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET)
4457 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4458 /* Stevens says that family must be AF_LOCAL, protocol 0.
4459 I'm going to enforce that, then ignore it, and use TCP (or UDP). */
4464 struct sockaddr_in listen_addr;
4465 struct sockaddr_in connect_addr;
4470 || family != AF_UNIX
4473 errno = EAFNOSUPPORT;
4481 #ifdef EMULATE_SOCKETPAIR_UDP
4482 if (type == SOCK_DGRAM)
4483 return S_socketpair_udp (fd);
4486 listener = PerlSock_socket (AF_INET, type, 0);
4489 memset (&listen_addr, 0, sizeof (listen_addr));
4490 listen_addr.sin_family = AF_INET;
4491 listen_addr.sin_addr.s_addr = htonl (INADDR_LOOPBACK);
4492 listen_addr.sin_port = 0; /* kernel choses port. */
4493 if (PerlSock_bind (listener, (struct sockaddr *) &listen_addr, sizeof (listen_addr))
4495 goto tidy_up_and_fail;
4496 if (PerlSock_listen(listener, 1) == -1)
4497 goto tidy_up_and_fail;
4499 connector = PerlSock_socket (AF_INET, type, 0);
4500 if (connector == -1)
4501 goto tidy_up_and_fail;
4502 /* We want to find out the port number to connect to. */
4503 size = sizeof (connect_addr);
4504 if (PerlSock_getsockname (listener, (struct sockaddr *) &connect_addr, &size) == -1)
4505 goto tidy_up_and_fail;
4506 if (size != sizeof (connect_addr))
4507 goto abort_tidy_up_and_fail;
4508 if (PerlSock_connect(connector, (struct sockaddr *) &connect_addr,
4509 sizeof (connect_addr)) == -1)
4510 goto tidy_up_and_fail;
4512 size = sizeof (listen_addr);
4513 acceptor = PerlSock_accept (listener, (struct sockaddr *) &listen_addr, &size);
4515 goto tidy_up_and_fail;
4516 if (size != sizeof (listen_addr))
4517 goto abort_tidy_up_and_fail;
4518 PerlLIO_close (listener);
4519 /* Now check we are talking to ourself by matching port and host on the
4521 if (PerlSock_getsockname (connector, (struct sockaddr *) &connect_addr, &size) == -1)
4522 goto tidy_up_and_fail;
4523 if (size != sizeof (connect_addr)
4524 || listen_addr.sin_family != connect_addr.sin_family
4525 || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr
4526 || listen_addr.sin_port != connect_addr.sin_port) {
4527 goto abort_tidy_up_and_fail;
4533 abort_tidy_up_and_fail:
4534 errno = ECONNABORTED; /* I hope this is portable and appropriate. */
4537 int save_errno = errno;
4539 PerlLIO_close (listener);
4540 if (connector != -1)
4541 PerlLIO_close (connector);
4543 PerlLIO_close (acceptor);
4549 /* In any case have a stub so that there's code corresponding
4550 * to the my_socketpair in global.sym. */
4552 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4553 #ifdef HAS_SOCKETPAIR
4554 return socketpair(family, type, protocol, fd);
4563 =for apidoc sv_nosharing
4565 Dummy routine which "shares" an SV when there is no sharing module present.
4566 Exists to avoid test for a NULL function pointer and because it could potentially warn under
4567 some level of strict-ness.
4573 Perl_sv_nosharing(pTHX_ SV *sv)
4578 =for apidoc sv_nolocking
4580 Dummy routine which "locks" an SV when there is no locking module present.
4581 Exists to avoid test for a NULL function pointer and because it could potentially warn under
4582 some level of strict-ness.
4588 Perl_sv_nolocking(pTHX_ SV *sv)
4594 =for apidoc sv_nounlocking
4596 Dummy routine which "unlocks" an SV when there is no locking module present.
4597 Exists to avoid test for a NULL function pointer and because it could potentially warn under
4598 some level of strict-ness.
4604 Perl_sv_nounlocking(pTHX_ SV *sv)