3 * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 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 # include <sys/wait.h>
39 # include <sys/select.h>
45 #if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC)
46 # define FD_CLOEXEC 1 /* NeXT needs this */
49 /* NOTE: Do not call the next three routines directly. Use the macros
50 * in handy.h, so that we can easily redefine everything to do tracking of
51 * allocated hunks back to the original New to track down any memory leaks.
52 * XXX This advice seems to be widely ignored :-( --AD August 1996.
55 /* paranoid version of system's malloc() */
58 Perl_safesysmalloc(MEM_SIZE size)
64 PerlIO_printf(Perl_error_log,
65 "Allocation too large: %lx\n", size) FLUSH;
68 #endif /* HAS_64K_LIMIT */
71 Perl_croak_nocontext("panic: malloc");
73 ptr = (Malloc_t)PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */
74 PERL_ALLOC_CHECK(ptr);
75 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
81 /* Can't use PerlIO to write as it allocates memory */
82 PerlLIO_write(PerlIO_fileno(Perl_error_log),
83 PL_no_mem, strlen(PL_no_mem));
90 /* paranoid version of system's realloc() */
93 Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
97 #if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) && !defined(PERL_MICRO)
98 Malloc_t PerlMem_realloc();
99 #endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */
103 PerlIO_printf(Perl_error_log,
104 "Reallocation too large: %lx\n", size) FLUSH;
107 #endif /* HAS_64K_LIMIT */
114 return safesysmalloc(size);
117 Perl_croak_nocontext("panic: realloc");
119 ptr = (Malloc_t)PerlMem_realloc(where,size);
120 PERL_ALLOC_CHECK(ptr);
122 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++));
123 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
130 /* Can't use PerlIO to write as it allocates memory */
131 PerlLIO_write(PerlIO_fileno(Perl_error_log),
132 PL_no_mem, strlen(PL_no_mem));
139 /* safe version of system's free() */
142 Perl_safesysfree(Malloc_t where)
144 #ifdef PERL_IMPLICIT_SYS
147 DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) free\n",PTR2UV(where),(long)PL_an++));
154 /* safe version of system's calloc() */
157 Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
163 if (size * count > 0xffff) {
164 PerlIO_printf(Perl_error_log,
165 "Allocation too large: %lx\n", size * count) FLUSH;
168 #endif /* HAS_64K_LIMIT */
170 if ((long)size < 0 || (long)count < 0)
171 Perl_croak_nocontext("panic: calloc");
174 ptr = (Malloc_t)PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */
175 PERL_ALLOC_CHECK(ptr);
176 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));
178 memset((void*)ptr, 0, size);
184 /* Can't use PerlIO to write as it allocates memory */
185 PerlLIO_write(PerlIO_fileno(Perl_error_log),
186 PL_no_mem, strlen(PL_no_mem));
193 /* These must be defined when not using Perl's malloc for binary
198 Malloc_t Perl_malloc (MEM_SIZE nbytes)
201 return (Malloc_t)PerlMem_malloc(nbytes);
204 Malloc_t Perl_calloc (MEM_SIZE elements, MEM_SIZE size)
207 return (Malloc_t)PerlMem_calloc(elements, size);
210 Malloc_t Perl_realloc (Malloc_t where, MEM_SIZE nbytes)
213 return (Malloc_t)PerlMem_realloc(where, nbytes);
216 Free_t Perl_mfree (Malloc_t where)
224 /* copy a string up to some (non-backslashed) delimiter, if any */
227 Perl_delimcpy(pTHX_ register char *to, register char *toend, register char *from, register char *fromend, register int delim, I32 *retlen)
230 for (tolen = 0; from < fromend; from++, tolen++) {
232 if (from[1] == delim)
241 else if (*from == delim)
252 /* return ptr to little string in big string, NULL if not found */
253 /* This routine was donated by Corey Satten. */
256 Perl_instr(pTHX_ register const char *big, register const char *little)
258 register const char *s, *x;
269 for (x=big,s=little; *s; /**/ ) {
278 return (char*)(big-1);
283 /* same as instr but allow embedded nulls */
286 Perl_ninstr(pTHX_ register const char *big, register const char *bigend, const char *little, const char *lend)
288 register const char *s, *x;
289 register I32 first = *little;
290 register const char *littleend = lend;
292 if (!first && little >= littleend)
294 if (bigend - big < littleend - little)
296 bigend -= littleend - little++;
297 while (big <= bigend) {
300 for (x=big,s=little; s < littleend; /**/ ) {
307 return (char*)(big-1);
312 /* reverse of the above--find last substring */
315 Perl_rninstr(pTHX_ register const char *big, const char *bigend, const char *little, const char *lend)
317 register const char *bigbeg;
318 register const char *s, *x;
319 register I32 first = *little;
320 register const char *littleend = lend;
322 if (!first && little >= littleend)
323 return (char*)bigend;
325 big = bigend - (littleend - little++);
326 while (big >= bigbeg) {
329 for (x=big+2,s=little; s < littleend; /**/ ) {
336 return (char*)(big+1);
341 #define FBM_TABLE_OFFSET 2 /* Number of bytes between EOS and table*/
343 /* As a space optimization, we do not compile tables for strings of length
344 0 and 1, and for strings of length 2 unless FBMcf_TAIL. These are
345 special-cased in fbm_instr().
347 If FBMcf_TAIL, the table is created as if the string has a trailing \n. */
350 =head1 Miscellaneous Functions
352 =for apidoc fbm_compile
354 Analyses the string in order to make fast searches on it using fbm_instr()
355 -- the Boyer-Moore algorithm.
361 Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
370 if (flags & FBMcf_TAIL) {
371 MAGIC *mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
372 sv_catpvn(sv, "\n", 1); /* Taken into account in fbm_instr() */
373 if (mg && mg->mg_len >= 0)
376 s = (U8*)SvPV_force(sv, len);
377 (void)SvUPGRADE(sv, SVt_PVBM);
378 if (len == 0) /* TAIL might be on a zero-length string. */
388 Sv_Grow(sv, len + 256 + FBM_TABLE_OFFSET);
389 table = (unsigned char*)(SvPVX(sv) + len + FBM_TABLE_OFFSET);
390 s = table - 1 - FBM_TABLE_OFFSET; /* last char */
391 memset((void*)table, mlen, 256);
392 table[-1] = (U8)flags;
394 sb = s - mlen + 1; /* first char (maybe) */
396 if (table[*s] == mlen)
401 sv_magic(sv, Nullsv, PERL_MAGIC_bm, Nullch, 0); /* deep magic */
404 s = (unsigned char*)(SvPVX(sv)); /* deeper magic */
405 for (i = 0; i < len; i++) {
406 if (PL_freq[s[i]] < frequency) {
408 frequency = PL_freq[s[i]];
411 BmRARE(sv) = s[rarest];
412 BmPREVIOUS(sv) = (U16)rarest;
413 BmUSEFUL(sv) = 100; /* Initial value */
414 if (flags & FBMcf_TAIL)
416 DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %d\n",
417 BmRARE(sv),BmPREVIOUS(sv)));
420 /* If SvTAIL(littlestr), it has a fake '\n' at end. */
421 /* If SvTAIL is actually due to \Z or \z, this gives false positives
425 =for apidoc fbm_instr
427 Returns the location of the SV in the string delimited by C<str> and
428 C<strend>. It returns C<Nullch> if the string can't be found. The C<sv>
429 does not have to be fbm_compiled, but the search will not be as fast
436 Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *littlestr, U32 flags)
438 register unsigned char *s;
440 register unsigned char *little = (unsigned char *)SvPV(littlestr,l);
441 register STRLEN littlelen = l;
442 register I32 multiline = flags & FBMrf_MULTILINE;
444 if ((STRLEN)(bigend - big) < littlelen) {
445 if ( SvTAIL(littlestr)
446 && ((STRLEN)(bigend - big) == littlelen - 1)
448 || (*big == *little &&
449 memEQ((char *)big, (char *)little, littlelen - 1))))
454 if (littlelen <= 2) { /* Special-cased */
456 if (littlelen == 1) {
457 if (SvTAIL(littlestr) && !multiline) { /* Anchor only! */
458 /* Know that bigend != big. */
459 if (bigend[-1] == '\n')
460 return (char *)(bigend - 1);
461 return (char *) bigend;
469 if (SvTAIL(littlestr))
470 return (char *) bigend;
474 return (char*)big; /* Cannot be SvTAIL! */
477 if (SvTAIL(littlestr) && !multiline) {
478 if (bigend[-1] == '\n' && bigend[-2] == *little)
479 return (char*)bigend - 2;
480 if (bigend[-1] == *little)
481 return (char*)bigend - 1;
485 /* This should be better than FBM if c1 == c2, and almost
486 as good otherwise: maybe better since we do less indirection.
487 And we save a lot of memory by caching no table. */
488 register unsigned char c1 = little[0];
489 register unsigned char c2 = little[1];
494 while (s <= bigend) {
504 goto check_1char_anchor;
515 goto check_1char_anchor;
518 while (s <= bigend) {
523 goto check_1char_anchor;
532 check_1char_anchor: /* One char and anchor! */
533 if (SvTAIL(littlestr) && (*bigend == *little))
534 return (char *)bigend; /* bigend is already decremented. */
537 if (SvTAIL(littlestr) && !multiline) { /* tail anchored? */
538 s = bigend - littlelen;
539 if (s >= big && bigend[-1] == '\n' && *s == *little
540 /* Automatically of length > 2 */
541 && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
543 return (char*)s; /* how sweet it is */
546 && memEQ((char*)s + 2, (char*)little + 1, littlelen - 2))
548 return (char*)s + 1; /* how sweet it is */
552 if (SvTYPE(littlestr) != SVt_PVBM || !SvVALID(littlestr)) {
553 char *b = ninstr((char*)big,(char*)bigend,
554 (char*)little, (char*)little + littlelen);
556 if (!b && SvTAIL(littlestr)) { /* Automatically multiline! */
557 /* Chop \n from littlestr: */
558 s = bigend - littlelen + 1;
560 && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
569 { /* Do actual FBM. */
570 register unsigned char *table = little + littlelen + FBM_TABLE_OFFSET;
571 register unsigned char *oldlittle;
573 if (littlelen > (STRLEN)(bigend - big))
575 --littlelen; /* Last char found by table lookup */
578 little += littlelen; /* last char */
585 if ((tmp = table[*s])) {
586 if ((s += tmp) < bigend)
590 else { /* less expensive than calling strncmp() */
591 register unsigned char *olds = s;
596 if (*--s == *--little)
598 s = olds + 1; /* here we pay the price for failure */
600 if (s < bigend) /* fake up continue to outer loop */
608 if ( s == bigend && (table[-1] & FBMcf_TAIL)
609 && memEQ((char *)(bigend - littlelen),
610 (char *)(oldlittle - littlelen), littlelen) )
611 return (char*)bigend - littlelen;
616 /* start_shift, end_shift are positive quantities which give offsets
617 of ends of some substring of bigstr.
618 If `last' we want the last occurrence.
619 old_posp is the way of communication between consequent calls if
620 the next call needs to find the .
621 The initial *old_posp should be -1.
623 Note that we take into account SvTAIL, so one can get extra
624 optimizations if _ALL flag is set.
627 /* If SvTAIL is actually due to \Z or \z, this gives false positives
628 if PL_multiline. In fact if !PL_multiline the authoritative answer
629 is not supported yet. */
632 Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last)
634 register unsigned char *s, *x;
635 register unsigned char *big;
637 register I32 previous;
639 register unsigned char *little;
640 register I32 stop_pos;
641 register unsigned char *littleend;
645 ? (pos = PL_screamfirst[BmRARE(littlestr)]) < 0
646 : (((pos = *old_posp), pos += PL_screamnext[pos]) == 0)) {
648 if ( BmRARE(littlestr) == '\n'
649 && BmPREVIOUS(littlestr) == SvCUR(littlestr) - 1) {
650 little = (unsigned char *)(SvPVX(littlestr));
651 littleend = little + SvCUR(littlestr);
658 little = (unsigned char *)(SvPVX(littlestr));
659 littleend = little + SvCUR(littlestr);
661 /* The value of pos we can start at: */
662 previous = BmPREVIOUS(littlestr);
663 big = (unsigned char *)(SvPVX(bigstr));
664 /* The value of pos we can stop at: */
665 stop_pos = SvCUR(bigstr) - end_shift - (SvCUR(littlestr) - 1 - previous);
666 if (previous + start_shift > stop_pos) {
668 stop_pos does not include SvTAIL in the count, so this check is incorrect
669 (I think) - see [ID 20010618.006] and t/op/study.t. HVDS 2001/06/19
672 if (previous + start_shift == stop_pos + 1) /* A fake '\n'? */
677 while (pos < previous + start_shift) {
678 if (!(pos += PL_screamnext[pos]))
683 if (pos >= stop_pos) break;
684 if (big[pos] != first)
686 for (x=big+pos+1,s=little; s < littleend; /**/ ) {
692 if (s == littleend) {
694 if (!last) return (char *)(big+pos);
697 } while ( pos += PL_screamnext[pos] );
699 return (char *)(big+(*old_posp));
701 if (!SvTAIL(littlestr) || (end_shift > 0))
703 /* Ignore the trailing "\n". This code is not microoptimized */
704 big = (unsigned char *)(SvPVX(bigstr) + SvCUR(bigstr));
705 stop_pos = littleend - little; /* Actual littlestr len */
710 && ((stop_pos == 1) ||
711 memEQ((char *)(big + 1), (char *)little, stop_pos - 1)))
717 Perl_ibcmp(pTHX_ const char *s1, const char *s2, register I32 len)
719 register U8 *a = (U8 *)s1;
720 register U8 *b = (U8 *)s2;
722 if (*a != *b && *a != PL_fold[*b])
730 Perl_ibcmp_locale(pTHX_ const char *s1, const char *s2, register I32 len)
732 register U8 *a = (U8 *)s1;
733 register U8 *b = (U8 *)s2;
735 if (*a != *b && *a != PL_fold_locale[*b])
742 /* copy a string to a safe spot */
745 =head1 Memory Management
749 Perl's version of C<strdup()>. Returns a pointer to a newly allocated
750 string which is a duplicate of C<pv>. The size of the string is
751 determined by C<strlen()>. The memory allocated for the new string can
752 be freed with the C<Safefree()> function.
758 Perl_savepv(pTHX_ const char *pv)
760 register char *newaddr;
764 New(902,newaddr,strlen(pv)+1,char);
765 return strcpy(newaddr,pv);
768 /* same thing but with a known length */
773 Perl's version of what C<strndup()> would be if it existed. Returns a
774 pointer to a newly allocated string which is a duplicate of the first
775 C<len> bytes from C<pv>. The memory allocated for the new string can be
776 freed with the C<Safefree()> function.
782 Perl_savepvn(pTHX_ const char *pv, register I32 len)
784 register char *newaddr;
786 New(903,newaddr,len+1,char);
787 /* Give a meaning to NULL pointer mainly for the use in sv_magic() */
789 /* might not be null terminated */
791 return CopyD(pv,newaddr,len,char);
794 return ZeroD(newaddr,len+1,char);
799 =for apidoc savesharedpv
801 A version of C<savepv()> which allocates the duplicate string in memory
802 which is shared between threads.
807 Perl_savesharedpv(pTHX_ const char *pv)
809 register char *newaddr;
813 newaddr = (char*)PerlMemShared_malloc(strlen(pv)+1);
815 PerlLIO_write(PerlIO_fileno(Perl_error_log),
816 PL_no_mem, strlen(PL_no_mem));
819 return strcpy(newaddr,pv);
824 /* the SV for Perl_form() and mess() is not kept in an arena */
833 return sv_2mortal(newSVpvn("",0));
838 /* Create as PVMG now, to avoid any upgrading later */
840 Newz(905, any, 1, XPVMG);
841 SvFLAGS(sv) = SVt_PVMG;
842 SvANY(sv) = (void*)any;
843 SvREFCNT(sv) = 1 << 30; /* practically infinite */
848 #if defined(PERL_IMPLICIT_CONTEXT)
850 Perl_form_nocontext(const char* pat, ...)
856 retval = vform(pat, &args);
860 #endif /* PERL_IMPLICIT_CONTEXT */
863 =head1 Miscellaneous Functions
866 Takes a sprintf-style format pattern and conventional
867 (non-SV) arguments and returns the formatted string.
869 (char *) Perl_form(pTHX_ const char* pat, ...)
871 can be used any place a string (char *) is required:
873 char * s = Perl_form("%d.%d",major,minor);
875 Uses a single private buffer so if you want to format several strings you
876 must explicitly copy the earlier strings away (and free the copies when you
883 Perl_form(pTHX_ const char* pat, ...)
888 retval = vform(pat, &args);
894 Perl_vform(pTHX_ const char *pat, va_list *args)
896 SV *sv = mess_alloc();
897 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
901 #if defined(PERL_IMPLICIT_CONTEXT)
903 Perl_mess_nocontext(const char *pat, ...)
909 retval = vmess(pat, &args);
913 #endif /* PERL_IMPLICIT_CONTEXT */
916 Perl_mess(pTHX_ const char *pat, ...)
921 retval = vmess(pat, &args);
927 S_closest_cop(pTHX_ COP *cop, OP *o)
929 /* Look for PL_op starting from o. cop is the last COP we've seen. */
931 if (!o || o == PL_op) return cop;
933 if (o->op_flags & OPf_KIDS) {
935 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
939 /* If the OP_NEXTSTATE has been optimised away we can still use it
940 * the get the file and line number. */
942 if (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE)
945 /* Keep searching, and return when we've found something. */
947 new_cop = closest_cop(cop, kid);
948 if (new_cop) return new_cop;
958 Perl_vmess(pTHX_ const char *pat, va_list *args)
960 SV *sv = mess_alloc();
961 static char dgd[] = " during global destruction.\n";
964 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
965 if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
968 * Try and find the file and line for PL_op. This will usually be
969 * PL_curcop, but it might be a cop that has been optimised away. We
970 * can try to find such a cop by searching through the optree starting
971 * from the sibling of PL_curcop.
974 cop = closest_cop(PL_curcop, PL_curcop->op_sibling);
975 if (!cop) cop = PL_curcop;
978 Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf,
979 OutCopFILE(cop), (IV)CopLINE(cop));
980 if (GvIO(PL_last_in_gv) && IoLINES(GvIOp(PL_last_in_gv))) {
981 bool line_mode = (RsSIMPLE(PL_rs) &&
982 SvCUR(PL_rs) == 1 && *SvPVX(PL_rs) == '\n');
983 Perl_sv_catpvf(aTHX_ sv, ", <%s> %s %"IVdf,
984 PL_last_in_gv == PL_argvgv ?
985 "" : GvNAME(PL_last_in_gv),
986 line_mode ? "line" : "chunk",
987 (IV)IoLINES(GvIOp(PL_last_in_gv)));
989 sv_catpv(sv, PL_dirty ? dgd : ".\n");
995 Perl_write_to_stderr(pTHX_ const char* message, int msglen)
1000 if (PL_stderrgv && SvREFCNT(PL_stderrgv)
1001 && (io = GvIO(PL_stderrgv))
1002 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
1009 SAVESPTR(PL_stderrgv);
1010 PL_stderrgv = Nullgv;
1012 PUSHSTACKi(PERLSI_MAGIC);
1016 PUSHs(SvTIED_obj((SV*)io, mg));
1017 PUSHs(sv_2mortal(newSVpvn(message, msglen)));
1019 call_method("PRINT", G_SCALAR);
1027 /* SFIO can really mess with your errno */
1030 PerlIO *serr = Perl_error_log;
1032 PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
1033 (void)PerlIO_flush(serr);
1041 Perl_vdie(pTHX_ const char* pat, va_list *args)
1044 int was_in_eval = PL_in_eval;
1052 DEBUG_S(PerlIO_printf(Perl_debug_log,
1053 "%p: die: curstack = %p, mainstack = %p\n",
1054 thr, PL_curstack, PL_mainstack));
1057 msv = vmess(pat, args);
1058 if (PL_errors && SvCUR(PL_errors)) {
1059 sv_catsv(PL_errors, msv);
1060 message = SvPV(PL_errors, msglen);
1061 SvCUR_set(PL_errors, 0);
1064 message = SvPV(msv,msglen);
1072 DEBUG_S(PerlIO_printf(Perl_debug_log,
1073 "%p: die: message = %s\ndiehook = %p\n",
1074 thr, message, PL_diehook));
1076 /* sv_2cv might call Perl_croak() */
1077 SV *olddiehook = PL_diehook;
1079 SAVESPTR(PL_diehook);
1080 PL_diehook = Nullsv;
1081 cv = sv_2cv(olddiehook, &stash, &gv, 0);
1083 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1090 msg = newSVpvn(message, msglen);
1091 SvFLAGS(msg) |= utf8;
1099 PUSHSTACKi(PERLSI_DIEHOOK);
1103 call_sv((SV*)cv, G_DISCARD);
1109 PL_restartop = die_where(message, msglen);
1110 SvFLAGS(ERRSV) |= utf8;
1111 DEBUG_S(PerlIO_printf(Perl_debug_log,
1112 "%p: die: restartop = %p, was_in_eval = %d, top_env = %p\n",
1113 thr, PL_restartop, was_in_eval, PL_top_env));
1114 if ((!PL_restartop && was_in_eval) || PL_top_env->je_prev)
1116 return PL_restartop;
1119 #if defined(PERL_IMPLICIT_CONTEXT)
1121 Perl_die_nocontext(const char* pat, ...)
1126 va_start(args, pat);
1127 o = vdie(pat, &args);
1131 #endif /* PERL_IMPLICIT_CONTEXT */
1134 Perl_die(pTHX_ const char* pat, ...)
1138 va_start(args, pat);
1139 o = vdie(pat, &args);
1145 Perl_vcroak(pTHX_ const char* pat, va_list *args)
1156 msv = vmess(pat, args);
1157 if (PL_errors && SvCUR(PL_errors)) {
1158 sv_catsv(PL_errors, msv);
1159 message = SvPV(PL_errors, msglen);
1160 SvCUR_set(PL_errors, 0);
1163 message = SvPV(msv,msglen);
1171 DEBUG_S(PerlIO_printf(Perl_debug_log, "croak: 0x%"UVxf" %s",
1172 PTR2UV(thr), message));
1175 /* sv_2cv might call Perl_croak() */
1176 SV *olddiehook = PL_diehook;
1178 SAVESPTR(PL_diehook);
1179 PL_diehook = Nullsv;
1180 cv = sv_2cv(olddiehook, &stash, &gv, 0);
1182 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1189 msg = newSVpvn(message, msglen);
1190 SvFLAGS(msg) |= utf8;
1198 PUSHSTACKi(PERLSI_DIEHOOK);
1202 call_sv((SV*)cv, G_DISCARD);
1208 PL_restartop = die_where(message, msglen);
1209 SvFLAGS(ERRSV) |= utf8;
1213 message = SvPVx(ERRSV, msglen);
1215 write_to_stderr(message, msglen);
1219 #if defined(PERL_IMPLICIT_CONTEXT)
1221 Perl_croak_nocontext(const char *pat, ...)
1225 va_start(args, pat);
1230 #endif /* PERL_IMPLICIT_CONTEXT */
1233 =head1 Warning and Dieing
1237 This is the XSUB-writer's interface to Perl's C<die> function.
1238 Normally call this function the same way you call the C C<printf>
1239 function. Calling C<croak> returns control directly to Perl,
1240 sidestepping the normal C order of execution. See C<warn>.
1242 If you want to throw an exception object, assign the object to
1243 C<$@> and then pass C<Nullch> to croak():
1245 errsv = get_sv("@", TRUE);
1246 sv_setsv(errsv, exception_object);
1253 Perl_croak(pTHX_ const char *pat, ...)
1256 va_start(args, pat);
1263 Perl_vwarn(pTHX_ const char* pat, va_list *args)
1273 msv = vmess(pat, args);
1275 message = SvPV(msv, msglen);
1278 /* sv_2cv might call Perl_warn() */
1279 SV *oldwarnhook = PL_warnhook;
1281 SAVESPTR(PL_warnhook);
1282 PL_warnhook = Nullsv;
1283 cv = sv_2cv(oldwarnhook, &stash, &gv, 0);
1285 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1291 msg = newSVpvn(message, msglen);
1292 SvFLAGS(msg) |= utf8;
1296 PUSHSTACKi(PERLSI_WARNHOOK);
1300 call_sv((SV*)cv, G_DISCARD);
1307 write_to_stderr(message, msglen);
1310 #if defined(PERL_IMPLICIT_CONTEXT)
1312 Perl_warn_nocontext(const char *pat, ...)
1316 va_start(args, pat);
1320 #endif /* PERL_IMPLICIT_CONTEXT */
1325 This is the XSUB-writer's interface to Perl's C<warn> function. Call this
1326 function the same way you call the C C<printf> function. See C<croak>.
1332 Perl_warn(pTHX_ const char *pat, ...)
1335 va_start(args, pat);
1340 #if defined(PERL_IMPLICIT_CONTEXT)
1342 Perl_warner_nocontext(U32 err, const char *pat, ...)
1346 va_start(args, pat);
1347 vwarner(err, pat, &args);
1350 #endif /* PERL_IMPLICIT_CONTEXT */
1353 Perl_warner(pTHX_ U32 err, const char* pat,...)
1356 va_start(args, pat);
1357 vwarner(err, pat, &args);
1362 Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args)
1372 msv = vmess(pat, args);
1373 message = SvPV(msv, msglen);
1378 /* sv_2cv might call Perl_croak() */
1379 SV *olddiehook = PL_diehook;
1381 SAVESPTR(PL_diehook);
1382 PL_diehook = Nullsv;
1383 cv = sv_2cv(olddiehook, &stash, &gv, 0);
1385 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1391 msg = newSVpvn(message, msglen);
1392 SvFLAGS(msg) |= utf8;
1396 PUSHSTACKi(PERLSI_DIEHOOK);
1400 call_sv((SV*)cv, G_DISCARD);
1406 PL_restartop = die_where(message, msglen);
1407 SvFLAGS(ERRSV) |= utf8;
1410 write_to_stderr(message, msglen);
1415 /* sv_2cv might call Perl_warn() */
1416 SV *oldwarnhook = PL_warnhook;
1418 SAVESPTR(PL_warnhook);
1419 PL_warnhook = Nullsv;
1420 cv = sv_2cv(oldwarnhook, &stash, &gv, 0);
1422 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1428 msg = newSVpvn(message, msglen);
1429 SvFLAGS(msg) |= utf8;
1433 PUSHSTACKi(PERLSI_WARNHOOK);
1437 call_sv((SV*)cv, G_DISCARD);
1443 write_to_stderr(message, msglen);
1447 /* since we've already done strlen() for both nam and val
1448 * we can use that info to make things faster than
1449 * sprintf(s, "%s=%s", nam, val)
1451 #define my_setenv_format(s, nam, nlen, val, vlen) \
1452 Copy(nam, s, nlen, char); \
1454 Copy(val, s+(nlen+1), vlen, char); \
1455 *(s+(nlen+1+vlen)) = '\0'
1457 #ifdef USE_ENVIRON_ARRAY
1458 /* VMS' my_setenv() is in vms.c */
1459 #if !defined(WIN32) && !defined(NETWARE)
1461 Perl_my_setenv(pTHX_ char *nam, char *val)
1464 /* only parent thread can modify process environment */
1465 if (PL_curinterp == aTHX)
1468 #ifndef PERL_USE_SAFE_PUTENV
1469 /* most putenv()s leak, so we manipulate environ directly */
1470 register I32 i=setenv_getix(nam); /* where does it go? */
1473 if (environ == PL_origenviron) { /* need we copy environment? */
1479 for (max = i; environ[max]; max++) ;
1480 tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*));
1481 for (j=0; j<max; j++) { /* copy environment */
1482 int len = strlen(environ[j]);
1483 tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char));
1484 Copy(environ[j], tmpenv[j], len+1, char);
1486 tmpenv[max] = Nullch;
1487 environ = tmpenv; /* tell exec where it is now */
1490 safesysfree(environ[i]);
1491 while (environ[i]) {
1492 environ[i] = environ[i+1];
1497 if (!environ[i]) { /* does not exist yet */
1498 environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
1499 environ[i+1] = Nullch; /* make sure it's null terminated */
1502 safesysfree(environ[i]);
1506 environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char));
1507 /* all that work just for this */
1508 my_setenv_format(environ[i], nam, nlen, val, vlen);
1510 #else /* PERL_USE_SAFE_PUTENV */
1511 # if defined(__CYGWIN__) || defined( EPOC)
1512 setenv(nam, val, 1);
1515 int nlen = strlen(nam), vlen;
1520 new_env = (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
1521 /* all that work just for this */
1522 my_setenv_format(new_env, nam, nlen, val, vlen);
1523 (void)putenv(new_env);
1524 # endif /* __CYGWIN__ */
1525 #endif /* PERL_USE_SAFE_PUTENV */
1529 #else /* WIN32 || NETWARE */
1532 Perl_my_setenv(pTHX_ char *nam,char *val)
1534 register char *envstr;
1535 int nlen = strlen(nam), vlen;
1541 New(904, envstr, nlen+vlen+2, char);
1542 my_setenv_format(envstr, nam, nlen, val, vlen);
1543 (void)PerlEnv_putenv(envstr);
1547 #endif /* WIN32 || NETWARE */
1551 Perl_setenv_getix(pTHX_ char *nam)
1553 register I32 i, len = strlen(nam);
1555 for (i = 0; environ[i]; i++) {
1558 strnicmp(environ[i],nam,len) == 0
1560 strnEQ(environ[i],nam,len)
1562 && environ[i][len] == '=')
1563 break; /* strnEQ must come first to avoid */
1564 } /* potential SEGV's */
1567 #endif /* !PERL_MICRO */
1569 #endif /* !VMS && !EPOC*/
1571 #ifdef UNLINK_ALL_VERSIONS
1573 Perl_unlnk(pTHX_ char *f) /* unlink all versions of a file */
1577 for (i = 0; PerlLIO_unlink(f) >= 0; i++) ;
1582 /* this is a drop-in replacement for bcopy() */
1583 #if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY))
1585 Perl_my_bcopy(register const char *from,register char *to,register I32 len)
1589 if (from - to >= 0) {
1597 *(--to) = *(--from);
1603 /* this is a drop-in replacement for memset() */
1606 Perl_my_memset(register char *loc, register I32 ch, register I32 len)
1616 /* this is a drop-in replacement for bzero() */
1617 #if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
1619 Perl_my_bzero(register char *loc, register I32 len)
1629 /* this is a drop-in replacement for memcmp() */
1630 #if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
1632 Perl_my_memcmp(const char *s1, const char *s2, register I32 len)
1634 register U8 *a = (U8 *)s1;
1635 register U8 *b = (U8 *)s2;
1639 if (tmp = *a++ - *b++)
1644 #endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */
1648 #ifdef USE_CHAR_VSPRINTF
1653 vsprintf(char *dest, const char *pat, char *args)
1657 fakebuf._ptr = dest;
1658 fakebuf._cnt = 32767;
1662 fakebuf._flag = _IOWRT|_IOSTRG;
1663 _doprnt(pat, args, &fakebuf); /* what a kludge */
1664 (void)putc('\0', &fakebuf);
1665 #ifdef USE_CHAR_VSPRINTF
1668 return 0; /* perl doesn't use return value */
1672 #endif /* HAS_VPRINTF */
1675 #if BYTEORDER != 0x4321
1677 Perl_my_swap(pTHX_ short s)
1679 #if (BYTEORDER & 1) == 0
1682 result = ((s & 255) << 8) + ((s >> 8) & 255);
1690 Perl_my_htonl(pTHX_ long l)
1694 char c[sizeof(long)];
1697 #if BYTEORDER == 0x1234
1698 u.c[0] = (l >> 24) & 255;
1699 u.c[1] = (l >> 16) & 255;
1700 u.c[2] = (l >> 8) & 255;
1704 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
1705 Perl_croak(aTHX_ "Unknown BYTEORDER\n");
1710 for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
1711 u.c[o & 0xf] = (l >> s) & 255;
1719 Perl_my_ntohl(pTHX_ long l)
1723 char c[sizeof(long)];
1726 #if BYTEORDER == 0x1234
1727 u.c[0] = (l >> 24) & 255;
1728 u.c[1] = (l >> 16) & 255;
1729 u.c[2] = (l >> 8) & 255;
1733 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
1734 Perl_croak(aTHX_ "Unknown BYTEORDER\n");
1741 for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
1742 l |= (u.c[o & 0xf] & 255) << s;
1749 #endif /* BYTEORDER != 0x4321 */
1753 * Little-endian byte order functions - 'v' for 'VAX', or 'reVerse'.
1754 * If these functions are defined,
1755 * the BYTEORDER is neither 0x1234 nor 0x4321.
1756 * However, this is not assumed.
1760 #define HTOLE(name,type) \
1762 name (register type n) \
1766 char c[sizeof(type)]; \
1769 register I32 s = 0; \
1770 for (i = 0; i < sizeof(u.c); i++, s += 8) { \
1771 u.c[i] = (n >> s) & 0xFF; \
1776 #define LETOH(name,type) \
1778 name (register type n) \
1782 char c[sizeof(type)]; \
1785 register I32 s = 0; \
1788 for (i = 0; i < sizeof(u.c); i++, s += 8) { \
1789 n |= ((type)(u.c[i] & 0xFF)) << s; \
1795 * Big-endian byte order functions.
1798 #define HTOBE(name,type) \
1800 name (register type n) \
1804 char c[sizeof(type)]; \
1807 register I32 s = 8*(sizeof(u.c)-1); \
1808 for (i = 0; i < sizeof(u.c); i++, s -= 8) { \
1809 u.c[i] = (n >> s) & 0xFF; \
1814 #define BETOH(name,type) \
1816 name (register type n) \
1820 char c[sizeof(type)]; \
1823 register I32 s = 8*(sizeof(u.c)-1); \
1826 for (i = 0; i < sizeof(u.c); i++, s -= 8) { \
1827 n |= ((type)(u.c[i] & 0xFF)) << s; \
1833 * If we just can't do it...
1836 #define NOT_AVAIL(name,type) \
1838 name (register type n) \
1840 Perl_croak_nocontext(#name "() not available"); \
1841 return n; /* not reached */ \
1845 #if defined(HAS_HTOVS) && !defined(htovs)
1848 #if defined(HAS_HTOVL) && !defined(htovl)
1851 #if defined(HAS_VTOHS) && !defined(vtohs)
1854 #if defined(HAS_VTOHL) && !defined(vtohl)
1858 #ifdef PERL_NEED_MY_HTOLE16
1860 HTOLE(Perl_my_htole16,U16)
1862 NOT_AVAIL(Perl_my_htole16,U16)
1865 #ifdef PERL_NEED_MY_LETOH16
1867 LETOH(Perl_my_letoh16,U16)
1869 NOT_AVAIL(Perl_my_letoh16,U16)
1872 #ifdef PERL_NEED_MY_HTOBE16
1874 HTOBE(Perl_my_htobe16,U16)
1876 NOT_AVAIL(Perl_my_htobe16,U16)
1879 #ifdef PERL_NEED_MY_BETOH16
1881 BETOH(Perl_my_betoh16,U16)
1883 NOT_AVAIL(Perl_my_betoh16,U16)
1887 #ifdef PERL_NEED_MY_HTOLE32
1889 HTOLE(Perl_my_htole32,U32)
1891 NOT_AVAIL(Perl_my_htole32,U32)
1894 #ifdef PERL_NEED_MY_LETOH32
1896 LETOH(Perl_my_letoh32,U32)
1898 NOT_AVAIL(Perl_my_letoh32,U32)
1901 #ifdef PERL_NEED_MY_HTOBE32
1903 HTOBE(Perl_my_htobe32,U32)
1905 NOT_AVAIL(Perl_my_htobe32,U32)
1908 #ifdef PERL_NEED_MY_BETOH32
1910 BETOH(Perl_my_betoh32,U32)
1912 NOT_AVAIL(Perl_my_betoh32,U32)
1916 #ifdef PERL_NEED_MY_HTOLE64
1918 HTOLE(Perl_my_htole64,U64)
1920 NOT_AVAIL(Perl_my_htole64,U64)
1923 #ifdef PERL_NEED_MY_LETOH64
1925 LETOH(Perl_my_letoh64,U64)
1927 NOT_AVAIL(Perl_my_letoh64,U64)
1930 #ifdef PERL_NEED_MY_HTOBE64
1932 HTOBE(Perl_my_htobe64,U64)
1934 NOT_AVAIL(Perl_my_htobe64,U64)
1937 #ifdef PERL_NEED_MY_BETOH64
1939 BETOH(Perl_my_betoh64,U64)
1941 NOT_AVAIL(Perl_my_betoh64,U64)
1945 #ifdef PERL_NEED_MY_HTOLES
1946 HTOLE(Perl_my_htoles,short)
1948 #ifdef PERL_NEED_MY_LETOHS
1949 LETOH(Perl_my_letohs,short)
1951 #ifdef PERL_NEED_MY_HTOBES
1952 HTOBE(Perl_my_htobes,short)
1954 #ifdef PERL_NEED_MY_BETOHS
1955 BETOH(Perl_my_betohs,short)
1958 #ifdef PERL_NEED_MY_HTOLEI
1959 HTOLE(Perl_my_htolei,int)
1961 #ifdef PERL_NEED_MY_LETOHI
1962 LETOH(Perl_my_letohi,int)
1964 #ifdef PERL_NEED_MY_HTOBEI
1965 HTOBE(Perl_my_htobei,int)
1967 #ifdef PERL_NEED_MY_BETOHI
1968 BETOH(Perl_my_betohi,int)
1971 #ifdef PERL_NEED_MY_HTOLEL
1972 HTOLE(Perl_my_htolel,long)
1974 #ifdef PERL_NEED_MY_LETOHL
1975 LETOH(Perl_my_letohl,long)
1977 #ifdef PERL_NEED_MY_HTOBEL
1978 HTOBE(Perl_my_htobel,long)
1980 #ifdef PERL_NEED_MY_BETOHL
1981 BETOH(Perl_my_betohl,long)
1985 Perl_my_swabn(void *ptr, int n)
1987 register char *s = (char *)ptr;
1988 register char *e = s + (n-1);
1991 for (n /= 2; n > 0; s++, e--, n--) {
1999 Perl_my_popen_list(pTHX_ char *mode, int n, SV **args)
2001 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) && !defined(NETWARE)
2003 register I32 This, that;
2009 PERL_FLUSHALL_FOR_CHILD;
2010 This = (*mode == 'w');
2014 taint_proper("Insecure %s%s", "EXEC");
2016 if (PerlProc_pipe(p) < 0)
2018 /* Try for another pipe pair for error return */
2019 if (PerlProc_pipe(pp) >= 0)
2021 while ((pid = PerlProc_fork()) < 0) {
2022 if (errno != EAGAIN) {
2023 PerlLIO_close(p[This]);
2024 PerlLIO_close(p[that]);
2026 PerlLIO_close(pp[0]);
2027 PerlLIO_close(pp[1]);
2039 /* Close parent's end of error status pipe (if any) */
2041 PerlLIO_close(pp[0]);
2042 #if defined(HAS_FCNTL) && defined(F_SETFD)
2043 /* Close error pipe automatically if exec works */
2044 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2047 /* Now dup our end of _the_ pipe to right position */
2048 if (p[THIS] != (*mode == 'r')) {
2049 PerlLIO_dup2(p[THIS], *mode == 'r');
2050 PerlLIO_close(p[THIS]);
2051 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2052 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
2055 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
2056 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2057 /* No automatic close - do it by hand */
2064 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) {
2070 do_aexec5(Nullsv, args-1, args-1+n, pp[1], did_pipes);
2076 do_execfree(); /* free any memory malloced by child on fork */
2078 PerlLIO_close(pp[1]);
2079 /* Keep the lower of the two fd numbers */
2080 if (p[that] < p[This]) {
2081 PerlLIO_dup2(p[This], p[that]);
2082 PerlLIO_close(p[This]);
2086 PerlLIO_close(p[that]); /* close child's end of pipe */
2089 sv = *av_fetch(PL_fdpid,p[This],TRUE);
2091 (void)SvUPGRADE(sv,SVt_IV);
2093 PL_forkprocess = pid;
2094 /* If we managed to get status pipe check for exec fail */
2095 if (did_pipes && pid > 0) {
2099 while (n < sizeof(int)) {
2100 n1 = PerlLIO_read(pp[0],
2101 (void*)(((char*)&errkid)+n),
2107 PerlLIO_close(pp[0]);
2109 if (n) { /* Error */
2111 PerlLIO_close(p[This]);
2112 if (n != sizeof(int))
2113 Perl_croak(aTHX_ "panic: kid popen errno read");
2115 pid2 = wait4pid(pid, &status, 0);
2116 } while (pid2 == -1 && errno == EINTR);
2117 errno = errkid; /* Propagate errno from kid */
2122 PerlLIO_close(pp[0]);
2123 return PerlIO_fdopen(p[This], mode);
2125 Perl_croak(aTHX_ "List form of piped open not implemented");
2126 return (PerlIO *) NULL;
2130 /* VMS' my_popen() is in VMS.c, same with OS/2. */
2131 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
2133 Perl_my_popen(pTHX_ char *cmd, char *mode)
2136 register I32 This, that;
2139 I32 doexec = strNE(cmd,"-");
2143 PERL_FLUSHALL_FOR_CHILD;
2146 return my_syspopen(aTHX_ cmd,mode);
2149 This = (*mode == 'w');
2151 if (doexec && PL_tainting) {
2153 taint_proper("Insecure %s%s", "EXEC");
2155 if (PerlProc_pipe(p) < 0)
2157 if (doexec && PerlProc_pipe(pp) >= 0)
2159 while ((pid = PerlProc_fork()) < 0) {
2160 if (errno != EAGAIN) {
2161 PerlLIO_close(p[This]);
2162 PerlLIO_close(p[that]);
2164 PerlLIO_close(pp[0]);
2165 PerlLIO_close(pp[1]);
2168 Perl_croak(aTHX_ "Can't fork");
2181 PerlLIO_close(pp[0]);
2182 #if defined(HAS_FCNTL) && defined(F_SETFD)
2183 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2186 if (p[THIS] != (*mode == 'r')) {
2187 PerlLIO_dup2(p[THIS], *mode == 'r');
2188 PerlLIO_close(p[THIS]);
2189 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2190 PerlLIO_close(p[THAT]);
2193 PerlLIO_close(p[THAT]);
2196 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2205 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
2210 /* may or may not use the shell */
2211 do_exec3(cmd, pp[1], did_pipes);
2214 #endif /* defined OS2 */
2216 if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) {
2217 SvREADONLY_off(GvSV(tmpgv));
2218 sv_setiv(GvSV(tmpgv), PerlProc_getpid());
2219 SvREADONLY_on(GvSV(tmpgv));
2221 #ifdef THREADS_HAVE_PIDS
2222 PL_ppid = (IV)getppid();
2225 hv_clear(PL_pidstatus); /* we have no children */
2230 do_execfree(); /* free any memory malloced by child on vfork */
2232 PerlLIO_close(pp[1]);
2233 if (p[that] < p[This]) {
2234 PerlLIO_dup2(p[This], p[that]);
2235 PerlLIO_close(p[This]);
2239 PerlLIO_close(p[that]);
2242 sv = *av_fetch(PL_fdpid,p[This],TRUE);
2244 (void)SvUPGRADE(sv,SVt_IV);
2246 PL_forkprocess = pid;
2247 if (did_pipes && pid > 0) {
2251 while (n < sizeof(int)) {
2252 n1 = PerlLIO_read(pp[0],
2253 (void*)(((char*)&errkid)+n),
2259 PerlLIO_close(pp[0]);
2261 if (n) { /* Error */
2263 PerlLIO_close(p[This]);
2264 if (n != sizeof(int))
2265 Perl_croak(aTHX_ "panic: kid popen errno read");
2267 pid2 = wait4pid(pid, &status, 0);
2268 } while (pid2 == -1 && errno == EINTR);
2269 errno = errkid; /* Propagate errno from kid */
2274 PerlLIO_close(pp[0]);
2275 return PerlIO_fdopen(p[This], mode);
2278 #if defined(atarist) || defined(EPOC)
2281 Perl_my_popen(pTHX_ char *cmd, char *mode)
2283 PERL_FLUSHALL_FOR_CHILD;
2284 /* Call system's popen() to get a FILE *, then import it.
2285 used 0 for 2nd parameter to PerlIO_importFILE;
2288 return PerlIO_importFILE(popen(cmd, mode), 0);
2292 FILE *djgpp_popen();
2294 Perl_my_popen(pTHX_ char *cmd, char *mode)
2296 PERL_FLUSHALL_FOR_CHILD;
2297 /* Call system's popen() to get a FILE *, then import it.
2298 used 0 for 2nd parameter to PerlIO_importFILE;
2301 return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
2306 #endif /* !DOSISH */
2308 /* this is called in parent before the fork() */
2310 Perl_atfork_lock(void)
2312 #if defined(USE_ITHREADS)
2313 /* locks must be held in locking order (if any) */
2315 MUTEX_LOCK(&PL_malloc_mutex);
2321 /* this is called in both parent and child after the fork() */
2323 Perl_atfork_unlock(void)
2325 #if defined(USE_ITHREADS)
2326 /* locks must be released in same order as in atfork_lock() */
2328 MUTEX_UNLOCK(&PL_malloc_mutex);
2337 #if defined(HAS_FORK)
2339 #if defined(USE_ITHREADS) && !defined(HAS_PTHREAD_ATFORK)
2344 /* atfork_lock() and atfork_unlock() are installed as pthread_atfork()
2345 * handlers elsewhere in the code */
2350 /* this "canna happen" since nothing should be calling here if !HAS_FORK */
2351 Perl_croak_nocontext("fork() not available");
2353 #endif /* HAS_FORK */
2358 Perl_dump_fds(pTHX_ char *s)
2363 PerlIO_printf(Perl_debug_log,"%s", s);
2364 for (fd = 0; fd < 32; fd++) {
2365 if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0)
2366 PerlIO_printf(Perl_debug_log," %d",fd);
2368 PerlIO_printf(Perl_debug_log,"\n");
2370 #endif /* DUMP_FDS */
2374 dup2(int oldfd, int newfd)
2376 #if defined(HAS_FCNTL) && defined(F_DUPFD)
2379 PerlLIO_close(newfd);
2380 return fcntl(oldfd, F_DUPFD, newfd);
2382 #define DUP2_MAX_FDS 256
2383 int fdtmp[DUP2_MAX_FDS];
2389 PerlLIO_close(newfd);
2390 /* good enough for low fd's... */
2391 while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
2392 if (fdx >= DUP2_MAX_FDS) {
2400 PerlLIO_close(fdtmp[--fdx]);
2407 #ifdef HAS_SIGACTION
2409 #ifdef MACOS_TRADITIONAL
2410 /* We don't want restart behavior on MacOS */
2415 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2417 struct sigaction act, oact;
2420 /* only "parent" interpreter can diddle signals */
2421 if (PL_curinterp != aTHX)
2425 act.sa_handler = handler;
2426 sigemptyset(&act.sa_mask);
2429 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2430 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
2432 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2433 if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN)
2434 act.sa_flags |= SA_NOCLDWAIT;
2436 if (sigaction(signo, &act, &oact) == -1)
2439 return oact.sa_handler;
2443 Perl_rsignal_state(pTHX_ int signo)
2445 struct sigaction oact;
2447 if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
2450 return oact.sa_handler;
2454 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2456 struct sigaction act;
2459 /* only "parent" interpreter can diddle signals */
2460 if (PL_curinterp != aTHX)
2464 act.sa_handler = handler;
2465 sigemptyset(&act.sa_mask);
2468 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2469 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
2471 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2472 if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN)
2473 act.sa_flags |= SA_NOCLDWAIT;
2475 return sigaction(signo, &act, save);
2479 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2482 /* only "parent" interpreter can diddle signals */
2483 if (PL_curinterp != aTHX)
2487 return sigaction(signo, save, (struct sigaction *)NULL);
2490 #else /* !HAS_SIGACTION */
2493 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2495 #if defined(USE_ITHREADS) && !defined(WIN32)
2496 /* only "parent" interpreter can diddle signals */
2497 if (PL_curinterp != aTHX)
2501 return PerlProc_signal(signo, handler);
2504 static int sig_trapped; /* XXX signals are process-wide anyway, so we
2505 ignore the implications of this for threading */
2515 Perl_rsignal_state(pTHX_ int signo)
2517 Sighandler_t oldsig;
2519 #if defined(USE_ITHREADS) && !defined(WIN32)
2520 /* only "parent" interpreter can diddle signals */
2521 if (PL_curinterp != aTHX)
2526 oldsig = PerlProc_signal(signo, sig_trap);
2527 PerlProc_signal(signo, oldsig);
2529 PerlProc_kill(PerlProc_getpid(), signo);
2534 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2536 #if defined(USE_ITHREADS) && !defined(WIN32)
2537 /* only "parent" interpreter can diddle signals */
2538 if (PL_curinterp != aTHX)
2541 *save = PerlProc_signal(signo, handler);
2542 return (*save == SIG_ERR) ? -1 : 0;
2546 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2548 #if defined(USE_ITHREADS) && !defined(WIN32)
2549 /* only "parent" interpreter can diddle signals */
2550 if (PL_curinterp != aTHX)
2553 return (PerlProc_signal(signo, *save) == SIG_ERR) ? -1 : 0;
2556 #endif /* !HAS_SIGACTION */
2557 #endif /* !PERL_MICRO */
2559 /* VMS' my_pclose() is in VMS.c; same with OS/2 */
2560 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
2562 Perl_my_pclose(pTHX_ PerlIO *ptr)
2564 Sigsave_t hstat, istat, qstat;
2570 int saved_errno = 0;
2572 int saved_vaxc_errno;
2575 int saved_win32_errno;
2579 svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE);
2581 pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
2583 *svp = &PL_sv_undef;
2585 if (pid == -1) { /* Opened by popen. */
2586 return my_syspclose(ptr);
2589 if ((close_failed = (PerlIO_close(ptr) == EOF))) {
2590 saved_errno = errno;
2592 saved_vaxc_errno = vaxc$errno;
2595 saved_win32_errno = GetLastError();
2599 if(PerlProc_kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */
2602 rsignal_save(SIGHUP, SIG_IGN, &hstat);
2603 rsignal_save(SIGINT, SIG_IGN, &istat);
2604 rsignal_save(SIGQUIT, SIG_IGN, &qstat);
2607 pid2 = wait4pid(pid, &status, 0);
2608 } while (pid2 == -1 && errno == EINTR);
2610 rsignal_restore(SIGHUP, &hstat);
2611 rsignal_restore(SIGINT, &istat);
2612 rsignal_restore(SIGQUIT, &qstat);
2615 SETERRNO(saved_errno, saved_vaxc_errno);
2618 return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status));
2620 #endif /* !DOSISH */
2622 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(MACOS_TRADITIONAL)
2624 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
2629 #if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME)
2633 char spid[TYPE_CHARS(int)];
2636 sprintf(spid, "%"IVdf, (IV)pid);
2637 svp = hv_fetch(PL_pidstatus,spid,strlen(spid),FALSE);
2638 if (svp && *svp != &PL_sv_undef) {
2639 *statusp = SvIVX(*svp);
2640 (void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD);
2647 hv_iterinit(PL_pidstatus);
2648 if ((entry = hv_iternext(PL_pidstatus))) {
2650 char spid[TYPE_CHARS(int)];
2652 pid = atoi(hv_iterkey(entry,(I32*)statusp));
2653 sv = hv_iterval(PL_pidstatus,entry);
2654 *statusp = SvIVX(sv);
2655 sprintf(spid, "%"IVdf, (IV)pid);
2656 (void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD);
2663 # ifdef HAS_WAITPID_RUNTIME
2664 if (!HAS_WAITPID_RUNTIME)
2667 result = PerlProc_waitpid(pid,statusp,flags);
2670 #if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
2671 result = wait4((pid==-1)?0:pid,statusp,flags,Null(struct rusage *));
2674 #if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME)
2678 Perl_croak(aTHX_ "Can't do waitpid with flags");
2680 while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
2681 pidgone(result,*statusp);
2688 if (result < 0 && errno == EINTR) {
2693 #endif /* !DOSISH || OS2 || WIN32 || NETWARE */
2697 Perl_pidgone(pTHX_ Pid_t pid, int status)
2700 char spid[TYPE_CHARS(int)];
2702 sprintf(spid, "%"IVdf, (IV)pid);
2703 sv = *hv_fetch(PL_pidstatus,spid,strlen(spid),TRUE);
2704 (void)SvUPGRADE(sv,SVt_IV);
2709 #if defined(atarist) || defined(OS2) || defined(EPOC)
2712 int /* Cannot prototype with I32
2714 my_syspclose(PerlIO *ptr)
2717 Perl_my_pclose(pTHX_ PerlIO *ptr)
2720 /* Needs work for PerlIO ! */
2721 FILE *f = PerlIO_findFILE(ptr);
2722 I32 result = pclose(f);
2723 PerlIO_releaseFILE(ptr,f);
2731 Perl_my_pclose(pTHX_ PerlIO *ptr)
2733 /* Needs work for PerlIO ! */
2734 FILE *f = PerlIO_findFILE(ptr);
2735 I32 result = djgpp_pclose(f);
2736 result = (result << 8) & 0xff00;
2737 PerlIO_releaseFILE(ptr,f);
2743 Perl_repeatcpy(pTHX_ register char *to, register const char *from, I32 len, register I32 count)
2746 register const char *frombase = from;
2749 register const char c = *from;
2754 while (count-- > 0) {
2755 for (todo = len; todo > 0; todo--) {
2764 Perl_same_dirent(pTHX_ char *a, char *b)
2766 char *fa = strrchr(a,'/');
2767 char *fb = strrchr(b,'/');
2770 SV *tmpsv = sv_newmortal();
2783 sv_setpv(tmpsv, ".");
2785 sv_setpvn(tmpsv, a, fa - a);
2786 if (PerlLIO_stat(SvPVX(tmpsv), &tmpstatbuf1) < 0)
2789 sv_setpv(tmpsv, ".");
2791 sv_setpvn(tmpsv, b, fb - b);
2792 if (PerlLIO_stat(SvPVX(tmpsv), &tmpstatbuf2) < 0)
2794 return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
2795 tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
2797 #endif /* !HAS_RENAME */
2800 Perl_find_script(pTHX_ char *scriptname, bool dosearch, char **search_ext, I32 flags)
2802 char *xfound = Nullch;
2803 char *xfailed = Nullch;
2804 char tmpbuf[MAXPATHLEN];
2808 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
2809 # define SEARCH_EXTS ".bat", ".cmd", NULL
2810 # define MAX_EXT_LEN 4
2813 # define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
2814 # define MAX_EXT_LEN 4
2817 # define SEARCH_EXTS ".pl", ".com", NULL
2818 # define MAX_EXT_LEN 4
2820 /* additional extensions to try in each dir if scriptname not found */
2822 char *exts[] = { SEARCH_EXTS };
2823 char **ext = search_ext ? search_ext : exts;
2824 int extidx = 0, i = 0;
2825 char *curext = Nullch;
2827 # define MAX_EXT_LEN 0
2831 * If dosearch is true and if scriptname does not contain path
2832 * delimiters, search the PATH for scriptname.
2834 * If SEARCH_EXTS is also defined, will look for each
2835 * scriptname{SEARCH_EXTS} whenever scriptname is not found
2836 * while searching the PATH.
2838 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
2839 * proceeds as follows:
2840 * If DOSISH or VMSISH:
2841 * + look for ./scriptname{,.foo,.bar}
2842 * + search the PATH for scriptname{,.foo,.bar}
2845 * + look *only* in the PATH for scriptname{,.foo,.bar} (note
2846 * this will not look in '.' if it's not in the PATH)
2851 # ifdef ALWAYS_DEFTYPES
2852 len = strlen(scriptname);
2853 if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
2854 int hasdir, idx = 0, deftypes = 1;
2857 hasdir = !dosearch || (strpbrk(scriptname,":[</") != Nullch) ;
2860 int hasdir, idx = 0, deftypes = 1;
2863 hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
2865 /* The first time through, just add SEARCH_EXTS to whatever we
2866 * already have, so we can check for default file types. */
2868 (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
2874 if ((strlen(tmpbuf) + strlen(scriptname)
2875 + MAX_EXT_LEN) >= sizeof tmpbuf)
2876 continue; /* don't search dir with too-long name */
2877 strcat(tmpbuf, scriptname);
2881 if (strEQ(scriptname, "-"))
2883 if (dosearch) { /* Look in '.' first. */
2884 char *cur = scriptname;
2886 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
2888 if (strEQ(ext[i++],curext)) {
2889 extidx = -1; /* already has an ext */
2894 DEBUG_p(PerlIO_printf(Perl_debug_log,
2895 "Looking for %s\n",cur));
2896 if (PerlLIO_stat(cur,&PL_statbuf) >= 0
2897 && !S_ISDIR(PL_statbuf.st_mode)) {
2905 if (cur == scriptname) {
2906 len = strlen(scriptname);
2907 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
2909 cur = strcpy(tmpbuf, scriptname);
2911 } while (extidx >= 0 && ext[extidx] /* try an extension? */
2912 && strcpy(tmpbuf+len, ext[extidx++]));
2917 #ifdef MACOS_TRADITIONAL
2918 if (dosearch && !strchr(scriptname, ':') &&
2919 (s = PerlEnv_getenv("Commands")))
2921 if (dosearch && !strchr(scriptname, '/')
2923 && !strchr(scriptname, '\\')
2925 && (s = PerlEnv_getenv("PATH")))
2930 PL_bufend = s + strlen(s);
2931 while (s < PL_bufend) {
2932 #ifdef MACOS_TRADITIONAL
2933 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
2937 #if defined(atarist) || defined(DOSISH)
2942 && *s != ';'; len++, s++) {
2943 if (len < sizeof tmpbuf)
2946 if (len < sizeof tmpbuf)
2948 #else /* ! (atarist || DOSISH) */
2949 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
2952 #endif /* ! (atarist || DOSISH) */
2953 #endif /* MACOS_TRADITIONAL */
2956 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
2957 continue; /* don't search dir with too-long name */
2958 #ifdef MACOS_TRADITIONAL
2959 if (len && tmpbuf[len - 1] != ':')
2960 tmpbuf[len++] = ':';
2963 #if defined(atarist) || defined(__MINT__) || defined(DOSISH)
2964 && tmpbuf[len - 1] != '/'
2965 && tmpbuf[len - 1] != '\\'
2968 tmpbuf[len++] = '/';
2969 if (len == 2 && tmpbuf[0] == '.')
2972 (void)strcpy(tmpbuf + len, scriptname);
2976 len = strlen(tmpbuf);
2977 if (extidx > 0) /* reset after previous loop */
2981 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
2982 retval = PerlLIO_stat(tmpbuf,&PL_statbuf);
2983 if (S_ISDIR(PL_statbuf.st_mode)) {
2987 } while ( retval < 0 /* not there */
2988 && extidx>=0 && ext[extidx] /* try an extension? */
2989 && strcpy(tmpbuf+len, ext[extidx++])
2994 if (S_ISREG(PL_statbuf.st_mode)
2995 && cando(S_IRUSR,TRUE,&PL_statbuf)
2996 #if !defined(DOSISH) && !defined(MACOS_TRADITIONAL)
2997 && cando(S_IXUSR,TRUE,&PL_statbuf)
3001 xfound = tmpbuf; /* bingo! */
3005 xfailed = savepv(tmpbuf);
3008 if (!xfound && !seen_dot && !xfailed &&
3009 (PerlLIO_stat(scriptname,&PL_statbuf) < 0
3010 || S_ISDIR(PL_statbuf.st_mode)))
3012 seen_dot = 1; /* Disable message. */
3014 if (flags & 1) { /* do or die? */
3015 Perl_croak(aTHX_ "Can't %s %s%s%s",
3016 (xfailed ? "execute" : "find"),
3017 (xfailed ? xfailed : scriptname),
3018 (xfailed ? "" : " on PATH"),
3019 (xfailed || seen_dot) ? "" : ", '.' not in PATH");
3021 scriptname = Nullch;
3025 scriptname = xfound;
3027 return (scriptname ? savepv(scriptname) : Nullch);
3030 #ifndef PERL_GET_CONTEXT_DEFINED
3033 Perl_get_context(void)
3035 #if defined(USE_ITHREADS)
3036 # ifdef OLD_PTHREADS_API
3038 if (pthread_getspecific(PL_thr_key, &t))
3039 Perl_croak_nocontext("panic: pthread_getspecific");
3042 # ifdef I_MACH_CTHREADS
3043 return (void*)cthread_data(cthread_self());
3045 return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
3054 Perl_set_context(void *t)
3056 #if defined(USE_ITHREADS)
3057 # ifdef I_MACH_CTHREADS
3058 cthread_set_data(cthread_self(), t);
3060 if (pthread_setspecific(PL_thr_key, t))
3061 Perl_croak_nocontext("panic: pthread_setspecific");
3066 #endif /* !PERL_GET_CONTEXT_DEFINED */
3068 #ifdef PERL_GLOBAL_STRUCT
3077 Perl_get_op_names(pTHX)
3083 Perl_get_op_descs(pTHX)
3089 Perl_get_no_modify(pTHX)
3091 return (char*)PL_no_modify;
3095 Perl_get_opargs(pTHX)
3101 Perl_get_ppaddr(pTHX)
3103 return (PPADDR_t*)PL_ppaddr;
3106 #ifndef HAS_GETENV_LEN
3108 Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
3110 char *env_trans = PerlEnv_getenv(env_elem);
3112 *len = strlen(env_trans);
3119 Perl_get_vtbl(pTHX_ int vtbl_id)
3121 MGVTBL* result = Null(MGVTBL*);
3125 result = &PL_vtbl_sv;
3128 result = &PL_vtbl_env;
3130 case want_vtbl_envelem:
3131 result = &PL_vtbl_envelem;
3134 result = &PL_vtbl_sig;
3136 case want_vtbl_sigelem:
3137 result = &PL_vtbl_sigelem;
3139 case want_vtbl_pack:
3140 result = &PL_vtbl_pack;
3142 case want_vtbl_packelem:
3143 result = &PL_vtbl_packelem;
3145 case want_vtbl_dbline:
3146 result = &PL_vtbl_dbline;
3149 result = &PL_vtbl_isa;
3151 case want_vtbl_isaelem:
3152 result = &PL_vtbl_isaelem;
3154 case want_vtbl_arylen:
3155 result = &PL_vtbl_arylen;
3157 case want_vtbl_glob:
3158 result = &PL_vtbl_glob;
3160 case want_vtbl_mglob:
3161 result = &PL_vtbl_mglob;
3163 case want_vtbl_nkeys:
3164 result = &PL_vtbl_nkeys;
3166 case want_vtbl_taint:
3167 result = &PL_vtbl_taint;
3169 case want_vtbl_substr:
3170 result = &PL_vtbl_substr;
3173 result = &PL_vtbl_vec;
3176 result = &PL_vtbl_pos;
3179 result = &PL_vtbl_bm;
3182 result = &PL_vtbl_fm;
3184 case want_vtbl_uvar:
3185 result = &PL_vtbl_uvar;
3187 case want_vtbl_defelem:
3188 result = &PL_vtbl_defelem;
3190 case want_vtbl_regexp:
3191 result = &PL_vtbl_regexp;
3193 case want_vtbl_regdata:
3194 result = &PL_vtbl_regdata;
3196 case want_vtbl_regdatum:
3197 result = &PL_vtbl_regdatum;
3199 #ifdef USE_LOCALE_COLLATE
3200 case want_vtbl_collxfrm:
3201 result = &PL_vtbl_collxfrm;
3204 case want_vtbl_amagic:
3205 result = &PL_vtbl_amagic;
3207 case want_vtbl_amagicelem:
3208 result = &PL_vtbl_amagicelem;
3210 case want_vtbl_backref:
3211 result = &PL_vtbl_backref;
3213 case want_vtbl_utf8:
3214 result = &PL_vtbl_utf8;
3221 Perl_my_fflush_all(pTHX)
3223 #if defined(USE_PERLIO) || defined(FFLUSH_NULL) || defined(USE_SFIO)
3224 return PerlIO_flush(NULL);
3226 # if defined(HAS__FWALK)
3227 extern int fflush(FILE *);
3228 /* undocumented, unprototyped, but very useful BSDism */
3229 extern void _fwalk(int (*)(FILE *));
3233 # if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
3235 # ifdef PERL_FFLUSH_ALL_FOPEN_MAX
3236 open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
3238 # if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
3239 open_max = sysconf(_SC_OPEN_MAX);
3242 open_max = FOPEN_MAX;
3245 open_max = OPEN_MAX;
3256 for (i = 0; i < open_max; i++)
3257 if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
3258 STDIO_STREAM_ARRAY[i]._file < open_max &&
3259 STDIO_STREAM_ARRAY[i]._flag)
3260 PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
3264 SETERRNO(EBADF,RMS_IFI);
3271 Perl_report_evil_fh(pTHX_ GV *gv, IO *io, I32 op)
3274 op == OP_READLINE ? "readline" : /* "<HANDLE>" not nice */
3275 op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */
3277 char *pars = OP_IS_FILETEST(op) ? "" : "()";
3278 char *type = OP_IS_SOCKET(op)
3279 || (gv && io && IoTYPE(io) == IoTYPE_SOCKET)
3280 ? "socket" : "filehandle";
3283 if (gv && isGV(gv)) {
3287 if (op == OP_phoney_OUTPUT_ONLY || op == OP_phoney_INPUT_ONLY) {
3288 if (ckWARN(WARN_IO)) {
3289 const char *direction = (op == OP_phoney_INPUT_ONLY) ? "in" : "out";
3291 Perl_warner(aTHX_ packWARN(WARN_IO),
3292 "Filehandle %s opened only for %sput",
3295 Perl_warner(aTHX_ packWARN(WARN_IO),
3296 "Filehandle opened only for %sput", direction);
3303 if (gv && io && IoTYPE(io) == IoTYPE_CLOSED) {
3305 warn_type = WARN_CLOSED;
3309 warn_type = WARN_UNOPENED;
3312 if (ckWARN(warn_type)) {
3313 if (name && *name) {
3314 Perl_warner(aTHX_ packWARN(warn_type),
3315 "%s%s on %s %s %s", func, pars, vile, type, name);
3316 if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3318 aTHX_ packWARN(warn_type),
3319 "\t(Are you trying to call %s%s on dirhandle %s?)\n",
3324 Perl_warner(aTHX_ packWARN(warn_type),
3325 "%s%s on %s %s", func, pars, vile, type);
3326 if (gv && io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3328 aTHX_ packWARN(warn_type),
3329 "\t(Are you trying to call %s%s on dirhandle?)\n",
3338 /* in ASCII order, not that it matters */
3339 static const char controllablechars[] = "?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_";
3342 Perl_ebcdic_control(pTHX_ int ch)
3350 if ((ctlp = strchr(controllablechars, ch)) == 0) {
3351 Perl_die(aTHX_ "unrecognised control character '%c'\n", ch);
3354 if (ctlp == controllablechars)
3355 return('\177'); /* DEL */
3357 return((unsigned char)(ctlp - controllablechars - 1));
3358 } else { /* Want uncontrol */
3359 if (ch == '\177' || ch == -1)
3361 else if (ch == '\157')
3363 else if (ch == '\174')
3365 else if (ch == '^') /* '\137' in 1047, '\260' in 819 */
3367 else if (ch == '\155')
3369 else if (0 < ch && ch < (sizeof(controllablechars) - 1))
3370 return(controllablechars[ch+1]);
3372 Perl_die(aTHX_ "invalid control request: '\\%03o'\n", ch & 0xFF);
3377 /* To workaround core dumps from the uninitialised tm_zone we get the
3378 * system to give us a reasonable struct to copy. This fix means that
3379 * strftime uses the tm_zone and tm_gmtoff values returned by
3380 * localtime(time()). That should give the desired result most of the
3381 * time. But probably not always!
3383 * This does not address tzname aspects of NETaa14816.
3388 # ifndef STRUCT_TM_HASZONE
3389 # define STRUCT_TM_HASZONE
3393 #ifdef STRUCT_TM_HASZONE /* Backward compat */
3394 # ifndef HAS_TM_TM_ZONE
3395 # define HAS_TM_TM_ZONE
3400 Perl_init_tm(pTHX_ struct tm *ptm) /* see mktime, strftime and asctime */
3402 #ifdef HAS_TM_TM_ZONE
3405 Copy(localtime(&now), ptm, 1, struct tm);
3410 * mini_mktime - normalise struct tm values without the localtime()
3411 * semantics (and overhead) of mktime().
3414 Perl_mini_mktime(pTHX_ struct tm *ptm)
3418 int month, mday, year, jday;
3419 int odd_cent, odd_year;
3421 #define DAYS_PER_YEAR 365
3422 #define DAYS_PER_QYEAR (4*DAYS_PER_YEAR+1)
3423 #define DAYS_PER_CENT (25*DAYS_PER_QYEAR-1)
3424 #define DAYS_PER_QCENT (4*DAYS_PER_CENT+1)
3425 #define SECS_PER_HOUR (60*60)
3426 #define SECS_PER_DAY (24*SECS_PER_HOUR)
3427 /* parentheses deliberately absent on these two, otherwise they don't work */
3428 #define MONTH_TO_DAYS 153/5
3429 #define DAYS_TO_MONTH 5/153
3430 /* offset to bias by March (month 4) 1st between month/mday & year finding */
3431 #define YEAR_ADJUST (4*MONTH_TO_DAYS+1)
3432 /* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */
3433 #define WEEKDAY_BIAS 6 /* (1+6)%7 makes Sunday 0 again */
3436 * Year/day algorithm notes:
3438 * With a suitable offset for numeric value of the month, one can find
3439 * an offset into the year by considering months to have 30.6 (153/5) days,
3440 * using integer arithmetic (i.e., with truncation). To avoid too much
3441 * messing about with leap days, we consider January and February to be
3442 * the 13th and 14th month of the previous year. After that transformation,
3443 * we need the month index we use to be high by 1 from 'normal human' usage,
3444 * so the month index values we use run from 4 through 15.
3446 * Given that, and the rules for the Gregorian calendar (leap years are those
3447 * divisible by 4 unless also divisible by 100, when they must be divisible
3448 * by 400 instead), we can simply calculate the number of days since some
3449 * arbitrary 'beginning of time' by futzing with the (adjusted) year number,
3450 * the days we derive from our month index, and adding in the day of the
3451 * month. The value used here is not adjusted for the actual origin which
3452 * it normally would use (1 January A.D. 1), since we're not exposing it.
3453 * We're only building the value so we can turn around and get the
3454 * normalised values for the year, month, day-of-month, and day-of-year.
3456 * For going backward, we need to bias the value we're using so that we find
3457 * the right year value. (Basically, we don't want the contribution of
3458 * March 1st to the number to apply while deriving the year). Having done
3459 * that, we 'count up' the contribution to the year number by accounting for
3460 * full quadracenturies (400-year periods) with their extra leap days, plus
3461 * the contribution from full centuries (to avoid counting in the lost leap
3462 * days), plus the contribution from full quad-years (to count in the normal
3463 * leap days), plus the leftover contribution from any non-leap years.
3464 * At this point, if we were working with an actual leap day, we'll have 0
3465 * days left over. This is also true for March 1st, however. So, we have
3466 * to special-case that result, and (earlier) keep track of the 'odd'
3467 * century and year contributions. If we got 4 extra centuries in a qcent,
3468 * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb.
3469 * Otherwise, we add back in the earlier bias we removed (the 123 from
3470 * figuring in March 1st), find the month index (integer division by 30.6),
3471 * and the remainder is the day-of-month. We then have to convert back to
3472 * 'real' months (including fixing January and February from being 14/15 in
3473 * the previous year to being in the proper year). After that, to get
3474 * tm_yday, we work with the normalised year and get a new yearday value for
3475 * January 1st, which we subtract from the yearday value we had earlier,
3476 * representing the date we've re-built. This is done from January 1
3477 * because tm_yday is 0-origin.
3479 * Since POSIX time routines are only guaranteed to work for times since the
3480 * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm
3481 * applies Gregorian calendar rules even to dates before the 16th century
3482 * doesn't bother me. Besides, you'd need cultural context for a given
3483 * date to know whether it was Julian or Gregorian calendar, and that's
3484 * outside the scope for this routine. Since we convert back based on the
3485 * same rules we used to build the yearday, you'll only get strange results
3486 * for input which needed normalising, or for the 'odd' century years which
3487 * were leap years in the Julian calander but not in the Gregorian one.
3488 * I can live with that.
3490 * This algorithm also fails to handle years before A.D. 1 gracefully, but
3491 * that's still outside the scope for POSIX time manipulation, so I don't
3495 year = 1900 + ptm->tm_year;
3496 month = ptm->tm_mon;
3497 mday = ptm->tm_mday;
3498 /* allow given yday with no month & mday to dominate the result */
3499 if (ptm->tm_yday >= 0 && mday <= 0 && month <= 0) {
3502 jday = 1 + ptm->tm_yday;
3511 yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400;
3512 yearday += month*MONTH_TO_DAYS + mday + jday;
3514 * Note that we don't know when leap-seconds were or will be,
3515 * so we have to trust the user if we get something which looks
3516 * like a sensible leap-second. Wild values for seconds will
3517 * be rationalised, however.
3519 if ((unsigned) ptm->tm_sec <= 60) {
3526 secs += 60 * ptm->tm_min;
3527 secs += SECS_PER_HOUR * ptm->tm_hour;
3529 if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) {
3530 /* got negative remainder, but need positive time */
3531 /* back off an extra day to compensate */
3532 yearday += (secs/SECS_PER_DAY)-1;
3533 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1);
3536 yearday += (secs/SECS_PER_DAY);
3537 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY);
3540 else if (secs >= SECS_PER_DAY) {
3541 yearday += (secs/SECS_PER_DAY);
3542 secs %= SECS_PER_DAY;
3544 ptm->tm_hour = secs/SECS_PER_HOUR;
3545 secs %= SECS_PER_HOUR;
3546 ptm->tm_min = secs/60;
3548 ptm->tm_sec += secs;
3549 /* done with time of day effects */
3551 * The algorithm for yearday has (so far) left it high by 428.
3552 * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to
3553 * bias it by 123 while trying to figure out what year it
3554 * really represents. Even with this tweak, the reverse
3555 * translation fails for years before A.D. 0001.
3556 * It would still fail for Feb 29, but we catch that one below.
3558 jday = yearday; /* save for later fixup vis-a-vis Jan 1 */
3559 yearday -= YEAR_ADJUST;
3560 year = (yearday / DAYS_PER_QCENT) * 400;
3561 yearday %= DAYS_PER_QCENT;
3562 odd_cent = yearday / DAYS_PER_CENT;
3563 year += odd_cent * 100;
3564 yearday %= DAYS_PER_CENT;
3565 year += (yearday / DAYS_PER_QYEAR) * 4;
3566 yearday %= DAYS_PER_QYEAR;
3567 odd_year = yearday / DAYS_PER_YEAR;
3569 yearday %= DAYS_PER_YEAR;
3570 if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */
3575 yearday += YEAR_ADJUST; /* recover March 1st crock */
3576 month = yearday*DAYS_TO_MONTH;
3577 yearday -= month*MONTH_TO_DAYS;
3578 /* recover other leap-year adjustment */
3587 ptm->tm_year = year - 1900;
3589 ptm->tm_mday = yearday;
3590 ptm->tm_mon = month;
3594 ptm->tm_mon = month - 1;
3596 /* re-build yearday based on Jan 1 to get tm_yday */
3598 yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400;
3599 yearday += 14*MONTH_TO_DAYS + 1;
3600 ptm->tm_yday = jday - yearday;
3601 /* fix tm_wday if not overridden by caller */
3602 if ((unsigned)ptm->tm_wday > 6)
3603 ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
3607 Perl_my_strftime(pTHX_ char *fmt, int sec, int min, int hour, int mday, int mon, int year, int wday, int yday, int isdst)
3615 init_tm(&mytm); /* XXX workaround - see init_tm() above */
3618 mytm.tm_hour = hour;
3619 mytm.tm_mday = mday;
3621 mytm.tm_year = year;
3622 mytm.tm_wday = wday;
3623 mytm.tm_yday = yday;
3624 mytm.tm_isdst = isdst;
3626 /* use libc to get the values for tm_gmtoff and tm_zone [perl #18238] */
3627 #if defined(HAS_MKTIME) && (defined(HAS_TM_TM_GMTOFF) || defined(HAS_TM_TM_ZONE))
3632 #ifdef HAS_TM_TM_GMTOFF
3633 mytm.tm_gmtoff = mytm2.tm_gmtoff;
3635 #ifdef HAS_TM_TM_ZONE
3636 mytm.tm_zone = mytm2.tm_zone;
3641 New(0, buf, buflen, char);
3642 len = strftime(buf, buflen, fmt, &mytm);
3644 ** The following is needed to handle to the situation where
3645 ** tmpbuf overflows. Basically we want to allocate a buffer
3646 ** and try repeatedly. The reason why it is so complicated
3647 ** is that getting a return value of 0 from strftime can indicate
3648 ** one of the following:
3649 ** 1. buffer overflowed,
3650 ** 2. illegal conversion specifier, or
3651 ** 3. the format string specifies nothing to be returned(not
3652 ** an error). This could be because format is an empty string
3653 ** or it specifies %p that yields an empty string in some locale.
3654 ** If there is a better way to make it portable, go ahead by
3657 if ((len > 0 && len < buflen) || (len == 0 && *fmt == '\0'))
3660 /* Possibly buf overflowed - try again with a bigger buf */
3661 int fmtlen = strlen(fmt);
3662 int bufsize = fmtlen + buflen;
3664 New(0, buf, bufsize, char);
3666 buflen = strftime(buf, bufsize, fmt, &mytm);
3667 if (buflen > 0 && buflen < bufsize)
3669 /* heuristic to prevent out-of-memory errors */
3670 if (bufsize > 100*fmtlen) {
3676 Renew(buf, bufsize, char);
3681 Perl_croak(aTHX_ "panic: no strftime");
3686 #define SV_CWD_RETURN_UNDEF \
3687 sv_setsv(sv, &PL_sv_undef); \
3690 #define SV_CWD_ISDOT(dp) \
3691 (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
3692 (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
3695 =head1 Miscellaneous Functions
3697 =for apidoc getcwd_sv
3699 Fill the sv with current working directory
3704 /* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars.
3705 * rewritten again by dougm, optimized for use with xs TARG, and to prefer
3706 * getcwd(3) if available
3707 * Comments from the orignal:
3708 * This is a faster version of getcwd. It's also more dangerous
3709 * because you might chdir out of a directory that you can't chdir
3713 Perl_getcwd_sv(pTHX_ register SV *sv)
3717 #ifndef INCOMPLETE_TAINTS
3723 char buf[MAXPATHLEN];
3725 /* Some getcwd()s automatically allocate a buffer of the given
3726 * size from the heap if they are given a NULL buffer pointer.
3727 * The problem is that this behaviour is not portable. */
3728 if (getcwd(buf, sizeof(buf) - 1)) {
3729 STRLEN len = strlen(buf);
3730 sv_setpvn(sv, buf, len);
3734 sv_setsv(sv, &PL_sv_undef);
3742 int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
3743 int namelen, pathlen=0;
3747 (void)SvUPGRADE(sv, SVt_PV);
3749 if (PerlLIO_lstat(".", &statbuf) < 0) {
3750 SV_CWD_RETURN_UNDEF;
3753 orig_cdev = statbuf.st_dev;
3754 orig_cino = statbuf.st_ino;
3762 if (PerlDir_chdir("..") < 0) {
3763 SV_CWD_RETURN_UNDEF;
3765 if (PerlLIO_stat(".", &statbuf) < 0) {
3766 SV_CWD_RETURN_UNDEF;
3769 cdev = statbuf.st_dev;
3770 cino = statbuf.st_ino;
3772 if (odev == cdev && oino == cino) {
3775 if (!(dir = PerlDir_open("."))) {
3776 SV_CWD_RETURN_UNDEF;
3779 while ((dp = PerlDir_read(dir)) != NULL) {
3781 namelen = dp->d_namlen;
3783 namelen = strlen(dp->d_name);
3786 if (SV_CWD_ISDOT(dp)) {
3790 if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
3791 SV_CWD_RETURN_UNDEF;
3794 tdev = statbuf.st_dev;
3795 tino = statbuf.st_ino;
3796 if (tino == oino && tdev == odev) {
3802 SV_CWD_RETURN_UNDEF;
3805 if (pathlen + namelen + 1 >= MAXPATHLEN) {
3806 SV_CWD_RETURN_UNDEF;
3809 SvGROW(sv, pathlen + namelen + 1);
3813 Move(SvPVX(sv), SvPVX(sv) + namelen + 1, pathlen, char);
3816 /* prepend current directory to the front */
3818 Move(dp->d_name, SvPVX(sv)+1, namelen, char);
3819 pathlen += (namelen + 1);
3821 #ifdef VOID_CLOSEDIR
3824 if (PerlDir_close(dir) < 0) {
3825 SV_CWD_RETURN_UNDEF;
3831 SvCUR_set(sv, pathlen);
3835 if (PerlDir_chdir(SvPVX(sv)) < 0) {
3836 SV_CWD_RETURN_UNDEF;
3839 if (PerlLIO_stat(".", &statbuf) < 0) {
3840 SV_CWD_RETURN_UNDEF;
3843 cdev = statbuf.st_dev;
3844 cino = statbuf.st_ino;
3846 if (cdev != orig_cdev || cino != orig_cino) {
3847 Perl_croak(aTHX_ "Unstable directory path, "
3848 "current directory changed unexpectedly");
3860 =for apidoc scan_version
3862 Returns a pointer to the next character after the parsed
3863 version string, as well as upgrading the passed in SV to
3866 Function must be called with an already existing SV like
3869 s = scan_version(s,SV *sv, bool qv);
3871 Performs some preprocessing to the string to ensure that
3872 it has the correct characteristics of a version. Flags the
3873 object if it contains an underscore (which denotes this
3874 is a alpha version). The boolean qv denotes that the version
3875 should be interpreted as if it had multiple decimals, even if
3882 Perl_scan_version(pTHX_ char *s, SV *rv, bool qv)
3884 const char *start = s;
3888 SV* sv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
3889 (void)sv_upgrade(sv, SVt_PVAV); /* needs to be an AV type */
3891 /* pre-scan the imput string to check for decimals */
3892 while ( *pos == '.' || *pos == '_' || isDIGIT(*pos) )
3897 Perl_croak(aTHX_ "Invalid version format (underscores before decimal)");
3900 else if ( *pos == '_' )
3903 Perl_croak(aTHX_ "Invalid version format (multiple underscores)");
3911 pos++; /* get past 'v' */
3912 qv = 1; /* force quoted version processing */
3914 while (isDIGIT(*pos))
3916 if (!isALPHA(*pos)) {
3919 if (*s == 'v') s++; /* get past 'v' */
3924 /* this is atoi() that delimits on underscores */
3928 if ( s < pos && s > start && *(s-1) == '_' ) {
3929 mult *= -1; /* alpha version */
3931 /* the following if() will only be true after the decimal
3932 * point of a version originally created with a bare
3933 * floating point number, i.e. not quoted in any way
3935 if ( !qv && s > start+1 && saw_period == 1 ) {
3939 rev += (*s - '0') * mult;
3941 if ( PERL_ABS(orev) > PERL_ABS(rev) )
3942 Perl_croak(aTHX_ "Integer overflow in version");
3947 while (--end >= s) {
3949 rev += (*end - '0') * mult;
3951 if ( PERL_ABS(orev) > PERL_ABS(rev) )
3952 Perl_croak(aTHX_ "Integer overflow in version");
3957 /* Append revision */
3958 av_push((AV *)sv, newSViv(rev));
3959 if ( (*pos == '.' || *pos == '_') && isDIGIT(pos[1]))
3961 else if ( isDIGIT(*pos) )
3967 while ( isDIGIT(*pos) ) {
3968 if ( saw_period == 1 && pos-s == 3 )
3974 if ( qv ) { /* quoted versions always become full version objects */
3975 I32 len = av_len((AV *)sv);
3976 /* This for loop appears to trigger a compiler bug on OS X, as it
3977 loops infinitely. Yes, len is negative. No, it makes no sense.
3978 Compiler in question is:
3979 gcc version 3.3 20030304 (Apple Computer, Inc. build 1640)
3980 for ( len = 2 - len; len > 0; len-- )
3981 av_push((AV *)sv, newSViv(0));
3985 av_push((AV *)sv, newSViv(0));
3991 =for apidoc new_version
3993 Returns a new version object based on the passed in SV:
3995 SV *sv = new_version(SV *ver);
3997 Does not alter the passed in ver SV. See "upg_version" if you
3998 want to upgrade the SV.
4004 Perl_new_version(pTHX_ SV *ver)
4007 if ( sv_derived_from(ver,"version") ) /* can just copy directly */
4010 AV *av = (AV *)SvRV(ver);
4011 SV* sv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
4012 (void)sv_upgrade(sv, SVt_PVAV); /* needs to be an AV type */
4013 for ( key = 0; key <= av_len(av); key++ )
4015 I32 rev = SvIV(*av_fetch(av, key, FALSE));
4016 av_push((AV *)sv, newSViv(rev));
4021 if ( SvVOK(ver) ) { /* already a v-string */
4023 MAGIC* mg = mg_find(ver,PERL_MAGIC_vstring);
4024 version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
4025 sv_setpv(rv,version);
4030 sv_setsv(rv,ver); /* make a duplicate */
4039 =for apidoc upg_version
4041 In-place upgrade of the supplied SV to a version object.
4043 SV *sv = upg_version(SV *sv);
4045 Returns a pointer to the upgraded SV.
4051 Perl_upg_version(pTHX_ SV *ver)
4056 if ( SvNOK(ver) ) /* may get too much accuracy */
4059 sprintf(tbuf,"%.9"NVgf, SvNVX(ver));
4060 version = savepv(tbuf);
4063 else if ( SvVOK(ver) ) { /* already a v-string */
4064 MAGIC* mg = mg_find(ver,PERL_MAGIC_vstring);
4065 version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
4069 else /* must be a string or something like a string */
4072 version = savepv(SvPV(ver,n_a));
4074 (void)scan_version(version, ver, qv);
4083 Accepts a version object and returns the normalized floating
4084 point representation. Call like:
4088 NOTE: you can pass either the object directly or the SV
4089 contained within the RV.
4095 Perl_vnumify(pTHX_ SV *vs)
4101 len = av_len((AV *)vs);
4104 Perl_sv_catpv(aTHX_ sv,"0");
4107 digit = SvIVX(*av_fetch((AV *)vs, 0, 0));
4108 Perl_sv_setpvf(aTHX_ sv,"%d.", (int)PERL_ABS(digit));
4109 for ( i = 1 ; i < len ; i++ )
4111 digit = SvIVX(*av_fetch((AV *)vs, i, 0));
4112 Perl_sv_catpvf(aTHX_ sv,"%03d", (int)PERL_ABS(digit));
4117 digit = SvIVX(*av_fetch((AV *)vs, len, 0));
4119 /* Don't display any additional trailing zeros */
4120 if ( (int)PERL_ABS(digit) != 0 || len == 1 )
4122 Perl_sv_catpvf(aTHX_ sv,"%03d", (int)PERL_ABS(digit));
4127 Perl_sv_catpv(aTHX_ sv,"000");
4135 Accepts a version object and returns the normalized string
4136 representation. Call like:
4140 NOTE: you can pass either the object directly or the SV
4141 contained within the RV.
4147 Perl_vnormal(pTHX_ SV *vs)
4153 len = av_len((AV *)vs);
4156 Perl_sv_catpv(aTHX_ sv,"");
4159 digit = SvIVX(*av_fetch((AV *)vs, 0, 0));
4160 Perl_sv_setpvf(aTHX_ sv,"%"IVdf,(IV)digit);
4161 for ( i = 1 ; i <= len ; i++ )
4163 digit = SvIVX(*av_fetch((AV *)vs, i, 0));
4165 Perl_sv_catpvf(aTHX_ sv,"_%"IVdf,(IV)-digit);
4167 Perl_sv_catpvf(aTHX_ sv,".%"IVdf,(IV)digit);
4170 if ( len <= 2 ) { /* short version, must be at least three */
4171 for ( len = 2 - len; len != 0; len-- )
4172 Perl_sv_catpv(aTHX_ sv,".0");
4179 =for apidoc vstringify
4181 In order to maintain maximum compatibility with earlier versions
4182 of Perl, this function will return either the floating point
4183 notation or the multiple dotted notation, depending on whether
4184 the original version contained 1 or more dots, respectively
4190 Perl_vstringify(pTHX_ SV *vs)
4195 len = av_len((AV *)vs);
4206 Version object aware cmp. Both operands must already have been
4207 converted into version objects.
4213 Perl_vcmp(pTHX_ SV *lsv, SV *rsv)
4220 l = av_len((AV *)lsv);
4221 r = av_len((AV *)rsv);
4225 while ( i <= m && retval == 0 )
4227 I32 left = SvIV(*av_fetch((AV *)lsv,i,0));
4228 I32 right = SvIV(*av_fetch((AV *)rsv,i,0));
4229 bool lalpha = left < 0 ? 1 : 0;
4230 bool ralpha = right < 0 ? 1 : 0;
4233 if ( left < right || (left == right && lalpha && !ralpha) )
4235 if ( left > right || (left == right && ralpha && !lalpha) )
4240 if ( l != r && retval == 0 ) /* possible match except for trailing 0's */
4244 while ( i <= r && retval == 0 )
4246 if ( SvIV(*av_fetch((AV *)rsv,i,0)) != 0 )
4247 retval = -1; /* not a match after all */
4253 while ( i <= l && retval == 0 )
4255 if ( SvIV(*av_fetch((AV *)lsv,i,0)) != 0 )
4256 retval = +1; /* not a match after all */
4264 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT)
4265 # define EMULATE_SOCKETPAIR_UDP
4268 #ifdef EMULATE_SOCKETPAIR_UDP
4270 S_socketpair_udp (int fd[2]) {
4272 /* Fake a datagram socketpair using UDP to localhost. */
4273 int sockets[2] = {-1, -1};
4274 struct sockaddr_in addresses[2];
4276 Sock_size_t size = sizeof(struct sockaddr_in);
4277 unsigned short port;
4280 memset(&addresses, 0, sizeof(addresses));
4283 sockets[i] = PerlSock_socket(AF_INET, SOCK_DGRAM, PF_INET);
4284 if (sockets[i] == -1)
4285 goto tidy_up_and_fail;
4287 addresses[i].sin_family = AF_INET;
4288 addresses[i].sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4289 addresses[i].sin_port = 0; /* kernel choses port. */
4290 if (PerlSock_bind(sockets[i], (struct sockaddr *) &addresses[i],
4291 sizeof(struct sockaddr_in)) == -1)
4292 goto tidy_up_and_fail;
4295 /* Now have 2 UDP sockets. Find out which port each is connected to, and
4296 for each connect the other socket to it. */
4299 if (PerlSock_getsockname(sockets[i], (struct sockaddr *) &addresses[i],
4301 goto tidy_up_and_fail;
4302 if (size != sizeof(struct sockaddr_in))
4303 goto abort_tidy_up_and_fail;
4304 /* !1 is 0, !0 is 1 */
4305 if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i],
4306 sizeof(struct sockaddr_in)) == -1)
4307 goto tidy_up_and_fail;
4310 /* Now we have 2 sockets connected to each other. I don't trust some other
4311 process not to have already sent a packet to us (by random) so send
4312 a packet from each to the other. */
4315 /* I'm going to send my own port number. As a short.
4316 (Who knows if someone somewhere has sin_port as a bitfield and needs
4317 this routine. (I'm assuming crays have socketpair)) */
4318 port = addresses[i].sin_port;
4319 got = PerlLIO_write(sockets[i], &port, sizeof(port));
4320 if (got != sizeof(port)) {
4322 goto tidy_up_and_fail;
4323 goto abort_tidy_up_and_fail;
4327 /* Packets sent. I don't trust them to have arrived though.
4328 (As I understand it Solaris TCP stack is multithreaded. Non-blocking
4329 connect to localhost will use a second kernel thread. In 2.6 the
4330 first thread running the connect() returns before the second completes,
4331 so EINPROGRESS> In 2.7 the improved stack is faster and connect()
4332 returns 0. Poor programs have tripped up. One poor program's authors'
4333 had a 50-1 reverse stock split. Not sure how connected these were.)
4334 So I don't trust someone not to have an unpredictable UDP stack.
4338 struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */
4339 int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0];
4343 FD_SET(sockets[0], &rset);
4344 FD_SET(sockets[1], &rset);
4346 got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor);
4347 if (got != 2 || !FD_ISSET(sockets[0], &rset)
4348 || !FD_ISSET(sockets[1], &rset)) {
4349 /* I hope this is portable and appropriate. */
4351 goto tidy_up_and_fail;
4352 goto abort_tidy_up_and_fail;
4356 /* And the paranoia department even now doesn't trust it to have arrive
4357 (hence MSG_DONTWAIT). Or that what arrives was sent by us. */
4359 struct sockaddr_in readfrom;
4360 unsigned short buffer[2];
4365 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4366 sizeof(buffer), MSG_DONTWAIT,
4367 (struct sockaddr *) &readfrom, &size);
4369 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4371 (struct sockaddr *) &readfrom, &size);
4375 goto tidy_up_and_fail;
4376 if (got != sizeof(port)
4377 || size != sizeof(struct sockaddr_in)
4378 /* Check other socket sent us its port. */
4379 || buffer[0] != (unsigned short) addresses[!i].sin_port
4380 /* Check kernel says we got the datagram from that socket */
4381 || readfrom.sin_family != addresses[!i].sin_family
4382 || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr
4383 || readfrom.sin_port != addresses[!i].sin_port)
4384 goto abort_tidy_up_and_fail;
4387 /* My caller (my_socketpair) has validated that this is non-NULL */
4390 /* I hereby declare this connection open. May God bless all who cross
4394 abort_tidy_up_and_fail:
4395 errno = ECONNABORTED;
4398 int save_errno = errno;
4399 if (sockets[0] != -1)
4400 PerlLIO_close(sockets[0]);
4401 if (sockets[1] != -1)
4402 PerlLIO_close(sockets[1]);
4407 #endif /* EMULATE_SOCKETPAIR_UDP */
4409 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET)
4411 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4412 /* Stevens says that family must be AF_LOCAL, protocol 0.
4413 I'm going to enforce that, then ignore it, and use TCP (or UDP). */
4418 struct sockaddr_in listen_addr;
4419 struct sockaddr_in connect_addr;
4424 || family != AF_UNIX
4427 errno = EAFNOSUPPORT;
4435 #ifdef EMULATE_SOCKETPAIR_UDP
4436 if (type == SOCK_DGRAM)
4437 return S_socketpair_udp(fd);
4440 listener = PerlSock_socket(AF_INET, type, 0);
4443 memset(&listen_addr, 0, sizeof(listen_addr));
4444 listen_addr.sin_family = AF_INET;
4445 listen_addr.sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4446 listen_addr.sin_port = 0; /* kernel choses port. */
4447 if (PerlSock_bind(listener, (struct sockaddr *) &listen_addr,
4448 sizeof(listen_addr)) == -1)
4449 goto tidy_up_and_fail;
4450 if (PerlSock_listen(listener, 1) == -1)
4451 goto tidy_up_and_fail;
4453 connector = PerlSock_socket(AF_INET, type, 0);
4454 if (connector == -1)
4455 goto tidy_up_and_fail;
4456 /* We want to find out the port number to connect to. */
4457 size = sizeof(connect_addr);
4458 if (PerlSock_getsockname(listener, (struct sockaddr *) &connect_addr,
4460 goto tidy_up_and_fail;
4461 if (size != sizeof(connect_addr))
4462 goto abort_tidy_up_and_fail;
4463 if (PerlSock_connect(connector, (struct sockaddr *) &connect_addr,
4464 sizeof(connect_addr)) == -1)
4465 goto tidy_up_and_fail;
4467 size = sizeof(listen_addr);
4468 acceptor = PerlSock_accept(listener, (struct sockaddr *) &listen_addr,
4471 goto tidy_up_and_fail;
4472 if (size != sizeof(listen_addr))
4473 goto abort_tidy_up_and_fail;
4474 PerlLIO_close(listener);
4475 /* Now check we are talking to ourself by matching port and host on the
4477 if (PerlSock_getsockname(connector, (struct sockaddr *) &connect_addr,
4479 goto tidy_up_and_fail;
4480 if (size != sizeof(connect_addr)
4481 || listen_addr.sin_family != connect_addr.sin_family
4482 || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr
4483 || listen_addr.sin_port != connect_addr.sin_port) {
4484 goto abort_tidy_up_and_fail;
4490 abort_tidy_up_and_fail:
4491 errno = ECONNABORTED; /* I hope this is portable and appropriate. */
4494 int save_errno = errno;
4496 PerlLIO_close(listener);
4497 if (connector != -1)
4498 PerlLIO_close(connector);
4500 PerlLIO_close(acceptor);
4506 /* In any case have a stub so that there's code corresponding
4507 * to the my_socketpair in global.sym. */
4509 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4510 #ifdef HAS_SOCKETPAIR
4511 return socketpair(family, type, protocol, fd);
4520 =for apidoc sv_nosharing
4522 Dummy routine which "shares" an SV when there is no sharing 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_nosharing(pTHX_ SV *sv)
4535 =for apidoc sv_nolocking
4537 Dummy routine which "locks" an SV when there is no locking module present.
4538 Exists to avoid test for a NULL function pointer and because it could potentially warn under
4539 some level of strict-ness.
4545 Perl_sv_nolocking(pTHX_ SV *sv)
4551 =for apidoc sv_nounlocking
4553 Dummy routine which "unlocks" an SV when there is no locking module present.
4554 Exists to avoid test for a NULL function pointer and because it could potentially warn under
4555 some level of strict-ness.
4561 Perl_sv_nounlocking(pTHX_ SV *sv)
4566 Perl_parse_unicode_opts(pTHX_ char **popt)
4573 opt = (U32) atoi(p);
4574 while (isDIGIT(*p)) p++;
4575 if (*p && *p != '\n' && *p != '\r')
4576 Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
4581 case PERL_UNICODE_STDIN:
4582 opt |= PERL_UNICODE_STDIN_FLAG; break;
4583 case PERL_UNICODE_STDOUT:
4584 opt |= PERL_UNICODE_STDOUT_FLAG; break;
4585 case PERL_UNICODE_STDERR:
4586 opt |= PERL_UNICODE_STDERR_FLAG; break;
4587 case PERL_UNICODE_STD:
4588 opt |= PERL_UNICODE_STD_FLAG; break;
4589 case PERL_UNICODE_IN:
4590 opt |= PERL_UNICODE_IN_FLAG; break;
4591 case PERL_UNICODE_OUT:
4592 opt |= PERL_UNICODE_OUT_FLAG; break;
4593 case PERL_UNICODE_INOUT:
4594 opt |= PERL_UNICODE_INOUT_FLAG; break;
4595 case PERL_UNICODE_LOCALE:
4596 opt |= PERL_UNICODE_LOCALE_FLAG; break;
4597 case PERL_UNICODE_ARGV:
4598 opt |= PERL_UNICODE_ARGV_FLAG; break;
4600 if (*p != '\n' && *p != '\r')
4602 "Unknown Unicode option letter '%c'", *p);
4608 opt = PERL_UNICODE_DEFAULT_FLAGS;
4610 if (opt & ~PERL_UNICODE_ALL_FLAGS)
4611 Perl_croak(aTHX_ "Unknown Unicode option value %"UVuf,
4612 (UV) (opt & ~PERL_UNICODE_ALL_FLAGS));
4623 * This is really just a quick hack which grabs various garbage
4624 * values. It really should be a real hash algorithm which
4625 * spreads the effect of every input bit onto every output bit,
4626 * if someone who knows about such things would bother to write it.
4627 * Might be a good idea to add that function to CORE as well.
4628 * No numbers below come from careful analysis or anything here,
4629 * except they are primes and SEED_C1 > 1E6 to get a full-width
4630 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
4631 * probably be bigger too.
4634 # define SEED_C1 1000003
4635 #define SEED_C4 73819
4637 # define SEED_C1 25747
4638 #define SEED_C4 20639
4642 #define SEED_C5 26107
4644 #ifndef PERL_NO_DEV_RANDOM
4649 # include <starlet.h>
4650 /* when[] = (low 32 bits, high 32 bits) of time since epoch
4651 * in 100-ns units, typically incremented ever 10 ms. */
4652 unsigned int when[2];
4654 # ifdef HAS_GETTIMEOFDAY
4655 struct timeval when;
4661 /* This test is an escape hatch, this symbol isn't set by Configure. */
4662 #ifndef PERL_NO_DEV_RANDOM
4663 #ifndef PERL_RANDOM_DEVICE
4664 /* /dev/random isn't used by default because reads from it will block
4665 * if there isn't enough entropy available. You can compile with
4666 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
4667 * is enough real entropy to fill the seed. */
4668 # define PERL_RANDOM_DEVICE "/dev/urandom"
4670 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
4672 if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
4681 _ckvmssts(sys$gettim(when));
4682 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
4684 # ifdef HAS_GETTIMEOFDAY
4685 PerlProc_gettimeofday(&when,NULL);
4686 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
4689 u = (U32)SEED_C1 * when;
4692 u += SEED_C3 * (U32)PerlProc_getpid();
4693 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
4694 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
4695 u += SEED_C5 * (U32)PTR2UV(&when);
4701 Perl_get_hash_seed(pTHX)
4703 char *s = PerlEnv_getenv("PERL_HASH_SEED");
4707 while (isSPACE(*s)) s++;
4708 if (s && isDIGIT(*s))
4709 myseed = (UV)Atoul(s);
4711 #ifdef USE_HASH_SEED_EXPLICIT
4715 /* Compute a random seed */
4716 (void)seedDrand01((Rand_seed_t)seed());
4717 myseed = (UV)(Drand01() * (NV)UV_MAX);
4718 #if RANDBITS < (UVSIZE * 8)
4719 /* Since there are not enough randbits to to reach all
4720 * the bits of a UV, the low bits might need extra
4721 * help. Sum in another random number that will
4722 * fill in the low bits. */
4724 (UV)(Drand01() * (NV)((1 << ((UVSIZE * 8 - RANDBITS))) - 1));
4725 #endif /* RANDBITS < (UVSIZE * 8) */
4726 if (myseed == 0) { /* Superparanoia. */
4727 myseed = (UV)(Drand01() * (NV)UV_MAX); /* One more chance. */
4729 Perl_croak(aTHX_ "Your random numbers are not that random");
4732 PL_rehash_seed_set = TRUE;