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));
2163 hv_clear(PL_pidstatus); /* we have no children */
2168 do_execfree(); /* free any memory malloced by child on vfork */
2170 PerlLIO_close(pp[1]);
2171 if (p[that] < p[This]) {
2172 PerlLIO_dup2(p[This], p[that]);
2173 PerlLIO_close(p[This]);
2177 PerlLIO_close(p[that]);
2180 sv = *av_fetch(PL_fdpid,p[This],TRUE);
2182 (void)SvUPGRADE(sv,SVt_IV);
2184 PL_forkprocess = pid;
2185 if (did_pipes && pid > 0) {
2189 while (n < sizeof(int)) {
2190 n1 = PerlLIO_read(pp[0],
2191 (void*)(((char*)&errkid)+n),
2197 PerlLIO_close(pp[0]);
2199 if (n) { /* Error */
2201 PerlLIO_close(p[This]);
2202 if (n != sizeof(int))
2203 Perl_croak(aTHX_ "panic: kid popen errno read");
2205 pid2 = wait4pid(pid, &status, 0);
2206 } while (pid2 == -1 && errno == EINTR);
2207 errno = errkid; /* Propagate errno from kid */
2212 PerlLIO_close(pp[0]);
2213 return PerlIO_fdopen(p[This], mode);
2216 #if defined(atarist) || defined(EPOC)
2219 Perl_my_popen(pTHX_ char *cmd, char *mode)
2221 PERL_FLUSHALL_FOR_CHILD;
2222 /* Call system's popen() to get a FILE *, then import it.
2223 used 0 for 2nd parameter to PerlIO_importFILE;
2226 return PerlIO_importFILE(popen(cmd, mode), 0);
2230 FILE *djgpp_popen();
2232 Perl_my_popen(pTHX_ char *cmd, char *mode)
2234 PERL_FLUSHALL_FOR_CHILD;
2235 /* Call system's popen() to get a FILE *, then import it.
2236 used 0 for 2nd parameter to PerlIO_importFILE;
2239 return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
2244 #endif /* !DOSISH */
2246 /* this is called in parent before the fork() */
2248 Perl_atfork_lock(void)
2250 #if defined(USE_5005THREADS) || defined(USE_ITHREADS)
2251 /* locks must be held in locking order (if any) */
2253 MUTEX_LOCK(&PL_malloc_mutex);
2259 /* this is called in both parent and child after the fork() */
2261 Perl_atfork_unlock(void)
2263 #if defined(USE_5005THREADS) || defined(USE_ITHREADS)
2264 /* locks must be released in same order as in atfork_lock() */
2266 MUTEX_UNLOCK(&PL_malloc_mutex);
2275 #if defined(HAS_FORK)
2277 #if (defined(USE_5005THREADS) || defined(USE_ITHREADS)) && !defined(HAS_PTHREAD_ATFORK)
2282 /* atfork_lock() and atfork_unlock() are installed as pthread_atfork()
2283 * handlers elsewhere in the code */
2288 /* this "canna happen" since nothing should be calling here if !HAS_FORK */
2289 Perl_croak_nocontext("fork() not available");
2291 #endif /* HAS_FORK */
2296 Perl_dump_fds(pTHX_ char *s)
2301 PerlIO_printf(Perl_debug_log,"%s", s);
2302 for (fd = 0; fd < 32; fd++) {
2303 if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0)
2304 PerlIO_printf(Perl_debug_log," %d",fd);
2306 PerlIO_printf(Perl_debug_log,"\n");
2308 #endif /* DUMP_FDS */
2312 dup2(int oldfd, int newfd)
2314 #if defined(HAS_FCNTL) && defined(F_DUPFD)
2317 PerlLIO_close(newfd);
2318 return fcntl(oldfd, F_DUPFD, newfd);
2320 #define DUP2_MAX_FDS 256
2321 int fdtmp[DUP2_MAX_FDS];
2327 PerlLIO_close(newfd);
2328 /* good enough for low fd's... */
2329 while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
2330 if (fdx >= DUP2_MAX_FDS) {
2338 PerlLIO_close(fdtmp[--fdx]);
2345 #ifdef HAS_SIGACTION
2348 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2350 struct sigaction act, oact;
2353 /* only "parent" interpreter can diddle signals */
2354 if (PL_curinterp != aTHX)
2358 act.sa_handler = handler;
2359 sigemptyset(&act.sa_mask);
2362 #if defined(PERL_OLD_SIGNALS)
2363 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
2367 if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN)
2368 act.sa_flags |= SA_NOCLDWAIT;
2370 if (sigaction(signo, &act, &oact) == -1)
2373 return oact.sa_handler;
2377 Perl_rsignal_state(pTHX_ int signo)
2379 struct sigaction oact;
2381 if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
2384 return oact.sa_handler;
2388 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2390 struct sigaction act;
2393 /* only "parent" interpreter can diddle signals */
2394 if (PL_curinterp != aTHX)
2398 act.sa_handler = handler;
2399 sigemptyset(&act.sa_mask);
2402 #if defined(PERL_OLD_SIGNALS)
2403 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
2407 if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN)
2408 act.sa_flags |= SA_NOCLDWAIT;
2410 return sigaction(signo, &act, save);
2414 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2417 /* only "parent" interpreter can diddle signals */
2418 if (PL_curinterp != aTHX)
2422 return sigaction(signo, save, (struct sigaction *)NULL);
2425 #else /* !HAS_SIGACTION */
2428 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2430 #if defined(USE_ITHREADS) && !defined(WIN32)
2431 /* only "parent" interpreter can diddle signals */
2432 if (PL_curinterp != aTHX)
2436 return PerlProc_signal(signo, handler);
2439 static int sig_trapped; /* XXX signals are process-wide anyway, so we
2440 ignore the implications of this for threading */
2450 Perl_rsignal_state(pTHX_ int signo)
2452 Sighandler_t oldsig;
2454 #if defined(USE_ITHREADS) && !defined(WIN32)
2455 /* only "parent" interpreter can diddle signals */
2456 if (PL_curinterp != aTHX)
2461 oldsig = PerlProc_signal(signo, sig_trap);
2462 PerlProc_signal(signo, oldsig);
2464 PerlProc_kill(PerlProc_getpid(), signo);
2469 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2471 #if defined(USE_ITHREADS) && !defined(WIN32)
2472 /* only "parent" interpreter can diddle signals */
2473 if (PL_curinterp != aTHX)
2476 *save = PerlProc_signal(signo, handler);
2477 return (*save == SIG_ERR) ? -1 : 0;
2481 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2483 #if defined(USE_ITHREADS) && !defined(WIN32)
2484 /* only "parent" interpreter can diddle signals */
2485 if (PL_curinterp != aTHX)
2488 return (PerlProc_signal(signo, *save) == SIG_ERR) ? -1 : 0;
2491 #endif /* !HAS_SIGACTION */
2492 #endif /* !PERL_MICRO */
2494 /* VMS' my_pclose() is in VMS.c; same with OS/2 */
2495 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
2497 Perl_my_pclose(pTHX_ PerlIO *ptr)
2499 Sigsave_t hstat, istat, qstat;
2505 int saved_errno = 0;
2507 int saved_vaxc_errno;
2510 int saved_win32_errno;
2514 svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE);
2516 pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
2518 *svp = &PL_sv_undef;
2520 if (pid == -1) { /* Opened by popen. */
2521 return my_syspclose(ptr);
2524 if ((close_failed = (PerlIO_close(ptr) == EOF))) {
2525 saved_errno = errno;
2527 saved_vaxc_errno = vaxc$errno;
2530 saved_win32_errno = GetLastError();
2534 if(PerlProc_kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */
2537 rsignal_save(SIGHUP, SIG_IGN, &hstat);
2538 rsignal_save(SIGINT, SIG_IGN, &istat);
2539 rsignal_save(SIGQUIT, SIG_IGN, &qstat);
2542 pid2 = wait4pid(pid, &status, 0);
2543 } while (pid2 == -1 && errno == EINTR);
2545 rsignal_restore(SIGHUP, &hstat);
2546 rsignal_restore(SIGINT, &istat);
2547 rsignal_restore(SIGQUIT, &qstat);
2550 SETERRNO(saved_errno, saved_vaxc_errno);
2553 return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status));
2555 #endif /* !DOSISH */
2557 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(MACOS_TRADITIONAL)
2559 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
2564 #if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME)
2568 char spid[TYPE_CHARS(int)];
2571 sprintf(spid, "%"IVdf, (IV)pid);
2572 svp = hv_fetch(PL_pidstatus,spid,strlen(spid),FALSE);
2573 if (svp && *svp != &PL_sv_undef) {
2574 *statusp = SvIVX(*svp);
2575 (void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD);
2582 hv_iterinit(PL_pidstatus);
2583 if ((entry = hv_iternext(PL_pidstatus))) {
2585 char spid[TYPE_CHARS(int)];
2587 pid = atoi(hv_iterkey(entry,(I32*)statusp));
2588 sv = hv_iterval(PL_pidstatus,entry);
2589 *statusp = SvIVX(sv);
2590 sprintf(spid, "%"IVdf, (IV)pid);
2591 (void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD);
2598 # ifdef HAS_WAITPID_RUNTIME
2599 if (!HAS_WAITPID_RUNTIME)
2602 result = PerlProc_waitpid(pid,statusp,flags);
2605 #if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
2606 result = wait4((pid==-1)?0:pid,statusp,flags,Null(struct rusage *));
2609 #if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME)
2613 Perl_croak(aTHX_ "Can't do waitpid with flags");
2615 while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
2616 pidgone(result,*statusp);
2623 if (result < 0 && errno == EINTR) {
2628 #endif /* !DOSISH || OS2 || WIN32 || NETWARE */
2632 Perl_pidgone(pTHX_ Pid_t pid, int status)
2635 char spid[TYPE_CHARS(int)];
2637 sprintf(spid, "%"IVdf, (IV)pid);
2638 sv = *hv_fetch(PL_pidstatus,spid,strlen(spid),TRUE);
2639 (void)SvUPGRADE(sv,SVt_IV);
2644 #if defined(atarist) || defined(OS2) || defined(EPOC)
2647 int /* Cannot prototype with I32
2649 my_syspclose(PerlIO *ptr)
2652 Perl_my_pclose(pTHX_ PerlIO *ptr)
2655 /* Needs work for PerlIO ! */
2656 FILE *f = PerlIO_findFILE(ptr);
2657 I32 result = pclose(f);
2658 PerlIO_releaseFILE(ptr,f);
2666 Perl_my_pclose(pTHX_ PerlIO *ptr)
2668 /* Needs work for PerlIO ! */
2669 FILE *f = PerlIO_findFILE(ptr);
2670 I32 result = djgpp_pclose(f);
2671 result = (result << 8) & 0xff00;
2672 PerlIO_releaseFILE(ptr,f);
2678 Perl_repeatcpy(pTHX_ register char *to, register const char *from, I32 len, register I32 count)
2681 register const char *frombase = from;
2684 register const char c = *from;
2689 while (count-- > 0) {
2690 for (todo = len; todo > 0; todo--) {
2699 Perl_same_dirent(pTHX_ char *a, char *b)
2701 char *fa = strrchr(a,'/');
2702 char *fb = strrchr(b,'/');
2705 SV *tmpsv = sv_newmortal();
2718 sv_setpv(tmpsv, ".");
2720 sv_setpvn(tmpsv, a, fa - a);
2721 if (PerlLIO_stat(SvPVX(tmpsv), &tmpstatbuf1) < 0)
2724 sv_setpv(tmpsv, ".");
2726 sv_setpvn(tmpsv, b, fb - b);
2727 if (PerlLIO_stat(SvPVX(tmpsv), &tmpstatbuf2) < 0)
2729 return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
2730 tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
2732 #endif /* !HAS_RENAME */
2735 Perl_find_script(pTHX_ char *scriptname, bool dosearch, char **search_ext, I32 flags)
2737 char *xfound = Nullch;
2738 char *xfailed = Nullch;
2739 char tmpbuf[MAXPATHLEN];
2743 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
2744 # define SEARCH_EXTS ".bat", ".cmd", NULL
2745 # define MAX_EXT_LEN 4
2748 # define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
2749 # define MAX_EXT_LEN 4
2752 # define SEARCH_EXTS ".pl", ".com", NULL
2753 # define MAX_EXT_LEN 4
2755 /* additional extensions to try in each dir if scriptname not found */
2757 char *exts[] = { SEARCH_EXTS };
2758 char **ext = search_ext ? search_ext : exts;
2759 int extidx = 0, i = 0;
2760 char *curext = Nullch;
2762 # define MAX_EXT_LEN 0
2766 * If dosearch is true and if scriptname does not contain path
2767 * delimiters, search the PATH for scriptname.
2769 * If SEARCH_EXTS is also defined, will look for each
2770 * scriptname{SEARCH_EXTS} whenever scriptname is not found
2771 * while searching the PATH.
2773 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
2774 * proceeds as follows:
2775 * If DOSISH or VMSISH:
2776 * + look for ./scriptname{,.foo,.bar}
2777 * + search the PATH for scriptname{,.foo,.bar}
2780 * + look *only* in the PATH for scriptname{,.foo,.bar} (note
2781 * this will not look in '.' if it's not in the PATH)
2786 # ifdef ALWAYS_DEFTYPES
2787 len = strlen(scriptname);
2788 if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
2789 int hasdir, idx = 0, deftypes = 1;
2792 hasdir = !dosearch || (strpbrk(scriptname,":[</") != Nullch) ;
2795 int hasdir, idx = 0, deftypes = 1;
2798 hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
2800 /* The first time through, just add SEARCH_EXTS to whatever we
2801 * already have, so we can check for default file types. */
2803 (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
2809 if ((strlen(tmpbuf) + strlen(scriptname)
2810 + MAX_EXT_LEN) >= sizeof tmpbuf)
2811 continue; /* don't search dir with too-long name */
2812 strcat(tmpbuf, scriptname);
2816 if (strEQ(scriptname, "-"))
2818 if (dosearch) { /* Look in '.' first. */
2819 char *cur = scriptname;
2821 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
2823 if (strEQ(ext[i++],curext)) {
2824 extidx = -1; /* already has an ext */
2829 DEBUG_p(PerlIO_printf(Perl_debug_log,
2830 "Looking for %s\n",cur));
2831 if (PerlLIO_stat(cur,&PL_statbuf) >= 0
2832 && !S_ISDIR(PL_statbuf.st_mode)) {
2840 if (cur == scriptname) {
2841 len = strlen(scriptname);
2842 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
2844 cur = strcpy(tmpbuf, scriptname);
2846 } while (extidx >= 0 && ext[extidx] /* try an extension? */
2847 && strcpy(tmpbuf+len, ext[extidx++]));
2852 #ifdef MACOS_TRADITIONAL
2853 if (dosearch && !strchr(scriptname, ':') &&
2854 (s = PerlEnv_getenv("Commands")))
2856 if (dosearch && !strchr(scriptname, '/')
2858 && !strchr(scriptname, '\\')
2860 && (s = PerlEnv_getenv("PATH")))
2865 PL_bufend = s + strlen(s);
2866 while (s < PL_bufend) {
2867 #ifdef MACOS_TRADITIONAL
2868 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
2872 #if defined(atarist) || defined(DOSISH)
2877 && *s != ';'; len++, s++) {
2878 if (len < sizeof tmpbuf)
2881 if (len < sizeof tmpbuf)
2883 #else /* ! (atarist || DOSISH) */
2884 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
2887 #endif /* ! (atarist || DOSISH) */
2888 #endif /* MACOS_TRADITIONAL */
2891 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
2892 continue; /* don't search dir with too-long name */
2893 #ifdef MACOS_TRADITIONAL
2894 if (len && tmpbuf[len - 1] != ':')
2895 tmpbuf[len++] = ':';
2898 #if defined(atarist) || defined(__MINT__) || defined(DOSISH)
2899 && tmpbuf[len - 1] != '/'
2900 && tmpbuf[len - 1] != '\\'
2903 tmpbuf[len++] = '/';
2904 if (len == 2 && tmpbuf[0] == '.')
2907 (void)strcpy(tmpbuf + len, scriptname);
2911 len = strlen(tmpbuf);
2912 if (extidx > 0) /* reset after previous loop */
2916 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
2917 retval = PerlLIO_stat(tmpbuf,&PL_statbuf);
2918 if (S_ISDIR(PL_statbuf.st_mode)) {
2922 } while ( retval < 0 /* not there */
2923 && extidx>=0 && ext[extidx] /* try an extension? */
2924 && strcpy(tmpbuf+len, ext[extidx++])
2929 if (S_ISREG(PL_statbuf.st_mode)
2930 && cando(S_IRUSR,TRUE,&PL_statbuf)
2931 #if !defined(DOSISH) && !defined(MACOS_TRADITIONAL)
2932 && cando(S_IXUSR,TRUE,&PL_statbuf)
2936 xfound = tmpbuf; /* bingo! */
2940 xfailed = savepv(tmpbuf);
2943 if (!xfound && !seen_dot && !xfailed &&
2944 (PerlLIO_stat(scriptname,&PL_statbuf) < 0
2945 || S_ISDIR(PL_statbuf.st_mode)))
2947 seen_dot = 1; /* Disable message. */
2949 if (flags & 1) { /* do or die? */
2950 Perl_croak(aTHX_ "Can't %s %s%s%s",
2951 (xfailed ? "execute" : "find"),
2952 (xfailed ? xfailed : scriptname),
2953 (xfailed ? "" : " on PATH"),
2954 (xfailed || seen_dot) ? "" : ", '.' not in PATH");
2956 scriptname = Nullch;
2960 scriptname = xfound;
2962 return (scriptname ? savepv(scriptname) : Nullch);
2965 #ifndef PERL_GET_CONTEXT_DEFINED
2968 Perl_get_context(void)
2970 #if defined(USE_5005THREADS) || defined(USE_ITHREADS)
2971 # ifdef OLD_PTHREADS_API
2973 if (pthread_getspecific(PL_thr_key, &t))
2974 Perl_croak_nocontext("panic: pthread_getspecific");
2977 # ifdef I_MACH_CTHREADS
2978 return (void*)cthread_data(cthread_self());
2980 return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
2989 Perl_set_context(void *t)
2991 #if defined(USE_5005THREADS) || defined(USE_ITHREADS)
2992 # ifdef I_MACH_CTHREADS
2993 cthread_set_data(cthread_self(), t);
2995 if (pthread_setspecific(PL_thr_key, t))
2996 Perl_croak_nocontext("panic: pthread_setspecific");
3001 #endif /* !PERL_GET_CONTEXT_DEFINED */
3003 #ifdef USE_5005THREADS
3006 /* Very simplistic scheduler for now */
3010 thr = thr->i.next_run;
3014 Perl_cond_init(pTHX_ perl_cond *cp)
3020 Perl_cond_signal(pTHX_ perl_cond *cp)
3023 perl_cond cond = *cp;
3028 /* Insert t in the runnable queue just ahead of us */
3029 t->i.next_run = thr->i.next_run;
3030 thr->i.next_run->i.prev_run = t;
3031 t->i.prev_run = thr;
3032 thr->i.next_run = t;
3033 thr->i.wait_queue = 0;
3034 /* Remove from the wait queue */
3040 Perl_cond_broadcast(pTHX_ perl_cond *cp)
3043 perl_cond cond, cond_next;
3045 for (cond = *cp; cond; cond = cond_next) {
3047 /* Insert t in the runnable queue just ahead of us */
3048 t->i.next_run = thr->i.next_run;
3049 thr->i.next_run->i.prev_run = t;
3050 t->i.prev_run = thr;
3051 thr->i.next_run = t;
3052 thr->i.wait_queue = 0;
3053 /* Remove from the wait queue */
3054 cond_next = cond->next;
3061 Perl_cond_wait(pTHX_ perl_cond *cp)
3065 if (thr->i.next_run == thr)
3066 Perl_croak(aTHX_ "panic: perl_cond_wait called by last runnable thread");
3068 New(666, cond, 1, struct perl_wait_queue);
3072 thr->i.wait_queue = cond;
3073 /* Remove ourselves from runnable queue */
3074 thr->i.next_run->i.prev_run = thr->i.prev_run;
3075 thr->i.prev_run->i.next_run = thr->i.next_run;
3077 #endif /* FAKE_THREADS */
3080 Perl_condpair_magic(pTHX_ SV *sv)
3084 (void)SvUPGRADE(sv, SVt_PVMG);
3085 mg = mg_find(sv, PERL_MAGIC_mutex);
3089 New(53, cp, 1, condpair_t);
3090 MUTEX_INIT(&cp->mutex);
3091 COND_INIT(&cp->owner_cond);
3092 COND_INIT(&cp->cond);
3094 LOCK_CRED_MUTEX; /* XXX need separate mutex? */
3095 mg = mg_find(sv, PERL_MAGIC_mutex);
3097 /* someone else beat us to initialising it */
3098 UNLOCK_CRED_MUTEX; /* XXX need separate mutex? */
3099 MUTEX_DESTROY(&cp->mutex);
3100 COND_DESTROY(&cp->owner_cond);
3101 COND_DESTROY(&cp->cond);
3105 sv_magic(sv, Nullsv, PERL_MAGIC_mutex, 0, 0);
3107 mg->mg_ptr = (char *)cp;
3108 mg->mg_len = sizeof(cp);
3109 UNLOCK_CRED_MUTEX; /* XXX need separate mutex? */
3110 DEBUG_S(WITH_THR(PerlIO_printf(Perl_debug_log,
3111 "%p: condpair_magic %p\n", thr, sv)));
3118 Perl_sv_lock(pTHX_ SV *osv)
3128 mg = condpair_magic(sv);
3129 MUTEX_LOCK(MgMUTEXP(mg));
3130 if (MgOWNER(mg) == thr)
3131 MUTEX_UNLOCK(MgMUTEXP(mg));
3134 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
3136 DEBUG_S(PerlIO_printf(Perl_debug_log,
3137 "0x%"UVxf": Perl_lock lock 0x%"UVxf"\n",
3138 PTR2UV(thr), PTR2UV(sv)));
3139 MUTEX_UNLOCK(MgMUTEXP(mg));
3140 SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv);
3142 UNLOCK_SV_LOCK_MUTEX;
3147 * Make a new perl thread structure using t as a prototype. Some of the
3148 * fields for the new thread are copied from the prototype thread, t,
3149 * so t should not be running in perl at the time this function is
3150 * called. The use by ext/Thread/Thread.xs in core perl (where t is the
3151 * thread calling new_struct_thread) clearly satisfies this constraint.
3153 struct perl_thread *
3154 Perl_new_struct_thread(pTHX_ struct perl_thread *t)
3156 #if !defined(PERL_IMPLICIT_CONTEXT)
3157 struct perl_thread *thr;
3163 sv = newSVpvn("", 0);
3164 SvGROW(sv, sizeof(struct perl_thread) + 1);
3165 SvCUR_set(sv, sizeof(struct perl_thread));
3166 thr = (Thread) SvPVX(sv);
3168 Poison(thr, 1, struct perl_thread);
3175 Zero(&PL_hv_fetch_ent_mh, 1, HE);
3176 PL_efloatbuf = (char*)NULL;
3179 Zero(thr, 1, struct perl_thread);
3185 PL_curcop = &PL_compiling;
3186 thr->interp = t->interp;
3187 thr->cvcache = newHV();
3188 thr->threadsv = newAV();
3189 thr->specific = newAV();
3190 thr->errsv = newSVpvn("", 0);
3191 thr->flags = THRf_R_JOINABLE;
3193 MUTEX_INIT(&thr->mutex);
3197 PL_in_eval = EVAL_NULL; /* ~(EVAL_INEVAL|EVAL_WARNONLY|EVAL_KEEPERR|EVAL_INREQUIRE) */
3200 PL_statname = NEWSV(66,0);
3201 PL_errors = newSVpvn("", 0);
3203 PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
3204 PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
3205 PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
3206 PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
3207 PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
3209 PL_reginterp_cnt = 0;
3210 PL_lastscream = Nullsv;
3213 PL_reg_start_tmp = 0;
3214 PL_reg_start_tmpl = 0;
3215 PL_reg_poscache = Nullch;
3217 PL_peepp = MEMBER_TO_FPTR(Perl_peep);
3219 /* parent thread's data needs to be locked while we make copy */
3220 MUTEX_LOCK(&t->mutex);
3222 #ifdef PERL_FLEXIBLE_EXCEPTIONS
3223 PL_protect = t->Tprotect;
3226 PL_curcop = t->Tcurcop; /* XXX As good a guess as any? */
3227 PL_defstash = t->Tdefstash; /* XXX maybe these should */
3228 PL_curstash = t->Tcurstash; /* always be set to main? */
3230 PL_tainted = t->Ttainted;
3231 PL_curpm = t->Tcurpm; /* XXX No PMOP ref count */
3232 PL_rs = newSVsv(t->Trs);
3233 PL_last_in_gv = Nullgv;
3234 PL_ofs_sv = t->Tofs_sv ? SvREFCNT_inc(PL_ofs_sv) : Nullsv;
3235 PL_defoutgv = (GV*)SvREFCNT_inc(t->Tdefoutgv);
3236 PL_chopset = t->Tchopset;
3237 PL_bodytarget = newSVsv(t->Tbodytarget);
3238 PL_toptarget = newSVsv(t->Ttoptarget);
3239 if (t->Tformtarget == t->Ttoptarget)
3240 PL_formtarget = PL_toptarget;
3242 PL_formtarget = PL_bodytarget;
3244 /* Initialise all per-thread SVs that the template thread used */
3245 svp = AvARRAY(t->threadsv);
3246 for (i = 0; i <= AvFILLp(t->threadsv); i++, svp++) {
3247 if (*svp && *svp != &PL_sv_undef) {
3248 SV *sv = newSVsv(*svp);
3249 av_store(thr->threadsv, i, sv);
3250 sv_magic(sv, 0, PERL_MAGIC_sv, &PL_threadsv_names[i], 1);
3251 DEBUG_S(PerlIO_printf(Perl_debug_log,
3252 "new_struct_thread: copied threadsv %"IVdf" %p->%p\n",
3256 thr->threadsvp = AvARRAY(thr->threadsv);
3258 MUTEX_LOCK(&PL_threads_mutex);
3260 thr->tid = ++PL_threadnum;
3261 thr->next = t->next;
3264 thr->next->prev = thr;
3265 MUTEX_UNLOCK(&PL_threads_mutex);
3267 /* done copying parent's state */
3268 MUTEX_UNLOCK(&t->mutex);
3270 #ifdef HAVE_THREAD_INTERN
3271 Perl_init_thread_intern(thr);
3272 #endif /* HAVE_THREAD_INTERN */
3275 #endif /* USE_5005THREADS */
3277 #ifdef PERL_GLOBAL_STRUCT
3286 Perl_get_op_names(pTHX)
3292 Perl_get_op_descs(pTHX)
3298 Perl_get_no_modify(pTHX)
3300 return (char*)PL_no_modify;
3304 Perl_get_opargs(pTHX)
3310 Perl_get_ppaddr(pTHX)
3312 return (PPADDR_t*)PL_ppaddr;
3315 #ifndef HAS_GETENV_LEN
3317 Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
3319 char *env_trans = PerlEnv_getenv(env_elem);
3321 *len = strlen(env_trans);
3328 Perl_get_vtbl(pTHX_ int vtbl_id)
3330 MGVTBL* result = Null(MGVTBL*);
3334 result = &PL_vtbl_sv;
3337 result = &PL_vtbl_env;
3339 case want_vtbl_envelem:
3340 result = &PL_vtbl_envelem;
3343 result = &PL_vtbl_sig;
3345 case want_vtbl_sigelem:
3346 result = &PL_vtbl_sigelem;
3348 case want_vtbl_pack:
3349 result = &PL_vtbl_pack;
3351 case want_vtbl_packelem:
3352 result = &PL_vtbl_packelem;
3354 case want_vtbl_dbline:
3355 result = &PL_vtbl_dbline;
3358 result = &PL_vtbl_isa;
3360 case want_vtbl_isaelem:
3361 result = &PL_vtbl_isaelem;
3363 case want_vtbl_arylen:
3364 result = &PL_vtbl_arylen;
3366 case want_vtbl_glob:
3367 result = &PL_vtbl_glob;
3369 case want_vtbl_mglob:
3370 result = &PL_vtbl_mglob;
3372 case want_vtbl_nkeys:
3373 result = &PL_vtbl_nkeys;
3375 case want_vtbl_taint:
3376 result = &PL_vtbl_taint;
3378 case want_vtbl_substr:
3379 result = &PL_vtbl_substr;
3382 result = &PL_vtbl_vec;
3385 result = &PL_vtbl_pos;
3388 result = &PL_vtbl_bm;
3391 result = &PL_vtbl_fm;
3393 case want_vtbl_uvar:
3394 result = &PL_vtbl_uvar;
3396 #ifdef USE_5005THREADS
3397 case want_vtbl_mutex:
3398 result = &PL_vtbl_mutex;
3401 case want_vtbl_defelem:
3402 result = &PL_vtbl_defelem;
3404 case want_vtbl_regexp:
3405 result = &PL_vtbl_regexp;
3407 case want_vtbl_regdata:
3408 result = &PL_vtbl_regdata;
3410 case want_vtbl_regdatum:
3411 result = &PL_vtbl_regdatum;
3413 #ifdef USE_LOCALE_COLLATE
3414 case want_vtbl_collxfrm:
3415 result = &PL_vtbl_collxfrm;
3418 case want_vtbl_amagic:
3419 result = &PL_vtbl_amagic;
3421 case want_vtbl_amagicelem:
3422 result = &PL_vtbl_amagicelem;
3424 case want_vtbl_backref:
3425 result = &PL_vtbl_backref;
3432 Perl_my_fflush_all(pTHX)
3434 #if defined(FFLUSH_NULL)
3435 return PerlIO_flush(NULL);
3437 # if defined(HAS__FWALK)
3438 extern int fflush(FILE *);
3439 /* undocumented, unprototyped, but very useful BSDism */
3440 extern void _fwalk(int (*)(FILE *));
3444 # if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
3446 # ifdef PERL_FFLUSH_ALL_FOPEN_MAX
3447 open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
3449 # if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
3450 open_max = sysconf(_SC_OPEN_MAX);
3453 open_max = FOPEN_MAX;
3456 open_max = OPEN_MAX;
3467 for (i = 0; i < open_max; i++)
3468 if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
3469 STDIO_STREAM_ARRAY[i]._file < open_max &&
3470 STDIO_STREAM_ARRAY[i]._flag)
3471 PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
3475 SETERRNO(EBADF,RMS$_IFI);
3482 Perl_report_evil_fh(pTHX_ GV *gv, IO *io, I32 op)
3485 op == OP_READLINE ? "readline" : /* "<HANDLE>" not nice */
3486 op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */
3488 char *pars = OP_IS_FILETEST(op) ? "" : "()";
3489 char *type = OP_IS_SOCKET(op) ||
3490 (gv && io && IoTYPE(io) == IoTYPE_SOCKET) ?
3491 "socket" : "filehandle";
3494 if (gv && isGV(gv)) {
3498 if (op == OP_phoney_OUTPUT_ONLY || op == OP_phoney_INPUT_ONLY) {
3499 if (ckWARN(WARN_IO)) {
3501 Perl_warner(aTHX_ packWARN(WARN_IO),
3502 "Filehandle %s opened only for %sput",
3503 name, (op == OP_phoney_INPUT_ONLY ? "in" : "out"));
3505 Perl_warner(aTHX_ packWARN(WARN_IO),
3506 "Filehandle opened only for %sput",
3507 (op == OP_phoney_INPUT_ONLY ? "in" : "out"));
3514 if (gv && io && IoTYPE(io) == IoTYPE_CLOSED) {
3516 warn_type = WARN_CLOSED;
3520 warn_type = WARN_UNOPENED;
3523 if (ckWARN(warn_type)) {
3524 if (name && *name) {
3525 Perl_warner(aTHX_ packWARN(warn_type),
3526 "%s%s on %s %s %s", func, pars, vile, type, name);
3527 if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3528 Perl_warner(aTHX_ packWARN(warn_type),
3529 "\t(Are you trying to call %s%s on dirhandle %s?)\n",
3533 Perl_warner(aTHX_ packWARN(warn_type),
3534 "%s%s on %s %s", func, pars, vile, type);
3535 if (gv && io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3536 Perl_warner(aTHX_ packWARN(warn_type),
3537 "\t(Are you trying to call %s%s on dirhandle?)\n",
3545 /* in ASCII order, not that it matters */
3546 static const char controllablechars[] = "?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_";
3549 Perl_ebcdic_control(pTHX_ int ch)
3557 if ((ctlp = strchr(controllablechars, ch)) == 0) {
3558 Perl_die(aTHX_ "unrecognised control character '%c'\n", ch);
3561 if (ctlp == controllablechars)
3562 return('\177'); /* DEL */
3564 return((unsigned char)(ctlp - controllablechars - 1));
3565 } else { /* Want uncontrol */
3566 if (ch == '\177' || ch == -1)
3568 else if (ch == '\157')
3570 else if (ch == '\174')
3572 else if (ch == '^') /* '\137' in 1047, '\260' in 819 */
3574 else if (ch == '\155')
3576 else if (0 < ch && ch < (sizeof(controllablechars) - 1))
3577 return(controllablechars[ch+1]);
3579 Perl_die(aTHX_ "invalid control request: '\\%03o'\n", ch & 0xFF);
3584 /* To workaround core dumps from the uninitialised tm_zone we get the
3585 * system to give us a reasonable struct to copy. This fix means that
3586 * strftime uses the tm_zone and tm_gmtoff values returned by
3587 * localtime(time()). That should give the desired result most of the
3588 * time. But probably not always!
3590 * This does not address tzname aspects of NETaa14816.
3595 # ifndef STRUCT_TM_HASZONE
3596 # define STRUCT_TM_HASZONE
3600 #ifdef STRUCT_TM_HASZONE /* Backward compat */
3601 # ifndef HAS_TM_TM_ZONE
3602 # define HAS_TM_TM_ZONE
3607 Perl_init_tm(pTHX_ struct tm *ptm) /* see mktime, strftime and asctime */
3609 #ifdef HAS_TM_TM_ZONE
3612 Copy(localtime(&now), ptm, 1, struct tm);
3617 * mini_mktime - normalise struct tm values without the localtime()
3618 * semantics (and overhead) of mktime().
3621 Perl_mini_mktime(pTHX_ struct tm *ptm)
3625 int month, mday, year, jday;
3626 int odd_cent, odd_year;
3628 #define DAYS_PER_YEAR 365
3629 #define DAYS_PER_QYEAR (4*DAYS_PER_YEAR+1)
3630 #define DAYS_PER_CENT (25*DAYS_PER_QYEAR-1)
3631 #define DAYS_PER_QCENT (4*DAYS_PER_CENT+1)
3632 #define SECS_PER_HOUR (60*60)
3633 #define SECS_PER_DAY (24*SECS_PER_HOUR)
3634 /* parentheses deliberately absent on these two, otherwise they don't work */
3635 #define MONTH_TO_DAYS 153/5
3636 #define DAYS_TO_MONTH 5/153
3637 /* offset to bias by March (month 4) 1st between month/mday & year finding */
3638 #define YEAR_ADJUST (4*MONTH_TO_DAYS+1)
3639 /* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */
3640 #define WEEKDAY_BIAS 6 /* (1+6)%7 makes Sunday 0 again */
3643 * Year/day algorithm notes:
3645 * With a suitable offset for numeric value of the month, one can find
3646 * an offset into the year by considering months to have 30.6 (153/5) days,
3647 * using integer arithmetic (i.e., with truncation). To avoid too much
3648 * messing about with leap days, we consider January and February to be
3649 * the 13th and 14th month of the previous year. After that transformation,
3650 * we need the month index we use to be high by 1 from 'normal human' usage,
3651 * so the month index values we use run from 4 through 15.
3653 * Given that, and the rules for the Gregorian calendar (leap years are those
3654 * divisible by 4 unless also divisible by 100, when they must be divisible
3655 * by 400 instead), we can simply calculate the number of days since some
3656 * arbitrary 'beginning of time' by futzing with the (adjusted) year number,
3657 * the days we derive from our month index, and adding in the day of the
3658 * month. The value used here is not adjusted for the actual origin which
3659 * it normally would use (1 January A.D. 1), since we're not exposing it.
3660 * We're only building the value so we can turn around and get the
3661 * normalised values for the year, month, day-of-month, and day-of-year.
3663 * For going backward, we need to bias the value we're using so that we find
3664 * the right year value. (Basically, we don't want the contribution of
3665 * March 1st to the number to apply while deriving the year). Having done
3666 * that, we 'count up' the contribution to the year number by accounting for
3667 * full quadracenturies (400-year periods) with their extra leap days, plus
3668 * the contribution from full centuries (to avoid counting in the lost leap
3669 * days), plus the contribution from full quad-years (to count in the normal
3670 * leap days), plus the leftover contribution from any non-leap years.
3671 * At this point, if we were working with an actual leap day, we'll have 0
3672 * days left over. This is also true for March 1st, however. So, we have
3673 * to special-case that result, and (earlier) keep track of the 'odd'
3674 * century and year contributions. If we got 4 extra centuries in a qcent,
3675 * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb.
3676 * Otherwise, we add back in the earlier bias we removed (the 123 from
3677 * figuring in March 1st), find the month index (integer division by 30.6),
3678 * and the remainder is the day-of-month. We then have to convert back to
3679 * 'real' months (including fixing January and February from being 14/15 in
3680 * the previous year to being in the proper year). After that, to get
3681 * tm_yday, we work with the normalised year and get a new yearday value for
3682 * January 1st, which we subtract from the yearday value we had earlier,
3683 * representing the date we've re-built. This is done from January 1
3684 * because tm_yday is 0-origin.
3686 * Since POSIX time routines are only guaranteed to work for times since the
3687 * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm
3688 * applies Gregorian calendar rules even to dates before the 16th century
3689 * doesn't bother me. Besides, you'd need cultural context for a given
3690 * date to know whether it was Julian or Gregorian calendar, and that's
3691 * outside the scope for this routine. Since we convert back based on the
3692 * same rules we used to build the yearday, you'll only get strange results
3693 * for input which needed normalising, or for the 'odd' century years which
3694 * were leap years in the Julian calander but not in the Gregorian one.
3695 * I can live with that.
3697 * This algorithm also fails to handle years before A.D. 1 gracefully, but
3698 * that's still outside the scope for POSIX time manipulation, so I don't
3702 year = 1900 + ptm->tm_year;
3703 month = ptm->tm_mon;
3704 mday = ptm->tm_mday;
3705 /* allow given yday with no month & mday to dominate the result */
3706 if (ptm->tm_yday >= 0 && mday <= 0 && month <= 0) {
3709 jday = 1 + ptm->tm_yday;
3718 yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400;
3719 yearday += month*MONTH_TO_DAYS + mday + jday;
3721 * Note that we don't know when leap-seconds were or will be,
3722 * so we have to trust the user if we get something which looks
3723 * like a sensible leap-second. Wild values for seconds will
3724 * be rationalised, however.
3726 if ((unsigned) ptm->tm_sec <= 60) {
3733 secs += 60 * ptm->tm_min;
3734 secs += SECS_PER_HOUR * ptm->tm_hour;
3736 if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) {
3737 /* got negative remainder, but need positive time */
3738 /* back off an extra day to compensate */
3739 yearday += (secs/SECS_PER_DAY)-1;
3740 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1);
3743 yearday += (secs/SECS_PER_DAY);
3744 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY);
3747 else if (secs >= SECS_PER_DAY) {
3748 yearday += (secs/SECS_PER_DAY);
3749 secs %= SECS_PER_DAY;
3751 ptm->tm_hour = secs/SECS_PER_HOUR;
3752 secs %= SECS_PER_HOUR;
3753 ptm->tm_min = secs/60;
3755 ptm->tm_sec += secs;
3756 /* done with time of day effects */
3758 * The algorithm for yearday has (so far) left it high by 428.
3759 * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to
3760 * bias it by 123 while trying to figure out what year it
3761 * really represents. Even with this tweak, the reverse
3762 * translation fails for years before A.D. 0001.
3763 * It would still fail for Feb 29, but we catch that one below.
3765 jday = yearday; /* save for later fixup vis-a-vis Jan 1 */
3766 yearday -= YEAR_ADJUST;
3767 year = (yearday / DAYS_PER_QCENT) * 400;
3768 yearday %= DAYS_PER_QCENT;
3769 odd_cent = yearday / DAYS_PER_CENT;
3770 year += odd_cent * 100;
3771 yearday %= DAYS_PER_CENT;
3772 year += (yearday / DAYS_PER_QYEAR) * 4;
3773 yearday %= DAYS_PER_QYEAR;
3774 odd_year = yearday / DAYS_PER_YEAR;
3776 yearday %= DAYS_PER_YEAR;
3777 if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */
3782 yearday += YEAR_ADJUST; /* recover March 1st crock */
3783 month = yearday*DAYS_TO_MONTH;
3784 yearday -= month*MONTH_TO_DAYS;
3785 /* recover other leap-year adjustment */
3794 ptm->tm_year = year - 1900;
3796 ptm->tm_mday = yearday;
3797 ptm->tm_mon = month;
3801 ptm->tm_mon = month - 1;
3803 /* re-build yearday based on Jan 1 to get tm_yday */
3805 yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400;
3806 yearday += 14*MONTH_TO_DAYS + 1;
3807 ptm->tm_yday = jday - yearday;
3808 /* fix tm_wday if not overridden by caller */
3809 if ((unsigned)ptm->tm_wday > 6)
3810 ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
3814 Perl_my_strftime(pTHX_ char *fmt, int sec, int min, int hour, int mday, int mon, int year, int wday, int yday, int isdst)
3822 init_tm(&mytm); /* XXX workaround - see init_tm() above */
3825 mytm.tm_hour = hour;
3826 mytm.tm_mday = mday;
3828 mytm.tm_year = year;
3829 mytm.tm_wday = wday;
3830 mytm.tm_yday = yday;
3831 mytm.tm_isdst = isdst;
3834 New(0, buf, buflen, char);
3835 len = strftime(buf, buflen, fmt, &mytm);
3837 ** The following is needed to handle to the situation where
3838 ** tmpbuf overflows. Basically we want to allocate a buffer
3839 ** and try repeatedly. The reason why it is so complicated
3840 ** is that getting a return value of 0 from strftime can indicate
3841 ** one of the following:
3842 ** 1. buffer overflowed,
3843 ** 2. illegal conversion specifier, or
3844 ** 3. the format string specifies nothing to be returned(not
3845 ** an error). This could be because format is an empty string
3846 ** or it specifies %p that yields an empty string in some locale.
3847 ** If there is a better way to make it portable, go ahead by
3850 if ((len > 0 && len < buflen) || (len == 0 && *fmt == '\0'))
3853 /* Possibly buf overflowed - try again with a bigger buf */
3854 int fmtlen = strlen(fmt);
3855 int bufsize = fmtlen + buflen;
3857 New(0, buf, bufsize, char);
3859 buflen = strftime(buf, bufsize, fmt, &mytm);
3860 if (buflen > 0 && buflen < bufsize)
3862 /* heuristic to prevent out-of-memory errors */
3863 if (bufsize > 100*fmtlen) {
3869 Renew(buf, bufsize, char);
3874 Perl_croak(aTHX_ "panic: no strftime");
3879 #define SV_CWD_RETURN_UNDEF \
3880 sv_setsv(sv, &PL_sv_undef); \
3883 #define SV_CWD_ISDOT(dp) \
3884 (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
3885 (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
3888 =head1 Miscellaneous Functions
3890 =for apidoc getcwd_sv
3892 Fill the sv with current working directory
3897 /* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars.
3898 * rewritten again by dougm, optimized for use with xs TARG, and to prefer
3899 * getcwd(3) if available
3900 * Comments from the orignal:
3901 * This is a faster version of getcwd. It's also more dangerous
3902 * because you might chdir out of a directory that you can't chdir
3906 Perl_getcwd_sv(pTHX_ register SV *sv)
3910 #ifndef INCOMPLETE_TAINTS
3916 char buf[MAXPATHLEN];
3918 /* Some getcwd()s automatically allocate a buffer of the given
3919 * size from the heap if they are given a NULL buffer pointer.
3920 * The problem is that this behaviour is not portable. */
3921 if (getcwd(buf, sizeof(buf) - 1)) {
3922 STRLEN len = strlen(buf);
3923 sv_setpvn(sv, buf, len);
3927 sv_setsv(sv, &PL_sv_undef);
3935 int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
3936 int namelen, pathlen=0;
3940 (void)SvUPGRADE(sv, SVt_PV);
3942 if (PerlLIO_lstat(".", &statbuf) < 0) {
3943 SV_CWD_RETURN_UNDEF;
3946 orig_cdev = statbuf.st_dev;
3947 orig_cino = statbuf.st_ino;
3955 if (PerlDir_chdir("..") < 0) {
3956 SV_CWD_RETURN_UNDEF;
3958 if (PerlLIO_stat(".", &statbuf) < 0) {
3959 SV_CWD_RETURN_UNDEF;
3962 cdev = statbuf.st_dev;
3963 cino = statbuf.st_ino;
3965 if (odev == cdev && oino == cino) {
3968 if (!(dir = PerlDir_open("."))) {
3969 SV_CWD_RETURN_UNDEF;
3972 while ((dp = PerlDir_read(dir)) != NULL) {
3974 namelen = dp->d_namlen;
3976 namelen = strlen(dp->d_name);
3979 if (SV_CWD_ISDOT(dp)) {
3983 if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
3984 SV_CWD_RETURN_UNDEF;
3987 tdev = statbuf.st_dev;
3988 tino = statbuf.st_ino;
3989 if (tino == oino && tdev == odev) {
3995 SV_CWD_RETURN_UNDEF;
3998 if (pathlen + namelen + 1 >= MAXPATHLEN) {
3999 SV_CWD_RETURN_UNDEF;
4002 SvGROW(sv, pathlen + namelen + 1);
4006 Move(SvPVX(sv), SvPVX(sv) + namelen + 1, pathlen, char);
4009 /* prepend current directory to the front */
4011 Move(dp->d_name, SvPVX(sv)+1, namelen, char);
4012 pathlen += (namelen + 1);
4014 #ifdef VOID_CLOSEDIR
4017 if (PerlDir_close(dir) < 0) {
4018 SV_CWD_RETURN_UNDEF;
4024 SvCUR_set(sv, pathlen);
4028 if (PerlDir_chdir(SvPVX(sv)) < 0) {
4029 SV_CWD_RETURN_UNDEF;
4032 if (PerlLIO_stat(".", &statbuf) < 0) {
4033 SV_CWD_RETURN_UNDEF;
4036 cdev = statbuf.st_dev;
4037 cino = statbuf.st_ino;
4039 if (cdev != orig_cdev || cino != orig_cino) {
4040 Perl_croak(aTHX_ "Unstable directory path, "
4041 "current directory changed unexpectedly");
4053 =head1 SV Manipulation Functions
4055 =for apidoc scan_vstring
4057 Returns a pointer to the next character after the parsed
4058 vstring, as well as updating the passed in sv.
4060 Function must be called like
4063 s = scan_vstring(s,sv);
4065 The sv should already be large enough to store the vstring
4066 passed in, for performance reasons.
4072 Perl_scan_vstring(pTHX_ char *s, SV *sv)
4076 if (*pos == 'v') pos++; /* get past 'v' */
4077 while (isDIGIT(*pos) || *pos == '_')
4079 if (!isALPHA(*pos)) {
4081 U8 tmpbuf[UTF8_MAXLEN+1];
4084 if (*s == 'v') s++; /* get past 'v' */
4086 sv_setpvn(sv, "", 0);
4091 /* this is atoi() that tolerates underscores */
4094 while (--end >= s) {
4099 rev += (*end - '0') * mult;
4101 if (orev > rev && ckWARN_d(WARN_OVERFLOW))
4102 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
4103 "Integer overflow in decimal number");
4107 if (rev > 0x7FFFFFFF)
4108 Perl_croak(aTHX "In EBCDIC the v-string components cannot exceed 2147483647");
4110 /* Append native character for the rev point */
4111 tmpend = uvchr_to_utf8(tmpbuf, rev);
4112 sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
4113 if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(rev)))
4115 if (*pos == '.' && isDIGIT(pos[1]))
4121 while (isDIGIT(*pos) || *pos == '_')
4125 sv_magicext(sv,NULL,PERL_MAGIC_vstring,NULL,(const char*)start, pos-start);
4133 =for apidoc scan_version
4135 Returns a pointer to the next character after the parsed
4136 version string, as well as upgrading the passed in SV to
4139 Function must be called with an already existing SV like
4142 s = scan_version(s,sv);
4144 Performs some preprocessing to the string to ensure that
4145 it has the correct characteristics of a version. Flags the
4146 object if it contains an underscore (which denotes this
4153 Perl_scan_version(pTHX_ char *version, SV *rv)
4157 SV * sv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
4162 while (isDIGIT(*d) || *d == '.')
4166 if ( *(d+1) == '0' && *(d+2) != '0' ) { /* perl-style version */
4175 version = scan_vstring(version,sv); /* store the v-string in the object */
4181 =for apidoc new_version
4183 Returns a new version object based on the passed in SV:
4185 SV *sv = new_version(SV *ver);
4187 Does not alter the passed in ver SV. See "upg_version" if you
4188 want to upgrade the SV.
4194 Perl_new_version(pTHX_ SV *ver)
4196 SV *rv = NEWSV(92,5);
4199 if ( SvMAGICAL(ver) ) { /* already a v-string */
4200 MAGIC* mg = mg_find(ver,PERL_MAGIC_vstring);
4201 version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
4204 version = (char *)SvPV_nolen(ver);
4206 version = scan_version(version,rv);
4211 =for apidoc upg_version
4213 In-place upgrade of the supplied SV to a version object.
4215 SV *sv = upg_version(SV *sv);
4217 Returns a pointer to the upgraded SV.
4223 Perl_upg_version(pTHX_ SV *sv)
4225 char *version = (char *)SvPV_nolen(sv_mortalcopy(sv));
4226 bool utf8 = SvUTF8(sv);
4227 if ( SvVOK(sv) ) { /* already a v-string */
4228 SV * ver = newSVrv(sv, "version");
4229 sv_setpv(ver,version);
4234 version = scan_version(version,sv);
4243 Accepts a version (or vstring) object and returns the
4244 normalized floating point representation. Call like:
4246 sv = vnumify(sv,SvRV(rv));
4248 NOTE: no checking is done to see if the object is of the
4249 correct type (for speed).
4255 Perl_vnumify(SV *sv, SV *vs)
4257 U8* pv = (U8*)SvPVX(vs);
4258 STRLEN len = SvCUR(vs);
4260 UV digit = utf8_to_uvchr(pv,&retlen);
4261 sv_setpvf(sv,"%"UVf".",digit);
4262 for (pv += retlen, len -= retlen;
4264 pv += retlen, len -= retlen)
4266 digit = utf8_to_uvchr(pv,&retlen);
4267 sv_catpvf(sv,"%03"UVf,digit);
4273 =for apidoc vstringify
4275 Accepts a version (or vstring) object and returns the
4276 normalized representation. Call like:
4278 sv = vstringify(sv,SvRV(rv));
4280 NOTE: no checking is done to see if the object is of the
4281 correct type (for speed).
4287 Perl_vstringify(SV *sv, SV *vs)
4289 U8* pv = (U8*)SvPVX(vs);
4290 STRLEN len = SvCUR(vs);
4292 UV digit = utf8_to_uvchr(pv,&retlen);
4293 sv_setpvf(sv,"%"UVf,digit);
4294 for (pv += retlen, len -= retlen;
4296 pv += retlen, len -= retlen)
4298 digit = utf8_to_uvchr(pv,&retlen);
4299 sv_catpvf(sv,".%03"UVf,digit);
4301 if ( SvIVX(vs) < 0 )
4302 sv_catpv(sv,"beta");
4306 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT)
4307 # define EMULATE_SOCKETPAIR_UDP
4310 #ifdef EMULATE_SOCKETPAIR_UDP
4312 S_socketpair_udp (int fd[2]) {
4314 /* Fake a datagram socketpair using UDP to localhost. */
4315 int sockets[2] = {-1, -1};
4316 struct sockaddr_in addresses[2];
4318 Sock_size_t size = sizeof (struct sockaddr_in);
4319 unsigned short port;
4322 memset (&addresses, 0, sizeof (addresses));
4325 sockets[i] = PerlSock_socket (AF_INET, SOCK_DGRAM, PF_INET);
4326 if (sockets[i] == -1)
4327 goto tidy_up_and_fail;
4329 addresses[i].sin_family = AF_INET;
4330 addresses[i].sin_addr.s_addr = htonl (INADDR_LOOPBACK);
4331 addresses[i].sin_port = 0; /* kernel choses port. */
4332 if (PerlSock_bind (sockets[i], (struct sockaddr *) &addresses[i],
4333 sizeof (struct sockaddr_in))
4335 goto tidy_up_and_fail;
4338 /* Now have 2 UDP sockets. Find out which port each is connected to, and
4339 for each connect the other socket to it. */
4342 if (PerlSock_getsockname (sockets[i], (struct sockaddr *) &addresses[i], &size)
4344 goto tidy_up_and_fail;
4345 if (size != sizeof (struct sockaddr_in))
4346 goto abort_tidy_up_and_fail;
4347 /* !1 is 0, !0 is 1 */
4348 if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i],
4349 sizeof (struct sockaddr_in)) == -1)
4350 goto tidy_up_and_fail;
4353 /* Now we have 2 sockets connected to each other. I don't trust some other
4354 process not to have already sent a packet to us (by random) so send
4355 a packet from each to the other. */
4358 /* I'm going to send my own port number. As a short.
4359 (Who knows if someone somewhere has sin_port as a bitfield and needs
4360 this routine. (I'm assuming crays have socketpair)) */
4361 port = addresses[i].sin_port;
4362 got = PerlLIO_write (sockets[i], &port, sizeof(port));
4363 if (got != sizeof(port)) {
4365 goto tidy_up_and_fail;
4366 goto abort_tidy_up_and_fail;
4370 /* Packets sent. I don't trust them to have arrived though.
4371 (As I understand it Solaris TCP stack is multithreaded. Non-blocking
4372 connect to localhost will use a second kernel thread. In 2.6 the
4373 first thread running the connect() returns before the second completes,
4374 so EINPROGRESS> In 2.7 the improved stack is faster and connect()
4375 returns 0. Poor programs have tripped up. One poor program's authors'
4376 had a 50-1 reverse stock split. Not sure how connected these were.)
4377 So I don't trust someone not to have an unpredictable UDP stack.
4381 struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */
4382 int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0];
4386 FD_SET (sockets[0], &rset);
4387 FD_SET (sockets[1], &rset);
4389 got = PerlSock_select (max + 1, &rset, NULL, NULL, &waitfor);
4390 if (got != 2 || !FD_ISSET (sockets[0], &rset)
4391 || !FD_ISSET (sockets[1], &rset)) {
4392 /* I hope this is portable and appropriate. */
4394 goto tidy_up_and_fail;
4395 goto abort_tidy_up_and_fail;
4399 /* And the paranoia department even now doesn't trust it to have arrive
4400 (hence MSG_DONTWAIT). Or that what arrives was sent by us. */
4402 struct sockaddr_in readfrom;
4403 unsigned short buffer[2];
4408 got = PerlSock_recvfrom (sockets[i], (char *) &buffer, sizeof(buffer),
4410 (struct sockaddr *) &readfrom, &size);
4412 got = PerlSock_recvfrom (sockets[i], (char *) &buffer, sizeof(buffer),
4414 (struct sockaddr *) &readfrom, &size);
4418 goto tidy_up_and_fail;
4419 if (got != sizeof(port)
4420 || size != sizeof (struct sockaddr_in)
4421 /* Check other socket sent us its port. */
4422 || buffer[0] != (unsigned short) addresses[!i].sin_port
4423 /* Check kernel says we got the datagram from that socket. */
4424 || readfrom.sin_family != addresses[!i].sin_family
4425 || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr
4426 || readfrom.sin_port != addresses[!i].sin_port)
4427 goto abort_tidy_up_and_fail;
4430 /* My caller (my_socketpair) has validated that this is non-NULL */
4433 /* I hereby declare this connection open. May God bless all who cross
4437 abort_tidy_up_and_fail:
4438 errno = ECONNABORTED;
4441 int save_errno = errno;
4442 if (sockets[0] != -1)
4443 PerlLIO_close (sockets[0]);
4444 if (sockets[1] != -1)
4445 PerlLIO_close (sockets[1]);
4450 #endif /* EMULATE_SOCKETPAIR_UDP */
4452 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET)
4454 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4455 /* Stevens says that family must be AF_LOCAL, protocol 0.
4456 I'm going to enforce that, then ignore it, and use TCP (or UDP). */
4461 struct sockaddr_in listen_addr;
4462 struct sockaddr_in connect_addr;
4467 || family != AF_UNIX
4470 errno = EAFNOSUPPORT;
4478 #ifdef EMULATE_SOCKETPAIR_UDP
4479 if (type == SOCK_DGRAM)
4480 return S_socketpair_udp (fd);
4483 listener = PerlSock_socket (AF_INET, type, 0);
4486 memset (&listen_addr, 0, sizeof (listen_addr));
4487 listen_addr.sin_family = AF_INET;
4488 listen_addr.sin_addr.s_addr = htonl (INADDR_LOOPBACK);
4489 listen_addr.sin_port = 0; /* kernel choses port. */
4490 if (PerlSock_bind (listener, (struct sockaddr *) &listen_addr, sizeof (listen_addr))
4492 goto tidy_up_and_fail;
4493 if (PerlSock_listen(listener, 1) == -1)
4494 goto tidy_up_and_fail;
4496 connector = PerlSock_socket (AF_INET, type, 0);
4497 if (connector == -1)
4498 goto tidy_up_and_fail;
4499 /* We want to find out the port number to connect to. */
4500 size = sizeof (connect_addr);
4501 if (PerlSock_getsockname (listener, (struct sockaddr *) &connect_addr, &size) == -1)
4502 goto tidy_up_and_fail;
4503 if (size != sizeof (connect_addr))
4504 goto abort_tidy_up_and_fail;
4505 if (PerlSock_connect(connector, (struct sockaddr *) &connect_addr,
4506 sizeof (connect_addr)) == -1)
4507 goto tidy_up_and_fail;
4509 size = sizeof (listen_addr);
4510 acceptor = PerlSock_accept (listener, (struct sockaddr *) &listen_addr, &size);
4512 goto tidy_up_and_fail;
4513 if (size != sizeof (listen_addr))
4514 goto abort_tidy_up_and_fail;
4515 PerlLIO_close (listener);
4516 /* Now check we are talking to ourself by matching port and host on the
4518 if (PerlSock_getsockname (connector, (struct sockaddr *) &connect_addr, &size) == -1)
4519 goto tidy_up_and_fail;
4520 if (size != sizeof (connect_addr)
4521 || listen_addr.sin_family != connect_addr.sin_family
4522 || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr
4523 || listen_addr.sin_port != connect_addr.sin_port) {
4524 goto abort_tidy_up_and_fail;
4530 abort_tidy_up_and_fail:
4531 errno = ECONNABORTED; /* I hope this is portable and appropriate. */
4534 int save_errno = errno;
4536 PerlLIO_close (listener);
4537 if (connector != -1)
4538 PerlLIO_close (connector);
4540 PerlLIO_close (acceptor);
4546 /* In any case have a stub so that there's code corresponding
4547 * to the my_socketpair in global.sym. */
4549 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4550 #ifdef HAS_SOCKETPAIR
4551 return socketpair(family, type, protocol, fd);
4560 =for apidoc sv_nosharing
4562 Dummy routine which "shares" an SV when there is no sharing module present.
4563 Exists to avoid test for a NULL function pointer and because it could potentially warn under
4564 some level of strict-ness.
4570 Perl_sv_nosharing(pTHX_ SV *sv)
4575 =for apidoc sv_nolocking
4577 Dummy routine which "locks" an SV when there is no locking module present.
4578 Exists to avoid test for a NULL function pointer and because it could potentially warn under
4579 some level of strict-ness.
4585 Perl_sv_nolocking(pTHX_ SV *sv)
4591 =for apidoc sv_nounlocking
4593 Dummy routine which "unlocks" an SV when there is no locking module present.
4594 Exists to avoid test for a NULL function pointer and because it could potentially warn under
4595 some level of strict-ness.
4601 Perl_sv_nounlocking(pTHX_ SV *sv)