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);
1537 /* sv_2cv might call Perl_warn() */
1538 SV *oldwarnhook = PL_warnhook;
1540 SAVESPTR(PL_warnhook);
1541 PL_warnhook = Nullsv;
1542 cv = sv_2cv(oldwarnhook, &stash, &gv, 0);
1544 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1550 msg = newSVpvn(message, msglen);
1554 PUSHSTACKi(PERLSI_WARNHOOK);
1558 call_sv((SV*)cv, G_DISCARD);
1565 PerlIO *serr = Perl_error_log;
1566 PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
1568 DEBUG_L(*message == '!'
1569 ? (xstat(message[1]=='!'
1570 ? (message[2]=='!' ? 2 : 1)
1575 (void)PerlIO_flush(serr);
1580 /* since we've already done strlen() for both nam and val
1581 * we can use that info to make things faster than
1582 * sprintf(s, "%s=%s", nam, val)
1584 #define my_setenv_format(s, nam, nlen, val, vlen) \
1585 Copy(nam, s, nlen, char); \
1587 Copy(val, s+(nlen+1), vlen, char); \
1588 *(s+(nlen+1+vlen)) = '\0'
1590 #ifdef USE_ENVIRON_ARRAY
1591 /* VMS' my_setenv() is in vms.c */
1592 #if !defined(WIN32) && !defined(NETWARE)
1594 Perl_my_setenv(pTHX_ char *nam, char *val)
1597 /* only parent thread can modify process environment */
1598 if (PL_curinterp == aTHX)
1601 #ifndef PERL_USE_SAFE_PUTENV
1602 /* most putenv()s leak, so we manipulate environ directly */
1603 register I32 i=setenv_getix(nam); /* where does it go? */
1606 if (environ == PL_origenviron) { /* need we copy environment? */
1612 for (max = i; environ[max]; max++) ;
1613 tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*));
1614 for (j=0; j<max; j++) { /* copy environment */
1615 int len = strlen(environ[j]);
1616 tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char));
1617 Copy(environ[j], tmpenv[j], len+1, char);
1619 tmpenv[max] = Nullch;
1620 environ = tmpenv; /* tell exec where it is now */
1623 safesysfree(environ[i]);
1624 while (environ[i]) {
1625 environ[i] = environ[i+1];
1630 if (!environ[i]) { /* does not exist yet */
1631 environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
1632 environ[i+1] = Nullch; /* make sure it's null terminated */
1635 safesysfree(environ[i]);
1639 environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char));
1640 /* all that work just for this */
1641 my_setenv_format(environ[i], nam, nlen, val, vlen);
1643 #else /* PERL_USE_SAFE_PUTENV */
1644 # if defined(__CYGWIN__) || defined( EPOC)
1645 setenv(nam, val, 1);
1648 int nlen = strlen(nam), vlen;
1653 new_env = (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
1654 /* all that work just for this */
1655 my_setenv_format(new_env, nam, nlen, val, vlen);
1656 (void)putenv(new_env);
1657 # endif /* __CYGWIN__ */
1658 #endif /* PERL_USE_SAFE_PUTENV */
1662 #else /* WIN32 || NETWARE */
1665 Perl_my_setenv(pTHX_ char *nam,char *val)
1667 register char *envstr;
1668 int nlen = strlen(nam), vlen;
1674 New(904, envstr, nlen+vlen+2, char);
1675 my_setenv_format(envstr, nam, nlen, val, vlen);
1676 (void)PerlEnv_putenv(envstr);
1680 #endif /* WIN32 || NETWARE */
1683 Perl_setenv_getix(pTHX_ char *nam)
1685 register I32 i, len = strlen(nam);
1687 for (i = 0; environ[i]; i++) {
1690 strnicmp(environ[i],nam,len) == 0
1692 strnEQ(environ[i],nam,len)
1694 && environ[i][len] == '=')
1695 break; /* strnEQ must come first to avoid */
1696 } /* potential SEGV's */
1700 #endif /* !VMS && !EPOC*/
1702 #ifdef UNLINK_ALL_VERSIONS
1704 Perl_unlnk(pTHX_ char *f) /* unlink all versions of a file */
1708 for (i = 0; PerlLIO_unlink(f) >= 0; i++) ;
1713 /* this is a drop-in replacement for bcopy() */
1714 #if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY))
1716 Perl_my_bcopy(register const char *from,register char *to,register I32 len)
1720 if (from - to >= 0) {
1728 *(--to) = *(--from);
1734 /* this is a drop-in replacement for memset() */
1737 Perl_my_memset(register char *loc, register I32 ch, register I32 len)
1747 /* this is a drop-in replacement for bzero() */
1748 #if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
1750 Perl_my_bzero(register char *loc, register I32 len)
1760 /* this is a drop-in replacement for memcmp() */
1761 #if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
1763 Perl_my_memcmp(const char *s1, const char *s2, register I32 len)
1765 register U8 *a = (U8 *)s1;
1766 register U8 *b = (U8 *)s2;
1770 if (tmp = *a++ - *b++)
1775 #endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */
1779 #ifdef USE_CHAR_VSPRINTF
1784 vsprintf(char *dest, const char *pat, char *args)
1788 fakebuf._ptr = dest;
1789 fakebuf._cnt = 32767;
1793 fakebuf._flag = _IOWRT|_IOSTRG;
1794 _doprnt(pat, args, &fakebuf); /* what a kludge */
1795 (void)putc('\0', &fakebuf);
1796 #ifdef USE_CHAR_VSPRINTF
1799 return 0; /* perl doesn't use return value */
1803 #endif /* HAS_VPRINTF */
1806 #if BYTEORDER != 0x4321
1808 Perl_my_swap(pTHX_ short s)
1810 #if (BYTEORDER & 1) == 0
1813 result = ((s & 255) << 8) + ((s >> 8) & 255);
1821 Perl_my_htonl(pTHX_ long l)
1825 char c[sizeof(long)];
1828 #if BYTEORDER == 0x1234
1829 u.c[0] = (l >> 24) & 255;
1830 u.c[1] = (l >> 16) & 255;
1831 u.c[2] = (l >> 8) & 255;
1835 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
1836 Perl_croak(aTHX_ "Unknown BYTEORDER\n");
1841 for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
1842 u.c[o & 0xf] = (l >> s) & 255;
1850 Perl_my_ntohl(pTHX_ long l)
1854 char c[sizeof(long)];
1857 #if BYTEORDER == 0x1234
1858 u.c[0] = (l >> 24) & 255;
1859 u.c[1] = (l >> 16) & 255;
1860 u.c[2] = (l >> 8) & 255;
1864 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
1865 Perl_croak(aTHX_ "Unknown BYTEORDER\n");
1872 for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
1873 l |= (u.c[o & 0xf] & 255) << s;
1880 #endif /* BYTEORDER != 0x4321 */
1884 * Little-endian byte order functions - 'v' for 'VAX', or 'reVerse'.
1885 * If these functions are defined,
1886 * the BYTEORDER is neither 0x1234 nor 0x4321.
1887 * However, this is not assumed.
1891 #define HTOV(name,type) \
1893 name (register type n) \
1897 char c[sizeof(type)]; \
1901 for (i = 0, s = 0; i < sizeof(u.c); i++, s += 8) { \
1902 u.c[i] = (n >> s) & 0xFF; \
1907 #define VTOH(name,type) \
1909 name (register type n) \
1913 char c[sizeof(type)]; \
1919 for (i = 0, s = 0; i < sizeof(u.c); i++, s += 8) { \
1920 n += (u.c[i] & 0xFF) << s; \
1925 #if defined(HAS_HTOVS) && !defined(htovs)
1928 #if defined(HAS_HTOVL) && !defined(htovl)
1931 #if defined(HAS_VTOHS) && !defined(vtohs)
1934 #if defined(HAS_VTOHL) && !defined(vtohl)
1939 Perl_my_popen_list(pTHX_ char *mode, int n, SV **args)
1941 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) && !defined(NETWARE)
1943 register I32 This, that;
1949 PERL_FLUSHALL_FOR_CHILD;
1950 This = (*mode == 'w');
1954 taint_proper("Insecure %s%s", "EXEC");
1956 if (PerlProc_pipe(p) < 0)
1958 /* Try for another pipe pair for error return */
1959 if (PerlProc_pipe(pp) >= 0)
1961 while ((pid = PerlProc_fork()) < 0) {
1962 if (errno != EAGAIN) {
1963 PerlLIO_close(p[This]);
1964 PerlLIO_close(p[that]);
1966 PerlLIO_close(pp[0]);
1967 PerlLIO_close(pp[1]);
1979 /* Close parent's end of error status pipe (if any) */
1981 PerlLIO_close(pp[0]);
1982 #if defined(HAS_FCNTL) && defined(F_SETFD)
1983 /* Close error pipe automatically if exec works */
1984 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
1987 /* Now dup our end of _the_ pipe to right position */
1988 if (p[THIS] != (*mode == 'r')) {
1989 PerlLIO_dup2(p[THIS], *mode == 'r');
1990 PerlLIO_close(p[THIS]);
1991 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
1992 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
1995 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
1996 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
1997 /* No automatic close - do it by hand */
2004 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) {
2010 do_aexec5(Nullsv, args-1, args-1+n, pp[1], did_pipes);
2016 do_execfree(); /* free any memory malloced by child on fork */
2018 PerlLIO_close(pp[1]);
2019 /* Keep the lower of the two fd numbers */
2020 if (p[that] < p[This]) {
2021 PerlLIO_dup2(p[This], p[that]);
2022 PerlLIO_close(p[This]);
2026 PerlLIO_close(p[that]); /* close child's end of pipe */
2029 sv = *av_fetch(PL_fdpid,p[This],TRUE);
2031 (void)SvUPGRADE(sv,SVt_IV);
2033 PL_forkprocess = pid;
2034 /* If we managed to get status pipe check for exec fail */
2035 if (did_pipes && pid > 0) {
2039 while (n < sizeof(int)) {
2040 n1 = PerlLIO_read(pp[0],
2041 (void*)(((char*)&errkid)+n),
2047 PerlLIO_close(pp[0]);
2049 if (n) { /* Error */
2051 PerlLIO_close(p[This]);
2052 if (n != sizeof(int))
2053 Perl_croak(aTHX_ "panic: kid popen errno read");
2055 pid2 = wait4pid(pid, &status, 0);
2056 } while (pid2 == -1 && errno == EINTR);
2057 errno = errkid; /* Propagate errno from kid */
2062 PerlLIO_close(pp[0]);
2063 return PerlIO_fdopen(p[This], mode);
2065 Perl_croak(aTHX_ "List form of piped open not implemented");
2066 return (PerlIO *) NULL;
2070 /* VMS' my_popen() is in VMS.c, same with OS/2. */
2071 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
2073 Perl_my_popen(pTHX_ char *cmd, char *mode)
2076 register I32 This, that;
2079 I32 doexec = strNE(cmd,"-");
2083 PERL_FLUSHALL_FOR_CHILD;
2086 return my_syspopen(aTHX_ cmd,mode);
2089 This = (*mode == 'w');
2091 if (doexec && PL_tainting) {
2093 taint_proper("Insecure %s%s", "EXEC");
2095 if (PerlProc_pipe(p) < 0)
2097 if (doexec && PerlProc_pipe(pp) >= 0)
2099 while ((pid = PerlProc_fork()) < 0) {
2100 if (errno != EAGAIN) {
2101 PerlLIO_close(p[This]);
2102 PerlLIO_close(p[that]);
2104 PerlLIO_close(pp[0]);
2105 PerlLIO_close(pp[1]);
2108 Perl_croak(aTHX_ "Can't fork");
2121 PerlLIO_close(pp[0]);
2122 #if defined(HAS_FCNTL) && defined(F_SETFD)
2123 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2126 if (p[THIS] != (*mode == 'r')) {
2127 PerlLIO_dup2(p[THIS], *mode == 'r');
2128 PerlLIO_close(p[THIS]);
2129 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2130 PerlLIO_close(p[THAT]);
2133 PerlLIO_close(p[THAT]);
2136 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2145 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
2150 /* may or may not use the shell */
2151 do_exec3(cmd, pp[1], did_pipes);
2154 #endif /* defined OS2 */
2156 if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) {
2157 SvREADONLY_off(GvSV(tmpgv));
2158 sv_setiv(GvSV(tmpgv), PerlProc_getpid());
2159 SvREADONLY_on(GvSV(tmpgv));
2161 #ifdef THREADS_HAVE_PIDS
2162 PL_ppid = (IV)getppid();
2165 hv_clear(PL_pidstatus); /* we have no children */
2170 do_execfree(); /* free any memory malloced by child on vfork */
2172 PerlLIO_close(pp[1]);
2173 if (p[that] < p[This]) {
2174 PerlLIO_dup2(p[This], p[that]);
2175 PerlLIO_close(p[This]);
2179 PerlLIO_close(p[that]);
2182 sv = *av_fetch(PL_fdpid,p[This],TRUE);
2184 (void)SvUPGRADE(sv,SVt_IV);
2186 PL_forkprocess = pid;
2187 if (did_pipes && pid > 0) {
2191 while (n < sizeof(int)) {
2192 n1 = PerlLIO_read(pp[0],
2193 (void*)(((char*)&errkid)+n),
2199 PerlLIO_close(pp[0]);
2201 if (n) { /* Error */
2203 PerlLIO_close(p[This]);
2204 if (n != sizeof(int))
2205 Perl_croak(aTHX_ "panic: kid popen errno read");
2207 pid2 = wait4pid(pid, &status, 0);
2208 } while (pid2 == -1 && errno == EINTR);
2209 errno = errkid; /* Propagate errno from kid */
2214 PerlLIO_close(pp[0]);
2215 return PerlIO_fdopen(p[This], mode);
2218 #if defined(atarist) || defined(EPOC)
2221 Perl_my_popen(pTHX_ char *cmd, char *mode)
2223 PERL_FLUSHALL_FOR_CHILD;
2224 /* Call system's popen() to get a FILE *, then import it.
2225 used 0 for 2nd parameter to PerlIO_importFILE;
2228 return PerlIO_importFILE(popen(cmd, mode), 0);
2232 FILE *djgpp_popen();
2234 Perl_my_popen(pTHX_ char *cmd, char *mode)
2236 PERL_FLUSHALL_FOR_CHILD;
2237 /* Call system's popen() to get a FILE *, then import it.
2238 used 0 for 2nd parameter to PerlIO_importFILE;
2241 return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
2246 #endif /* !DOSISH */
2248 /* this is called in parent before the fork() */
2250 Perl_atfork_lock(void)
2252 #if defined(USE_5005THREADS) || defined(USE_ITHREADS)
2253 /* locks must be held in locking order (if any) */
2255 MUTEX_LOCK(&PL_malloc_mutex);
2261 /* this is called in both parent and child after the fork() */
2263 Perl_atfork_unlock(void)
2265 #if defined(USE_5005THREADS) || defined(USE_ITHREADS)
2266 /* locks must be released in same order as in atfork_lock() */
2268 MUTEX_UNLOCK(&PL_malloc_mutex);
2277 #if defined(HAS_FORK)
2279 #if (defined(USE_5005THREADS) || defined(USE_ITHREADS)) && !defined(HAS_PTHREAD_ATFORK)
2284 /* atfork_lock() and atfork_unlock() are installed as pthread_atfork()
2285 * handlers elsewhere in the code */
2290 /* this "canna happen" since nothing should be calling here if !HAS_FORK */
2291 Perl_croak_nocontext("fork() not available");
2293 #endif /* HAS_FORK */
2298 Perl_dump_fds(pTHX_ char *s)
2303 PerlIO_printf(Perl_debug_log,"%s", s);
2304 for (fd = 0; fd < 32; fd++) {
2305 if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0)
2306 PerlIO_printf(Perl_debug_log," %d",fd);
2308 PerlIO_printf(Perl_debug_log,"\n");
2310 #endif /* DUMP_FDS */
2314 dup2(int oldfd, int newfd)
2316 #if defined(HAS_FCNTL) && defined(F_DUPFD)
2319 PerlLIO_close(newfd);
2320 return fcntl(oldfd, F_DUPFD, newfd);
2322 #define DUP2_MAX_FDS 256
2323 int fdtmp[DUP2_MAX_FDS];
2329 PerlLIO_close(newfd);
2330 /* good enough for low fd's... */
2331 while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
2332 if (fdx >= DUP2_MAX_FDS) {
2340 PerlLIO_close(fdtmp[--fdx]);
2347 #ifdef HAS_SIGACTION
2350 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2352 struct sigaction act, oact;
2355 /* only "parent" interpreter can diddle signals */
2356 if (PL_curinterp != aTHX)
2360 act.sa_handler = handler;
2361 sigemptyset(&act.sa_mask);
2364 #if defined(PERL_OLD_SIGNALS)
2365 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
2369 if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN)
2370 act.sa_flags |= SA_NOCLDWAIT;
2372 if (sigaction(signo, &act, &oact) == -1)
2375 return oact.sa_handler;
2379 Perl_rsignal_state(pTHX_ int signo)
2381 struct sigaction oact;
2383 if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
2386 return oact.sa_handler;
2390 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2392 struct sigaction act;
2395 /* only "parent" interpreter can diddle signals */
2396 if (PL_curinterp != aTHX)
2400 act.sa_handler = handler;
2401 sigemptyset(&act.sa_mask);
2404 #if defined(PERL_OLD_SIGNALS)
2405 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
2409 if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN)
2410 act.sa_flags |= SA_NOCLDWAIT;
2412 return sigaction(signo, &act, save);
2416 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2419 /* only "parent" interpreter can diddle signals */
2420 if (PL_curinterp != aTHX)
2424 return sigaction(signo, save, (struct sigaction *)NULL);
2427 #else /* !HAS_SIGACTION */
2430 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2432 #if defined(USE_ITHREADS) && !defined(WIN32)
2433 /* only "parent" interpreter can diddle signals */
2434 if (PL_curinterp != aTHX)
2438 return PerlProc_signal(signo, handler);
2441 static int sig_trapped; /* XXX signals are process-wide anyway, so we
2442 ignore the implications of this for threading */
2452 Perl_rsignal_state(pTHX_ int signo)
2454 Sighandler_t oldsig;
2456 #if defined(USE_ITHREADS) && !defined(WIN32)
2457 /* only "parent" interpreter can diddle signals */
2458 if (PL_curinterp != aTHX)
2463 oldsig = PerlProc_signal(signo, sig_trap);
2464 PerlProc_signal(signo, oldsig);
2466 PerlProc_kill(PerlProc_getpid(), signo);
2471 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2473 #if defined(USE_ITHREADS) && !defined(WIN32)
2474 /* only "parent" interpreter can diddle signals */
2475 if (PL_curinterp != aTHX)
2478 *save = PerlProc_signal(signo, handler);
2479 return (*save == SIG_ERR) ? -1 : 0;
2483 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2485 #if defined(USE_ITHREADS) && !defined(WIN32)
2486 /* only "parent" interpreter can diddle signals */
2487 if (PL_curinterp != aTHX)
2490 return (PerlProc_signal(signo, *save) == SIG_ERR) ? -1 : 0;
2493 #endif /* !HAS_SIGACTION */
2494 #endif /* !PERL_MICRO */
2496 /* VMS' my_pclose() is in VMS.c; same with OS/2 */
2497 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
2499 Perl_my_pclose(pTHX_ PerlIO *ptr)
2501 Sigsave_t hstat, istat, qstat;
2507 int saved_errno = 0;
2509 int saved_vaxc_errno;
2512 int saved_win32_errno;
2516 svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE);
2518 pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
2520 *svp = &PL_sv_undef;
2522 if (pid == -1) { /* Opened by popen. */
2523 return my_syspclose(ptr);
2526 if ((close_failed = (PerlIO_close(ptr) == EOF))) {
2527 saved_errno = errno;
2529 saved_vaxc_errno = vaxc$errno;
2532 saved_win32_errno = GetLastError();
2536 if(PerlProc_kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */
2539 rsignal_save(SIGHUP, SIG_IGN, &hstat);
2540 rsignal_save(SIGINT, SIG_IGN, &istat);
2541 rsignal_save(SIGQUIT, SIG_IGN, &qstat);
2544 pid2 = wait4pid(pid, &status, 0);
2545 } while (pid2 == -1 && errno == EINTR);
2547 rsignal_restore(SIGHUP, &hstat);
2548 rsignal_restore(SIGINT, &istat);
2549 rsignal_restore(SIGQUIT, &qstat);
2552 SETERRNO(saved_errno, saved_vaxc_errno);
2555 return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status));
2557 #endif /* !DOSISH */
2559 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(MACOS_TRADITIONAL)
2561 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
2566 #if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME)
2570 char spid[TYPE_CHARS(int)];
2573 sprintf(spid, "%"IVdf, (IV)pid);
2574 svp = hv_fetch(PL_pidstatus,spid,strlen(spid),FALSE);
2575 if (svp && *svp != &PL_sv_undef) {
2576 *statusp = SvIVX(*svp);
2577 (void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD);
2584 hv_iterinit(PL_pidstatus);
2585 if ((entry = hv_iternext(PL_pidstatus))) {
2587 char spid[TYPE_CHARS(int)];
2589 pid = atoi(hv_iterkey(entry,(I32*)statusp));
2590 sv = hv_iterval(PL_pidstatus,entry);
2591 *statusp = SvIVX(sv);
2592 sprintf(spid, "%"IVdf, (IV)pid);
2593 (void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD);
2600 # ifdef HAS_WAITPID_RUNTIME
2601 if (!HAS_WAITPID_RUNTIME)
2604 result = PerlProc_waitpid(pid,statusp,flags);
2607 #if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
2608 result = wait4((pid==-1)?0:pid,statusp,flags,Null(struct rusage *));
2611 #if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME)
2615 Perl_croak(aTHX_ "Can't do waitpid with flags");
2617 while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
2618 pidgone(result,*statusp);
2625 if (result < 0 && errno == EINTR) {
2630 #endif /* !DOSISH || OS2 || WIN32 || NETWARE */
2634 Perl_pidgone(pTHX_ Pid_t pid, int status)
2637 char spid[TYPE_CHARS(int)];
2639 sprintf(spid, "%"IVdf, (IV)pid);
2640 sv = *hv_fetch(PL_pidstatus,spid,strlen(spid),TRUE);
2641 (void)SvUPGRADE(sv,SVt_IV);
2646 #if defined(atarist) || defined(OS2) || defined(EPOC)
2649 int /* Cannot prototype with I32
2651 my_syspclose(PerlIO *ptr)
2654 Perl_my_pclose(pTHX_ PerlIO *ptr)
2657 /* Needs work for PerlIO ! */
2658 FILE *f = PerlIO_findFILE(ptr);
2659 I32 result = pclose(f);
2660 PerlIO_releaseFILE(ptr,f);
2668 Perl_my_pclose(pTHX_ PerlIO *ptr)
2670 /* Needs work for PerlIO ! */
2671 FILE *f = PerlIO_findFILE(ptr);
2672 I32 result = djgpp_pclose(f);
2673 result = (result << 8) & 0xff00;
2674 PerlIO_releaseFILE(ptr,f);
2680 Perl_repeatcpy(pTHX_ register char *to, register const char *from, I32 len, register I32 count)
2683 register const char *frombase = from;
2686 register const char c = *from;
2691 while (count-- > 0) {
2692 for (todo = len; todo > 0; todo--) {
2701 Perl_same_dirent(pTHX_ char *a, char *b)
2703 char *fa = strrchr(a,'/');
2704 char *fb = strrchr(b,'/');
2707 SV *tmpsv = sv_newmortal();
2720 sv_setpv(tmpsv, ".");
2722 sv_setpvn(tmpsv, a, fa - a);
2723 if (PerlLIO_stat(SvPVX(tmpsv), &tmpstatbuf1) < 0)
2726 sv_setpv(tmpsv, ".");
2728 sv_setpvn(tmpsv, b, fb - b);
2729 if (PerlLIO_stat(SvPVX(tmpsv), &tmpstatbuf2) < 0)
2731 return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
2732 tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
2734 #endif /* !HAS_RENAME */
2737 Perl_find_script(pTHX_ char *scriptname, bool dosearch, char **search_ext, I32 flags)
2739 char *xfound = Nullch;
2740 char *xfailed = Nullch;
2741 char tmpbuf[MAXPATHLEN];
2745 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
2746 # define SEARCH_EXTS ".bat", ".cmd", NULL
2747 # define MAX_EXT_LEN 4
2750 # define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
2751 # define MAX_EXT_LEN 4
2754 # define SEARCH_EXTS ".pl", ".com", NULL
2755 # define MAX_EXT_LEN 4
2757 /* additional extensions to try in each dir if scriptname not found */
2759 char *exts[] = { SEARCH_EXTS };
2760 char **ext = search_ext ? search_ext : exts;
2761 int extidx = 0, i = 0;
2762 char *curext = Nullch;
2764 # define MAX_EXT_LEN 0
2768 * If dosearch is true and if scriptname does not contain path
2769 * delimiters, search the PATH for scriptname.
2771 * If SEARCH_EXTS is also defined, will look for each
2772 * scriptname{SEARCH_EXTS} whenever scriptname is not found
2773 * while searching the PATH.
2775 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
2776 * proceeds as follows:
2777 * If DOSISH or VMSISH:
2778 * + look for ./scriptname{,.foo,.bar}
2779 * + search the PATH for scriptname{,.foo,.bar}
2782 * + look *only* in the PATH for scriptname{,.foo,.bar} (note
2783 * this will not look in '.' if it's not in the PATH)
2788 # ifdef ALWAYS_DEFTYPES
2789 len = strlen(scriptname);
2790 if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
2791 int hasdir, idx = 0, deftypes = 1;
2794 hasdir = !dosearch || (strpbrk(scriptname,":[</") != Nullch) ;
2797 int hasdir, idx = 0, deftypes = 1;
2800 hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
2802 /* The first time through, just add SEARCH_EXTS to whatever we
2803 * already have, so we can check for default file types. */
2805 (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
2811 if ((strlen(tmpbuf) + strlen(scriptname)
2812 + MAX_EXT_LEN) >= sizeof tmpbuf)
2813 continue; /* don't search dir with too-long name */
2814 strcat(tmpbuf, scriptname);
2818 if (strEQ(scriptname, "-"))
2820 if (dosearch) { /* Look in '.' first. */
2821 char *cur = scriptname;
2823 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
2825 if (strEQ(ext[i++],curext)) {
2826 extidx = -1; /* already has an ext */
2831 DEBUG_p(PerlIO_printf(Perl_debug_log,
2832 "Looking for %s\n",cur));
2833 if (PerlLIO_stat(cur,&PL_statbuf) >= 0
2834 && !S_ISDIR(PL_statbuf.st_mode)) {
2842 if (cur == scriptname) {
2843 len = strlen(scriptname);
2844 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
2846 cur = strcpy(tmpbuf, scriptname);
2848 } while (extidx >= 0 && ext[extidx] /* try an extension? */
2849 && strcpy(tmpbuf+len, ext[extidx++]));
2854 #ifdef MACOS_TRADITIONAL
2855 if (dosearch && !strchr(scriptname, ':') &&
2856 (s = PerlEnv_getenv("Commands")))
2858 if (dosearch && !strchr(scriptname, '/')
2860 && !strchr(scriptname, '\\')
2862 && (s = PerlEnv_getenv("PATH")))
2867 PL_bufend = s + strlen(s);
2868 while (s < PL_bufend) {
2869 #ifdef MACOS_TRADITIONAL
2870 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
2874 #if defined(atarist) || defined(DOSISH)
2879 && *s != ';'; len++, s++) {
2880 if (len < sizeof tmpbuf)
2883 if (len < sizeof tmpbuf)
2885 #else /* ! (atarist || DOSISH) */
2886 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
2889 #endif /* ! (atarist || DOSISH) */
2890 #endif /* MACOS_TRADITIONAL */
2893 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
2894 continue; /* don't search dir with too-long name */
2895 #ifdef MACOS_TRADITIONAL
2896 if (len && tmpbuf[len - 1] != ':')
2897 tmpbuf[len++] = ':';
2900 #if defined(atarist) || defined(__MINT__) || defined(DOSISH)
2901 && tmpbuf[len - 1] != '/'
2902 && tmpbuf[len - 1] != '\\'
2905 tmpbuf[len++] = '/';
2906 if (len == 2 && tmpbuf[0] == '.')
2909 (void)strcpy(tmpbuf + len, scriptname);
2913 len = strlen(tmpbuf);
2914 if (extidx > 0) /* reset after previous loop */
2918 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
2919 retval = PerlLIO_stat(tmpbuf,&PL_statbuf);
2920 if (S_ISDIR(PL_statbuf.st_mode)) {
2924 } while ( retval < 0 /* not there */
2925 && extidx>=0 && ext[extidx] /* try an extension? */
2926 && strcpy(tmpbuf+len, ext[extidx++])
2931 if (S_ISREG(PL_statbuf.st_mode)
2932 && cando(S_IRUSR,TRUE,&PL_statbuf)
2933 #if !defined(DOSISH) && !defined(MACOS_TRADITIONAL)
2934 && cando(S_IXUSR,TRUE,&PL_statbuf)
2938 xfound = tmpbuf; /* bingo! */
2942 xfailed = savepv(tmpbuf);
2945 if (!xfound && !seen_dot && !xfailed &&
2946 (PerlLIO_stat(scriptname,&PL_statbuf) < 0
2947 || S_ISDIR(PL_statbuf.st_mode)))
2949 seen_dot = 1; /* Disable message. */
2951 if (flags & 1) { /* do or die? */
2952 Perl_croak(aTHX_ "Can't %s %s%s%s",
2953 (xfailed ? "execute" : "find"),
2954 (xfailed ? xfailed : scriptname),
2955 (xfailed ? "" : " on PATH"),
2956 (xfailed || seen_dot) ? "" : ", '.' not in PATH");
2958 scriptname = Nullch;
2962 scriptname = xfound;
2964 return (scriptname ? savepv(scriptname) : Nullch);
2967 #ifndef PERL_GET_CONTEXT_DEFINED
2970 Perl_get_context(void)
2972 #if defined(USE_5005THREADS) || defined(USE_ITHREADS)
2973 # ifdef OLD_PTHREADS_API
2975 if (pthread_getspecific(PL_thr_key, &t))
2976 Perl_croak_nocontext("panic: pthread_getspecific");
2979 # ifdef I_MACH_CTHREADS
2980 return (void*)cthread_data(cthread_self());
2982 return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
2991 Perl_set_context(void *t)
2993 #if defined(USE_5005THREADS) || defined(USE_ITHREADS)
2994 # ifdef I_MACH_CTHREADS
2995 cthread_set_data(cthread_self(), t);
2997 if (pthread_setspecific(PL_thr_key, t))
2998 Perl_croak_nocontext("panic: pthread_setspecific");
3003 #endif /* !PERL_GET_CONTEXT_DEFINED */
3005 #ifdef USE_5005THREADS
3008 /* Very simplistic scheduler for now */
3012 thr = thr->i.next_run;
3016 Perl_cond_init(pTHX_ perl_cond *cp)
3022 Perl_cond_signal(pTHX_ perl_cond *cp)
3025 perl_cond cond = *cp;
3030 /* Insert t in the runnable queue just ahead of us */
3031 t->i.next_run = thr->i.next_run;
3032 thr->i.next_run->i.prev_run = t;
3033 t->i.prev_run = thr;
3034 thr->i.next_run = t;
3035 thr->i.wait_queue = 0;
3036 /* Remove from the wait queue */
3042 Perl_cond_broadcast(pTHX_ perl_cond *cp)
3045 perl_cond cond, cond_next;
3047 for (cond = *cp; cond; cond = cond_next) {
3049 /* Insert t in the runnable queue just ahead of us */
3050 t->i.next_run = thr->i.next_run;
3051 thr->i.next_run->i.prev_run = t;
3052 t->i.prev_run = thr;
3053 thr->i.next_run = t;
3054 thr->i.wait_queue = 0;
3055 /* Remove from the wait queue */
3056 cond_next = cond->next;
3063 Perl_cond_wait(pTHX_ perl_cond *cp)
3067 if (thr->i.next_run == thr)
3068 Perl_croak(aTHX_ "panic: perl_cond_wait called by last runnable thread");
3070 New(666, cond, 1, struct perl_wait_queue);
3074 thr->i.wait_queue = cond;
3075 /* Remove ourselves from runnable queue */
3076 thr->i.next_run->i.prev_run = thr->i.prev_run;
3077 thr->i.prev_run->i.next_run = thr->i.next_run;
3079 #endif /* FAKE_THREADS */
3082 Perl_condpair_magic(pTHX_ SV *sv)
3086 (void)SvUPGRADE(sv, SVt_PVMG);
3087 mg = mg_find(sv, PERL_MAGIC_mutex);
3091 New(53, cp, 1, condpair_t);
3092 MUTEX_INIT(&cp->mutex);
3093 COND_INIT(&cp->owner_cond);
3094 COND_INIT(&cp->cond);
3096 LOCK_CRED_MUTEX; /* XXX need separate mutex? */
3097 mg = mg_find(sv, PERL_MAGIC_mutex);
3099 /* someone else beat us to initialising it */
3100 UNLOCK_CRED_MUTEX; /* XXX need separate mutex? */
3101 MUTEX_DESTROY(&cp->mutex);
3102 COND_DESTROY(&cp->owner_cond);
3103 COND_DESTROY(&cp->cond);
3107 sv_magic(sv, Nullsv, PERL_MAGIC_mutex, 0, 0);
3109 mg->mg_ptr = (char *)cp;
3110 mg->mg_len = sizeof(cp);
3111 UNLOCK_CRED_MUTEX; /* XXX need separate mutex? */
3112 DEBUG_S(WITH_THR(PerlIO_printf(Perl_debug_log,
3113 "%p: condpair_magic %p\n", thr, sv)));
3120 Perl_sv_lock(pTHX_ SV *osv)
3130 mg = condpair_magic(sv);
3131 MUTEX_LOCK(MgMUTEXP(mg));
3132 if (MgOWNER(mg) == thr)
3133 MUTEX_UNLOCK(MgMUTEXP(mg));
3136 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
3138 DEBUG_S(PerlIO_printf(Perl_debug_log,
3139 "0x%"UVxf": Perl_lock lock 0x%"UVxf"\n",
3140 PTR2UV(thr), PTR2UV(sv)));
3141 MUTEX_UNLOCK(MgMUTEXP(mg));
3142 SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv);
3144 UNLOCK_SV_LOCK_MUTEX;
3149 * Make a new perl thread structure using t as a prototype. Some of the
3150 * fields for the new thread are copied from the prototype thread, t,
3151 * so t should not be running in perl at the time this function is
3152 * called. The use by ext/Thread/Thread.xs in core perl (where t is the
3153 * thread calling new_struct_thread) clearly satisfies this constraint.
3155 struct perl_thread *
3156 Perl_new_struct_thread(pTHX_ struct perl_thread *t)
3158 #if !defined(PERL_IMPLICIT_CONTEXT)
3159 struct perl_thread *thr;
3165 sv = newSVpvn("", 0);
3166 SvGROW(sv, sizeof(struct perl_thread) + 1);
3167 SvCUR_set(sv, sizeof(struct perl_thread));
3168 thr = (Thread) SvPVX(sv);
3170 Poison(thr, 1, struct perl_thread);
3177 Zero(&PL_hv_fetch_ent_mh, 1, HE);
3178 PL_efloatbuf = (char*)NULL;
3181 Zero(thr, 1, struct perl_thread);
3187 PL_curcop = &PL_compiling;
3188 thr->interp = t->interp;
3189 thr->cvcache = newHV();
3190 thr->threadsv = newAV();
3191 thr->specific = newAV();
3192 thr->errsv = newSVpvn("", 0);
3193 thr->flags = THRf_R_JOINABLE;
3195 MUTEX_INIT(&thr->mutex);
3199 PL_in_eval = EVAL_NULL; /* ~(EVAL_INEVAL|EVAL_WARNONLY|EVAL_KEEPERR|EVAL_INREQUIRE) */
3202 PL_statname = NEWSV(66,0);
3203 PL_errors = newSVpvn("", 0);
3205 PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
3206 PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
3207 PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
3208 PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
3209 PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
3211 PL_reginterp_cnt = 0;
3212 PL_lastscream = Nullsv;
3215 PL_reg_start_tmp = 0;
3216 PL_reg_start_tmpl = 0;
3217 PL_reg_poscache = Nullch;
3219 PL_peepp = MEMBER_TO_FPTR(Perl_peep);
3221 /* parent thread's data needs to be locked while we make copy */
3222 MUTEX_LOCK(&t->mutex);
3224 #ifdef PERL_FLEXIBLE_EXCEPTIONS
3225 PL_protect = t->Tprotect;
3228 PL_curcop = t->Tcurcop; /* XXX As good a guess as any? */
3229 PL_defstash = t->Tdefstash; /* XXX maybe these should */
3230 PL_curstash = t->Tcurstash; /* always be set to main? */
3232 PL_tainted = t->Ttainted;
3233 PL_curpm = t->Tcurpm; /* XXX No PMOP ref count */
3234 PL_rs = newSVsv(t->Trs);
3235 PL_last_in_gv = Nullgv;
3236 PL_ofs_sv = t->Tofs_sv ? SvREFCNT_inc(PL_ofs_sv) : Nullsv;
3237 PL_defoutgv = (GV*)SvREFCNT_inc(t->Tdefoutgv);
3238 PL_chopset = t->Tchopset;
3239 PL_bodytarget = newSVsv(t->Tbodytarget);
3240 PL_toptarget = newSVsv(t->Ttoptarget);
3241 if (t->Tformtarget == t->Ttoptarget)
3242 PL_formtarget = PL_toptarget;
3244 PL_formtarget = PL_bodytarget;
3246 /* Initialise all per-thread SVs that the template thread used */
3247 svp = AvARRAY(t->threadsv);
3248 for (i = 0; i <= AvFILLp(t->threadsv); i++, svp++) {
3249 if (*svp && *svp != &PL_sv_undef) {
3250 SV *sv = newSVsv(*svp);
3251 av_store(thr->threadsv, i, sv);
3252 sv_magic(sv, 0, PERL_MAGIC_sv, &PL_threadsv_names[i], 1);
3253 DEBUG_S(PerlIO_printf(Perl_debug_log,
3254 "new_struct_thread: copied threadsv %"IVdf" %p->%p\n",
3258 thr->threadsvp = AvARRAY(thr->threadsv);
3260 MUTEX_LOCK(&PL_threads_mutex);
3262 thr->tid = ++PL_threadnum;
3263 thr->next = t->next;
3266 thr->next->prev = thr;
3267 MUTEX_UNLOCK(&PL_threads_mutex);
3269 /* done copying parent's state */
3270 MUTEX_UNLOCK(&t->mutex);
3272 #ifdef HAVE_THREAD_INTERN
3273 Perl_init_thread_intern(thr);
3274 #endif /* HAVE_THREAD_INTERN */
3277 #endif /* USE_5005THREADS */
3279 #ifdef PERL_GLOBAL_STRUCT
3288 Perl_get_op_names(pTHX)
3294 Perl_get_op_descs(pTHX)
3300 Perl_get_no_modify(pTHX)
3302 return (char*)PL_no_modify;
3306 Perl_get_opargs(pTHX)
3312 Perl_get_ppaddr(pTHX)
3314 return (PPADDR_t*)PL_ppaddr;
3317 #ifndef HAS_GETENV_LEN
3319 Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
3321 char *env_trans = PerlEnv_getenv(env_elem);
3323 *len = strlen(env_trans);
3330 Perl_get_vtbl(pTHX_ int vtbl_id)
3332 MGVTBL* result = Null(MGVTBL*);
3336 result = &PL_vtbl_sv;
3339 result = &PL_vtbl_env;
3341 case want_vtbl_envelem:
3342 result = &PL_vtbl_envelem;
3345 result = &PL_vtbl_sig;
3347 case want_vtbl_sigelem:
3348 result = &PL_vtbl_sigelem;
3350 case want_vtbl_pack:
3351 result = &PL_vtbl_pack;
3353 case want_vtbl_packelem:
3354 result = &PL_vtbl_packelem;
3356 case want_vtbl_dbline:
3357 result = &PL_vtbl_dbline;
3360 result = &PL_vtbl_isa;
3362 case want_vtbl_isaelem:
3363 result = &PL_vtbl_isaelem;
3365 case want_vtbl_arylen:
3366 result = &PL_vtbl_arylen;
3368 case want_vtbl_glob:
3369 result = &PL_vtbl_glob;
3371 case want_vtbl_mglob:
3372 result = &PL_vtbl_mglob;
3374 case want_vtbl_nkeys:
3375 result = &PL_vtbl_nkeys;
3377 case want_vtbl_taint:
3378 result = &PL_vtbl_taint;
3380 case want_vtbl_substr:
3381 result = &PL_vtbl_substr;
3384 result = &PL_vtbl_vec;
3387 result = &PL_vtbl_pos;
3390 result = &PL_vtbl_bm;
3393 result = &PL_vtbl_fm;
3395 case want_vtbl_uvar:
3396 result = &PL_vtbl_uvar;
3398 #ifdef USE_5005THREADS
3399 case want_vtbl_mutex:
3400 result = &PL_vtbl_mutex;
3403 case want_vtbl_defelem:
3404 result = &PL_vtbl_defelem;
3406 case want_vtbl_regexp:
3407 result = &PL_vtbl_regexp;
3409 case want_vtbl_regdata:
3410 result = &PL_vtbl_regdata;
3412 case want_vtbl_regdatum:
3413 result = &PL_vtbl_regdatum;
3415 #ifdef USE_LOCALE_COLLATE
3416 case want_vtbl_collxfrm:
3417 result = &PL_vtbl_collxfrm;
3420 case want_vtbl_amagic:
3421 result = &PL_vtbl_amagic;
3423 case want_vtbl_amagicelem:
3424 result = &PL_vtbl_amagicelem;
3426 case want_vtbl_backref:
3427 result = &PL_vtbl_backref;
3434 Perl_my_fflush_all(pTHX)
3436 #if defined(FFLUSH_NULL)
3437 return PerlIO_flush(NULL);
3439 # if defined(HAS__FWALK)
3440 extern int fflush(FILE *);
3441 /* undocumented, unprototyped, but very useful BSDism */
3442 extern void _fwalk(int (*)(FILE *));
3446 # if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
3448 # ifdef PERL_FFLUSH_ALL_FOPEN_MAX
3449 open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
3451 # if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
3452 open_max = sysconf(_SC_OPEN_MAX);
3455 open_max = FOPEN_MAX;
3458 open_max = OPEN_MAX;
3469 for (i = 0; i < open_max; i++)
3470 if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
3471 STDIO_STREAM_ARRAY[i]._file < open_max &&
3472 STDIO_STREAM_ARRAY[i]._flag)
3473 PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
3477 SETERRNO(EBADF,RMS$_IFI);
3484 Perl_report_evil_fh(pTHX_ GV *gv, IO *io, I32 op)
3487 op == OP_READLINE ? "readline" : /* "<HANDLE>" not nice */
3488 op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */
3490 char *pars = OP_IS_FILETEST(op) ? "" : "()";
3491 char *type = OP_IS_SOCKET(op)
3492 || (gv && io && IoTYPE(io) == IoTYPE_SOCKET)
3493 ? "socket" : "filehandle";
3496 if (gv && isGV(gv)) {
3500 if (op == OP_phoney_OUTPUT_ONLY || op == OP_phoney_INPUT_ONLY) {
3501 if (ckWARN(WARN_IO)) {
3502 const char *direction = (op == OP_phoney_INPUT_ONLY) ? "in" : "out";
3504 Perl_warner(aTHX_ packWARN(WARN_IO),
3505 "Filehandle %s opened only for %sput",
3508 Perl_warner(aTHX_ packWARN(WARN_IO),
3509 "Filehandle opened only for %sput", direction);
3516 if (gv && io && IoTYPE(io) == IoTYPE_CLOSED) {
3518 warn_type = WARN_CLOSED;
3522 warn_type = WARN_UNOPENED;
3525 if (ckWARN(warn_type)) {
3526 if (name && *name) {
3527 Perl_warner(aTHX_ packWARN(warn_type),
3528 "%s%s on %s %s %s", func, pars, vile, type, name);
3529 if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3531 aTHX_ packWARN(warn_type),
3532 "\t(Are you trying to call %s%s on dirhandle %s?)\n",
3537 Perl_warner(aTHX_ packWARN(warn_type),
3538 "%s%s on %s %s", func, pars, vile, type);
3539 if (gv && io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3541 aTHX_ packWARN(warn_type),
3542 "\t(Are you trying to call %s%s on dirhandle?)\n",
3551 /* in ASCII order, not that it matters */
3552 static const char controllablechars[] = "?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_";
3555 Perl_ebcdic_control(pTHX_ int ch)
3563 if ((ctlp = strchr(controllablechars, ch)) == 0) {
3564 Perl_die(aTHX_ "unrecognised control character '%c'\n", ch);
3567 if (ctlp == controllablechars)
3568 return('\177'); /* DEL */
3570 return((unsigned char)(ctlp - controllablechars - 1));
3571 } else { /* Want uncontrol */
3572 if (ch == '\177' || ch == -1)
3574 else if (ch == '\157')
3576 else if (ch == '\174')
3578 else if (ch == '^') /* '\137' in 1047, '\260' in 819 */
3580 else if (ch == '\155')
3582 else if (0 < ch && ch < (sizeof(controllablechars) - 1))
3583 return(controllablechars[ch+1]);
3585 Perl_die(aTHX_ "invalid control request: '\\%03o'\n", ch & 0xFF);
3590 /* To workaround core dumps from the uninitialised tm_zone we get the
3591 * system to give us a reasonable struct to copy. This fix means that
3592 * strftime uses the tm_zone and tm_gmtoff values returned by
3593 * localtime(time()). That should give the desired result most of the
3594 * time. But probably not always!
3596 * This does not address tzname aspects of NETaa14816.
3601 # ifndef STRUCT_TM_HASZONE
3602 # define STRUCT_TM_HASZONE
3606 #ifdef STRUCT_TM_HASZONE /* Backward compat */
3607 # ifndef HAS_TM_TM_ZONE
3608 # define HAS_TM_TM_ZONE
3613 Perl_init_tm(pTHX_ struct tm *ptm) /* see mktime, strftime and asctime */
3615 #ifdef HAS_TM_TM_ZONE
3618 Copy(localtime(&now), ptm, 1, struct tm);
3623 * mini_mktime - normalise struct tm values without the localtime()
3624 * semantics (and overhead) of mktime().
3627 Perl_mini_mktime(pTHX_ struct tm *ptm)
3631 int month, mday, year, jday;
3632 int odd_cent, odd_year;
3634 #define DAYS_PER_YEAR 365
3635 #define DAYS_PER_QYEAR (4*DAYS_PER_YEAR+1)
3636 #define DAYS_PER_CENT (25*DAYS_PER_QYEAR-1)
3637 #define DAYS_PER_QCENT (4*DAYS_PER_CENT+1)
3638 #define SECS_PER_HOUR (60*60)
3639 #define SECS_PER_DAY (24*SECS_PER_HOUR)
3640 /* parentheses deliberately absent on these two, otherwise they don't work */
3641 #define MONTH_TO_DAYS 153/5
3642 #define DAYS_TO_MONTH 5/153
3643 /* offset to bias by March (month 4) 1st between month/mday & year finding */
3644 #define YEAR_ADJUST (4*MONTH_TO_DAYS+1)
3645 /* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */
3646 #define WEEKDAY_BIAS 6 /* (1+6)%7 makes Sunday 0 again */
3649 * Year/day algorithm notes:
3651 * With a suitable offset for numeric value of the month, one can find
3652 * an offset into the year by considering months to have 30.6 (153/5) days,
3653 * using integer arithmetic (i.e., with truncation). To avoid too much
3654 * messing about with leap days, we consider January and February to be
3655 * the 13th and 14th month of the previous year. After that transformation,
3656 * we need the month index we use to be high by 1 from 'normal human' usage,
3657 * so the month index values we use run from 4 through 15.
3659 * Given that, and the rules for the Gregorian calendar (leap years are those
3660 * divisible by 4 unless also divisible by 100, when they must be divisible
3661 * by 400 instead), we can simply calculate the number of days since some
3662 * arbitrary 'beginning of time' by futzing with the (adjusted) year number,
3663 * the days we derive from our month index, and adding in the day of the
3664 * month. The value used here is not adjusted for the actual origin which
3665 * it normally would use (1 January A.D. 1), since we're not exposing it.
3666 * We're only building the value so we can turn around and get the
3667 * normalised values for the year, month, day-of-month, and day-of-year.
3669 * For going backward, we need to bias the value we're using so that we find
3670 * the right year value. (Basically, we don't want the contribution of
3671 * March 1st to the number to apply while deriving the year). Having done
3672 * that, we 'count up' the contribution to the year number by accounting for
3673 * full quadracenturies (400-year periods) with their extra leap days, plus
3674 * the contribution from full centuries (to avoid counting in the lost leap
3675 * days), plus the contribution from full quad-years (to count in the normal
3676 * leap days), plus the leftover contribution from any non-leap years.
3677 * At this point, if we were working with an actual leap day, we'll have 0
3678 * days left over. This is also true for March 1st, however. So, we have
3679 * to special-case that result, and (earlier) keep track of the 'odd'
3680 * century and year contributions. If we got 4 extra centuries in a qcent,
3681 * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb.
3682 * Otherwise, we add back in the earlier bias we removed (the 123 from
3683 * figuring in March 1st), find the month index (integer division by 30.6),
3684 * and the remainder is the day-of-month. We then have to convert back to
3685 * 'real' months (including fixing January and February from being 14/15 in
3686 * the previous year to being in the proper year). After that, to get
3687 * tm_yday, we work with the normalised year and get a new yearday value for
3688 * January 1st, which we subtract from the yearday value we had earlier,
3689 * representing the date we've re-built. This is done from January 1
3690 * because tm_yday is 0-origin.
3692 * Since POSIX time routines are only guaranteed to work for times since the
3693 * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm
3694 * applies Gregorian calendar rules even to dates before the 16th century
3695 * doesn't bother me. Besides, you'd need cultural context for a given
3696 * date to know whether it was Julian or Gregorian calendar, and that's
3697 * outside the scope for this routine. Since we convert back based on the
3698 * same rules we used to build the yearday, you'll only get strange results
3699 * for input which needed normalising, or for the 'odd' century years which
3700 * were leap years in the Julian calander but not in the Gregorian one.
3701 * I can live with that.
3703 * This algorithm also fails to handle years before A.D. 1 gracefully, but
3704 * that's still outside the scope for POSIX time manipulation, so I don't
3708 year = 1900 + ptm->tm_year;
3709 month = ptm->tm_mon;
3710 mday = ptm->tm_mday;
3711 /* allow given yday with no month & mday to dominate the result */
3712 if (ptm->tm_yday >= 0 && mday <= 0 && month <= 0) {
3715 jday = 1 + ptm->tm_yday;
3724 yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400;
3725 yearday += month*MONTH_TO_DAYS + mday + jday;
3727 * Note that we don't know when leap-seconds were or will be,
3728 * so we have to trust the user if we get something which looks
3729 * like a sensible leap-second. Wild values for seconds will
3730 * be rationalised, however.
3732 if ((unsigned) ptm->tm_sec <= 60) {
3739 secs += 60 * ptm->tm_min;
3740 secs += SECS_PER_HOUR * ptm->tm_hour;
3742 if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) {
3743 /* got negative remainder, but need positive time */
3744 /* back off an extra day to compensate */
3745 yearday += (secs/SECS_PER_DAY)-1;
3746 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1);
3749 yearday += (secs/SECS_PER_DAY);
3750 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY);
3753 else if (secs >= SECS_PER_DAY) {
3754 yearday += (secs/SECS_PER_DAY);
3755 secs %= SECS_PER_DAY;
3757 ptm->tm_hour = secs/SECS_PER_HOUR;
3758 secs %= SECS_PER_HOUR;
3759 ptm->tm_min = secs/60;
3761 ptm->tm_sec += secs;
3762 /* done with time of day effects */
3764 * The algorithm for yearday has (so far) left it high by 428.
3765 * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to
3766 * bias it by 123 while trying to figure out what year it
3767 * really represents. Even with this tweak, the reverse
3768 * translation fails for years before A.D. 0001.
3769 * It would still fail for Feb 29, but we catch that one below.
3771 jday = yearday; /* save for later fixup vis-a-vis Jan 1 */
3772 yearday -= YEAR_ADJUST;
3773 year = (yearday / DAYS_PER_QCENT) * 400;
3774 yearday %= DAYS_PER_QCENT;
3775 odd_cent = yearday / DAYS_PER_CENT;
3776 year += odd_cent * 100;
3777 yearday %= DAYS_PER_CENT;
3778 year += (yearday / DAYS_PER_QYEAR) * 4;
3779 yearday %= DAYS_PER_QYEAR;
3780 odd_year = yearday / DAYS_PER_YEAR;
3782 yearday %= DAYS_PER_YEAR;
3783 if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */
3788 yearday += YEAR_ADJUST; /* recover March 1st crock */
3789 month = yearday*DAYS_TO_MONTH;
3790 yearday -= month*MONTH_TO_DAYS;
3791 /* recover other leap-year adjustment */
3800 ptm->tm_year = year - 1900;
3802 ptm->tm_mday = yearday;
3803 ptm->tm_mon = month;
3807 ptm->tm_mon = month - 1;
3809 /* re-build yearday based on Jan 1 to get tm_yday */
3811 yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400;
3812 yearday += 14*MONTH_TO_DAYS + 1;
3813 ptm->tm_yday = jday - yearday;
3814 /* fix tm_wday if not overridden by caller */
3815 if ((unsigned)ptm->tm_wday > 6)
3816 ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
3820 Perl_my_strftime(pTHX_ char *fmt, int sec, int min, int hour, int mday, int mon, int year, int wday, int yday, int isdst)
3828 init_tm(&mytm); /* XXX workaround - see init_tm() above */
3831 mytm.tm_hour = hour;
3832 mytm.tm_mday = mday;
3834 mytm.tm_year = year;
3835 mytm.tm_wday = wday;
3836 mytm.tm_yday = yday;
3837 mytm.tm_isdst = isdst;
3840 New(0, buf, buflen, char);
3841 len = strftime(buf, buflen, fmt, &mytm);
3843 ** The following is needed to handle to the situation where
3844 ** tmpbuf overflows. Basically we want to allocate a buffer
3845 ** and try repeatedly. The reason why it is so complicated
3846 ** is that getting a return value of 0 from strftime can indicate
3847 ** one of the following:
3848 ** 1. buffer overflowed,
3849 ** 2. illegal conversion specifier, or
3850 ** 3. the format string specifies nothing to be returned(not
3851 ** an error). This could be because format is an empty string
3852 ** or it specifies %p that yields an empty string in some locale.
3853 ** If there is a better way to make it portable, go ahead by
3856 if ((len > 0 && len < buflen) || (len == 0 && *fmt == '\0'))
3859 /* Possibly buf overflowed - try again with a bigger buf */
3860 int fmtlen = strlen(fmt);
3861 int bufsize = fmtlen + buflen;
3863 New(0, buf, bufsize, char);
3865 buflen = strftime(buf, bufsize, fmt, &mytm);
3866 if (buflen > 0 && buflen < bufsize)
3868 /* heuristic to prevent out-of-memory errors */
3869 if (bufsize > 100*fmtlen) {
3875 Renew(buf, bufsize, char);
3880 Perl_croak(aTHX_ "panic: no strftime");
3885 #define SV_CWD_RETURN_UNDEF \
3886 sv_setsv(sv, &PL_sv_undef); \
3889 #define SV_CWD_ISDOT(dp) \
3890 (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
3891 (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
3894 =head1 Miscellaneous Functions
3896 =for apidoc getcwd_sv
3898 Fill the sv with current working directory
3903 /* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars.
3904 * rewritten again by dougm, optimized for use with xs TARG, and to prefer
3905 * getcwd(3) if available
3906 * Comments from the orignal:
3907 * This is a faster version of getcwd. It's also more dangerous
3908 * because you might chdir out of a directory that you can't chdir
3912 Perl_getcwd_sv(pTHX_ register SV *sv)
3916 #ifndef INCOMPLETE_TAINTS
3922 char buf[MAXPATHLEN];
3924 /* Some getcwd()s automatically allocate a buffer of the given
3925 * size from the heap if they are given a NULL buffer pointer.
3926 * The problem is that this behaviour is not portable. */
3927 if (getcwd(buf, sizeof(buf) - 1)) {
3928 STRLEN len = strlen(buf);
3929 sv_setpvn(sv, buf, len);
3933 sv_setsv(sv, &PL_sv_undef);
3941 int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
3942 int namelen, pathlen=0;
3946 (void)SvUPGRADE(sv, SVt_PV);
3948 if (PerlLIO_lstat(".", &statbuf) < 0) {
3949 SV_CWD_RETURN_UNDEF;
3952 orig_cdev = statbuf.st_dev;
3953 orig_cino = statbuf.st_ino;
3961 if (PerlDir_chdir("..") < 0) {
3962 SV_CWD_RETURN_UNDEF;
3964 if (PerlLIO_stat(".", &statbuf) < 0) {
3965 SV_CWD_RETURN_UNDEF;
3968 cdev = statbuf.st_dev;
3969 cino = statbuf.st_ino;
3971 if (odev == cdev && oino == cino) {
3974 if (!(dir = PerlDir_open("."))) {
3975 SV_CWD_RETURN_UNDEF;
3978 while ((dp = PerlDir_read(dir)) != NULL) {
3980 namelen = dp->d_namlen;
3982 namelen = strlen(dp->d_name);
3985 if (SV_CWD_ISDOT(dp)) {
3989 if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
3990 SV_CWD_RETURN_UNDEF;
3993 tdev = statbuf.st_dev;
3994 tino = statbuf.st_ino;
3995 if (tino == oino && tdev == odev) {
4001 SV_CWD_RETURN_UNDEF;
4004 if (pathlen + namelen + 1 >= MAXPATHLEN) {
4005 SV_CWD_RETURN_UNDEF;
4008 SvGROW(sv, pathlen + namelen + 1);
4012 Move(SvPVX(sv), SvPVX(sv) + namelen + 1, pathlen, char);
4015 /* prepend current directory to the front */
4017 Move(dp->d_name, SvPVX(sv)+1, namelen, char);
4018 pathlen += (namelen + 1);
4020 #ifdef VOID_CLOSEDIR
4023 if (PerlDir_close(dir) < 0) {
4024 SV_CWD_RETURN_UNDEF;
4030 SvCUR_set(sv, pathlen);
4034 if (PerlDir_chdir(SvPVX(sv)) < 0) {
4035 SV_CWD_RETURN_UNDEF;
4038 if (PerlLIO_stat(".", &statbuf) < 0) {
4039 SV_CWD_RETURN_UNDEF;
4042 cdev = statbuf.st_dev;
4043 cino = statbuf.st_ino;
4045 if (cdev != orig_cdev || cino != orig_cino) {
4046 Perl_croak(aTHX_ "Unstable directory path, "
4047 "current directory changed unexpectedly");
4059 =head1 SV Manipulation Functions
4061 =for apidoc scan_vstring
4063 Returns a pointer to the next character after the parsed
4064 vstring, as well as updating the passed in sv.
4066 Function must be called like
4069 s = scan_vstring(s,sv);
4071 The sv should already be large enough to store the vstring
4072 passed in, for performance reasons.
4078 Perl_scan_vstring(pTHX_ char *s, SV *sv)
4082 if (*pos == 'v') pos++; /* get past 'v' */
4083 while (isDIGIT(*pos) || *pos == '_')
4085 if (!isALPHA(*pos)) {
4087 U8 tmpbuf[UTF8_MAXLEN+1];
4090 if (*s == 'v') s++; /* get past 'v' */
4092 sv_setpvn(sv, "", 0);
4097 /* this is atoi() that tolerates underscores */
4100 while (--end >= s) {
4105 rev += (*end - '0') * mult;
4107 if (orev > rev && ckWARN_d(WARN_OVERFLOW))
4108 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
4109 "Integer overflow in decimal number");
4113 if (rev > 0x7FFFFFFF)
4114 Perl_croak(aTHX "In EBCDIC the v-string components cannot exceed 2147483647");
4116 /* Append native character for the rev point */
4117 tmpend = uvchr_to_utf8(tmpbuf, rev);
4118 sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
4119 if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(rev)))
4121 if (*pos == '.' && isDIGIT(pos[1]))
4127 while (isDIGIT(*pos) || *pos == '_')
4131 sv_magicext(sv,NULL,PERL_MAGIC_vstring,NULL,(const char*)start, pos-start);
4139 =for apidoc scan_version
4141 Returns a pointer to the next character after the parsed
4142 version string, as well as upgrading the passed in SV to
4145 Function must be called with an already existing SV like
4148 s = scan_version(s,sv);
4150 Performs some preprocessing to the string to ensure that
4151 it has the correct characteristics of a version. Flags the
4152 object if it contains an underscore (which denotes this
4159 Perl_scan_version(pTHX_ char *version, SV *rv)
4163 SV* sv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
4168 while (isDIGIT(*d) || *d == '.' || *d == '\0')
4172 if (*(d+1) == '0' && *(d+2) != '0') { /* perl-style version */
4175 if (ckWARN(WARN_PORTABLE))
4176 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
4177 "perl-style version not portable");
4183 while (isDIGIT(*d) || *d == '.' || *d == '\0')
4186 Perl_croak(aTHX_ "Invalid version format (multiple underscores)");
4188 version = scan_vstring(version, sv); /* store the v-string in the object */
4194 =for apidoc new_version
4196 Returns a new version object based on the passed in SV:
4198 SV *sv = new_version(SV *ver);
4200 Does not alter the passed in ver SV. See "upg_version" if you
4201 want to upgrade the SV.
4207 Perl_new_version(pTHX_ SV *ver)
4209 SV *rv = NEWSV(92,5);
4212 if ( SvMAGICAL(ver) ) { /* already a v-string */
4213 MAGIC* mg = mg_find(ver,PERL_MAGIC_vstring);
4214 version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
4217 version = (char *)SvPV_nolen(ver);
4219 version = scan_version(version,rv);
4224 =for apidoc upg_version
4226 In-place upgrade of the supplied SV to a version object.
4228 SV *sv = upg_version(SV *sv);
4230 Returns a pointer to the upgraded SV.
4236 Perl_upg_version(pTHX_ SV *sv)
4238 char *version = (char *)SvPV_nolen(sv_mortalcopy(sv));
4239 bool utf8 = SvUTF8(sv);
4240 if ( SvVOK(sv) ) { /* already a v-string */
4241 SV * ver = newSVrv(sv, "version");
4242 sv_setpv(ver,version);
4247 version = scan_version(version,sv);
4256 Accepts a version (or vstring) object and returns the
4257 normalized floating point representation. Call like:
4259 sv = vnumify(sv,SvRV(rv));
4261 NOTE: no checking is done to see if the object is of the
4262 correct type (for speed).
4268 Perl_vnumify(pTHX_ SV *sv, SV *vs)
4270 U8* pv = (U8*)SvPVX(vs);
4271 STRLEN len = SvCUR(vs);
4273 UV digit = utf8_to_uvchr(pv,&retlen);
4274 Perl_sv_setpvf(aTHX_ sv,"%"UVf".",digit);
4275 for (pv += retlen, len -= retlen;
4277 pv += retlen, len -= retlen)
4279 digit = utf8_to_uvchr(pv,&retlen);
4280 Perl_sv_catpvf(aTHX_ sv,"%03"UVf,digit);
4286 =for apidoc vstringify
4288 Accepts a version (or vstring) object and returns the
4289 normalized representation. Call like:
4291 sv = vstringify(sv,SvRV(rv));
4293 NOTE: no checking is done to see if the object is of the
4294 correct type (for speed).
4300 Perl_vstringify(pTHX_ SV *sv, SV *vs)
4302 U8* pv = (U8*)SvPVX(vs);
4303 STRLEN len = SvCUR(vs);
4305 UV digit = utf8_to_uvchr(pv,&retlen);
4306 Perl_sv_setpvf(aTHX_ sv,"%"UVf,digit);
4307 for (pv += retlen, len -= retlen;
4309 pv += retlen, len -= retlen)
4311 digit = utf8_to_uvchr(pv,&retlen);
4312 Perl_sv_catpvf(aTHX_ sv,".%"UVf,digit);
4314 if (SvIVX(vs) < 0) {
4315 char* pv = SvPVX(sv);
4316 for (pv += SvCUR(sv); *pv != '.'; pv--)
4323 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT)
4324 # define EMULATE_SOCKETPAIR_UDP
4327 #ifdef EMULATE_SOCKETPAIR_UDP
4329 S_socketpair_udp (int fd[2]) {
4331 /* Fake a datagram socketpair using UDP to localhost. */
4332 int sockets[2] = {-1, -1};
4333 struct sockaddr_in addresses[2];
4335 Sock_size_t size = sizeof(struct sockaddr_in);
4336 unsigned short port;
4339 memset(&addresses, 0, sizeof(addresses));
4342 sockets[i] = PerlSock_socket(AF_INET, SOCK_DGRAM, PF_INET);
4343 if (sockets[i] == -1)
4344 goto tidy_up_and_fail;
4346 addresses[i].sin_family = AF_INET;
4347 addresses[i].sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4348 addresses[i].sin_port = 0; /* kernel choses port. */
4349 if (PerlSock_bind(sockets[i], (struct sockaddr *) &addresses[i],
4350 sizeof(struct sockaddr_in)) == -1)
4351 goto tidy_up_and_fail;
4354 /* Now have 2 UDP sockets. Find out which port each is connected to, and
4355 for each connect the other socket to it. */
4358 if (PerlSock_getsockname(sockets[i], (struct sockaddr *) &addresses[i],
4360 goto tidy_up_and_fail;
4361 if (size != sizeof(struct sockaddr_in))
4362 goto abort_tidy_up_and_fail;
4363 /* !1 is 0, !0 is 1 */
4364 if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i],
4365 sizeof(struct sockaddr_in)) == -1)
4366 goto tidy_up_and_fail;
4369 /* Now we have 2 sockets connected to each other. I don't trust some other
4370 process not to have already sent a packet to us (by random) so send
4371 a packet from each to the other. */
4374 /* I'm going to send my own port number. As a short.
4375 (Who knows if someone somewhere has sin_port as a bitfield and needs
4376 this routine. (I'm assuming crays have socketpair)) */
4377 port = addresses[i].sin_port;
4378 got = PerlLIO_write(sockets[i], &port, sizeof(port));
4379 if (got != sizeof(port)) {
4381 goto tidy_up_and_fail;
4382 goto abort_tidy_up_and_fail;
4386 /* Packets sent. I don't trust them to have arrived though.
4387 (As I understand it Solaris TCP stack is multithreaded. Non-blocking
4388 connect to localhost will use a second kernel thread. In 2.6 the
4389 first thread running the connect() returns before the second completes,
4390 so EINPROGRESS> In 2.7 the improved stack is faster and connect()
4391 returns 0. Poor programs have tripped up. One poor program's authors'
4392 had a 50-1 reverse stock split. Not sure how connected these were.)
4393 So I don't trust someone not to have an unpredictable UDP stack.
4397 struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */
4398 int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0];
4402 FD_SET(sockets[0], &rset);
4403 FD_SET(sockets[1], &rset);
4405 got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor);
4406 if (got != 2 || !FD_ISSET(sockets[0], &rset)
4407 || !FD_ISSET(sockets[1], &rset)) {
4408 /* I hope this is portable and appropriate. */
4410 goto tidy_up_and_fail;
4411 goto abort_tidy_up_and_fail;
4415 /* And the paranoia department even now doesn't trust it to have arrive
4416 (hence MSG_DONTWAIT). Or that what arrives was sent by us. */
4418 struct sockaddr_in readfrom;
4419 unsigned short buffer[2];
4424 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4425 sizeof(buffer), MSG_DONTWAIT,
4426 (struct sockaddr *) &readfrom, &size);
4428 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4430 (struct sockaddr *) &readfrom, &size);
4434 goto tidy_up_and_fail;
4435 if (got != sizeof(port)
4436 || size != sizeof(struct sockaddr_in)
4437 /* Check other socket sent us its port. */
4438 || buffer[0] != (unsigned short) addresses[!i].sin_port
4439 /* Check kernel says we got the datagram from that socket */
4440 || readfrom.sin_family != addresses[!i].sin_family
4441 || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr
4442 || readfrom.sin_port != addresses[!i].sin_port)
4443 goto abort_tidy_up_and_fail;
4446 /* My caller (my_socketpair) has validated that this is non-NULL */
4449 /* I hereby declare this connection open. May God bless all who cross
4453 abort_tidy_up_and_fail:
4454 errno = ECONNABORTED;
4457 int save_errno = errno;
4458 if (sockets[0] != -1)
4459 PerlLIO_close(sockets[0]);
4460 if (sockets[1] != -1)
4461 PerlLIO_close(sockets[1]);
4466 #endif /* EMULATE_SOCKETPAIR_UDP */
4468 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET)
4470 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4471 /* Stevens says that family must be AF_LOCAL, protocol 0.
4472 I'm going to enforce that, then ignore it, and use TCP (or UDP). */
4477 struct sockaddr_in listen_addr;
4478 struct sockaddr_in connect_addr;
4483 || family != AF_UNIX
4486 errno = EAFNOSUPPORT;
4494 #ifdef EMULATE_SOCKETPAIR_UDP
4495 if (type == SOCK_DGRAM)
4496 return S_socketpair_udp(fd);
4499 listener = PerlSock_socket(AF_INET, type, 0);
4502 memset(&listen_addr, 0, sizeof(listen_addr));
4503 listen_addr.sin_family = AF_INET;
4504 listen_addr.sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4505 listen_addr.sin_port = 0; /* kernel choses port. */
4506 if (PerlSock_bind(listener, (struct sockaddr *) &listen_addr,
4507 sizeof(listen_addr)) == -1)
4508 goto tidy_up_and_fail;
4509 if (PerlSock_listen(listener, 1) == -1)
4510 goto tidy_up_and_fail;
4512 connector = PerlSock_socket(AF_INET, type, 0);
4513 if (connector == -1)
4514 goto tidy_up_and_fail;
4515 /* We want to find out the port number to connect to. */
4516 size = sizeof(connect_addr);
4517 if (PerlSock_getsockname(listener, (struct sockaddr *) &connect_addr,
4519 goto tidy_up_and_fail;
4520 if (size != sizeof(connect_addr))
4521 goto abort_tidy_up_and_fail;
4522 if (PerlSock_connect(connector, (struct sockaddr *) &connect_addr,
4523 sizeof(connect_addr)) == -1)
4524 goto tidy_up_and_fail;
4526 size = sizeof(listen_addr);
4527 acceptor = PerlSock_accept(listener, (struct sockaddr *) &listen_addr,
4530 goto tidy_up_and_fail;
4531 if (size != sizeof(listen_addr))
4532 goto abort_tidy_up_and_fail;
4533 PerlLIO_close(listener);
4534 /* Now check we are talking to ourself by matching port and host on the
4536 if (PerlSock_getsockname(connector, (struct sockaddr *) &connect_addr,
4538 goto tidy_up_and_fail;
4539 if (size != sizeof(connect_addr)
4540 || listen_addr.sin_family != connect_addr.sin_family
4541 || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr
4542 || listen_addr.sin_port != connect_addr.sin_port) {
4543 goto abort_tidy_up_and_fail;
4549 abort_tidy_up_and_fail:
4550 errno = ECONNABORTED; /* I hope this is portable and appropriate. */
4553 int save_errno = errno;
4555 PerlLIO_close(listener);
4556 if (connector != -1)
4557 PerlLIO_close(connector);
4559 PerlLIO_close(acceptor);
4565 /* In any case have a stub so that there's code corresponding
4566 * to the my_socketpair in global.sym. */
4568 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4569 #ifdef HAS_SOCKETPAIR
4570 return socketpair(family, type, protocol, fd);
4579 =for apidoc sv_nosharing
4581 Dummy routine which "shares" an SV when there is no sharing module present.
4582 Exists to avoid test for a NULL function pointer and because it could potentially warn under
4583 some level of strict-ness.
4589 Perl_sv_nosharing(pTHX_ SV *sv)
4594 =for apidoc sv_nolocking
4596 Dummy routine which "locks" 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_nolocking(pTHX_ SV *sv)
4610 =for apidoc sv_nounlocking
4612 Dummy routine which "unlocks" an SV when there is no locking module present.
4613 Exists to avoid test for a NULL function pointer and because it could potentially warn under
4614 some level of strict-ness.
4620 Perl_sv_nounlocking(pTHX_ SV *sv)