3 * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * "Very useful, no doubt, that was to Saruman; yet it seems that he was
13 * not content." --Gandalf
16 /* This file contains assorted utility routines.
17 * Which is a polite way of saying any stuff that people couldn't think of
18 * a better place for. Amongst other things, it includes the warning and
19 * dieing stuff, plus wrappers for malloc code.
23 #define PERL_IN_UTIL_C
29 # define SIG_ERR ((Sighandler_t) -1)
34 /* Missing protos on LynxOS */
39 # include <sys/wait.h>
44 # include <sys/select.h>
50 #if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC)
51 # define FD_CLOEXEC 1 /* NeXT needs this */
54 /* NOTE: Do not call the next three routines directly. Use the macros
55 * in handy.h, so that we can easily redefine everything to do tracking of
56 * allocated hunks back to the original New to track down any memory leaks.
57 * XXX This advice seems to be widely ignored :-( --AD August 1996.
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 /* Can't use PerlIO to write as it allocates memory */
87 PerlLIO_write(PerlIO_fileno(Perl_error_log),
88 PL_no_mem, strlen(PL_no_mem));
95 /* paranoid version of system's realloc() */
98 Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
102 #if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) && !defined(PERL_MICRO)
103 Malloc_t PerlMem_realloc();
104 #endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */
108 PerlIO_printf(Perl_error_log,
109 "Reallocation too large: %lx\n", size) FLUSH;
112 #endif /* HAS_64K_LIMIT */
119 return safesysmalloc(size);
122 Perl_croak_nocontext("panic: realloc");
124 ptr = (Malloc_t)PerlMem_realloc(where,size);
125 PERL_ALLOC_CHECK(ptr);
127 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++));
128 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
135 /* Can't use PerlIO to write as it allocates memory */
136 PerlLIO_write(PerlIO_fileno(Perl_error_log),
137 PL_no_mem, strlen(PL_no_mem));
144 /* safe version of system's free() */
147 Perl_safesysfree(Malloc_t where)
150 #ifdef PERL_IMPLICIT_SYS
153 DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) free\n",PTR2UV(where),(long)PL_an++));
160 /* safe version of system's calloc() */
163 Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
169 if (size * count > 0xffff) {
170 PerlIO_printf(Perl_error_log,
171 "Allocation too large: %lx\n", size * count) FLUSH;
174 #endif /* HAS_64K_LIMIT */
176 if ((long)size < 0 || (long)count < 0)
177 Perl_croak_nocontext("panic: calloc");
180 ptr = (Malloc_t)PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */
181 PERL_ALLOC_CHECK(ptr);
182 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));
184 memset((void*)ptr, 0, size);
190 /* Can't use PerlIO to write as it allocates memory */
191 PerlLIO_write(PerlIO_fileno(Perl_error_log),
192 PL_no_mem, strlen(PL_no_mem));
199 /* These must be defined when not using Perl's malloc for binary
204 Malloc_t Perl_malloc (MEM_SIZE nbytes)
207 return (Malloc_t)PerlMem_malloc(nbytes);
210 Malloc_t Perl_calloc (MEM_SIZE elements, MEM_SIZE size)
213 return (Malloc_t)PerlMem_calloc(elements, size);
216 Malloc_t Perl_realloc (Malloc_t where, MEM_SIZE nbytes)
219 return (Malloc_t)PerlMem_realloc(where, nbytes);
222 Free_t Perl_mfree (Malloc_t where)
230 /* copy a string up to some (non-backslashed) delimiter, if any */
233 Perl_delimcpy(pTHX_ register char *to, register const char *toend, register const char *from, register const char *fromend, register int delim, I32 *retlen)
236 for (tolen = 0; from < fromend; from++, tolen++) {
238 if (from[1] == delim)
247 else if (*from == delim)
258 /* return ptr to little string in big string, NULL if not found */
259 /* This routine was donated by Corey Satten. */
262 Perl_instr(pTHX_ register const char *big, register const char *little)
264 register const char *s, *x;
275 for (x=big,s=little; *s; /**/ ) {
284 return (char*)(big-1);
289 /* same as instr but allow embedded nulls */
292 Perl_ninstr(pTHX_ register const char *big, register const char *bigend, const char *little, const char *lend)
294 register const char *s, *x;
295 register const I32 first = *little;
296 register const char *littleend = lend;
298 if (!first && little >= littleend)
300 if (bigend - big < littleend - little)
302 bigend -= littleend - little++;
303 while (big <= bigend) {
306 for (x=big,s=little; s < littleend; /**/ ) {
313 return (char*)(big-1);
318 /* reverse of the above--find last substring */
321 Perl_rninstr(pTHX_ register const char *big, const char *bigend, const char *little, const char *lend)
323 register const char *bigbeg;
324 register const char *s, *x;
325 register const I32 first = *little;
326 register const char *littleend = lend;
328 if (!first && little >= littleend)
329 return (char*)bigend;
331 big = bigend - (littleend - little++);
332 while (big >= bigbeg) {
335 for (x=big+2,s=little; s < littleend; /**/ ) {
342 return (char*)(big+1);
347 #define FBM_TABLE_OFFSET 2 /* Number of bytes between EOS and table*/
349 /* As a space optimization, we do not compile tables for strings of length
350 0 and 1, and for strings of length 2 unless FBMcf_TAIL. These are
351 special-cased in fbm_instr().
353 If FBMcf_TAIL, the table is created as if the string has a trailing \n. */
356 =head1 Miscellaneous Functions
358 =for apidoc fbm_compile
360 Analyses the string in order to make fast searches on it using fbm_instr()
361 -- the Boyer-Moore algorithm.
367 Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
369 const register U8 *s;
376 if (flags & FBMcf_TAIL) {
377 MAGIC *mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
378 sv_catpvn(sv, "\n", 1); /* Taken into account in fbm_instr() */
379 if (mg && mg->mg_len >= 0)
382 s = (U8*)SvPV_force_mutable(sv, len);
383 SvUPGRADE(sv, SVt_PVBM);
384 if (len == 0) /* TAIL might be on a zero-length string. */
388 const unsigned char *sb;
394 Sv_Grow(sv, len + 256 + FBM_TABLE_OFFSET);
395 table = (unsigned char*)(SvPVX_mutable(sv) + len + FBM_TABLE_OFFSET);
396 s = table - 1 - FBM_TABLE_OFFSET; /* last char */
397 memset((void*)table, mlen, 256);
398 table[-1] = (U8)flags;
400 sb = s - mlen + 1; /* first char (maybe) */
402 if (table[*s] == mlen)
407 sv_magic(sv, Nullsv, PERL_MAGIC_bm, Nullch, 0); /* deep magic */
410 s = (const unsigned char*)(SvPVX_const(sv)); /* deeper magic */
411 for (i = 0; i < len; i++) {
412 if (PL_freq[s[i]] < frequency) {
414 frequency = PL_freq[s[i]];
417 BmRARE(sv) = s[rarest];
418 BmPREVIOUS(sv) = (U16)rarest;
419 BmUSEFUL(sv) = 100; /* Initial value */
420 if (flags & FBMcf_TAIL)
422 DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %d\n",
423 BmRARE(sv),BmPREVIOUS(sv)));
426 /* If SvTAIL(littlestr), it has a fake '\n' at end. */
427 /* If SvTAIL is actually due to \Z or \z, this gives false positives
431 =for apidoc fbm_instr
433 Returns the location of the SV in the string delimited by C<str> and
434 C<strend>. It returns C<Nullch> if the string can't be found. The C<sv>
435 does not have to be fbm_compiled, but the search will not be as fast
442 Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *littlestr, U32 flags)
444 register unsigned char *s;
446 register const unsigned char *little
447 = (const unsigned char *)SvPV_const(littlestr,l);
448 register STRLEN littlelen = l;
449 register const I32 multiline = flags & FBMrf_MULTILINE;
451 if ((STRLEN)(bigend - big) < littlelen) {
452 if ( SvTAIL(littlestr)
453 && ((STRLEN)(bigend - big) == littlelen - 1)
455 || (*big == *little &&
456 memEQ((char *)big, (char *)little, littlelen - 1))))
461 if (littlelen <= 2) { /* Special-cased */
463 if (littlelen == 1) {
464 if (SvTAIL(littlestr) && !multiline) { /* Anchor only! */
465 /* Know that bigend != big. */
466 if (bigend[-1] == '\n')
467 return (char *)(bigend - 1);
468 return (char *) bigend;
476 if (SvTAIL(littlestr))
477 return (char *) bigend;
481 return (char*)big; /* Cannot be SvTAIL! */
484 if (SvTAIL(littlestr) && !multiline) {
485 if (bigend[-1] == '\n' && bigend[-2] == *little)
486 return (char*)bigend - 2;
487 if (bigend[-1] == *little)
488 return (char*)bigend - 1;
492 /* This should be better than FBM if c1 == c2, and almost
493 as good otherwise: maybe better since we do less indirection.
494 And we save a lot of memory by caching no table. */
495 register unsigned char c1 = little[0];
496 register unsigned char c2 = little[1];
501 while (s <= bigend) {
511 goto check_1char_anchor;
522 goto check_1char_anchor;
525 while (s <= bigend) {
530 goto check_1char_anchor;
539 check_1char_anchor: /* One char and anchor! */
540 if (SvTAIL(littlestr) && (*bigend == *little))
541 return (char *)bigend; /* bigend is already decremented. */
544 if (SvTAIL(littlestr) && !multiline) { /* tail anchored? */
545 s = bigend - littlelen;
546 if (s >= big && bigend[-1] == '\n' && *s == *little
547 /* Automatically of length > 2 */
548 && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
550 return (char*)s; /* how sweet it is */
553 && memEQ((char*)s + 2, (char*)little + 1, littlelen - 2))
555 return (char*)s + 1; /* how sweet it is */
559 if (SvTYPE(littlestr) != SVt_PVBM || !SvVALID(littlestr)) {
560 char *b = ninstr((char*)big,(char*)bigend,
561 (char*)little, (char*)little + littlelen);
563 if (!b && SvTAIL(littlestr)) { /* Automatically multiline! */
564 /* Chop \n from littlestr: */
565 s = bigend - littlelen + 1;
567 && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
576 { /* Do actual FBM. */
577 register const unsigned char *table = little + littlelen + FBM_TABLE_OFFSET;
578 const register unsigned char *oldlittle;
580 if (littlelen > (STRLEN)(bigend - big))
582 --littlelen; /* Last char found by table lookup */
585 little += littlelen; /* last char */
592 if ((tmp = table[*s])) {
593 if ((s += tmp) < bigend)
597 else { /* less expensive than calling strncmp() */
598 register unsigned char *olds = s;
603 if (*--s == *--little)
605 s = olds + 1; /* here we pay the price for failure */
607 if (s < bigend) /* fake up continue to outer loop */
615 if ( s == bigend && (table[-1] & FBMcf_TAIL)
616 && memEQ((char *)(bigend - littlelen),
617 (char *)(oldlittle - littlelen), littlelen) )
618 return (char*)bigend - littlelen;
623 /* start_shift, end_shift are positive quantities which give offsets
624 of ends of some substring of bigstr.
625 If "last" we want the last occurrence.
626 old_posp is the way of communication between consequent calls if
627 the next call needs to find the .
628 The initial *old_posp should be -1.
630 Note that we take into account SvTAIL, so one can get extra
631 optimizations if _ALL flag is set.
634 /* If SvTAIL is actually due to \Z or \z, this gives false positives
635 if PL_multiline. In fact if !PL_multiline the authoritative answer
636 is not supported yet. */
639 Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last)
641 register unsigned char *s, *x;
642 register unsigned char *big;
644 register I32 previous;
646 register unsigned char *little;
647 register I32 stop_pos;
648 register unsigned char *littleend;
652 ? (pos = PL_screamfirst[BmRARE(littlestr)]) < 0
653 : (((pos = *old_posp), pos += PL_screamnext[pos]) == 0)) {
655 if ( BmRARE(littlestr) == '\n'
656 && BmPREVIOUS(littlestr) == SvCUR(littlestr) - 1) {
657 little = (unsigned char *)(SvPVX(littlestr));
658 littleend = little + SvCUR(littlestr);
665 little = (unsigned char *)(SvPVX(littlestr));
666 littleend = little + SvCUR(littlestr);
668 /* The value of pos we can start at: */
669 previous = BmPREVIOUS(littlestr);
670 big = (unsigned char *)(SvPVX(bigstr));
671 /* The value of pos we can stop at: */
672 stop_pos = SvCUR(bigstr) - end_shift - (SvCUR(littlestr) - 1 - previous);
673 if (previous + start_shift > stop_pos) {
675 stop_pos does not include SvTAIL in the count, so this check is incorrect
676 (I think) - see [ID 20010618.006] and t/op/study.t. HVDS 2001/06/19
679 if (previous + start_shift == stop_pos + 1) /* A fake '\n'? */
684 while (pos < previous + start_shift) {
685 if (!(pos += PL_screamnext[pos]))
690 if (pos >= stop_pos) break;
691 if (big[pos] != first)
693 for (x=big+pos+1,s=little; s < littleend; /**/ ) {
699 if (s == littleend) {
701 if (!last) return (char *)(big+pos);
704 } while ( pos += PL_screamnext[pos] );
706 return (char *)(big+(*old_posp));
708 if (!SvTAIL(littlestr) || (end_shift > 0))
710 /* Ignore the trailing "\n". This code is not microoptimized */
711 big = (unsigned char *)(SvPVX(bigstr) + SvCUR(bigstr));
712 stop_pos = littleend - little; /* Actual littlestr len */
717 && ((stop_pos == 1) ||
718 memEQ((char *)(big + 1), (char *)little, stop_pos - 1)))
724 Perl_ibcmp(pTHX_ const char *s1, const char *s2, register I32 len)
726 register const U8 *a = (const U8 *)s1;
727 register const U8 *b = (const U8 *)s2;
729 if (*a != *b && *a != PL_fold[*b])
737 Perl_ibcmp_locale(pTHX_ const char *s1, const char *s2, register I32 len)
740 register const U8 *a = (const U8 *)s1;
741 register const U8 *b = (const U8 *)s2;
743 if (*a != *b && *a != PL_fold_locale[*b])
750 /* copy a string to a safe spot */
753 =head1 Memory Management
757 Perl's version of C<strdup()>. Returns a pointer to a newly allocated
758 string which is a duplicate of C<pv>. The size of the string is
759 determined by C<strlen()>. The memory allocated for the new string can
760 be freed with the C<Safefree()> function.
766 Perl_savepv(pTHX_ const char *pv)
768 register char *newaddr;
769 #ifdef PERL_MALLOC_WRAP
775 #ifdef PERL_MALLOC_WRAP
776 pvlen = strlen(pv)+1;
777 New(902,newaddr,pvlen,char);
779 New(902,newaddr,strlen(pv)+1,char);
781 return strcpy(newaddr,pv);
784 /* same thing but with a known length */
789 Perl's version of what C<strndup()> would be if it existed. Returns a
790 pointer to a newly allocated string which is a duplicate of the first
791 C<len> bytes from C<pv>. The memory allocated for the new string can be
792 freed with the C<Safefree()> function.
798 Perl_savepvn(pTHX_ const char *pv, register I32 len)
800 register char *newaddr;
802 New(903,newaddr,len+1,char);
803 /* Give a meaning to NULL pointer mainly for the use in sv_magic() */
805 /* might not be null terminated */
807 return (char *) CopyD(pv,newaddr,len,char);
810 return (char *) ZeroD(newaddr,len+1,char);
815 =for apidoc savesharedpv
817 A version of C<savepv()> which allocates the duplicate string in memory
818 which is shared between threads.
823 Perl_savesharedpv(pTHX_ const char *pv)
825 register char *newaddr;
829 newaddr = (char*)PerlMemShared_malloc(strlen(pv)+1);
831 PerlLIO_write(PerlIO_fileno(Perl_error_log),
832 PL_no_mem, strlen(PL_no_mem));
835 return strcpy(newaddr,pv);
841 A version of C<savepv()>/C<savepvn()> which gets the string to duplicate from
842 the passed in SV using C<SvPV()>
848 Perl_savesvpv(pTHX_ SV *sv)
851 const char *pv = SvPV(sv, len);
852 register char *newaddr;
855 New(903,newaddr,len,char);
856 return (char *) CopyD(pv,newaddr,len,char);
860 /* the SV for Perl_form() and mess() is not kept in an arena */
869 return sv_2mortal(newSVpvn("",0));
874 /* Create as PVMG now, to avoid any upgrading later */
876 Newz(905, any, 1, XPVMG);
877 SvFLAGS(sv) = SVt_PVMG;
878 SvANY(sv) = (void*)any;
880 SvREFCNT(sv) = 1 << 30; /* practically infinite */
885 #if defined(PERL_IMPLICIT_CONTEXT)
887 Perl_form_nocontext(const char* pat, ...)
893 retval = vform(pat, &args);
897 #endif /* PERL_IMPLICIT_CONTEXT */
900 =head1 Miscellaneous Functions
903 Takes a sprintf-style format pattern and conventional
904 (non-SV) arguments and returns the formatted string.
906 (char *) Perl_form(pTHX_ const char* pat, ...)
908 can be used any place a string (char *) is required:
910 char * s = Perl_form("%d.%d",major,minor);
912 Uses a single private buffer so if you want to format several strings you
913 must explicitly copy the earlier strings away (and free the copies when you
920 Perl_form(pTHX_ const char* pat, ...)
925 retval = vform(pat, &args);
931 Perl_vform(pTHX_ const char *pat, va_list *args)
933 SV *sv = mess_alloc();
934 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
938 #if defined(PERL_IMPLICIT_CONTEXT)
940 Perl_mess_nocontext(const char *pat, ...)
946 retval = vmess(pat, &args);
950 #endif /* PERL_IMPLICIT_CONTEXT */
953 Perl_mess(pTHX_ const char *pat, ...)
958 retval = vmess(pat, &args);
964 S_closest_cop(pTHX_ COP *cop, OP *o)
966 /* Look for PL_op starting from o. cop is the last COP we've seen. */
968 if (!o || o == PL_op) return cop;
970 if (o->op_flags & OPf_KIDS) {
972 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
976 /* If the OP_NEXTSTATE has been optimised away we can still use it
977 * the get the file and line number. */
979 if (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE)
982 /* Keep searching, and return when we've found something. */
984 new_cop = closest_cop(cop, kid);
985 if (new_cop) return new_cop;
995 Perl_vmess(pTHX_ const char *pat, va_list *args)
997 SV *sv = mess_alloc();
998 static const char dgd[] = " during global destruction.\n";
1000 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
1001 if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
1004 * Try and find the file and line for PL_op. This will usually be
1005 * PL_curcop, but it might be a cop that has been optimised away. We
1006 * can try to find such a cop by searching through the optree starting
1007 * from the sibling of PL_curcop.
1010 const COP *cop = closest_cop(PL_curcop, PL_curcop->op_sibling);
1011 if (!cop) cop = PL_curcop;
1014 Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf,
1015 OutCopFILE(cop), (IV)CopLINE(cop));
1016 if (GvIO(PL_last_in_gv) && IoLINES(GvIOp(PL_last_in_gv))) {
1017 const bool line_mode = (RsSIMPLE(PL_rs) &&
1018 SvCUR(PL_rs) == 1 && *SvPVX_const(PL_rs) == '\n');
1019 Perl_sv_catpvf(aTHX_ sv, ", <%s> %s %"IVdf,
1020 PL_last_in_gv == PL_argvgv ?
1021 "" : GvNAME(PL_last_in_gv),
1022 line_mode ? "line" : "chunk",
1023 (IV)IoLINES(GvIOp(PL_last_in_gv)));
1025 sv_catpv(sv, PL_dirty ? dgd : ".\n");
1031 Perl_write_to_stderr(pTHX_ const char* message, int msglen)
1037 if (PL_stderrgv && SvREFCNT(PL_stderrgv)
1038 && (io = GvIO(PL_stderrgv))
1039 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
1046 SAVESPTR(PL_stderrgv);
1047 PL_stderrgv = Nullgv;
1049 PUSHSTACKi(PERLSI_MAGIC);
1053 PUSHs(SvTIED_obj((SV*)io, mg));
1054 PUSHs(sv_2mortal(newSVpvn(message, msglen)));
1056 call_method("PRINT", G_SCALAR);
1064 /* SFIO can really mess with your errno */
1067 PerlIO *serr = Perl_error_log;
1069 PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
1070 (void)PerlIO_flush(serr);
1077 /* Common code used by vcroak, vdie and vwarner */
1080 S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8)
1085 /* sv_2cv might call Perl_croak() */
1086 SV *olddiehook = PL_diehook;
1090 SAVESPTR(PL_diehook);
1091 PL_diehook = Nullsv;
1092 cv = sv_2cv(olddiehook, &stash, &gv, 0);
1094 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1101 msg = newSVpvn(message, msglen);
1102 SvFLAGS(msg) |= utf8;
1110 PUSHSTACKi(PERLSI_DIEHOOK);
1114 call_sv((SV*)cv, G_DISCARD);
1121 S_vdie_croak_common(pTHX_ const char* pat, va_list* args, STRLEN* msglen,
1128 SV *msv = vmess(pat, args);
1129 if (PL_errors && SvCUR(PL_errors)) {
1130 sv_catsv(PL_errors, msv);
1131 message = SvPV(PL_errors, *msglen);
1132 SvCUR_set(PL_errors, 0);
1135 message = SvPV(msv,*msglen);
1136 *utf8 = SvUTF8(msv);
1142 DEBUG_S(PerlIO_printf(Perl_debug_log,
1143 "%p: die/croak: message = %s\ndiehook = %p\n",
1144 thr, message, PL_diehook));
1146 S_vdie_common(aTHX_ message, *msglen, *utf8);
1152 Perl_vdie(pTHX_ const char* pat, va_list *args)
1154 const char *message;
1155 const int was_in_eval = PL_in_eval;
1159 DEBUG_S(PerlIO_printf(Perl_debug_log,
1160 "%p: die: curstack = %p, mainstack = %p\n",
1161 thr, PL_curstack, PL_mainstack));
1163 message = S_vdie_croak_common(aTHX_ pat, args, &msglen, &utf8);
1165 PL_restartop = die_where(message, msglen);
1166 SvFLAGS(ERRSV) |= utf8;
1167 DEBUG_S(PerlIO_printf(Perl_debug_log,
1168 "%p: die: restartop = %p, was_in_eval = %d, top_env = %p\n",
1169 thr, PL_restartop, was_in_eval, PL_top_env));
1170 if ((!PL_restartop && was_in_eval) || PL_top_env->je_prev)
1172 return PL_restartop;
1175 #if defined(PERL_IMPLICIT_CONTEXT)
1177 Perl_die_nocontext(const char* pat, ...)
1182 va_start(args, pat);
1183 o = vdie(pat, &args);
1187 #endif /* PERL_IMPLICIT_CONTEXT */
1190 Perl_die(pTHX_ const char* pat, ...)
1194 va_start(args, pat);
1195 o = vdie(pat, &args);
1201 Perl_vcroak(pTHX_ const char* pat, va_list *args)
1203 const char *message;
1207 message = S_vdie_croak_common(aTHX_ pat, args, &msglen, &utf8);
1210 PL_restartop = die_where(message, msglen);
1211 SvFLAGS(ERRSV) |= utf8;
1215 message = SvPVx(ERRSV, msglen);
1217 write_to_stderr(message, msglen);
1221 #if defined(PERL_IMPLICIT_CONTEXT)
1223 Perl_croak_nocontext(const char *pat, ...)
1227 va_start(args, pat);
1232 #endif /* PERL_IMPLICIT_CONTEXT */
1235 =head1 Warning and Dieing
1239 This is the XSUB-writer's interface to Perl's C<die> function.
1240 Normally call this function the same way you call the C C<printf>
1241 function. Calling C<croak> returns control directly to Perl,
1242 sidestepping the normal C order of execution. See C<warn>.
1244 If you want to throw an exception object, assign the object to
1245 C<$@> and then pass C<Nullch> to croak():
1247 errsv = get_sv("@", TRUE);
1248 sv_setsv(errsv, exception_object);
1255 Perl_croak(pTHX_ const char *pat, ...)
1258 va_start(args, pat);
1265 Perl_vwarn(pTHX_ const char* pat, va_list *args)
1276 msv = vmess(pat, args);
1278 message = SvPV(msv, msglen);
1281 /* sv_2cv might call Perl_warn() */
1282 SV *oldwarnhook = PL_warnhook;
1284 SAVESPTR(PL_warnhook);
1285 PL_warnhook = Nullsv;
1286 cv = sv_2cv(oldwarnhook, &stash, &gv, 0);
1288 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1294 msg = newSVpvn(message, msglen);
1295 SvFLAGS(msg) |= utf8;
1299 PUSHSTACKi(PERLSI_WARNHOOK);
1303 call_sv((SV*)cv, G_DISCARD);
1310 write_to_stderr(message, msglen);
1313 #if defined(PERL_IMPLICIT_CONTEXT)
1315 Perl_warn_nocontext(const char *pat, ...)
1319 va_start(args, pat);
1323 #endif /* PERL_IMPLICIT_CONTEXT */
1328 This is the XSUB-writer's interface to Perl's C<warn> function. Call this
1329 function the same way you call the C C<printf> function. See C<croak>.
1335 Perl_warn(pTHX_ const char *pat, ...)
1338 va_start(args, pat);
1343 #if defined(PERL_IMPLICIT_CONTEXT)
1345 Perl_warner_nocontext(U32 err, const char *pat, ...)
1349 va_start(args, pat);
1350 vwarner(err, pat, &args);
1353 #endif /* PERL_IMPLICIT_CONTEXT */
1356 Perl_warner(pTHX_ U32 err, const char* pat,...)
1359 va_start(args, pat);
1360 vwarner(err, pat, &args);
1365 Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args)
1369 SV * const msv = vmess(pat, args);
1371 const char *message = SvPV(msv, msglen);
1372 const I32 utf8 = SvUTF8(msv);
1376 S_vdie_common(aTHX_ message, msglen, utf8);
1379 PL_restartop = die_where(message, msglen);
1380 SvFLAGS(ERRSV) |= utf8;
1383 write_to_stderr(message, msglen);
1387 Perl_vwarn(aTHX_ pat, args);
1391 /* since we've already done strlen() for both nam and val
1392 * we can use that info to make things faster than
1393 * sprintf(s, "%s=%s", nam, val)
1395 #define my_setenv_format(s, nam, nlen, val, vlen) \
1396 Copy(nam, s, nlen, char); \
1398 Copy(val, s+(nlen+1), vlen, char); \
1399 *(s+(nlen+1+vlen)) = '\0'
1401 #ifdef USE_ENVIRON_ARRAY
1402 /* VMS' my_setenv() is in vms.c */
1403 #if !defined(WIN32) && !defined(NETWARE)
1405 Perl_my_setenv(pTHX_ const char *nam, const char *val)
1409 /* only parent thread can modify process environment */
1410 if (PL_curinterp == aTHX)
1413 #ifndef PERL_USE_SAFE_PUTENV
1414 if (!PL_use_safe_putenv) {
1415 /* most putenv()s leak, so we manipulate environ directly */
1416 register I32 i=setenv_getix(nam); /* where does it go? */
1419 if (environ == PL_origenviron) { /* need we copy environment? */
1425 for (max = i; environ[max]; max++) ;
1426 tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*));
1427 for (j=0; j<max; j++) { /* copy environment */
1428 const int len = strlen(environ[j]);
1429 tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char));
1430 Copy(environ[j], tmpenv[j], len+1, char);
1432 tmpenv[max] = Nullch;
1433 environ = tmpenv; /* tell exec where it is now */
1436 safesysfree(environ[i]);
1437 while (environ[i]) {
1438 environ[i] = environ[i+1];
1443 if (!environ[i]) { /* does not exist yet */
1444 environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
1445 environ[i+1] = Nullch; /* make sure it's null terminated */
1448 safesysfree(environ[i]);
1452 environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char));
1453 /* all that work just for this */
1454 my_setenv_format(environ[i], nam, nlen, val, vlen);
1457 # if defined(__CYGWIN__) || defined(EPOC) || defined(SYMBIAN)
1458 setenv(nam, val, 1);
1461 int nlen = strlen(nam), vlen;
1466 new_env = (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
1467 /* all that work just for this */
1468 my_setenv_format(new_env, nam, nlen, val, vlen);
1469 (void)putenv(new_env);
1470 # endif /* __CYGWIN__ */
1471 #ifndef PERL_USE_SAFE_PUTENV
1477 #else /* WIN32 || NETWARE */
1480 Perl_my_setenv(pTHX_ const char *nam, const char *val)
1483 register char *envstr;
1484 const int nlen = strlen(nam);
1491 New(904, envstr, nlen+vlen+2, char);
1492 my_setenv_format(envstr, nam, nlen, val, vlen);
1493 (void)PerlEnv_putenv(envstr);
1497 #endif /* WIN32 || NETWARE */
1501 Perl_setenv_getix(pTHX_ const char *nam)
1503 register I32 i, len = strlen(nam);
1505 for (i = 0; environ[i]; i++) {
1508 strnicmp(environ[i],nam,len) == 0
1510 strnEQ(environ[i],nam,len)
1512 && environ[i][len] == '=')
1513 break; /* strnEQ must come first to avoid */
1514 } /* potential SEGV's */
1517 #endif /* !PERL_MICRO */
1519 #endif /* !VMS && !EPOC*/
1521 #ifdef UNLINK_ALL_VERSIONS
1523 Perl_unlnk(pTHX_ char *f) /* unlink all versions of a file */
1527 for (i = 0; PerlLIO_unlink(f) >= 0; i++) ;
1532 /* this is a drop-in replacement for bcopy() */
1533 #if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY))
1535 Perl_my_bcopy(register const char *from,register char *to,register I32 len)
1539 if (from - to >= 0) {
1547 *(--to) = *(--from);
1553 /* this is a drop-in replacement for memset() */
1556 Perl_my_memset(register char *loc, register I32 ch, register I32 len)
1566 /* this is a drop-in replacement for bzero() */
1567 #if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
1569 Perl_my_bzero(register char *loc, register I32 len)
1579 /* this is a drop-in replacement for memcmp() */
1580 #if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
1582 Perl_my_memcmp(const char *s1, const char *s2, register I32 len)
1584 register const U8 *a = (const U8 *)s1;
1585 register const U8 *b = (const U8 *)s2;
1589 if ((tmp = *a++ - *b++))
1594 #endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */
1598 #ifdef USE_CHAR_VSPRINTF
1603 vsprintf(char *dest, const char *pat, char *args)
1607 fakebuf._ptr = dest;
1608 fakebuf._cnt = 32767;
1612 fakebuf._flag = _IOWRT|_IOSTRG;
1613 _doprnt(pat, args, &fakebuf); /* what a kludge */
1614 (void)putc('\0', &fakebuf);
1615 #ifdef USE_CHAR_VSPRINTF
1618 return 0; /* perl doesn't use return value */
1622 #endif /* HAS_VPRINTF */
1625 #if BYTEORDER != 0x4321
1627 Perl_my_swap(pTHX_ short s)
1629 #if (BYTEORDER & 1) == 0
1632 result = ((s & 255) << 8) + ((s >> 8) & 255);
1640 Perl_my_htonl(pTHX_ long l)
1644 char c[sizeof(long)];
1647 #if BYTEORDER == 0x1234
1648 u.c[0] = (l >> 24) & 255;
1649 u.c[1] = (l >> 16) & 255;
1650 u.c[2] = (l >> 8) & 255;
1654 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
1655 Perl_croak(aTHX_ "Unknown BYTEORDER\n");
1660 for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
1661 u.c[o & 0xf] = (l >> s) & 255;
1669 Perl_my_ntohl(pTHX_ long l)
1673 char c[sizeof(long)];
1676 #if BYTEORDER == 0x1234
1677 u.c[0] = (l >> 24) & 255;
1678 u.c[1] = (l >> 16) & 255;
1679 u.c[2] = (l >> 8) & 255;
1683 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
1684 Perl_croak(aTHX_ "Unknown BYTEORDER\n");
1691 for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
1692 l |= (u.c[o & 0xf] & 255) << s;
1699 #endif /* BYTEORDER != 0x4321 */
1703 * Little-endian byte order functions - 'v' for 'VAX', or 'reVerse'.
1704 * If these functions are defined,
1705 * the BYTEORDER is neither 0x1234 nor 0x4321.
1706 * However, this is not assumed.
1710 #define HTOLE(name,type) \
1712 name (register type n) \
1716 char c[sizeof(type)]; \
1719 register I32 s = 0; \
1720 for (i = 0; i < sizeof(u.c); i++, s += 8) { \
1721 u.c[i] = (n >> s) & 0xFF; \
1726 #define LETOH(name,type) \
1728 name (register type n) \
1732 char c[sizeof(type)]; \
1735 register I32 s = 0; \
1738 for (i = 0; i < sizeof(u.c); i++, s += 8) { \
1739 n |= ((type)(u.c[i] & 0xFF)) << s; \
1745 * Big-endian byte order functions.
1748 #define HTOBE(name,type) \
1750 name (register type n) \
1754 char c[sizeof(type)]; \
1757 register I32 s = 8*(sizeof(u.c)-1); \
1758 for (i = 0; i < sizeof(u.c); i++, s -= 8) { \
1759 u.c[i] = (n >> s) & 0xFF; \
1764 #define BETOH(name,type) \
1766 name (register type n) \
1770 char c[sizeof(type)]; \
1773 register I32 s = 8*(sizeof(u.c)-1); \
1776 for (i = 0; i < sizeof(u.c); i++, s -= 8) { \
1777 n |= ((type)(u.c[i] & 0xFF)) << s; \
1783 * If we just can't do it...
1786 #define NOT_AVAIL(name,type) \
1788 name (register type n) \
1790 Perl_croak_nocontext(#name "() not available"); \
1791 return n; /* not reached */ \
1795 #if defined(HAS_HTOVS) && !defined(htovs)
1798 #if defined(HAS_HTOVL) && !defined(htovl)
1801 #if defined(HAS_VTOHS) && !defined(vtohs)
1804 #if defined(HAS_VTOHL) && !defined(vtohl)
1808 #ifdef PERL_NEED_MY_HTOLE16
1810 HTOLE(Perl_my_htole16,U16)
1812 NOT_AVAIL(Perl_my_htole16,U16)
1815 #ifdef PERL_NEED_MY_LETOH16
1817 LETOH(Perl_my_letoh16,U16)
1819 NOT_AVAIL(Perl_my_letoh16,U16)
1822 #ifdef PERL_NEED_MY_HTOBE16
1824 HTOBE(Perl_my_htobe16,U16)
1826 NOT_AVAIL(Perl_my_htobe16,U16)
1829 #ifdef PERL_NEED_MY_BETOH16
1831 BETOH(Perl_my_betoh16,U16)
1833 NOT_AVAIL(Perl_my_betoh16,U16)
1837 #ifdef PERL_NEED_MY_HTOLE32
1839 HTOLE(Perl_my_htole32,U32)
1841 NOT_AVAIL(Perl_my_htole32,U32)
1844 #ifdef PERL_NEED_MY_LETOH32
1846 LETOH(Perl_my_letoh32,U32)
1848 NOT_AVAIL(Perl_my_letoh32,U32)
1851 #ifdef PERL_NEED_MY_HTOBE32
1853 HTOBE(Perl_my_htobe32,U32)
1855 NOT_AVAIL(Perl_my_htobe32,U32)
1858 #ifdef PERL_NEED_MY_BETOH32
1860 BETOH(Perl_my_betoh32,U32)
1862 NOT_AVAIL(Perl_my_betoh32,U32)
1866 #ifdef PERL_NEED_MY_HTOLE64
1868 HTOLE(Perl_my_htole64,U64)
1870 NOT_AVAIL(Perl_my_htole64,U64)
1873 #ifdef PERL_NEED_MY_LETOH64
1875 LETOH(Perl_my_letoh64,U64)
1877 NOT_AVAIL(Perl_my_letoh64,U64)
1880 #ifdef PERL_NEED_MY_HTOBE64
1882 HTOBE(Perl_my_htobe64,U64)
1884 NOT_AVAIL(Perl_my_htobe64,U64)
1887 #ifdef PERL_NEED_MY_BETOH64
1889 BETOH(Perl_my_betoh64,U64)
1891 NOT_AVAIL(Perl_my_betoh64,U64)
1895 #ifdef PERL_NEED_MY_HTOLES
1896 HTOLE(Perl_my_htoles,short)
1898 #ifdef PERL_NEED_MY_LETOHS
1899 LETOH(Perl_my_letohs,short)
1901 #ifdef PERL_NEED_MY_HTOBES
1902 HTOBE(Perl_my_htobes,short)
1904 #ifdef PERL_NEED_MY_BETOHS
1905 BETOH(Perl_my_betohs,short)
1908 #ifdef PERL_NEED_MY_HTOLEI
1909 HTOLE(Perl_my_htolei,int)
1911 #ifdef PERL_NEED_MY_LETOHI
1912 LETOH(Perl_my_letohi,int)
1914 #ifdef PERL_NEED_MY_HTOBEI
1915 HTOBE(Perl_my_htobei,int)
1917 #ifdef PERL_NEED_MY_BETOHI
1918 BETOH(Perl_my_betohi,int)
1921 #ifdef PERL_NEED_MY_HTOLEL
1922 HTOLE(Perl_my_htolel,long)
1924 #ifdef PERL_NEED_MY_LETOHL
1925 LETOH(Perl_my_letohl,long)
1927 #ifdef PERL_NEED_MY_HTOBEL
1928 HTOBE(Perl_my_htobel,long)
1930 #ifdef PERL_NEED_MY_BETOHL
1931 BETOH(Perl_my_betohl,long)
1935 Perl_my_swabn(void *ptr, int n)
1937 register char *s = (char *)ptr;
1938 register char *e = s + (n-1);
1941 for (n /= 2; n > 0; s++, e--, n--) {
1949 Perl_my_popen_list(pTHX_ char *mode, int n, SV **args)
1951 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) && !defined(NETWARE)
1953 register I32 This, that;
1959 PERL_FLUSHALL_FOR_CHILD;
1960 This = (*mode == 'w');
1964 taint_proper("Insecure %s%s", "EXEC");
1966 if (PerlProc_pipe(p) < 0)
1968 /* Try for another pipe pair for error return */
1969 if (PerlProc_pipe(pp) >= 0)
1971 while ((pid = PerlProc_fork()) < 0) {
1972 if (errno != EAGAIN) {
1973 PerlLIO_close(p[This]);
1974 PerlLIO_close(p[that]);
1976 PerlLIO_close(pp[0]);
1977 PerlLIO_close(pp[1]);
1989 /* Close parent's end of error status pipe (if any) */
1991 PerlLIO_close(pp[0]);
1992 #if defined(HAS_FCNTL) && defined(F_SETFD)
1993 /* Close error pipe automatically if exec works */
1994 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
1997 /* Now dup our end of _the_ pipe to right position */
1998 if (p[THIS] != (*mode == 'r')) {
1999 PerlLIO_dup2(p[THIS], *mode == 'r');
2000 PerlLIO_close(p[THIS]);
2001 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2002 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
2005 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
2006 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2007 /* No automatic close - do it by hand */
2014 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) {
2020 do_aexec5(Nullsv, args-1, args-1+n, pp[1], did_pipes);
2026 do_execfree(); /* free any memory malloced by child on fork */
2028 PerlLIO_close(pp[1]);
2029 /* Keep the lower of the two fd numbers */
2030 if (p[that] < p[This]) {
2031 PerlLIO_dup2(p[This], p[that]);
2032 PerlLIO_close(p[This]);
2036 PerlLIO_close(p[that]); /* close child's end of pipe */
2039 sv = *av_fetch(PL_fdpid,p[This],TRUE);
2041 SvUPGRADE(sv,SVt_IV);
2043 PL_forkprocess = pid;
2044 /* If we managed to get status pipe check for exec fail */
2045 if (did_pipes && pid > 0) {
2049 while (n < sizeof(int)) {
2050 n1 = PerlLIO_read(pp[0],
2051 (void*)(((char*)&errkid)+n),
2057 PerlLIO_close(pp[0]);
2059 if (n) { /* Error */
2061 PerlLIO_close(p[This]);
2062 if (n != sizeof(int))
2063 Perl_croak(aTHX_ "panic: kid popen errno read");
2065 pid2 = wait4pid(pid, &status, 0);
2066 } while (pid2 == -1 && errno == EINTR);
2067 errno = errkid; /* Propagate errno from kid */
2072 PerlLIO_close(pp[0]);
2073 return PerlIO_fdopen(p[This], mode);
2075 Perl_croak(aTHX_ "List form of piped open not implemented");
2076 return (PerlIO *) NULL;
2080 /* VMS' my_popen() is in VMS.c, same with OS/2. */
2081 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
2083 Perl_my_popen(pTHX_ char *cmd, char *mode)
2086 register I32 This, that;
2089 I32 doexec = !(*cmd == '-' && cmd[1] == '\0');
2093 PERL_FLUSHALL_FOR_CHILD;
2096 return my_syspopen(aTHX_ cmd,mode);
2099 This = (*mode == 'w');
2101 if (doexec && PL_tainting) {
2103 taint_proper("Insecure %s%s", "EXEC");
2105 if (PerlProc_pipe(p) < 0)
2107 if (doexec && PerlProc_pipe(pp) >= 0)
2109 while ((pid = PerlProc_fork()) < 0) {
2110 if (errno != EAGAIN) {
2111 PerlLIO_close(p[This]);
2112 PerlLIO_close(p[that]);
2114 PerlLIO_close(pp[0]);
2115 PerlLIO_close(pp[1]);
2118 Perl_croak(aTHX_ "Can't fork");
2131 PerlLIO_close(pp[0]);
2132 #if defined(HAS_FCNTL) && defined(F_SETFD)
2133 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2136 if (p[THIS] != (*mode == 'r')) {
2137 PerlLIO_dup2(p[THIS], *mode == 'r');
2138 PerlLIO_close(p[THIS]);
2139 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2140 PerlLIO_close(p[THAT]);
2143 PerlLIO_close(p[THAT]);
2146 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2153 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
2158 /* may or may not use the shell */
2159 do_exec3(cmd, pp[1], did_pipes);
2162 #endif /* defined OS2 */
2164 if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) {
2165 SvREADONLY_off(GvSV(tmpgv));
2166 sv_setiv(GvSV(tmpgv), PerlProc_getpid());
2167 SvREADONLY_on(GvSV(tmpgv));
2169 #ifdef THREADS_HAVE_PIDS
2170 PL_ppid = (IV)getppid();
2173 hv_clear(PL_pidstatus); /* we have no children */
2178 do_execfree(); /* free any memory malloced by child on vfork */
2180 PerlLIO_close(pp[1]);
2181 if (p[that] < p[This]) {
2182 PerlLIO_dup2(p[This], p[that]);
2183 PerlLIO_close(p[This]);
2187 PerlLIO_close(p[that]);
2190 sv = *av_fetch(PL_fdpid,p[This],TRUE);
2192 SvUPGRADE(sv,SVt_IV);
2194 PL_forkprocess = pid;
2195 if (did_pipes && pid > 0) {
2199 while (n < sizeof(int)) {
2200 n1 = PerlLIO_read(pp[0],
2201 (void*)(((char*)&errkid)+n),
2207 PerlLIO_close(pp[0]);
2209 if (n) { /* Error */
2211 PerlLIO_close(p[This]);
2212 if (n != sizeof(int))
2213 Perl_croak(aTHX_ "panic: kid popen errno read");
2215 pid2 = wait4pid(pid, &status, 0);
2216 } while (pid2 == -1 && errno == EINTR);
2217 errno = errkid; /* Propagate errno from kid */
2222 PerlLIO_close(pp[0]);
2223 return PerlIO_fdopen(p[This], mode);
2226 #if defined(atarist) || defined(EPOC)
2229 Perl_my_popen(pTHX_ char *cmd, char *mode)
2231 PERL_FLUSHALL_FOR_CHILD;
2232 /* Call system's popen() to get a FILE *, then import it.
2233 used 0 for 2nd parameter to PerlIO_importFILE;
2236 return PerlIO_importFILE(popen(cmd, mode), 0);
2240 FILE *djgpp_popen();
2242 Perl_my_popen(pTHX_ char *cmd, char *mode)
2244 PERL_FLUSHALL_FOR_CHILD;
2245 /* Call system's popen() to get a FILE *, then import it.
2246 used 0 for 2nd parameter to PerlIO_importFILE;
2249 return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
2254 #endif /* !DOSISH */
2256 /* this is called in parent before the fork() */
2258 Perl_atfork_lock(void)
2261 #if defined(USE_ITHREADS)
2262 /* locks must be held in locking order (if any) */
2264 MUTEX_LOCK(&PL_malloc_mutex);
2270 /* this is called in both parent and child after the fork() */
2272 Perl_atfork_unlock(void)
2275 #if defined(USE_ITHREADS)
2276 /* locks must be released in same order as in atfork_lock() */
2278 MUTEX_UNLOCK(&PL_malloc_mutex);
2287 #if defined(HAS_FORK)
2289 #if defined(USE_ITHREADS) && !defined(HAS_PTHREAD_ATFORK)
2294 /* atfork_lock() and atfork_unlock() are installed as pthread_atfork()
2295 * handlers elsewhere in the code */
2300 /* this "canna happen" since nothing should be calling here if !HAS_FORK */
2301 Perl_croak_nocontext("fork() not available");
2303 #endif /* HAS_FORK */
2308 Perl_dump_fds(pTHX_ char *s)
2313 PerlIO_printf(Perl_debug_log,"%s", s);
2314 for (fd = 0; fd < 32; fd++) {
2315 if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0)
2316 PerlIO_printf(Perl_debug_log," %d",fd);
2318 PerlIO_printf(Perl_debug_log,"\n");
2321 #endif /* DUMP_FDS */
2325 dup2(int oldfd, int newfd)
2327 #if defined(HAS_FCNTL) && defined(F_DUPFD)
2330 PerlLIO_close(newfd);
2331 return fcntl(oldfd, F_DUPFD, newfd);
2333 #define DUP2_MAX_FDS 256
2334 int fdtmp[DUP2_MAX_FDS];
2340 PerlLIO_close(newfd);
2341 /* good enough for low fd's... */
2342 while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
2343 if (fdx >= DUP2_MAX_FDS) {
2351 PerlLIO_close(fdtmp[--fdx]);
2358 #ifdef HAS_SIGACTION
2360 #ifdef MACOS_TRADITIONAL
2361 /* We don't want restart behavior on MacOS */
2366 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2369 struct sigaction act, oact;
2372 /* only "parent" interpreter can diddle signals */
2373 if (PL_curinterp != aTHX)
2377 act.sa_handler = handler;
2378 sigemptyset(&act.sa_mask);
2381 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2382 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
2384 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2385 if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN)
2386 act.sa_flags |= SA_NOCLDWAIT;
2388 if (sigaction(signo, &act, &oact) == -1)
2391 return oact.sa_handler;
2395 Perl_rsignal_state(pTHX_ int signo)
2397 struct sigaction oact;
2399 if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
2402 return oact.sa_handler;
2406 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2409 struct sigaction act;
2412 /* only "parent" interpreter can diddle signals */
2413 if (PL_curinterp != aTHX)
2417 act.sa_handler = handler;
2418 sigemptyset(&act.sa_mask);
2421 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2422 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
2424 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2425 if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN)
2426 act.sa_flags |= SA_NOCLDWAIT;
2428 return sigaction(signo, &act, save);
2432 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2436 /* only "parent" interpreter can diddle signals */
2437 if (PL_curinterp != aTHX)
2441 return sigaction(signo, save, (struct sigaction *)NULL);
2444 #else /* !HAS_SIGACTION */
2447 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2449 #if defined(USE_ITHREADS) && !defined(WIN32)
2450 /* only "parent" interpreter can diddle signals */
2451 if (PL_curinterp != aTHX)
2455 return PerlProc_signal(signo, handler);
2467 Perl_rsignal_state(pTHX_ int signo)
2470 Sighandler_t oldsig;
2472 #if defined(USE_ITHREADS) && !defined(WIN32)
2473 /* only "parent" interpreter can diddle signals */
2474 if (PL_curinterp != aTHX)
2479 oldsig = PerlProc_signal(signo, sig_trap);
2480 PerlProc_signal(signo, oldsig);
2482 PerlProc_kill(PerlProc_getpid(), signo);
2487 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2489 #if defined(USE_ITHREADS) && !defined(WIN32)
2490 /* only "parent" interpreter can diddle signals */
2491 if (PL_curinterp != aTHX)
2494 *save = PerlProc_signal(signo, handler);
2495 return (*save == SIG_ERR) ? -1 : 0;
2499 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2501 #if defined(USE_ITHREADS) && !defined(WIN32)
2502 /* only "parent" interpreter can diddle signals */
2503 if (PL_curinterp != aTHX)
2506 return (PerlProc_signal(signo, *save) == SIG_ERR) ? -1 : 0;
2509 #endif /* !HAS_SIGACTION */
2510 #endif /* !PERL_MICRO */
2512 /* VMS' my_pclose() is in VMS.c; same with OS/2 */
2513 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
2515 Perl_my_pclose(pTHX_ PerlIO *ptr)
2517 Sigsave_t hstat, istat, qstat;
2523 int saved_errno = 0;
2525 int saved_win32_errno;
2529 svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE);
2531 pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
2533 *svp = &PL_sv_undef;
2535 if (pid == -1) { /* Opened by popen. */
2536 return my_syspclose(ptr);
2539 if ((close_failed = (PerlIO_close(ptr) == EOF))) {
2540 saved_errno = errno;
2542 saved_win32_errno = GetLastError();
2546 if(PerlProc_kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */
2549 rsignal_save(SIGHUP, SIG_IGN, &hstat);
2550 rsignal_save(SIGINT, SIG_IGN, &istat);
2551 rsignal_save(SIGQUIT, SIG_IGN, &qstat);
2554 pid2 = wait4pid(pid, &status, 0);
2555 } while (pid2 == -1 && errno == EINTR);
2557 rsignal_restore(SIGHUP, &hstat);
2558 rsignal_restore(SIGINT, &istat);
2559 rsignal_restore(SIGQUIT, &qstat);
2562 SETERRNO(saved_errno, 0);
2565 return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status));
2567 #endif /* !DOSISH */
2569 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(MACOS_TRADITIONAL)
2571 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
2576 #if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME)
2578 char spid[TYPE_CHARS(IV)];
2582 sprintf(spid, "%"IVdf, (IV)pid);
2583 svp = hv_fetch(PL_pidstatus,spid,strlen(spid),FALSE);
2584 if (svp && *svp != &PL_sv_undef) {
2585 *statusp = SvIVX(*svp);
2586 (void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD);
2593 hv_iterinit(PL_pidstatus);
2594 if ((entry = hv_iternext(PL_pidstatus))) {
2595 SV *sv = hv_iterval(PL_pidstatus,entry);
2597 pid = atoi(hv_iterkey(entry,(I32*)statusp));
2598 *statusp = SvIVX(sv);
2599 sprintf(spid, "%"IVdf, (IV)pid);
2600 (void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD);
2607 # ifdef HAS_WAITPID_RUNTIME
2608 if (!HAS_WAITPID_RUNTIME)
2611 result = PerlProc_waitpid(pid,statusp,flags);
2614 #if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
2615 result = wait4((pid==-1)?0:pid,statusp,flags,Null(struct rusage *));
2618 #if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME)
2619 #if defined(HAS_WAITPID) && defined(HAS_WAITPID_RUNTIME)
2624 Perl_croak(aTHX_ "Can't do waitpid with flags");
2626 while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
2627 pidgone(result,*statusp);
2633 #if defined(HAS_WAITPID) || defined(HAS_WAIT4)
2636 if (result < 0 && errno == EINTR) {
2641 #endif /* !DOSISH || OS2 || WIN32 || NETWARE */
2645 Perl_pidgone(pTHX_ Pid_t pid, int status)
2648 char spid[TYPE_CHARS(IV)];
2650 sprintf(spid, "%"IVdf, (IV)pid);
2651 sv = *hv_fetch(PL_pidstatus,spid,strlen(spid),TRUE);
2652 SvUPGRADE(sv,SVt_IV);
2653 SvIV_set(sv, status);
2657 #if defined(atarist) || defined(OS2) || defined(EPOC)
2660 int /* Cannot prototype with I32
2662 my_syspclose(PerlIO *ptr)
2665 Perl_my_pclose(pTHX_ PerlIO *ptr)
2668 /* Needs work for PerlIO ! */
2669 FILE *f = PerlIO_findFILE(ptr);
2670 I32 result = pclose(f);
2671 PerlIO_releaseFILE(ptr,f);
2679 Perl_my_pclose(pTHX_ PerlIO *ptr)
2681 /* Needs work for PerlIO ! */
2682 FILE *f = PerlIO_findFILE(ptr);
2683 I32 result = djgpp_pclose(f);
2684 result = (result << 8) & 0xff00;
2685 PerlIO_releaseFILE(ptr,f);
2691 Perl_repeatcpy(pTHX_ register char *to, register const char *from, I32 len, register I32 count)
2694 register const char *frombase = from;
2697 register const char c = *from;
2702 while (count-- > 0) {
2703 for (todo = len; todo > 0; todo--) {
2712 Perl_same_dirent(pTHX_ const char *a, const char *b)
2714 char *fa = strrchr(a,'/');
2715 char *fb = strrchr(b,'/');
2718 SV *tmpsv = sv_newmortal();
2731 sv_setpvn(tmpsv, ".", 1);
2733 sv_setpvn(tmpsv, a, fa - a);
2734 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0)
2737 sv_setpvn(tmpsv, ".", 1);
2739 sv_setpvn(tmpsv, b, fb - b);
2740 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0)
2742 return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
2743 tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
2745 #endif /* !HAS_RENAME */
2748 Perl_find_script(pTHX_ const char *scriptname, bool dosearch, const char **search_ext, I32 flags)
2750 const char *xfound = Nullch;
2751 char *xfailed = Nullch;
2752 char tmpbuf[MAXPATHLEN];
2756 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
2757 # define SEARCH_EXTS ".bat", ".cmd", NULL
2758 # define MAX_EXT_LEN 4
2761 # define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
2762 # define MAX_EXT_LEN 4
2765 # define SEARCH_EXTS ".pl", ".com", NULL
2766 # define MAX_EXT_LEN 4
2768 /* additional extensions to try in each dir if scriptname not found */
2770 const char *exts[] = { SEARCH_EXTS };
2771 const char **ext = search_ext ? search_ext : exts;
2772 int extidx = 0, i = 0;
2773 const char *curext = Nullch;
2776 # define MAX_EXT_LEN 0
2780 * If dosearch is true and if scriptname does not contain path
2781 * delimiters, search the PATH for scriptname.
2783 * If SEARCH_EXTS is also defined, will look for each
2784 * scriptname{SEARCH_EXTS} whenever scriptname is not found
2785 * while searching the PATH.
2787 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
2788 * proceeds as follows:
2789 * If DOSISH or VMSISH:
2790 * + look for ./scriptname{,.foo,.bar}
2791 * + search the PATH for scriptname{,.foo,.bar}
2794 * + look *only* in the PATH for scriptname{,.foo,.bar} (note
2795 * this will not look in '.' if it's not in the PATH)
2800 # ifdef ALWAYS_DEFTYPES
2801 len = strlen(scriptname);
2802 if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
2803 int hasdir, idx = 0, deftypes = 1;
2806 hasdir = !dosearch || (strpbrk(scriptname,":[</") != Nullch) ;
2809 int hasdir, idx = 0, deftypes = 1;
2812 hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
2814 /* The first time through, just add SEARCH_EXTS to whatever we
2815 * already have, so we can check for default file types. */
2817 (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
2823 if ((strlen(tmpbuf) + strlen(scriptname)
2824 + MAX_EXT_LEN) >= sizeof tmpbuf)
2825 continue; /* don't search dir with too-long name */
2826 strcat(tmpbuf, scriptname);
2830 if (strEQ(scriptname, "-"))
2832 if (dosearch) { /* Look in '.' first. */
2833 const char *cur = scriptname;
2835 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
2837 if (strEQ(ext[i++],curext)) {
2838 extidx = -1; /* already has an ext */
2843 DEBUG_p(PerlIO_printf(Perl_debug_log,
2844 "Looking for %s\n",cur));
2845 if (PerlLIO_stat(cur,&PL_statbuf) >= 0
2846 && !S_ISDIR(PL_statbuf.st_mode)) {
2854 if (cur == scriptname) {
2855 len = strlen(scriptname);
2856 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
2858 cur = strcpy(tmpbuf, scriptname);
2860 } while (extidx >= 0 && ext[extidx] /* try an extension? */
2861 && strcpy(tmpbuf+len, ext[extidx++]));
2866 #ifdef MACOS_TRADITIONAL
2867 if (dosearch && !strchr(scriptname, ':') &&
2868 (s = PerlEnv_getenv("Commands")))
2870 if (dosearch && !strchr(scriptname, '/')
2872 && !strchr(scriptname, '\\')
2874 && (s = PerlEnv_getenv("PATH")))
2879 PL_bufend = s + strlen(s);
2880 while (s < PL_bufend) {
2881 #ifdef MACOS_TRADITIONAL
2882 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
2886 #if defined(atarist) || defined(DOSISH)
2891 && *s != ';'; len++, s++) {
2892 if (len < sizeof tmpbuf)
2895 if (len < sizeof tmpbuf)
2897 #else /* ! (atarist || DOSISH) */
2898 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
2901 #endif /* ! (atarist || DOSISH) */
2902 #endif /* MACOS_TRADITIONAL */
2905 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
2906 continue; /* don't search dir with too-long name */
2907 #ifdef MACOS_TRADITIONAL
2908 if (len && tmpbuf[len - 1] != ':')
2909 tmpbuf[len++] = ':';
2912 #if defined(atarist) || defined(__MINT__) || defined(DOSISH)
2913 && tmpbuf[len - 1] != '/'
2914 && tmpbuf[len - 1] != '\\'
2917 tmpbuf[len++] = '/';
2918 if (len == 2 && tmpbuf[0] == '.')
2921 (void)strcpy(tmpbuf + len, scriptname);
2925 len = strlen(tmpbuf);
2926 if (extidx > 0) /* reset after previous loop */
2930 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
2931 retval = PerlLIO_stat(tmpbuf,&PL_statbuf);
2932 if (S_ISDIR(PL_statbuf.st_mode)) {
2936 } while ( retval < 0 /* not there */
2937 && extidx>=0 && ext[extidx] /* try an extension? */
2938 && strcpy(tmpbuf+len, ext[extidx++])
2943 if (S_ISREG(PL_statbuf.st_mode)
2944 && cando(S_IRUSR,TRUE,&PL_statbuf)
2945 #if !defined(DOSISH) && !defined(MACOS_TRADITIONAL)
2946 && cando(S_IXUSR,TRUE,&PL_statbuf)
2950 xfound = tmpbuf; /* bingo! */
2954 xfailed = savepv(tmpbuf);
2957 if (!xfound && !seen_dot && !xfailed &&
2958 (PerlLIO_stat(scriptname,&PL_statbuf) < 0
2959 || S_ISDIR(PL_statbuf.st_mode)))
2961 seen_dot = 1; /* Disable message. */
2963 if (flags & 1) { /* do or die? */
2964 Perl_croak(aTHX_ "Can't %s %s%s%s",
2965 (xfailed ? "execute" : "find"),
2966 (xfailed ? xfailed : scriptname),
2967 (xfailed ? "" : " on PATH"),
2968 (xfailed || seen_dot) ? "" : ", '.' not in PATH");
2970 scriptname = Nullch;
2974 scriptname = xfound;
2976 return (scriptname ? savepv(scriptname) : Nullch);
2979 #ifndef PERL_GET_CONTEXT_DEFINED
2982 Perl_get_context(void)
2985 #if defined(USE_ITHREADS)
2986 # ifdef OLD_PTHREADS_API
2988 if (pthread_getspecific(PL_thr_key, &t))
2989 Perl_croak_nocontext("panic: pthread_getspecific");
2992 # ifdef I_MACH_CTHREADS
2993 return (void*)cthread_data(cthread_self());
2995 return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
3004 Perl_set_context(void *t)
3007 #if defined(USE_ITHREADS)
3008 # ifdef I_MACH_CTHREADS
3009 cthread_set_data(cthread_self(), t);
3011 if (pthread_setspecific(PL_thr_key, t))
3012 Perl_croak_nocontext("panic: pthread_setspecific");
3019 #endif /* !PERL_GET_CONTEXT_DEFINED */
3021 #if defined(PERL_GLOBAL_STRUCT) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
3030 Perl_get_op_names(pTHX)
3032 return (char **)PL_op_name;
3036 Perl_get_op_descs(pTHX)
3038 return (char **)PL_op_desc;
3042 Perl_get_no_modify(pTHX)
3044 return PL_no_modify;
3048 Perl_get_opargs(pTHX)
3050 return (U32 *)PL_opargs;
3054 Perl_get_ppaddr(pTHX)
3057 return (PPADDR_t*)PL_ppaddr;
3060 #ifndef HAS_GETENV_LEN
3062 Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
3064 char *env_trans = PerlEnv_getenv(env_elem);
3066 *len = strlen(env_trans);
3073 Perl_get_vtbl(pTHX_ int vtbl_id)
3075 const MGVTBL* result = Null(MGVTBL*);
3079 result = &PL_vtbl_sv;
3082 result = &PL_vtbl_env;
3084 case want_vtbl_envelem:
3085 result = &PL_vtbl_envelem;
3088 result = &PL_vtbl_sig;
3090 case want_vtbl_sigelem:
3091 result = &PL_vtbl_sigelem;
3093 case want_vtbl_pack:
3094 result = &PL_vtbl_pack;
3096 case want_vtbl_packelem:
3097 result = &PL_vtbl_packelem;
3099 case want_vtbl_dbline:
3100 result = &PL_vtbl_dbline;
3103 result = &PL_vtbl_isa;
3105 case want_vtbl_isaelem:
3106 result = &PL_vtbl_isaelem;
3108 case want_vtbl_arylen:
3109 result = &PL_vtbl_arylen;
3111 case want_vtbl_glob:
3112 result = &PL_vtbl_glob;
3114 case want_vtbl_mglob:
3115 result = &PL_vtbl_mglob;
3117 case want_vtbl_nkeys:
3118 result = &PL_vtbl_nkeys;
3120 case want_vtbl_taint:
3121 result = &PL_vtbl_taint;
3123 case want_vtbl_substr:
3124 result = &PL_vtbl_substr;
3127 result = &PL_vtbl_vec;
3130 result = &PL_vtbl_pos;
3133 result = &PL_vtbl_bm;
3136 result = &PL_vtbl_fm;
3138 case want_vtbl_uvar:
3139 result = &PL_vtbl_uvar;
3141 case want_vtbl_defelem:
3142 result = &PL_vtbl_defelem;
3144 case want_vtbl_regexp:
3145 result = &PL_vtbl_regexp;
3147 case want_vtbl_regdata:
3148 result = &PL_vtbl_regdata;
3150 case want_vtbl_regdatum:
3151 result = &PL_vtbl_regdatum;
3153 #ifdef USE_LOCALE_COLLATE
3154 case want_vtbl_collxfrm:
3155 result = &PL_vtbl_collxfrm;
3158 case want_vtbl_amagic:
3159 result = &PL_vtbl_amagic;
3161 case want_vtbl_amagicelem:
3162 result = &PL_vtbl_amagicelem;
3164 case want_vtbl_backref:
3165 result = &PL_vtbl_backref;
3167 case want_vtbl_utf8:
3168 result = &PL_vtbl_utf8;
3171 return (MGVTBL*)result;
3175 Perl_my_fflush_all(pTHX)
3177 #if defined(USE_PERLIO) || defined(FFLUSH_NULL) || defined(USE_SFIO)
3178 return PerlIO_flush(NULL);
3180 # if defined(HAS__FWALK)
3181 extern int fflush(FILE *);
3182 /* undocumented, unprototyped, but very useful BSDism */
3183 extern void _fwalk(int (*)(FILE *));
3187 # if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
3189 # ifdef PERL_FFLUSH_ALL_FOPEN_MAX
3190 open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
3192 # if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
3193 open_max = sysconf(_SC_OPEN_MAX);
3196 open_max = FOPEN_MAX;
3199 open_max = OPEN_MAX;
3210 for (i = 0; i < open_max; i++)
3211 if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
3212 STDIO_STREAM_ARRAY[i]._file < open_max &&
3213 STDIO_STREAM_ARRAY[i]._flag)
3214 PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
3218 SETERRNO(EBADF,RMS_IFI);
3225 Perl_report_evil_fh(pTHX_ const GV *gv, const IO *io, I32 op)
3228 op == OP_READLINE ? "readline" : /* "<HANDLE>" not nice */
3229 op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */
3231 const char *pars = OP_IS_FILETEST(op) ? "" : "()";
3232 const char *type = OP_IS_SOCKET(op)
3233 || (gv && io && IoTYPE(io) == IoTYPE_SOCKET)
3234 ? "socket" : "filehandle";
3235 const char *name = NULL;
3237 if (gv && isGV(gv)) {
3241 if (op == OP_phoney_OUTPUT_ONLY || op == OP_phoney_INPUT_ONLY) {
3242 if (ckWARN(WARN_IO)) {
3243 const char *direction = (op == OP_phoney_INPUT_ONLY) ? "in" : "out";
3245 Perl_warner(aTHX_ packWARN(WARN_IO),
3246 "Filehandle %s opened only for %sput",
3249 Perl_warner(aTHX_ packWARN(WARN_IO),
3250 "Filehandle opened only for %sput", direction);
3257 if (gv && io && IoTYPE(io) == IoTYPE_CLOSED) {
3259 warn_type = WARN_CLOSED;
3263 warn_type = WARN_UNOPENED;
3266 if (ckWARN(warn_type)) {
3267 if (name && *name) {
3268 Perl_warner(aTHX_ packWARN(warn_type),
3269 "%s%s on %s %s %s", func, pars, vile, type, name);
3270 if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3272 aTHX_ packWARN(warn_type),
3273 "\t(Are you trying to call %s%s on dirhandle %s?)\n",
3278 Perl_warner(aTHX_ packWARN(warn_type),
3279 "%s%s on %s %s", func, pars, vile, type);
3280 if (gv && io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3282 aTHX_ packWARN(warn_type),
3283 "\t(Are you trying to call %s%s on dirhandle?)\n",
3292 /* in ASCII order, not that it matters */
3293 static const char controllablechars[] = "?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_";
3296 Perl_ebcdic_control(pTHX_ int ch)
3304 if ((ctlp = strchr(controllablechars, ch)) == 0) {
3305 Perl_die(aTHX_ "unrecognised control character '%c'\n", ch);
3308 if (ctlp == controllablechars)
3309 return('\177'); /* DEL */
3311 return((unsigned char)(ctlp - controllablechars - 1));
3312 } else { /* Want uncontrol */
3313 if (ch == '\177' || ch == -1)
3315 else if (ch == '\157')
3317 else if (ch == '\174')
3319 else if (ch == '^') /* '\137' in 1047, '\260' in 819 */
3321 else if (ch == '\155')
3323 else if (0 < ch && ch < (sizeof(controllablechars) - 1))
3324 return(controllablechars[ch+1]);
3326 Perl_die(aTHX_ "invalid control request: '\\%03o'\n", ch & 0xFF);
3331 /* To workaround core dumps from the uninitialised tm_zone we get the
3332 * system to give us a reasonable struct to copy. This fix means that
3333 * strftime uses the tm_zone and tm_gmtoff values returned by
3334 * localtime(time()). That should give the desired result most of the
3335 * time. But probably not always!
3337 * This does not address tzname aspects of NETaa14816.
3342 # ifndef STRUCT_TM_HASZONE
3343 # define STRUCT_TM_HASZONE
3347 #ifdef STRUCT_TM_HASZONE /* Backward compat */
3348 # ifndef HAS_TM_TM_ZONE
3349 # define HAS_TM_TM_ZONE
3354 Perl_init_tm(pTHX_ struct tm *ptm) /* see mktime, strftime and asctime */
3356 #ifdef HAS_TM_TM_ZONE
3360 my_tm = localtime(&now);
3362 Copy(my_tm, ptm, 1, struct tm);
3367 * mini_mktime - normalise struct tm values without the localtime()
3368 * semantics (and overhead) of mktime().
3371 Perl_mini_mktime(pTHX_ struct tm *ptm)
3375 int month, mday, year, jday;
3376 int odd_cent, odd_year;
3378 #define DAYS_PER_YEAR 365
3379 #define DAYS_PER_QYEAR (4*DAYS_PER_YEAR+1)
3380 #define DAYS_PER_CENT (25*DAYS_PER_QYEAR-1)
3381 #define DAYS_PER_QCENT (4*DAYS_PER_CENT+1)
3382 #define SECS_PER_HOUR (60*60)
3383 #define SECS_PER_DAY (24*SECS_PER_HOUR)
3384 /* parentheses deliberately absent on these two, otherwise they don't work */
3385 #define MONTH_TO_DAYS 153/5
3386 #define DAYS_TO_MONTH 5/153
3387 /* offset to bias by March (month 4) 1st between month/mday & year finding */
3388 #define YEAR_ADJUST (4*MONTH_TO_DAYS+1)
3389 /* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */
3390 #define WEEKDAY_BIAS 6 /* (1+6)%7 makes Sunday 0 again */
3393 * Year/day algorithm notes:
3395 * With a suitable offset for numeric value of the month, one can find
3396 * an offset into the year by considering months to have 30.6 (153/5) days,
3397 * using integer arithmetic (i.e., with truncation). To avoid too much
3398 * messing about with leap days, we consider January and February to be
3399 * the 13th and 14th month of the previous year. After that transformation,
3400 * we need the month index we use to be high by 1 from 'normal human' usage,
3401 * so the month index values we use run from 4 through 15.
3403 * Given that, and the rules for the Gregorian calendar (leap years are those
3404 * divisible by 4 unless also divisible by 100, when they must be divisible
3405 * by 400 instead), we can simply calculate the number of days since some
3406 * arbitrary 'beginning of time' by futzing with the (adjusted) year number,
3407 * the days we derive from our month index, and adding in the day of the
3408 * month. The value used here is not adjusted for the actual origin which
3409 * it normally would use (1 January A.D. 1), since we're not exposing it.
3410 * We're only building the value so we can turn around and get the
3411 * normalised values for the year, month, day-of-month, and day-of-year.
3413 * For going backward, we need to bias the value we're using so that we find
3414 * the right year value. (Basically, we don't want the contribution of
3415 * March 1st to the number to apply while deriving the year). Having done
3416 * that, we 'count up' the contribution to the year number by accounting for
3417 * full quadracenturies (400-year periods) with their extra leap days, plus
3418 * the contribution from full centuries (to avoid counting in the lost leap
3419 * days), plus the contribution from full quad-years (to count in the normal
3420 * leap days), plus the leftover contribution from any non-leap years.
3421 * At this point, if we were working with an actual leap day, we'll have 0
3422 * days left over. This is also true for March 1st, however. So, we have
3423 * to special-case that result, and (earlier) keep track of the 'odd'
3424 * century and year contributions. If we got 4 extra centuries in a qcent,
3425 * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb.
3426 * Otherwise, we add back in the earlier bias we removed (the 123 from
3427 * figuring in March 1st), find the month index (integer division by 30.6),
3428 * and the remainder is the day-of-month. We then have to convert back to
3429 * 'real' months (including fixing January and February from being 14/15 in
3430 * the previous year to being in the proper year). After that, to get
3431 * tm_yday, we work with the normalised year and get a new yearday value for
3432 * January 1st, which we subtract from the yearday value we had earlier,
3433 * representing the date we've re-built. This is done from January 1
3434 * because tm_yday is 0-origin.
3436 * Since POSIX time routines are only guaranteed to work for times since the
3437 * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm
3438 * applies Gregorian calendar rules even to dates before the 16th century
3439 * doesn't bother me. Besides, you'd need cultural context for a given
3440 * date to know whether it was Julian or Gregorian calendar, and that's
3441 * outside the scope for this routine. Since we convert back based on the
3442 * same rules we used to build the yearday, you'll only get strange results
3443 * for input which needed normalising, or for the 'odd' century years which
3444 * were leap years in the Julian calander but not in the Gregorian one.
3445 * I can live with that.
3447 * This algorithm also fails to handle years before A.D. 1 gracefully, but
3448 * that's still outside the scope for POSIX time manipulation, so I don't
3452 year = 1900 + ptm->tm_year;
3453 month = ptm->tm_mon;
3454 mday = ptm->tm_mday;
3455 /* allow given yday with no month & mday to dominate the result */
3456 if (ptm->tm_yday >= 0 && mday <= 0 && month <= 0) {
3459 jday = 1 + ptm->tm_yday;
3468 yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400;
3469 yearday += month*MONTH_TO_DAYS + mday + jday;
3471 * Note that we don't know when leap-seconds were or will be,
3472 * so we have to trust the user if we get something which looks
3473 * like a sensible leap-second. Wild values for seconds will
3474 * be rationalised, however.
3476 if ((unsigned) ptm->tm_sec <= 60) {
3483 secs += 60 * ptm->tm_min;
3484 secs += SECS_PER_HOUR * ptm->tm_hour;
3486 if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) {
3487 /* got negative remainder, but need positive time */
3488 /* back off an extra day to compensate */
3489 yearday += (secs/SECS_PER_DAY)-1;
3490 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1);
3493 yearday += (secs/SECS_PER_DAY);
3494 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY);
3497 else if (secs >= SECS_PER_DAY) {
3498 yearday += (secs/SECS_PER_DAY);
3499 secs %= SECS_PER_DAY;
3501 ptm->tm_hour = secs/SECS_PER_HOUR;
3502 secs %= SECS_PER_HOUR;
3503 ptm->tm_min = secs/60;
3505 ptm->tm_sec += secs;
3506 /* done with time of day effects */
3508 * The algorithm for yearday has (so far) left it high by 428.
3509 * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to
3510 * bias it by 123 while trying to figure out what year it
3511 * really represents. Even with this tweak, the reverse
3512 * translation fails for years before A.D. 0001.
3513 * It would still fail for Feb 29, but we catch that one below.
3515 jday = yearday; /* save for later fixup vis-a-vis Jan 1 */
3516 yearday -= YEAR_ADJUST;
3517 year = (yearday / DAYS_PER_QCENT) * 400;
3518 yearday %= DAYS_PER_QCENT;
3519 odd_cent = yearday / DAYS_PER_CENT;
3520 year += odd_cent * 100;
3521 yearday %= DAYS_PER_CENT;
3522 year += (yearday / DAYS_PER_QYEAR) * 4;
3523 yearday %= DAYS_PER_QYEAR;
3524 odd_year = yearday / DAYS_PER_YEAR;
3526 yearday %= DAYS_PER_YEAR;
3527 if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */
3532 yearday += YEAR_ADJUST; /* recover March 1st crock */
3533 month = yearday*DAYS_TO_MONTH;
3534 yearday -= month*MONTH_TO_DAYS;
3535 /* recover other leap-year adjustment */
3544 ptm->tm_year = year - 1900;
3546 ptm->tm_mday = yearday;
3547 ptm->tm_mon = month;
3551 ptm->tm_mon = month - 1;
3553 /* re-build yearday based on Jan 1 to get tm_yday */
3555 yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400;
3556 yearday += 14*MONTH_TO_DAYS + 1;
3557 ptm->tm_yday = jday - yearday;
3558 /* fix tm_wday if not overridden by caller */
3559 if ((unsigned)ptm->tm_wday > 6)
3560 ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
3564 Perl_my_strftime(pTHX_ const char *fmt, int sec, int min, int hour, int mday, int mon, int year, int wday, int yday, int isdst)
3572 init_tm(&mytm); /* XXX workaround - see init_tm() above */
3575 mytm.tm_hour = hour;
3576 mytm.tm_mday = mday;
3578 mytm.tm_year = year;
3579 mytm.tm_wday = wday;
3580 mytm.tm_yday = yday;
3581 mytm.tm_isdst = isdst;
3583 /* use libc to get the values for tm_gmtoff and tm_zone [perl #18238] */
3584 #if defined(HAS_MKTIME) && (defined(HAS_TM_TM_GMTOFF) || defined(HAS_TM_TM_ZONE))
3589 #ifdef HAS_TM_TM_GMTOFF
3590 mytm.tm_gmtoff = mytm2.tm_gmtoff;
3592 #ifdef HAS_TM_TM_ZONE
3593 mytm.tm_zone = mytm2.tm_zone;
3598 New(0, buf, buflen, char);
3599 len = strftime(buf, buflen, fmt, &mytm);
3601 ** The following is needed to handle to the situation where
3602 ** tmpbuf overflows. Basically we want to allocate a buffer
3603 ** and try repeatedly. The reason why it is so complicated
3604 ** is that getting a return value of 0 from strftime can indicate
3605 ** one of the following:
3606 ** 1. buffer overflowed,
3607 ** 2. illegal conversion specifier, or
3608 ** 3. the format string specifies nothing to be returned(not
3609 ** an error). This could be because format is an empty string
3610 ** or it specifies %p that yields an empty string in some locale.
3611 ** If there is a better way to make it portable, go ahead by
3614 if ((len > 0 && len < buflen) || (len == 0 && *fmt == '\0'))
3617 /* Possibly buf overflowed - try again with a bigger buf */
3618 const int fmtlen = strlen(fmt);
3619 const int bufsize = fmtlen + buflen;
3621 New(0, buf, bufsize, char);
3623 buflen = strftime(buf, bufsize, fmt, &mytm);
3624 if (buflen > 0 && buflen < bufsize)
3626 /* heuristic to prevent out-of-memory errors */
3627 if (bufsize > 100*fmtlen) {
3632 Renew(buf, bufsize*2, char);
3637 Perl_croak(aTHX_ "panic: no strftime");
3643 #define SV_CWD_RETURN_UNDEF \
3644 sv_setsv(sv, &PL_sv_undef); \
3647 #define SV_CWD_ISDOT(dp) \
3648 (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
3649 (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
3652 =head1 Miscellaneous Functions
3654 =for apidoc getcwd_sv
3656 Fill the sv with current working directory
3661 /* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars.
3662 * rewritten again by dougm, optimized for use with xs TARG, and to prefer
3663 * getcwd(3) if available
3664 * Comments from the orignal:
3665 * This is a faster version of getcwd. It's also more dangerous
3666 * because you might chdir out of a directory that you can't chdir
3670 Perl_getcwd_sv(pTHX_ register SV *sv)
3674 #ifndef INCOMPLETE_TAINTS
3680 char buf[MAXPATHLEN];
3682 /* Some getcwd()s automatically allocate a buffer of the given
3683 * size from the heap if they are given a NULL buffer pointer.
3684 * The problem is that this behaviour is not portable. */
3685 if (getcwd(buf, sizeof(buf) - 1)) {
3686 sv_setpvn(sv, buf, strlen(buf));
3690 sv_setsv(sv, &PL_sv_undef);
3698 int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
3702 SvUPGRADE(sv, SVt_PV);
3704 if (PerlLIO_lstat(".", &statbuf) < 0) {
3705 SV_CWD_RETURN_UNDEF;
3708 orig_cdev = statbuf.st_dev;
3709 orig_cino = statbuf.st_ino;
3718 if (PerlDir_chdir("..") < 0) {
3719 SV_CWD_RETURN_UNDEF;
3721 if (PerlLIO_stat(".", &statbuf) < 0) {
3722 SV_CWD_RETURN_UNDEF;
3725 cdev = statbuf.st_dev;
3726 cino = statbuf.st_ino;
3728 if (odev == cdev && oino == cino) {
3731 if (!(dir = PerlDir_open("."))) {
3732 SV_CWD_RETURN_UNDEF;
3735 while ((dp = PerlDir_read(dir)) != NULL) {
3737 const int namelen = dp->d_namlen;
3739 const int namelen = strlen(dp->d_name);
3742 if (SV_CWD_ISDOT(dp)) {
3746 if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
3747 SV_CWD_RETURN_UNDEF;
3750 tdev = statbuf.st_dev;
3751 tino = statbuf.st_ino;
3752 if (tino == oino && tdev == odev) {
3758 SV_CWD_RETURN_UNDEF;
3761 if (pathlen + namelen + 1 >= MAXPATHLEN) {
3762 SV_CWD_RETURN_UNDEF;
3765 SvGROW(sv, pathlen + namelen + 1);
3769 Move(SvPVX_const(sv), SvPVX(sv) + namelen + 1, pathlen, char);
3772 /* prepend current directory to the front */
3774 Move(dp->d_name, SvPVX(sv)+1, namelen, char);
3775 pathlen += (namelen + 1);
3777 #ifdef VOID_CLOSEDIR
3780 if (PerlDir_close(dir) < 0) {
3781 SV_CWD_RETURN_UNDEF;
3787 SvCUR_set(sv, pathlen);
3791 if (PerlDir_chdir(SvPVX_const(sv)) < 0) {
3792 SV_CWD_RETURN_UNDEF;
3795 if (PerlLIO_stat(".", &statbuf) < 0) {
3796 SV_CWD_RETURN_UNDEF;
3799 cdev = statbuf.st_dev;
3800 cino = statbuf.st_ino;
3802 if (cdev != orig_cdev || cino != orig_cino) {
3803 Perl_croak(aTHX_ "Unstable directory path, "
3804 "current directory changed unexpectedly");
3816 =for apidoc scan_version
3818 Returns a pointer to the next character after the parsed
3819 version string, as well as upgrading the passed in SV to
3822 Function must be called with an already existing SV like
3825 s = scan_version(s,SV *sv, bool qv);
3827 Performs some preprocessing to the string to ensure that
3828 it has the correct characteristics of a version. Flags the
3829 object if it contains an underscore (which denotes this
3830 is a alpha version). The boolean qv denotes that the version
3831 should be interpreted as if it had multiple decimals, even if
3838 Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
3840 const char *start = s;
3841 const char *pos = s;
3844 SV* sv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
3845 (void)sv_upgrade(sv, SVt_PVAV); /* needs to be an AV type */
3848 /* pre-scan the imput string to check for decimals */
3849 while ( *pos == '.' || *pos == '_' || isDIGIT(*pos) )
3854 Perl_croak(aTHX_ "Invalid version format (underscores before decimal)");
3857 else if ( *pos == '_' )
3860 Perl_croak(aTHX_ "Invalid version format (multiple underscores)");
3868 pos++; /* get past 'v' */
3869 qv = 1; /* force quoted version processing */
3871 while (isDIGIT(*pos))
3873 if (!isALPHA(*pos)) {
3876 if (*s == 'v') s++; /* get past 'v' */
3881 /* this is atoi() that delimits on underscores */
3882 const char *end = pos;
3885 if ( s < pos && s > start && *(s-1) == '_' ) {
3886 mult *= -1; /* alpha version */
3888 /* the following if() will only be true after the decimal
3889 * point of a version originally created with a bare
3890 * floating point number, i.e. not quoted in any way
3892 if ( !qv && s > start+1 && saw_period == 1 ) {
3896 rev += (*s - '0') * mult;
3898 if ( PERL_ABS(orev) > PERL_ABS(rev) )
3899 Perl_croak(aTHX_ "Integer overflow in version");
3904 while (--end >= s) {
3906 rev += (*end - '0') * mult;
3908 if ( PERL_ABS(orev) > PERL_ABS(rev) )
3909 Perl_croak(aTHX_ "Integer overflow in version");
3914 /* Append revision */
3915 av_push((AV *)sv, newSViv(rev));
3916 if ( (*pos == '.' || *pos == '_') && isDIGIT(pos[1]))
3918 else if ( isDIGIT(*pos) )
3924 while ( isDIGIT(*pos) ) {
3925 if ( saw_period == 1 && pos-s == 3 )
3931 if ( qv ) { /* quoted versions always become full version objects */
3932 I32 len = av_len((AV *)sv);
3933 /* This for loop appears to trigger a compiler bug on OS X, as it
3934 loops infinitely. Yes, len is negative. No, it makes no sense.
3935 Compiler in question is:
3936 gcc version 3.3 20030304 (Apple Computer, Inc. build 1640)
3937 for ( len = 2 - len; len > 0; len-- )
3938 av_push((AV *)sv, newSViv(0));
3942 av_push((AV *)sv, newSViv(0));
3948 =for apidoc new_version
3950 Returns a new version object based on the passed in SV:
3952 SV *sv = new_version(SV *ver);
3954 Does not alter the passed in ver SV. See "upg_version" if you
3955 want to upgrade the SV.
3961 Perl_new_version(pTHX_ SV *ver)
3964 if ( sv_derived_from(ver,"version") ) /* can just copy directly */
3967 AV *av = (AV *)SvRV(ver);
3968 SV* sv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
3969 (void)sv_upgrade(sv, SVt_PVAV); /* needs to be an AV type */
3971 for ( key = 0; key <= av_len(av); key++ )
3973 const I32 rev = SvIV(*av_fetch(av, key, FALSE));
3974 av_push((AV *)sv, newSViv(rev));
3979 if ( SvVOK(ver) ) { /* already a v-string */
3981 MAGIC* mg = mg_find(ver,PERL_MAGIC_vstring);
3982 version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
3983 sv_setpv(rv,version);
3988 sv_setsv(rv,ver); /* make a duplicate */
3997 =for apidoc upg_version
3999 In-place upgrade of the supplied SV to a version object.
4001 SV *sv = upg_version(SV *sv);
4003 Returns a pointer to the upgraded SV.
4009 Perl_upg_version(pTHX_ SV *ver)
4014 if ( SvNOK(ver) ) /* may get too much accuracy */
4017 sprintf(tbuf,"%.9"NVgf, SvNVX(ver));
4018 version = savepv(tbuf);
4021 else if ( SvVOK(ver) ) { /* already a v-string */
4022 MAGIC* mg = mg_find(ver,PERL_MAGIC_vstring);
4023 version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
4027 else /* must be a string or something like a string */
4029 version = savesvpv(ver);
4031 (void)scan_version(version, ver, qv);
4040 Accepts a version object and returns the normalized floating
4041 point representation. Call like:
4045 NOTE: you can pass either the object directly or the SV
4046 contained within the RV.
4052 Perl_vnumify(pTHX_ SV *vs)
4058 len = av_len((AV *)vs);
4061 Perl_sv_catpv(aTHX_ sv,"0");
4064 digit = SvIVX(*av_fetch((AV *)vs, 0, 0));
4065 Perl_sv_setpvf(aTHX_ sv,"%d.", (int)PERL_ABS(digit));
4066 for ( i = 1 ; i < len ; i++ )
4068 digit = SvIVX(*av_fetch((AV *)vs, i, 0));
4069 Perl_sv_catpvf(aTHX_ sv,"%03d", (int)PERL_ABS(digit));
4074 digit = SvIVX(*av_fetch((AV *)vs, len, 0));
4075 if ( (int)PERL_ABS(digit) != 0 || len == 1 )
4077 if ( digit < 0 ) /* alpha version */
4078 Perl_sv_catpv(aTHX_ sv,"_");
4079 /* Don't display additional trailing zeros */
4080 Perl_sv_catpvf(aTHX_ sv,"%03d", (int)PERL_ABS(digit));
4085 Perl_sv_catpv(aTHX_ sv,"000");
4093 Accepts a version object and returns the normalized string
4094 representation. Call like:
4098 NOTE: you can pass either the object directly or the SV
4099 contained within the RV.
4105 Perl_vnormal(pTHX_ SV *vs)
4111 len = av_len((AV *)vs);
4114 Perl_sv_catpv(aTHX_ sv,"");
4117 digit = SvIVX(*av_fetch((AV *)vs, 0, 0));
4118 Perl_sv_setpvf(aTHX_ sv,"%"IVdf,(IV)digit);
4119 for ( i = 1 ; i <= len ; i++ )
4121 digit = SvIVX(*av_fetch((AV *)vs, i, 0));
4123 Perl_sv_catpvf(aTHX_ sv,"_%"IVdf,(IV)-digit);
4125 Perl_sv_catpvf(aTHX_ sv,".%"IVdf,(IV)digit);
4128 if ( len <= 2 ) { /* short version, must be at least three */
4129 for ( len = 2 - len; len != 0; len-- )
4130 Perl_sv_catpv(aTHX_ sv,".0");
4137 =for apidoc vstringify
4139 In order to maintain maximum compatibility with earlier versions
4140 of Perl, this function will return either the floating point
4141 notation or the multiple dotted notation, depending on whether
4142 the original version contained 1 or more dots, respectively
4148 Perl_vstringify(pTHX_ SV *vs)
4153 len = av_len((AV *)vs);
4154 digit = SvIVX(*av_fetch((AV *)vs, len, 0));
4156 if ( len < 2 || ( len == 2 && digit < 0 ) )
4165 Version object aware cmp. Both operands must already have been
4166 converted into version objects.
4172 Perl_vcmp(pTHX_ SV *lsv, SV *rsv)
4179 l = av_len((AV *)lsv);
4180 r = av_len((AV *)rsv);
4184 while ( i <= m && retval == 0 )
4186 I32 left = SvIV(*av_fetch((AV *)lsv,i,0));
4187 I32 right = SvIV(*av_fetch((AV *)rsv,i,0));
4188 bool lalpha = left < 0 ? 1 : 0;
4189 bool ralpha = right < 0 ? 1 : 0;
4192 if ( left < right || (left == right && lalpha && !ralpha) )
4194 if ( left > right || (left == right && ralpha && !lalpha) )
4199 if ( l != r && retval == 0 ) /* possible match except for trailing 0's */
4203 while ( i <= r && retval == 0 )
4205 if ( SvIV(*av_fetch((AV *)rsv,i,0)) != 0 )
4206 retval = -1; /* not a match after all */
4212 while ( i <= l && retval == 0 )
4214 if ( SvIV(*av_fetch((AV *)lsv,i,0)) != 0 )
4215 retval = +1; /* not a match after all */
4223 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT)
4224 # define EMULATE_SOCKETPAIR_UDP
4227 #ifdef EMULATE_SOCKETPAIR_UDP
4229 S_socketpair_udp (int fd[2]) {
4231 /* Fake a datagram socketpair using UDP to localhost. */
4232 int sockets[2] = {-1, -1};
4233 struct sockaddr_in addresses[2];
4235 Sock_size_t size = sizeof(struct sockaddr_in);
4236 unsigned short port;
4239 memset(&addresses, 0, sizeof(addresses));
4242 sockets[i] = PerlSock_socket(AF_INET, SOCK_DGRAM, PF_INET);
4243 if (sockets[i] == -1)
4244 goto tidy_up_and_fail;
4246 addresses[i].sin_family = AF_INET;
4247 addresses[i].sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4248 addresses[i].sin_port = 0; /* kernel choses port. */
4249 if (PerlSock_bind(sockets[i], (struct sockaddr *) &addresses[i],
4250 sizeof(struct sockaddr_in)) == -1)
4251 goto tidy_up_and_fail;
4254 /* Now have 2 UDP sockets. Find out which port each is connected to, and
4255 for each connect the other socket to it. */
4258 if (PerlSock_getsockname(sockets[i], (struct sockaddr *) &addresses[i],
4260 goto tidy_up_and_fail;
4261 if (size != sizeof(struct sockaddr_in))
4262 goto abort_tidy_up_and_fail;
4263 /* !1 is 0, !0 is 1 */
4264 if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i],
4265 sizeof(struct sockaddr_in)) == -1)
4266 goto tidy_up_and_fail;
4269 /* Now we have 2 sockets connected to each other. I don't trust some other
4270 process not to have already sent a packet to us (by random) so send
4271 a packet from each to the other. */
4274 /* I'm going to send my own port number. As a short.
4275 (Who knows if someone somewhere has sin_port as a bitfield and needs
4276 this routine. (I'm assuming crays have socketpair)) */
4277 port = addresses[i].sin_port;
4278 got = PerlLIO_write(sockets[i], &port, sizeof(port));
4279 if (got != sizeof(port)) {
4281 goto tidy_up_and_fail;
4282 goto abort_tidy_up_and_fail;
4286 /* Packets sent. I don't trust them to have arrived though.
4287 (As I understand it Solaris TCP stack is multithreaded. Non-blocking
4288 connect to localhost will use a second kernel thread. In 2.6 the
4289 first thread running the connect() returns before the second completes,
4290 so EINPROGRESS> In 2.7 the improved stack is faster and connect()
4291 returns 0. Poor programs have tripped up. One poor program's authors'
4292 had a 50-1 reverse stock split. Not sure how connected these were.)
4293 So I don't trust someone not to have an unpredictable UDP stack.
4297 struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */
4298 int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0];
4302 FD_SET(sockets[0], &rset);
4303 FD_SET(sockets[1], &rset);
4305 got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor);
4306 if (got != 2 || !FD_ISSET(sockets[0], &rset)
4307 || !FD_ISSET(sockets[1], &rset)) {
4308 /* I hope this is portable and appropriate. */
4310 goto tidy_up_and_fail;
4311 goto abort_tidy_up_and_fail;
4315 /* And the paranoia department even now doesn't trust it to have arrive
4316 (hence MSG_DONTWAIT). Or that what arrives was sent by us. */
4318 struct sockaddr_in readfrom;
4319 unsigned short buffer[2];
4324 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4325 sizeof(buffer), MSG_DONTWAIT,
4326 (struct sockaddr *) &readfrom, &size);
4328 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4330 (struct sockaddr *) &readfrom, &size);
4334 goto tidy_up_and_fail;
4335 if (got != sizeof(port)
4336 || size != sizeof(struct sockaddr_in)
4337 /* Check other socket sent us its port. */
4338 || buffer[0] != (unsigned short) addresses[!i].sin_port
4339 /* Check kernel says we got the datagram from that socket */
4340 || readfrom.sin_family != addresses[!i].sin_family
4341 || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr
4342 || readfrom.sin_port != addresses[!i].sin_port)
4343 goto abort_tidy_up_and_fail;
4346 /* My caller (my_socketpair) has validated that this is non-NULL */
4349 /* I hereby declare this connection open. May God bless all who cross
4353 abort_tidy_up_and_fail:
4354 errno = ECONNABORTED;
4357 const int save_errno = errno;
4358 if (sockets[0] != -1)
4359 PerlLIO_close(sockets[0]);
4360 if (sockets[1] != -1)
4361 PerlLIO_close(sockets[1]);
4366 #endif /* EMULATE_SOCKETPAIR_UDP */
4368 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET)
4370 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4371 /* Stevens says that family must be AF_LOCAL, protocol 0.
4372 I'm going to enforce that, then ignore it, and use TCP (or UDP). */
4377 struct sockaddr_in listen_addr;
4378 struct sockaddr_in connect_addr;
4383 || family != AF_UNIX
4386 errno = EAFNOSUPPORT;
4394 #ifdef EMULATE_SOCKETPAIR_UDP
4395 if (type == SOCK_DGRAM)
4396 return S_socketpair_udp(fd);
4399 listener = PerlSock_socket(AF_INET, type, 0);
4402 memset(&listen_addr, 0, sizeof(listen_addr));
4403 listen_addr.sin_family = AF_INET;
4404 listen_addr.sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4405 listen_addr.sin_port = 0; /* kernel choses port. */
4406 if (PerlSock_bind(listener, (struct sockaddr *) &listen_addr,
4407 sizeof(listen_addr)) == -1)
4408 goto tidy_up_and_fail;
4409 if (PerlSock_listen(listener, 1) == -1)
4410 goto tidy_up_and_fail;
4412 connector = PerlSock_socket(AF_INET, type, 0);
4413 if (connector == -1)
4414 goto tidy_up_and_fail;
4415 /* We want to find out the port number to connect to. */
4416 size = sizeof(connect_addr);
4417 if (PerlSock_getsockname(listener, (struct sockaddr *) &connect_addr,
4419 goto tidy_up_and_fail;
4420 if (size != sizeof(connect_addr))
4421 goto abort_tidy_up_and_fail;
4422 if (PerlSock_connect(connector, (struct sockaddr *) &connect_addr,
4423 sizeof(connect_addr)) == -1)
4424 goto tidy_up_and_fail;
4426 size = sizeof(listen_addr);
4427 acceptor = PerlSock_accept(listener, (struct sockaddr *) &listen_addr,
4430 goto tidy_up_and_fail;
4431 if (size != sizeof(listen_addr))
4432 goto abort_tidy_up_and_fail;
4433 PerlLIO_close(listener);
4434 /* Now check we are talking to ourself by matching port and host on the
4436 if (PerlSock_getsockname(connector, (struct sockaddr *) &connect_addr,
4438 goto tidy_up_and_fail;
4439 if (size != sizeof(connect_addr)
4440 || listen_addr.sin_family != connect_addr.sin_family
4441 || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr
4442 || listen_addr.sin_port != connect_addr.sin_port) {
4443 goto abort_tidy_up_and_fail;
4449 abort_tidy_up_and_fail:
4451 errno = ECONNABORTED; /* This would be the standard thing to do. */
4453 # ifdef ECONNREFUSED
4454 errno = ECONNREFUSED; /* E.g. Symbian does not have ECONNABORTED. */
4456 errno = ETIMEDOUT; /* Desperation time. */
4461 int save_errno = errno;
4463 PerlLIO_close(listener);
4464 if (connector != -1)
4465 PerlLIO_close(connector);
4467 PerlLIO_close(acceptor);
4473 /* In any case have a stub so that there's code corresponding
4474 * to the my_socketpair in global.sym. */
4476 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4477 #ifdef HAS_SOCKETPAIR
4478 return socketpair(family, type, protocol, fd);
4487 =for apidoc sv_nosharing
4489 Dummy routine which "shares" an SV when there is no sharing module present.
4490 Exists to avoid test for a NULL function pointer and because it could potentially warn under
4491 some level of strict-ness.
4497 Perl_sv_nosharing(pTHX_ SV *sv)
4503 =for apidoc sv_nolocking
4505 Dummy routine which "locks" an SV when there is no locking module present.
4506 Exists to avoid test for a NULL function pointer and because it could potentially warn under
4507 some level of strict-ness.
4513 Perl_sv_nolocking(pTHX_ SV *sv)
4520 =for apidoc sv_nounlocking
4522 Dummy routine which "unlocks" an SV when there is no locking module present.
4523 Exists to avoid test for a NULL function pointer and because it could potentially warn under
4524 some level of strict-ness.
4530 Perl_sv_nounlocking(pTHX_ SV *sv)
4536 Perl_parse_unicode_opts(pTHX_ const char **popt)
4538 const char *p = *popt;
4543 opt = (U32) atoi(p);
4544 while (isDIGIT(*p)) p++;
4545 if (*p && *p != '\n' && *p != '\r')
4546 Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
4551 case PERL_UNICODE_STDIN:
4552 opt |= PERL_UNICODE_STDIN_FLAG; break;
4553 case PERL_UNICODE_STDOUT:
4554 opt |= PERL_UNICODE_STDOUT_FLAG; break;
4555 case PERL_UNICODE_STDERR:
4556 opt |= PERL_UNICODE_STDERR_FLAG; break;
4557 case PERL_UNICODE_STD:
4558 opt |= PERL_UNICODE_STD_FLAG; break;
4559 case PERL_UNICODE_IN:
4560 opt |= PERL_UNICODE_IN_FLAG; break;
4561 case PERL_UNICODE_OUT:
4562 opt |= PERL_UNICODE_OUT_FLAG; break;
4563 case PERL_UNICODE_INOUT:
4564 opt |= PERL_UNICODE_INOUT_FLAG; break;
4565 case PERL_UNICODE_LOCALE:
4566 opt |= PERL_UNICODE_LOCALE_FLAG; break;
4567 case PERL_UNICODE_ARGV:
4568 opt |= PERL_UNICODE_ARGV_FLAG; break;
4570 if (*p != '\n' && *p != '\r')
4572 "Unknown Unicode option letter '%c'", *p);
4578 opt = PERL_UNICODE_DEFAULT_FLAGS;
4580 if (opt & ~PERL_UNICODE_ALL_FLAGS)
4581 Perl_croak(aTHX_ "Unknown Unicode option value %"UVuf,
4582 (UV) (opt & ~PERL_UNICODE_ALL_FLAGS));
4593 * This is really just a quick hack which grabs various garbage
4594 * values. It really should be a real hash algorithm which
4595 * spreads the effect of every input bit onto every output bit,
4596 * if someone who knows about such things would bother to write it.
4597 * Might be a good idea to add that function to CORE as well.
4598 * No numbers below come from careful analysis or anything here,
4599 * except they are primes and SEED_C1 > 1E6 to get a full-width
4600 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
4601 * probably be bigger too.
4604 # define SEED_C1 1000003
4605 #define SEED_C4 73819
4607 # define SEED_C1 25747
4608 #define SEED_C4 20639
4612 #define SEED_C5 26107
4614 #ifndef PERL_NO_DEV_RANDOM
4619 # include <starlet.h>
4620 /* when[] = (low 32 bits, high 32 bits) of time since epoch
4621 * in 100-ns units, typically incremented ever 10 ms. */
4622 unsigned int when[2];
4624 # ifdef HAS_GETTIMEOFDAY
4625 struct timeval when;
4631 /* This test is an escape hatch, this symbol isn't set by Configure. */
4632 #ifndef PERL_NO_DEV_RANDOM
4633 #ifndef PERL_RANDOM_DEVICE
4634 /* /dev/random isn't used by default because reads from it will block
4635 * if there isn't enough entropy available. You can compile with
4636 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
4637 * is enough real entropy to fill the seed. */
4638 # define PERL_RANDOM_DEVICE "/dev/urandom"
4640 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
4642 if (PerlLIO_read(fd, (void*)&u, sizeof u) != sizeof u)
4651 _ckvmssts(sys$gettim(when));
4652 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
4654 # ifdef HAS_GETTIMEOFDAY
4655 PerlProc_gettimeofday(&when,NULL);
4656 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
4659 u = (U32)SEED_C1 * when;
4662 u += SEED_C3 * (U32)PerlProc_getpid();
4663 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
4664 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
4665 u += SEED_C5 * (U32)PTR2UV(&when);
4671 Perl_get_hash_seed(pTHX)
4673 const char *s = PerlEnv_getenv("PERL_HASH_SEED");
4677 while (isSPACE(*s)) s++;
4678 if (s && isDIGIT(*s))
4679 myseed = (UV)Atoul(s);
4681 #ifdef USE_HASH_SEED_EXPLICIT
4685 /* Compute a random seed */
4686 (void)seedDrand01((Rand_seed_t)seed());
4687 myseed = (UV)(Drand01() * (NV)UV_MAX);
4688 #if RANDBITS < (UVSIZE * 8)
4689 /* Since there are not enough randbits to to reach all
4690 * the bits of a UV, the low bits might need extra
4691 * help. Sum in another random number that will
4692 * fill in the low bits. */
4694 (UV)(Drand01() * (NV)((1 << ((UVSIZE * 8 - RANDBITS))) - 1));
4695 #endif /* RANDBITS < (UVSIZE * 8) */
4696 if (myseed == 0) { /* Superparanoia. */
4697 myseed = (UV)(Drand01() * (NV)UV_MAX); /* One more chance. */
4699 Perl_croak(aTHX_ "Your random numbers are not that random");
4702 PL_rehash_seed_set = TRUE;
4707 #ifdef PERL_GLOBAL_STRUCT
4710 Perl_init_global_struct(pTHX)
4712 struct perl_vars *plvarsp = NULL;
4713 #ifdef PERL_GLOBAL_STRUCT
4714 # define PERL_GLOBAL_STRUCT_INIT
4715 # include "opcode.h" /* the ppaddr and check */
4716 IV nppaddr = sizeof(Gppaddr)/sizeof(Perl_ppaddr_t);
4717 IV ncheck = sizeof(Gcheck) /sizeof(Perl_check_t);
4718 # ifdef PERL_GLOBAL_STRUCT_PRIVATE
4719 /* PerlMem_malloc() because can't use even safesysmalloc() this early. */
4720 plvarsp = (struct perl_vars*)PerlMem_malloc(sizeof(struct perl_vars));
4724 plvarsp = PL_VarsPtr;
4725 # endif /* PERL_GLOBAL_STRUCT_PRIVATE */
4731 # define PERLVAR(var,type) /**/
4732 # define PERLVARA(var,n,type) /**/
4733 # define PERLVARI(var,type,init) plvarsp->var = init;
4734 # define PERLVARIC(var,type,init) plvarsp->var = init;
4735 # define PERLVARISC(var,init) Copy(init, plvarsp->var, sizeof(init), char);
4736 # include "perlvars.h"
4742 # ifdef PERL_GLOBAL_STRUCT
4743 plvarsp->Gppaddr = PerlMem_malloc(nppaddr * sizeof(Perl_ppaddr_t));
4744 if (!plvarsp->Gppaddr)
4746 plvarsp->Gcheck = PerlMem_malloc(ncheck * sizeof(Perl_check_t));
4747 if (!plvarsp->Gcheck)
4749 Copy(Gppaddr, plvarsp->Gppaddr, nppaddr, Perl_ppaddr_t);
4750 Copy(Gcheck, plvarsp->Gcheck, ncheck, Perl_check_t);
4752 # ifdef PERL_SET_VARS
4753 PERL_SET_VARS(plvarsp);
4755 # undef PERL_GLOBAL_STRUCT_INIT
4760 #endif /* PERL_GLOBAL_STRUCT */
4762 #ifdef PERL_GLOBAL_STRUCT
4765 Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp)
4767 #ifdef PERL_GLOBAL_STRUCT
4768 # ifdef PERL_UNSET_VARS
4769 PERL_UNSET_VARS(plvarsp);
4771 free(plvarsp->Gppaddr);
4772 free(plvarsp->Gcheck);
4773 # ifdef PERL_GLOBAL_STRUCT_PRIVATE
4779 #endif /* PERL_GLOBAL_STRUCT */
4783 * c-indentation-style: bsd
4785 * indent-tabs-mode: t
4788 * ex: set ts=8 sts=4 sw=4 noet: