3 * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 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
17 #define PERL_IN_UTIL_C
23 # define SIG_ERR ((Sighandler_t) -1)
28 # include <sys/wait.h>
33 # include <sys/select.h>
39 #if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC)
40 # define FD_CLOEXEC 1 /* NeXT needs this */
43 /* NOTE: Do not call the next three routines directly. Use the macros
44 * in handy.h, so that we can easily redefine everything to do tracking of
45 * allocated hunks back to the original New to track down any memory leaks.
46 * XXX This advice seems to be widely ignored :-( --AD August 1996.
49 /* paranoid version of system's malloc() */
52 Perl_safesysmalloc(MEM_SIZE size)
58 PerlIO_printf(Perl_error_log,
59 "Allocation too large: %lx\n", size) FLUSH;
62 #endif /* HAS_64K_LIMIT */
65 Perl_croak_nocontext("panic: malloc");
67 ptr = (Malloc_t)PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */
68 PERL_ALLOC_CHECK(ptr);
69 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
75 PerlIO_puts(Perl_error_log,PL_no_mem) FLUSH;
82 /* paranoid version of system's realloc() */
85 Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
89 #if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) && !defined(PERL_MICRO)
90 Malloc_t PerlMem_realloc();
91 #endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */
95 PerlIO_printf(Perl_error_log,
96 "Reallocation too large: %lx\n", size) FLUSH;
99 #endif /* HAS_64K_LIMIT */
106 return safesysmalloc(size);
109 Perl_croak_nocontext("panic: realloc");
111 ptr = (Malloc_t)PerlMem_realloc(where,size);
112 PERL_ALLOC_CHECK(ptr);
114 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++));
115 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
122 PerlIO_puts(Perl_error_log,PL_no_mem) FLUSH;
129 /* safe version of system's free() */
132 Perl_safesysfree(Malloc_t where)
134 #ifdef PERL_IMPLICIT_SYS
137 DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) free\n",PTR2UV(where),(long)PL_an++));
144 /* safe version of system's calloc() */
147 Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
153 if (size * count > 0xffff) {
154 PerlIO_printf(Perl_error_log,
155 "Allocation too large: %lx\n", size * count) FLUSH;
158 #endif /* HAS_64K_LIMIT */
160 if ((long)size < 0 || (long)count < 0)
161 Perl_croak_nocontext("panic: calloc");
164 ptr = (Malloc_t)PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */
165 PERL_ALLOC_CHECK(ptr);
166 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));
168 memset((void*)ptr, 0, size);
174 PerlIO_puts(Perl_error_log,PL_no_mem) FLUSH;
181 /* These must be defined when not using Perl's malloc for binary
186 Malloc_t Perl_malloc (MEM_SIZE nbytes)
189 return (Malloc_t)PerlMem_malloc(nbytes);
192 Malloc_t Perl_calloc (MEM_SIZE elements, MEM_SIZE size)
195 return (Malloc_t)PerlMem_calloc(elements, size);
198 Malloc_t Perl_realloc (Malloc_t where, MEM_SIZE nbytes)
201 return (Malloc_t)PerlMem_realloc(where, nbytes);
204 Free_t Perl_mfree (Malloc_t where)
212 /* copy a string up to some (non-backslashed) delimiter, if any */
215 Perl_delimcpy(pTHX_ register char *to, register char *toend, register char *from, register char *fromend, register int delim, I32 *retlen)
218 for (tolen = 0; from < fromend; from++, tolen++) {
220 if (from[1] == delim)
229 else if (*from == delim)
240 /* return ptr to little string in big string, NULL if not found */
241 /* This routine was donated by Corey Satten. */
244 Perl_instr(pTHX_ register const char *big, register const char *little)
246 register const char *s, *x;
257 for (x=big,s=little; *s; /**/ ) {
266 return (char*)(big-1);
271 /* same as instr but allow embedded nulls */
274 Perl_ninstr(pTHX_ register const char *big, register const char *bigend, const char *little, const char *lend)
276 register const char *s, *x;
277 register I32 first = *little;
278 register const char *littleend = lend;
280 if (!first && little >= littleend)
282 if (bigend - big < littleend - little)
284 bigend -= littleend - little++;
285 while (big <= bigend) {
288 for (x=big,s=little; s < littleend; /**/ ) {
295 return (char*)(big-1);
300 /* reverse of the above--find last substring */
303 Perl_rninstr(pTHX_ register const char *big, const char *bigend, const char *little, const char *lend)
305 register const char *bigbeg;
306 register const char *s, *x;
307 register I32 first = *little;
308 register const char *littleend = lend;
310 if (!first && little >= littleend)
311 return (char*)bigend;
313 big = bigend - (littleend - little++);
314 while (big >= bigbeg) {
317 for (x=big+2,s=little; s < littleend; /**/ ) {
324 return (char*)(big+1);
329 #define FBM_TABLE_OFFSET 2 /* Number of bytes between EOS and table*/
331 /* As a space optimization, we do not compile tables for strings of length
332 0 and 1, and for strings of length 2 unless FBMcf_TAIL. These are
333 special-cased in fbm_instr().
335 If FBMcf_TAIL, the table is created as if the string has a trailing \n. */
338 =head1 Miscellaneous Functions
340 =for apidoc fbm_compile
342 Analyses the string in order to make fast searches on it using fbm_instr()
343 -- the Boyer-Moore algorithm.
349 Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
358 if (flags & FBMcf_TAIL) {
359 MAGIC *mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
360 sv_catpvn(sv, "\n", 1); /* Taken into account in fbm_instr() */
361 if (mg && mg->mg_len >= 0)
364 s = (U8*)SvPV_force(sv, len);
365 (void)SvUPGRADE(sv, SVt_PVBM);
366 if (len == 0) /* TAIL might be on a zero-length string. */
376 Sv_Grow(sv, len + 256 + FBM_TABLE_OFFSET);
377 table = (unsigned char*)(SvPVX(sv) + len + FBM_TABLE_OFFSET);
378 s = table - 1 - FBM_TABLE_OFFSET; /* last char */
379 memset((void*)table, mlen, 256);
380 table[-1] = (U8)flags;
382 sb = s - mlen + 1; /* first char (maybe) */
384 if (table[*s] == mlen)
389 sv_magic(sv, Nullsv, PERL_MAGIC_bm, Nullch, 0); /* deep magic */
392 s = (unsigned char*)(SvPVX(sv)); /* deeper magic */
393 for (i = 0; i < len; i++) {
394 if (PL_freq[s[i]] < frequency) {
396 frequency = PL_freq[s[i]];
399 BmRARE(sv) = s[rarest];
400 BmPREVIOUS(sv) = (U16)rarest;
401 BmUSEFUL(sv) = 100; /* Initial value */
402 if (flags & FBMcf_TAIL)
404 DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %d\n",
405 BmRARE(sv),BmPREVIOUS(sv)));
408 /* If SvTAIL(littlestr), it has a fake '\n' at end. */
409 /* If SvTAIL is actually due to \Z or \z, this gives false positives
413 =for apidoc fbm_instr
415 Returns the location of the SV in the string delimited by C<str> and
416 C<strend>. It returns C<Nullch> if the string can't be found. The C<sv>
417 does not have to be fbm_compiled, but the search will not be as fast
424 Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *littlestr, U32 flags)
426 register unsigned char *s;
428 register unsigned char *little = (unsigned char *)SvPV(littlestr,l);
429 register STRLEN littlelen = l;
430 register I32 multiline = flags & FBMrf_MULTILINE;
432 if ((STRLEN)(bigend - big) < littlelen) {
433 if ( SvTAIL(littlestr)
434 && ((STRLEN)(bigend - big) == littlelen - 1)
436 || (*big == *little &&
437 memEQ((char *)big, (char *)little, littlelen - 1))))
442 if (littlelen <= 2) { /* Special-cased */
444 if (littlelen == 1) {
445 if (SvTAIL(littlestr) && !multiline) { /* Anchor only! */
446 /* Know that bigend != big. */
447 if (bigend[-1] == '\n')
448 return (char *)(bigend - 1);
449 return (char *) bigend;
457 if (SvTAIL(littlestr))
458 return (char *) bigend;
462 return (char*)big; /* Cannot be SvTAIL! */
465 if (SvTAIL(littlestr) && !multiline) {
466 if (bigend[-1] == '\n' && bigend[-2] == *little)
467 return (char*)bigend - 2;
468 if (bigend[-1] == *little)
469 return (char*)bigend - 1;
473 /* This should be better than FBM if c1 == c2, and almost
474 as good otherwise: maybe better since we do less indirection.
475 And we save a lot of memory by caching no table. */
476 register unsigned char c1 = little[0];
477 register unsigned char c2 = little[1];
482 while (s <= bigend) {
492 goto check_1char_anchor;
503 goto check_1char_anchor;
506 while (s <= bigend) {
511 goto check_1char_anchor;
520 check_1char_anchor: /* One char and anchor! */
521 if (SvTAIL(littlestr) && (*bigend == *little))
522 return (char *)bigend; /* bigend is already decremented. */
525 if (SvTAIL(littlestr) && !multiline) { /* tail anchored? */
526 s = bigend - littlelen;
527 if (s >= big && bigend[-1] == '\n' && *s == *little
528 /* Automatically of length > 2 */
529 && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
531 return (char*)s; /* how sweet it is */
534 && memEQ((char*)s + 2, (char*)little + 1, littlelen - 2))
536 return (char*)s + 1; /* how sweet it is */
540 if (SvTYPE(littlestr) != SVt_PVBM || !SvVALID(littlestr)) {
541 char *b = ninstr((char*)big,(char*)bigend,
542 (char*)little, (char*)little + littlelen);
544 if (!b && SvTAIL(littlestr)) { /* Automatically multiline! */
545 /* Chop \n from littlestr: */
546 s = bigend - littlelen + 1;
548 && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
557 { /* Do actual FBM. */
558 register unsigned char *table = little + littlelen + FBM_TABLE_OFFSET;
559 register unsigned char *oldlittle;
561 if (littlelen > (STRLEN)(bigend - big))
563 --littlelen; /* Last char found by table lookup */
566 little += littlelen; /* last char */
573 if ((tmp = table[*s])) {
574 if ((s += tmp) < bigend)
578 else { /* less expensive than calling strncmp() */
579 register unsigned char *olds = s;
584 if (*--s == *--little)
586 s = olds + 1; /* here we pay the price for failure */
588 if (s < bigend) /* fake up continue to outer loop */
596 if ( s == bigend && (table[-1] & FBMcf_TAIL)
597 && memEQ((char *)(bigend - littlelen),
598 (char *)(oldlittle - littlelen), littlelen) )
599 return (char*)bigend - littlelen;
604 /* start_shift, end_shift are positive quantities which give offsets
605 of ends of some substring of bigstr.
606 If `last' we want the last occurrence.
607 old_posp is the way of communication between consequent calls if
608 the next call needs to find the .
609 The initial *old_posp should be -1.
611 Note that we take into account SvTAIL, so one can get extra
612 optimizations if _ALL flag is set.
615 /* If SvTAIL is actually due to \Z or \z, this gives false positives
616 if PL_multiline. In fact if !PL_multiline the authoritative answer
617 is not supported yet. */
620 Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last)
622 register unsigned char *s, *x;
623 register unsigned char *big;
625 register I32 previous;
627 register unsigned char *little;
628 register I32 stop_pos;
629 register unsigned char *littleend;
633 ? (pos = PL_screamfirst[BmRARE(littlestr)]) < 0
634 : (((pos = *old_posp), pos += PL_screamnext[pos]) == 0)) {
636 if ( BmRARE(littlestr) == '\n'
637 && BmPREVIOUS(littlestr) == SvCUR(littlestr) - 1) {
638 little = (unsigned char *)(SvPVX(littlestr));
639 littleend = little + SvCUR(littlestr);
646 little = (unsigned char *)(SvPVX(littlestr));
647 littleend = little + SvCUR(littlestr);
649 /* The value of pos we can start at: */
650 previous = BmPREVIOUS(littlestr);
651 big = (unsigned char *)(SvPVX(bigstr));
652 /* The value of pos we can stop at: */
653 stop_pos = SvCUR(bigstr) - end_shift - (SvCUR(littlestr) - 1 - previous);
654 if (previous + start_shift > stop_pos) {
656 stop_pos does not include SvTAIL in the count, so this check is incorrect
657 (I think) - see [ID 20010618.006] and t/op/study.t. HVDS 2001/06/19
660 if (previous + start_shift == stop_pos + 1) /* A fake '\n'? */
665 while (pos < previous + start_shift) {
666 if (!(pos += PL_screamnext[pos]))
671 if (pos >= stop_pos) break;
672 if (big[pos] != first)
674 for (x=big+pos+1,s=little; s < littleend; /**/ ) {
680 if (s == littleend) {
682 if (!last) return (char *)(big+pos);
685 } while ( pos += PL_screamnext[pos] );
687 return (char *)(big+(*old_posp));
689 if (!SvTAIL(littlestr) || (end_shift > 0))
691 /* Ignore the trailing "\n". This code is not microoptimized */
692 big = (unsigned char *)(SvPVX(bigstr) + SvCUR(bigstr));
693 stop_pos = littleend - little; /* Actual littlestr len */
698 && ((stop_pos == 1) ||
699 memEQ((char *)(big + 1), (char *)little, stop_pos - 1)))
705 Perl_ibcmp(pTHX_ const char *s1, const char *s2, register I32 len)
707 register U8 *a = (U8 *)s1;
708 register U8 *b = (U8 *)s2;
710 if (*a != *b && *a != PL_fold[*b])
718 Perl_ibcmp_locale(pTHX_ const char *s1, const char *s2, register I32 len)
720 register U8 *a = (U8 *)s1;
721 register U8 *b = (U8 *)s2;
723 if (*a != *b && *a != PL_fold_locale[*b])
730 /* copy a string to a safe spot */
733 =head1 Memory Management
737 Perl's version of C<strdup()>. Returns a pointer to a newly allocated
738 string which is a duplicate of C<pv>. The size of the string is
739 determined by C<strlen()>. The memory allocated for the new string can
740 be freed with the C<Safefree()> function.
746 Perl_savepv(pTHX_ const char *pv)
748 register char *newaddr = Nullch;
750 New(902,newaddr,strlen(pv)+1,char);
751 (void)strcpy(newaddr,pv);
756 /* same thing but with a known length */
761 Perl's version of what C<strndup()> would be if it existed. Returns a
762 pointer to a newly allocated string which is a duplicate of the first
763 C<len> bytes from C<pv>. The memory allocated for the new string can be
764 freed with the C<Safefree()> function.
770 Perl_savepvn(pTHX_ const char *pv, register I32 len)
772 register char *newaddr;
774 New(903,newaddr,len+1,char);
775 /* Give a meaning to NULL pointer mainly for the use in sv_magic() */
777 Copy(pv,newaddr,len,char); /* might not be null terminated */
778 newaddr[len] = '\0'; /* is now */
781 Zero(newaddr,len+1,char);
787 =for apidoc savesharedpv
789 A version of C<savepv()> which allocates the duplicate string in memory
790 which is shared between threads.
795 Perl_savesharedpv(pTHX_ const char *pv)
797 register char *newaddr = Nullch;
799 newaddr = (char*)PerlMemShared_malloc(strlen(pv)+1);
800 (void)strcpy(newaddr,pv);
807 /* the SV for Perl_form() and mess() is not kept in an arena */
816 return sv_2mortal(newSVpvn("",0));
821 /* Create as PVMG now, to avoid any upgrading later */
823 Newz(905, any, 1, XPVMG);
824 SvFLAGS(sv) = SVt_PVMG;
825 SvANY(sv) = (void*)any;
826 SvREFCNT(sv) = 1 << 30; /* practically infinite */
831 #if defined(PERL_IMPLICIT_CONTEXT)
833 Perl_form_nocontext(const char* pat, ...)
839 retval = vform(pat, &args);
843 #endif /* PERL_IMPLICIT_CONTEXT */
846 =head1 Miscellaneous Functions
849 Takes a sprintf-style format pattern and conventional
850 (non-SV) arguments and returns the formatted string.
852 (char *) Perl_form(pTHX_ const char* pat, ...)
854 can be used any place a string (char *) is required:
856 char * s = Perl_form("%d.%d",major,minor);
858 Uses a single private buffer so if you want to format several strings you
859 must explicitly copy the earlier strings away (and free the copies when you
866 Perl_form(pTHX_ const char* pat, ...)
871 retval = vform(pat, &args);
877 Perl_vform(pTHX_ const char *pat, va_list *args)
879 SV *sv = mess_alloc();
880 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
884 #if defined(PERL_IMPLICIT_CONTEXT)
886 Perl_mess_nocontext(const char *pat, ...)
892 retval = vmess(pat, &args);
896 #endif /* PERL_IMPLICIT_CONTEXT */
899 Perl_mess(pTHX_ const char *pat, ...)
904 retval = vmess(pat, &args);
910 S_closest_cop(pTHX_ COP *cop, OP *o)
912 /* Look for PL_op starting from o. cop is the last COP we've seen. */
914 if (!o || o == PL_op) return cop;
916 if (o->op_flags & OPf_KIDS) {
918 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
922 /* If the OP_NEXTSTATE has been optimised away we can still use it
923 * the get the file and line number. */
925 if (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE)
928 /* Keep searching, and return when we've found something. */
930 new_cop = closest_cop(cop, kid);
931 if (new_cop) return new_cop;
941 Perl_vmess(pTHX_ const char *pat, va_list *args)
943 SV *sv = mess_alloc();
944 static char dgd[] = " during global destruction.\n";
947 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
948 if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
951 * Try and find the file and line for PL_op. This will usually be
952 * PL_curcop, but it might be a cop that has been optimised away. We
953 * can try to find such a cop by searching through the optree starting
954 * from the sibling of PL_curcop.
957 cop = closest_cop(PL_curcop, PL_curcop->op_sibling);
958 if (!cop) cop = PL_curcop;
961 Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf,
962 OutCopFILE(cop), (IV)CopLINE(cop));
963 if (GvIO(PL_last_in_gv) && IoLINES(GvIOp(PL_last_in_gv))) {
964 bool line_mode = (RsSIMPLE(PL_rs) &&
965 SvCUR(PL_rs) == 1 && *SvPVX(PL_rs) == '\n');
966 Perl_sv_catpvf(aTHX_ sv, ", <%s> %s %"IVdf,
967 PL_last_in_gv == PL_argvgv ?
968 "" : GvNAME(PL_last_in_gv),
969 line_mode ? "line" : "chunk",
970 (IV)IoLINES(GvIOp(PL_last_in_gv)));
972 sv_catpv(sv, PL_dirty ? dgd : ".\n");
978 Perl_write_to_stderr(pTHX_ const char* message, int msglen)
983 if (PL_stderrgv && SvREFCNT(PL_stderrgv)
984 && (io = GvIO(PL_stderrgv))
985 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
992 SAVESPTR(PL_stderrgv);
993 PL_stderrgv = Nullgv;
995 PUSHSTACKi(PERLSI_MAGIC);
999 PUSHs(SvTIED_obj((SV*)io, mg));
1000 PUSHs(sv_2mortal(newSVpvn(message, msglen)));
1002 call_method("PRINT", G_SCALAR);
1010 /* SFIO can really mess with your errno */
1013 PerlIO *serr = Perl_error_log;
1015 PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
1016 (void)PerlIO_flush(serr);
1024 Perl_vdie(pTHX_ const char* pat, va_list *args)
1027 int was_in_eval = PL_in_eval;
1035 DEBUG_S(PerlIO_printf(Perl_debug_log,
1036 "%p: die: curstack = %p, mainstack = %p\n",
1037 thr, PL_curstack, PL_mainstack));
1040 msv = vmess(pat, args);
1041 if (PL_errors && SvCUR(PL_errors)) {
1042 sv_catsv(PL_errors, msv);
1043 message = SvPV(PL_errors, msglen);
1044 SvCUR_set(PL_errors, 0);
1047 message = SvPV(msv,msglen);
1055 DEBUG_S(PerlIO_printf(Perl_debug_log,
1056 "%p: die: message = %s\ndiehook = %p\n",
1057 thr, message, PL_diehook));
1059 /* sv_2cv might call Perl_croak() */
1060 SV *olddiehook = PL_diehook;
1062 SAVESPTR(PL_diehook);
1063 PL_diehook = Nullsv;
1064 cv = sv_2cv(olddiehook, &stash, &gv, 0);
1066 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1073 msg = newSVpvn(message, msglen);
1074 SvFLAGS(msg) |= utf8;
1082 PUSHSTACKi(PERLSI_DIEHOOK);
1086 call_sv((SV*)cv, G_DISCARD);
1092 PL_restartop = die_where(message, msglen);
1093 SvFLAGS(ERRSV) |= utf8;
1094 DEBUG_S(PerlIO_printf(Perl_debug_log,
1095 "%p: die: restartop = %p, was_in_eval = %d, top_env = %p\n",
1096 thr, PL_restartop, was_in_eval, PL_top_env));
1097 if ((!PL_restartop && was_in_eval) || PL_top_env->je_prev)
1099 return PL_restartop;
1102 #if defined(PERL_IMPLICIT_CONTEXT)
1104 Perl_die_nocontext(const char* pat, ...)
1109 va_start(args, pat);
1110 o = vdie(pat, &args);
1114 #endif /* PERL_IMPLICIT_CONTEXT */
1117 Perl_die(pTHX_ const char* pat, ...)
1121 va_start(args, pat);
1122 o = vdie(pat, &args);
1128 Perl_vcroak(pTHX_ const char* pat, va_list *args)
1139 msv = vmess(pat, args);
1140 if (PL_errors && SvCUR(PL_errors)) {
1141 sv_catsv(PL_errors, msv);
1142 message = SvPV(PL_errors, msglen);
1143 SvCUR_set(PL_errors, 0);
1146 message = SvPV(msv,msglen);
1154 DEBUG_S(PerlIO_printf(Perl_debug_log, "croak: 0x%"UVxf" %s",
1155 PTR2UV(thr), message));
1158 /* sv_2cv might call Perl_croak() */
1159 SV *olddiehook = PL_diehook;
1161 SAVESPTR(PL_diehook);
1162 PL_diehook = Nullsv;
1163 cv = sv_2cv(olddiehook, &stash, &gv, 0);
1165 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1172 msg = newSVpvn(message, msglen);
1173 SvFLAGS(msg) |= utf8;
1181 PUSHSTACKi(PERLSI_DIEHOOK);
1185 call_sv((SV*)cv, G_DISCARD);
1191 PL_restartop = die_where(message, msglen);
1192 SvFLAGS(ERRSV) |= utf8;
1196 message = SvPVx(ERRSV, msglen);
1198 write_to_stderr(message, msglen);
1202 #if defined(PERL_IMPLICIT_CONTEXT)
1204 Perl_croak_nocontext(const char *pat, ...)
1208 va_start(args, pat);
1213 #endif /* PERL_IMPLICIT_CONTEXT */
1216 =head1 Warning and Dieing
1220 This is the XSUB-writer's interface to Perl's C<die> function.
1221 Normally use this function the same way you use the C C<printf>
1222 function. See C<warn>.
1224 If you want to throw an exception object, assign the object to
1225 C<$@> and then pass C<Nullch> to croak():
1227 errsv = get_sv("@", TRUE);
1228 sv_setsv(errsv, exception_object);
1235 Perl_croak(pTHX_ const char *pat, ...)
1238 va_start(args, pat);
1245 Perl_vwarn(pTHX_ const char* pat, va_list *args)
1255 msv = vmess(pat, args);
1257 message = SvPV(msv, msglen);
1260 /* sv_2cv might call Perl_warn() */
1261 SV *oldwarnhook = PL_warnhook;
1263 SAVESPTR(PL_warnhook);
1264 PL_warnhook = Nullsv;
1265 cv = sv_2cv(oldwarnhook, &stash, &gv, 0);
1267 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1273 msg = newSVpvn(message, msglen);
1274 SvFLAGS(msg) |= utf8;
1278 PUSHSTACKi(PERLSI_WARNHOOK);
1282 call_sv((SV*)cv, G_DISCARD);
1289 write_to_stderr(message, msglen);
1292 #if defined(PERL_IMPLICIT_CONTEXT)
1294 Perl_warn_nocontext(const char *pat, ...)
1298 va_start(args, pat);
1302 #endif /* PERL_IMPLICIT_CONTEXT */
1307 This is the XSUB-writer's interface to Perl's C<warn> function. Use this
1308 function the same way you use the C C<printf> function. See
1315 Perl_warn(pTHX_ const char *pat, ...)
1318 va_start(args, pat);
1323 #if defined(PERL_IMPLICIT_CONTEXT)
1325 Perl_warner_nocontext(U32 err, const char *pat, ...)
1329 va_start(args, pat);
1330 vwarner(err, pat, &args);
1333 #endif /* PERL_IMPLICIT_CONTEXT */
1336 Perl_warner(pTHX_ U32 err, const char* pat,...)
1339 va_start(args, pat);
1340 vwarner(err, pat, &args);
1345 Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args)
1355 msv = vmess(pat, args);
1356 message = SvPV(msv, msglen);
1361 /* sv_2cv might call Perl_croak() */
1362 SV *olddiehook = PL_diehook;
1364 SAVESPTR(PL_diehook);
1365 PL_diehook = Nullsv;
1366 cv = sv_2cv(olddiehook, &stash, &gv, 0);
1368 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1374 msg = newSVpvn(message, msglen);
1375 SvFLAGS(msg) |= utf8;
1379 PUSHSTACKi(PERLSI_DIEHOOK);
1383 call_sv((SV*)cv, G_DISCARD);
1389 PL_restartop = die_where(message, msglen);
1390 SvFLAGS(ERRSV) |= utf8;
1393 write_to_stderr(message, msglen);
1398 /* sv_2cv might call Perl_warn() */
1399 SV *oldwarnhook = PL_warnhook;
1401 SAVESPTR(PL_warnhook);
1402 PL_warnhook = Nullsv;
1403 cv = sv_2cv(oldwarnhook, &stash, &gv, 0);
1405 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1411 msg = newSVpvn(message, msglen);
1412 SvFLAGS(msg) |= utf8;
1416 PUSHSTACKi(PERLSI_WARNHOOK);
1420 call_sv((SV*)cv, G_DISCARD);
1426 write_to_stderr(message, msglen);
1430 /* since we've already done strlen() for both nam and val
1431 * we can use that info to make things faster than
1432 * sprintf(s, "%s=%s", nam, val)
1434 #define my_setenv_format(s, nam, nlen, val, vlen) \
1435 Copy(nam, s, nlen, char); \
1437 Copy(val, s+(nlen+1), vlen, char); \
1438 *(s+(nlen+1+vlen)) = '\0'
1440 #ifdef USE_ENVIRON_ARRAY
1441 /* VMS' my_setenv() is in vms.c */
1442 #if !defined(WIN32) && !defined(NETWARE)
1444 Perl_my_setenv(pTHX_ char *nam, char *val)
1447 /* only parent thread can modify process environment */
1448 if (PL_curinterp == aTHX)
1451 #ifndef PERL_USE_SAFE_PUTENV
1452 /* most putenv()s leak, so we manipulate environ directly */
1453 register I32 i=setenv_getix(nam); /* where does it go? */
1456 if (environ == PL_origenviron) { /* need we copy environment? */
1462 for (max = i; environ[max]; max++) ;
1463 tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*));
1464 for (j=0; j<max; j++) { /* copy environment */
1465 int len = strlen(environ[j]);
1466 tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char));
1467 Copy(environ[j], tmpenv[j], len+1, char);
1469 tmpenv[max] = Nullch;
1470 environ = tmpenv; /* tell exec where it is now */
1473 safesysfree(environ[i]);
1474 while (environ[i]) {
1475 environ[i] = environ[i+1];
1480 if (!environ[i]) { /* does not exist yet */
1481 environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
1482 environ[i+1] = Nullch; /* make sure it's null terminated */
1485 safesysfree(environ[i]);
1489 environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char));
1490 /* all that work just for this */
1491 my_setenv_format(environ[i], nam, nlen, val, vlen);
1493 #else /* PERL_USE_SAFE_PUTENV */
1494 # if defined(__CYGWIN__) || defined( EPOC)
1495 setenv(nam, val, 1);
1498 int nlen = strlen(nam), vlen;
1503 new_env = (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
1504 /* all that work just for this */
1505 my_setenv_format(new_env, nam, nlen, val, vlen);
1506 (void)putenv(new_env);
1507 # endif /* __CYGWIN__ */
1508 #endif /* PERL_USE_SAFE_PUTENV */
1512 #else /* WIN32 || NETWARE */
1515 Perl_my_setenv(pTHX_ char *nam,char *val)
1517 register char *envstr;
1518 int nlen = strlen(nam), vlen;
1524 New(904, envstr, nlen+vlen+2, char);
1525 my_setenv_format(envstr, nam, nlen, val, vlen);
1526 (void)PerlEnv_putenv(envstr);
1530 #endif /* WIN32 || NETWARE */
1534 Perl_setenv_getix(pTHX_ char *nam)
1536 register I32 i, len = strlen(nam);
1538 for (i = 0; environ[i]; i++) {
1541 strnicmp(environ[i],nam,len) == 0
1543 strnEQ(environ[i],nam,len)
1545 && environ[i][len] == '=')
1546 break; /* strnEQ must come first to avoid */
1547 } /* potential SEGV's */
1550 #endif /* !PERL_MICRO */
1552 #endif /* !VMS && !EPOC*/
1554 #ifdef UNLINK_ALL_VERSIONS
1556 Perl_unlnk(pTHX_ char *f) /* unlink all versions of a file */
1560 for (i = 0; PerlLIO_unlink(f) >= 0; i++) ;
1565 /* this is a drop-in replacement for bcopy() */
1566 #if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY))
1568 Perl_my_bcopy(register const char *from,register char *to,register I32 len)
1572 if (from - to >= 0) {
1580 *(--to) = *(--from);
1586 /* this is a drop-in replacement for memset() */
1589 Perl_my_memset(register char *loc, register I32 ch, register I32 len)
1599 /* this is a drop-in replacement for bzero() */
1600 #if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
1602 Perl_my_bzero(register char *loc, register I32 len)
1612 /* this is a drop-in replacement for memcmp() */
1613 #if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
1615 Perl_my_memcmp(const char *s1, const char *s2, register I32 len)
1617 register U8 *a = (U8 *)s1;
1618 register U8 *b = (U8 *)s2;
1622 if (tmp = *a++ - *b++)
1627 #endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */
1631 #ifdef USE_CHAR_VSPRINTF
1636 vsprintf(char *dest, const char *pat, char *args)
1640 fakebuf._ptr = dest;
1641 fakebuf._cnt = 32767;
1645 fakebuf._flag = _IOWRT|_IOSTRG;
1646 _doprnt(pat, args, &fakebuf); /* what a kludge */
1647 (void)putc('\0', &fakebuf);
1648 #ifdef USE_CHAR_VSPRINTF
1651 return 0; /* perl doesn't use return value */
1655 #endif /* HAS_VPRINTF */
1658 #if BYTEORDER != 0x4321
1660 Perl_my_swap(pTHX_ short s)
1662 #if (BYTEORDER & 1) == 0
1665 result = ((s & 255) << 8) + ((s >> 8) & 255);
1673 Perl_my_htonl(pTHX_ long l)
1677 char c[sizeof(long)];
1680 #if BYTEORDER == 0x1234
1681 u.c[0] = (l >> 24) & 255;
1682 u.c[1] = (l >> 16) & 255;
1683 u.c[2] = (l >> 8) & 255;
1687 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
1688 Perl_croak(aTHX_ "Unknown BYTEORDER\n");
1693 for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
1694 u.c[o & 0xf] = (l >> s) & 255;
1702 Perl_my_ntohl(pTHX_ long l)
1706 char c[sizeof(long)];
1709 #if BYTEORDER == 0x1234
1710 u.c[0] = (l >> 24) & 255;
1711 u.c[1] = (l >> 16) & 255;
1712 u.c[2] = (l >> 8) & 255;
1716 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
1717 Perl_croak(aTHX_ "Unknown BYTEORDER\n");
1724 for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
1725 l |= (u.c[o & 0xf] & 255) << s;
1732 #endif /* BYTEORDER != 0x4321 */
1736 * Little-endian byte order functions - 'v' for 'VAX', or 'reVerse'.
1737 * If these functions are defined,
1738 * the BYTEORDER is neither 0x1234 nor 0x4321.
1739 * However, this is not assumed.
1743 #define HTOV(name,type) \
1745 name (register type n) \
1749 char c[sizeof(type)]; \
1753 for (i = 0, s = 0; i < sizeof(u.c); i++, s += 8) { \
1754 u.c[i] = (n >> s) & 0xFF; \
1759 #define VTOH(name,type) \
1761 name (register type n) \
1765 char c[sizeof(type)]; \
1771 for (i = 0, s = 0; i < sizeof(u.c); i++, s += 8) { \
1772 n += (u.c[i] & 0xFF) << s; \
1777 #if defined(HAS_HTOVS) && !defined(htovs)
1780 #if defined(HAS_HTOVL) && !defined(htovl)
1783 #if defined(HAS_VTOHS) && !defined(vtohs)
1786 #if defined(HAS_VTOHL) && !defined(vtohl)
1791 Perl_my_popen_list(pTHX_ char *mode, int n, SV **args)
1793 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) && !defined(NETWARE)
1795 register I32 This, that;
1801 PERL_FLUSHALL_FOR_CHILD;
1802 This = (*mode == 'w');
1806 taint_proper("Insecure %s%s", "EXEC");
1808 if (PerlProc_pipe(p) < 0)
1810 /* Try for another pipe pair for error return */
1811 if (PerlProc_pipe(pp) >= 0)
1813 while ((pid = PerlProc_fork()) < 0) {
1814 if (errno != EAGAIN) {
1815 PerlLIO_close(p[This]);
1816 PerlLIO_close(p[that]);
1818 PerlLIO_close(pp[0]);
1819 PerlLIO_close(pp[1]);
1831 /* Close parent's end of error status pipe (if any) */
1833 PerlLIO_close(pp[0]);
1834 #if defined(HAS_FCNTL) && defined(F_SETFD)
1835 /* Close error pipe automatically if exec works */
1836 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
1839 /* Now dup our end of _the_ pipe to right position */
1840 if (p[THIS] != (*mode == 'r')) {
1841 PerlLIO_dup2(p[THIS], *mode == 'r');
1842 PerlLIO_close(p[THIS]);
1843 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
1844 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
1847 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
1848 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
1849 /* No automatic close - do it by hand */
1856 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) {
1862 do_aexec5(Nullsv, args-1, args-1+n, pp[1], did_pipes);
1868 do_execfree(); /* free any memory malloced by child on fork */
1870 PerlLIO_close(pp[1]);
1871 /* Keep the lower of the two fd numbers */
1872 if (p[that] < p[This]) {
1873 PerlLIO_dup2(p[This], p[that]);
1874 PerlLIO_close(p[This]);
1878 PerlLIO_close(p[that]); /* close child's end of pipe */
1881 sv = *av_fetch(PL_fdpid,p[This],TRUE);
1883 (void)SvUPGRADE(sv,SVt_IV);
1885 PL_forkprocess = pid;
1886 /* If we managed to get status pipe check for exec fail */
1887 if (did_pipes && pid > 0) {
1891 while (n < sizeof(int)) {
1892 n1 = PerlLIO_read(pp[0],
1893 (void*)(((char*)&errkid)+n),
1899 PerlLIO_close(pp[0]);
1901 if (n) { /* Error */
1903 PerlLIO_close(p[This]);
1904 if (n != sizeof(int))
1905 Perl_croak(aTHX_ "panic: kid popen errno read");
1907 pid2 = wait4pid(pid, &status, 0);
1908 } while (pid2 == -1 && errno == EINTR);
1909 errno = errkid; /* Propagate errno from kid */
1914 PerlLIO_close(pp[0]);
1915 return PerlIO_fdopen(p[This], mode);
1917 Perl_croak(aTHX_ "List form of piped open not implemented");
1918 return (PerlIO *) NULL;
1922 /* VMS' my_popen() is in VMS.c, same with OS/2. */
1923 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
1925 Perl_my_popen(pTHX_ char *cmd, char *mode)
1928 register I32 This, that;
1931 I32 doexec = strNE(cmd,"-");
1935 PERL_FLUSHALL_FOR_CHILD;
1938 return my_syspopen(aTHX_ cmd,mode);
1941 This = (*mode == 'w');
1943 if (doexec && PL_tainting) {
1945 taint_proper("Insecure %s%s", "EXEC");
1947 if (PerlProc_pipe(p) < 0)
1949 if (doexec && PerlProc_pipe(pp) >= 0)
1951 while ((pid = PerlProc_fork()) < 0) {
1952 if (errno != EAGAIN) {
1953 PerlLIO_close(p[This]);
1954 PerlLIO_close(p[that]);
1956 PerlLIO_close(pp[0]);
1957 PerlLIO_close(pp[1]);
1960 Perl_croak(aTHX_ "Can't fork");
1973 PerlLIO_close(pp[0]);
1974 #if defined(HAS_FCNTL) && defined(F_SETFD)
1975 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
1978 if (p[THIS] != (*mode == 'r')) {
1979 PerlLIO_dup2(p[THIS], *mode == 'r');
1980 PerlLIO_close(p[THIS]);
1981 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
1982 PerlLIO_close(p[THAT]);
1985 PerlLIO_close(p[THAT]);
1988 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
1997 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
2002 /* may or may not use the shell */
2003 do_exec3(cmd, pp[1], did_pipes);
2006 #endif /* defined OS2 */
2008 if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) {
2009 SvREADONLY_off(GvSV(tmpgv));
2010 sv_setiv(GvSV(tmpgv), PerlProc_getpid());
2011 SvREADONLY_on(GvSV(tmpgv));
2013 #ifdef THREADS_HAVE_PIDS
2014 PL_ppid = (IV)getppid();
2017 hv_clear(PL_pidstatus); /* we have no children */
2022 do_execfree(); /* free any memory malloced by child on vfork */
2024 PerlLIO_close(pp[1]);
2025 if (p[that] < p[This]) {
2026 PerlLIO_dup2(p[This], p[that]);
2027 PerlLIO_close(p[This]);
2031 PerlLIO_close(p[that]);
2034 sv = *av_fetch(PL_fdpid,p[This],TRUE);
2036 (void)SvUPGRADE(sv,SVt_IV);
2038 PL_forkprocess = pid;
2039 if (did_pipes && pid > 0) {
2043 while (n < sizeof(int)) {
2044 n1 = PerlLIO_read(pp[0],
2045 (void*)(((char*)&errkid)+n),
2051 PerlLIO_close(pp[0]);
2053 if (n) { /* Error */
2055 PerlLIO_close(p[This]);
2056 if (n != sizeof(int))
2057 Perl_croak(aTHX_ "panic: kid popen errno read");
2059 pid2 = wait4pid(pid, &status, 0);
2060 } while (pid2 == -1 && errno == EINTR);
2061 errno = errkid; /* Propagate errno from kid */
2066 PerlLIO_close(pp[0]);
2067 return PerlIO_fdopen(p[This], mode);
2070 #if defined(atarist) || defined(EPOC)
2073 Perl_my_popen(pTHX_ char *cmd, char *mode)
2075 PERL_FLUSHALL_FOR_CHILD;
2076 /* Call system's popen() to get a FILE *, then import it.
2077 used 0 for 2nd parameter to PerlIO_importFILE;
2080 return PerlIO_importFILE(popen(cmd, mode), 0);
2084 FILE *djgpp_popen();
2086 Perl_my_popen(pTHX_ char *cmd, char *mode)
2088 PERL_FLUSHALL_FOR_CHILD;
2089 /* Call system's popen() to get a FILE *, then import it.
2090 used 0 for 2nd parameter to PerlIO_importFILE;
2093 return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
2098 #endif /* !DOSISH */
2100 /* this is called in parent before the fork() */
2102 Perl_atfork_lock(void)
2104 #if defined(USE_ITHREADS)
2105 /* locks must be held in locking order (if any) */
2107 MUTEX_LOCK(&PL_malloc_mutex);
2113 /* this is called in both parent and child after the fork() */
2115 Perl_atfork_unlock(void)
2117 #if defined(USE_ITHREADS)
2118 /* locks must be released in same order as in atfork_lock() */
2120 MUTEX_UNLOCK(&PL_malloc_mutex);
2129 #if defined(HAS_FORK)
2131 #if defined(USE_ITHREADS) && !defined(HAS_PTHREAD_ATFORK)
2136 /* atfork_lock() and atfork_unlock() are installed as pthread_atfork()
2137 * handlers elsewhere in the code */
2142 /* this "canna happen" since nothing should be calling here if !HAS_FORK */
2143 Perl_croak_nocontext("fork() not available");
2145 #endif /* HAS_FORK */
2150 Perl_dump_fds(pTHX_ char *s)
2155 PerlIO_printf(Perl_debug_log,"%s", s);
2156 for (fd = 0; fd < 32; fd++) {
2157 if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0)
2158 PerlIO_printf(Perl_debug_log," %d",fd);
2160 PerlIO_printf(Perl_debug_log,"\n");
2162 #endif /* DUMP_FDS */
2166 dup2(int oldfd, int newfd)
2168 #if defined(HAS_FCNTL) && defined(F_DUPFD)
2171 PerlLIO_close(newfd);
2172 return fcntl(oldfd, F_DUPFD, newfd);
2174 #define DUP2_MAX_FDS 256
2175 int fdtmp[DUP2_MAX_FDS];
2181 PerlLIO_close(newfd);
2182 /* good enough for low fd's... */
2183 while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
2184 if (fdx >= DUP2_MAX_FDS) {
2192 PerlLIO_close(fdtmp[--fdx]);
2199 #ifdef HAS_SIGACTION
2201 #ifdef MACOS_TRADITIONAL
2202 /* We don't want restart behavior on MacOS */
2207 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2209 struct sigaction act, oact;
2212 /* only "parent" interpreter can diddle signals */
2213 if (PL_curinterp != aTHX)
2217 act.sa_handler = handler;
2218 sigemptyset(&act.sa_mask);
2221 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2222 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
2224 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2225 if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN)
2226 act.sa_flags |= SA_NOCLDWAIT;
2228 if (sigaction(signo, &act, &oact) == -1)
2231 return oact.sa_handler;
2235 Perl_rsignal_state(pTHX_ int signo)
2237 struct sigaction oact;
2239 if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
2242 return oact.sa_handler;
2246 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2248 struct sigaction act;
2251 /* only "parent" interpreter can diddle signals */
2252 if (PL_curinterp != aTHX)
2256 act.sa_handler = handler;
2257 sigemptyset(&act.sa_mask);
2260 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2261 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
2263 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2264 if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN)
2265 act.sa_flags |= SA_NOCLDWAIT;
2267 return sigaction(signo, &act, save);
2271 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2274 /* only "parent" interpreter can diddle signals */
2275 if (PL_curinterp != aTHX)
2279 return sigaction(signo, save, (struct sigaction *)NULL);
2282 #else /* !HAS_SIGACTION */
2285 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2287 #if defined(USE_ITHREADS) && !defined(WIN32)
2288 /* only "parent" interpreter can diddle signals */
2289 if (PL_curinterp != aTHX)
2293 return PerlProc_signal(signo, handler);
2296 static int sig_trapped; /* XXX signals are process-wide anyway, so we
2297 ignore the implications of this for threading */
2307 Perl_rsignal_state(pTHX_ int signo)
2309 Sighandler_t oldsig;
2311 #if defined(USE_ITHREADS) && !defined(WIN32)
2312 /* only "parent" interpreter can diddle signals */
2313 if (PL_curinterp != aTHX)
2318 oldsig = PerlProc_signal(signo, sig_trap);
2319 PerlProc_signal(signo, oldsig);
2321 PerlProc_kill(PerlProc_getpid(), signo);
2326 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2328 #if defined(USE_ITHREADS) && !defined(WIN32)
2329 /* only "parent" interpreter can diddle signals */
2330 if (PL_curinterp != aTHX)
2333 *save = PerlProc_signal(signo, handler);
2334 return (*save == SIG_ERR) ? -1 : 0;
2338 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2340 #if defined(USE_ITHREADS) && !defined(WIN32)
2341 /* only "parent" interpreter can diddle signals */
2342 if (PL_curinterp != aTHX)
2345 return (PerlProc_signal(signo, *save) == SIG_ERR) ? -1 : 0;
2348 #endif /* !HAS_SIGACTION */
2349 #endif /* !PERL_MICRO */
2351 /* VMS' my_pclose() is in VMS.c; same with OS/2 */
2352 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
2354 Perl_my_pclose(pTHX_ PerlIO *ptr)
2356 Sigsave_t hstat, istat, qstat;
2362 int saved_errno = 0;
2364 int saved_vaxc_errno;
2367 int saved_win32_errno;
2371 svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE);
2373 pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
2375 *svp = &PL_sv_undef;
2377 if (pid == -1) { /* Opened by popen. */
2378 return my_syspclose(ptr);
2381 if ((close_failed = (PerlIO_close(ptr) == EOF))) {
2382 saved_errno = errno;
2384 saved_vaxc_errno = vaxc$errno;
2387 saved_win32_errno = GetLastError();
2391 if(PerlProc_kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */
2394 rsignal_save(SIGHUP, SIG_IGN, &hstat);
2395 rsignal_save(SIGINT, SIG_IGN, &istat);
2396 rsignal_save(SIGQUIT, SIG_IGN, &qstat);
2399 pid2 = wait4pid(pid, &status, 0);
2400 } while (pid2 == -1 && errno == EINTR);
2402 rsignal_restore(SIGHUP, &hstat);
2403 rsignal_restore(SIGINT, &istat);
2404 rsignal_restore(SIGQUIT, &qstat);
2407 SETERRNO(saved_errno, saved_vaxc_errno);
2410 return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status));
2412 #endif /* !DOSISH */
2414 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(MACOS_TRADITIONAL)
2416 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
2421 #if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME)
2425 char spid[TYPE_CHARS(int)];
2428 sprintf(spid, "%"IVdf, (IV)pid);
2429 svp = hv_fetch(PL_pidstatus,spid,strlen(spid),FALSE);
2430 if (svp && *svp != &PL_sv_undef) {
2431 *statusp = SvIVX(*svp);
2432 (void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD);
2439 hv_iterinit(PL_pidstatus);
2440 if ((entry = hv_iternext(PL_pidstatus))) {
2442 char spid[TYPE_CHARS(int)];
2444 pid = atoi(hv_iterkey(entry,(I32*)statusp));
2445 sv = hv_iterval(PL_pidstatus,entry);
2446 *statusp = SvIVX(sv);
2447 sprintf(spid, "%"IVdf, (IV)pid);
2448 (void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD);
2455 # ifdef HAS_WAITPID_RUNTIME
2456 if (!HAS_WAITPID_RUNTIME)
2459 result = PerlProc_waitpid(pid,statusp,flags);
2462 #if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
2463 result = wait4((pid==-1)?0:pid,statusp,flags,Null(struct rusage *));
2466 #if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME)
2470 Perl_croak(aTHX_ "Can't do waitpid with flags");
2472 while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
2473 pidgone(result,*statusp);
2480 if (result < 0 && errno == EINTR) {
2485 #endif /* !DOSISH || OS2 || WIN32 || NETWARE */
2489 Perl_pidgone(pTHX_ Pid_t pid, int status)
2492 char spid[TYPE_CHARS(int)];
2494 sprintf(spid, "%"IVdf, (IV)pid);
2495 sv = *hv_fetch(PL_pidstatus,spid,strlen(spid),TRUE);
2496 (void)SvUPGRADE(sv,SVt_IV);
2501 #if defined(atarist) || defined(OS2) || defined(EPOC)
2504 int /* Cannot prototype with I32
2506 my_syspclose(PerlIO *ptr)
2509 Perl_my_pclose(pTHX_ PerlIO *ptr)
2512 /* Needs work for PerlIO ! */
2513 FILE *f = PerlIO_findFILE(ptr);
2514 I32 result = pclose(f);
2515 PerlIO_releaseFILE(ptr,f);
2523 Perl_my_pclose(pTHX_ PerlIO *ptr)
2525 /* Needs work for PerlIO ! */
2526 FILE *f = PerlIO_findFILE(ptr);
2527 I32 result = djgpp_pclose(f);
2528 result = (result << 8) & 0xff00;
2529 PerlIO_releaseFILE(ptr,f);
2535 Perl_repeatcpy(pTHX_ register char *to, register const char *from, I32 len, register I32 count)
2538 register const char *frombase = from;
2541 register const char c = *from;
2546 while (count-- > 0) {
2547 for (todo = len; todo > 0; todo--) {
2556 Perl_same_dirent(pTHX_ char *a, char *b)
2558 char *fa = strrchr(a,'/');
2559 char *fb = strrchr(b,'/');
2562 SV *tmpsv = sv_newmortal();
2575 sv_setpv(tmpsv, ".");
2577 sv_setpvn(tmpsv, a, fa - a);
2578 if (PerlLIO_stat(SvPVX(tmpsv), &tmpstatbuf1) < 0)
2581 sv_setpv(tmpsv, ".");
2583 sv_setpvn(tmpsv, b, fb - b);
2584 if (PerlLIO_stat(SvPVX(tmpsv), &tmpstatbuf2) < 0)
2586 return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
2587 tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
2589 #endif /* !HAS_RENAME */
2592 Perl_find_script(pTHX_ char *scriptname, bool dosearch, char **search_ext, I32 flags)
2594 char *xfound = Nullch;
2595 char *xfailed = Nullch;
2596 char tmpbuf[MAXPATHLEN];
2600 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
2601 # define SEARCH_EXTS ".bat", ".cmd", NULL
2602 # define MAX_EXT_LEN 4
2605 # define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
2606 # define MAX_EXT_LEN 4
2609 # define SEARCH_EXTS ".pl", ".com", NULL
2610 # define MAX_EXT_LEN 4
2612 /* additional extensions to try in each dir if scriptname not found */
2614 char *exts[] = { SEARCH_EXTS };
2615 char **ext = search_ext ? search_ext : exts;
2616 int extidx = 0, i = 0;
2617 char *curext = Nullch;
2619 # define MAX_EXT_LEN 0
2623 * If dosearch is true and if scriptname does not contain path
2624 * delimiters, search the PATH for scriptname.
2626 * If SEARCH_EXTS is also defined, will look for each
2627 * scriptname{SEARCH_EXTS} whenever scriptname is not found
2628 * while searching the PATH.
2630 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
2631 * proceeds as follows:
2632 * If DOSISH or VMSISH:
2633 * + look for ./scriptname{,.foo,.bar}
2634 * + search the PATH for scriptname{,.foo,.bar}
2637 * + look *only* in the PATH for scriptname{,.foo,.bar} (note
2638 * this will not look in '.' if it's not in the PATH)
2643 # ifdef ALWAYS_DEFTYPES
2644 len = strlen(scriptname);
2645 if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
2646 int hasdir, idx = 0, deftypes = 1;
2649 hasdir = !dosearch || (strpbrk(scriptname,":[</") != Nullch) ;
2652 int hasdir, idx = 0, deftypes = 1;
2655 hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
2657 /* The first time through, just add SEARCH_EXTS to whatever we
2658 * already have, so we can check for default file types. */
2660 (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
2666 if ((strlen(tmpbuf) + strlen(scriptname)
2667 + MAX_EXT_LEN) >= sizeof tmpbuf)
2668 continue; /* don't search dir with too-long name */
2669 strcat(tmpbuf, scriptname);
2673 if (strEQ(scriptname, "-"))
2675 if (dosearch) { /* Look in '.' first. */
2676 char *cur = scriptname;
2678 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
2680 if (strEQ(ext[i++],curext)) {
2681 extidx = -1; /* already has an ext */
2686 DEBUG_p(PerlIO_printf(Perl_debug_log,
2687 "Looking for %s\n",cur));
2688 if (PerlLIO_stat(cur,&PL_statbuf) >= 0
2689 && !S_ISDIR(PL_statbuf.st_mode)) {
2697 if (cur == scriptname) {
2698 len = strlen(scriptname);
2699 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
2701 cur = strcpy(tmpbuf, scriptname);
2703 } while (extidx >= 0 && ext[extidx] /* try an extension? */
2704 && strcpy(tmpbuf+len, ext[extidx++]));
2709 #ifdef MACOS_TRADITIONAL
2710 if (dosearch && !strchr(scriptname, ':') &&
2711 (s = PerlEnv_getenv("Commands")))
2713 if (dosearch && !strchr(scriptname, '/')
2715 && !strchr(scriptname, '\\')
2717 && (s = PerlEnv_getenv("PATH")))
2722 PL_bufend = s + strlen(s);
2723 while (s < PL_bufend) {
2724 #ifdef MACOS_TRADITIONAL
2725 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
2729 #if defined(atarist) || defined(DOSISH)
2734 && *s != ';'; len++, s++) {
2735 if (len < sizeof tmpbuf)
2738 if (len < sizeof tmpbuf)
2740 #else /* ! (atarist || DOSISH) */
2741 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
2744 #endif /* ! (atarist || DOSISH) */
2745 #endif /* MACOS_TRADITIONAL */
2748 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
2749 continue; /* don't search dir with too-long name */
2750 #ifdef MACOS_TRADITIONAL
2751 if (len && tmpbuf[len - 1] != ':')
2752 tmpbuf[len++] = ':';
2755 #if defined(atarist) || defined(__MINT__) || defined(DOSISH)
2756 && tmpbuf[len - 1] != '/'
2757 && tmpbuf[len - 1] != '\\'
2760 tmpbuf[len++] = '/';
2761 if (len == 2 && tmpbuf[0] == '.')
2764 (void)strcpy(tmpbuf + len, scriptname);
2768 len = strlen(tmpbuf);
2769 if (extidx > 0) /* reset after previous loop */
2773 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
2774 retval = PerlLIO_stat(tmpbuf,&PL_statbuf);
2775 if (S_ISDIR(PL_statbuf.st_mode)) {
2779 } while ( retval < 0 /* not there */
2780 && extidx>=0 && ext[extidx] /* try an extension? */
2781 && strcpy(tmpbuf+len, ext[extidx++])
2786 if (S_ISREG(PL_statbuf.st_mode)
2787 && cando(S_IRUSR,TRUE,&PL_statbuf)
2788 #if !defined(DOSISH) && !defined(MACOS_TRADITIONAL)
2789 && cando(S_IXUSR,TRUE,&PL_statbuf)
2793 xfound = tmpbuf; /* bingo! */
2797 xfailed = savepv(tmpbuf);
2800 if (!xfound && !seen_dot && !xfailed &&
2801 (PerlLIO_stat(scriptname,&PL_statbuf) < 0
2802 || S_ISDIR(PL_statbuf.st_mode)))
2804 seen_dot = 1; /* Disable message. */
2806 if (flags & 1) { /* do or die? */
2807 Perl_croak(aTHX_ "Can't %s %s%s%s",
2808 (xfailed ? "execute" : "find"),
2809 (xfailed ? xfailed : scriptname),
2810 (xfailed ? "" : " on PATH"),
2811 (xfailed || seen_dot) ? "" : ", '.' not in PATH");
2813 scriptname = Nullch;
2817 scriptname = xfound;
2819 return (scriptname ? savepv(scriptname) : Nullch);
2822 #ifndef PERL_GET_CONTEXT_DEFINED
2825 Perl_get_context(void)
2827 #if defined(USE_ITHREADS)
2828 # ifdef OLD_PTHREADS_API
2830 if (pthread_getspecific(PL_thr_key, &t))
2831 Perl_croak_nocontext("panic: pthread_getspecific");
2834 # ifdef I_MACH_CTHREADS
2835 return (void*)cthread_data(cthread_self());
2837 return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
2846 Perl_set_context(void *t)
2848 #if defined(USE_ITHREADS)
2849 # ifdef I_MACH_CTHREADS
2850 cthread_set_data(cthread_self(), t);
2852 if (pthread_setspecific(PL_thr_key, t))
2853 Perl_croak_nocontext("panic: pthread_setspecific");
2858 #endif /* !PERL_GET_CONTEXT_DEFINED */
2860 #ifdef PERL_GLOBAL_STRUCT
2869 Perl_get_op_names(pTHX)
2875 Perl_get_op_descs(pTHX)
2881 Perl_get_no_modify(pTHX)
2883 return (char*)PL_no_modify;
2887 Perl_get_opargs(pTHX)
2893 Perl_get_ppaddr(pTHX)
2895 return (PPADDR_t*)PL_ppaddr;
2898 #ifndef HAS_GETENV_LEN
2900 Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
2902 char *env_trans = PerlEnv_getenv(env_elem);
2904 *len = strlen(env_trans);
2911 Perl_get_vtbl(pTHX_ int vtbl_id)
2913 MGVTBL* result = Null(MGVTBL*);
2917 result = &PL_vtbl_sv;
2920 result = &PL_vtbl_env;
2922 case want_vtbl_envelem:
2923 result = &PL_vtbl_envelem;
2926 result = &PL_vtbl_sig;
2928 case want_vtbl_sigelem:
2929 result = &PL_vtbl_sigelem;
2931 case want_vtbl_pack:
2932 result = &PL_vtbl_pack;
2934 case want_vtbl_packelem:
2935 result = &PL_vtbl_packelem;
2937 case want_vtbl_dbline:
2938 result = &PL_vtbl_dbline;
2941 result = &PL_vtbl_isa;
2943 case want_vtbl_isaelem:
2944 result = &PL_vtbl_isaelem;
2946 case want_vtbl_arylen:
2947 result = &PL_vtbl_arylen;
2949 case want_vtbl_glob:
2950 result = &PL_vtbl_glob;
2952 case want_vtbl_mglob:
2953 result = &PL_vtbl_mglob;
2955 case want_vtbl_nkeys:
2956 result = &PL_vtbl_nkeys;
2958 case want_vtbl_taint:
2959 result = &PL_vtbl_taint;
2961 case want_vtbl_substr:
2962 result = &PL_vtbl_substr;
2965 result = &PL_vtbl_vec;
2968 result = &PL_vtbl_pos;
2971 result = &PL_vtbl_bm;
2974 result = &PL_vtbl_fm;
2976 case want_vtbl_uvar:
2977 result = &PL_vtbl_uvar;
2979 case want_vtbl_defelem:
2980 result = &PL_vtbl_defelem;
2982 case want_vtbl_regexp:
2983 result = &PL_vtbl_regexp;
2985 case want_vtbl_regdata:
2986 result = &PL_vtbl_regdata;
2988 case want_vtbl_regdatum:
2989 result = &PL_vtbl_regdatum;
2991 #ifdef USE_LOCALE_COLLATE
2992 case want_vtbl_collxfrm:
2993 result = &PL_vtbl_collxfrm;
2996 case want_vtbl_amagic:
2997 result = &PL_vtbl_amagic;
2999 case want_vtbl_amagicelem:
3000 result = &PL_vtbl_amagicelem;
3002 case want_vtbl_backref:
3003 result = &PL_vtbl_backref;
3005 case want_vtbl_utf8:
3006 result = &PL_vtbl_utf8;
3013 Perl_my_fflush_all(pTHX)
3015 #if defined(USE_PERLIO) || defined(FFLUSH_NULL) || defined(USE_SFIO)
3016 return PerlIO_flush(NULL);
3018 # if defined(HAS__FWALK)
3019 extern int fflush(FILE *);
3020 /* undocumented, unprototyped, but very useful BSDism */
3021 extern void _fwalk(int (*)(FILE *));
3025 # if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
3027 # ifdef PERL_FFLUSH_ALL_FOPEN_MAX
3028 open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
3030 # if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
3031 open_max = sysconf(_SC_OPEN_MAX);
3034 open_max = FOPEN_MAX;
3037 open_max = OPEN_MAX;
3048 for (i = 0; i < open_max; i++)
3049 if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
3050 STDIO_STREAM_ARRAY[i]._file < open_max &&
3051 STDIO_STREAM_ARRAY[i]._flag)
3052 PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
3056 SETERRNO(EBADF,RMS_IFI);
3063 Perl_report_evil_fh(pTHX_ GV *gv, IO *io, I32 op)
3066 op == OP_READLINE ? "readline" : /* "<HANDLE>" not nice */
3067 op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */
3069 char *pars = OP_IS_FILETEST(op) ? "" : "()";
3070 char *type = OP_IS_SOCKET(op)
3071 || (gv && io && IoTYPE(io) == IoTYPE_SOCKET)
3072 ? "socket" : "filehandle";
3075 if (gv && isGV(gv)) {
3079 if (op == OP_phoney_OUTPUT_ONLY || op == OP_phoney_INPUT_ONLY) {
3080 if (ckWARN(WARN_IO)) {
3081 const char *direction = (op == OP_phoney_INPUT_ONLY) ? "in" : "out";
3083 Perl_warner(aTHX_ packWARN(WARN_IO),
3084 "Filehandle %s opened only for %sput",
3087 Perl_warner(aTHX_ packWARN(WARN_IO),
3088 "Filehandle opened only for %sput", direction);
3095 if (gv && io && IoTYPE(io) == IoTYPE_CLOSED) {
3097 warn_type = WARN_CLOSED;
3101 warn_type = WARN_UNOPENED;
3104 if (ckWARN(warn_type)) {
3105 if (name && *name) {
3106 Perl_warner(aTHX_ packWARN(warn_type),
3107 "%s%s on %s %s %s", func, pars, vile, type, name);
3108 if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3110 aTHX_ packWARN(warn_type),
3111 "\t(Are you trying to call %s%s on dirhandle %s?)\n",
3116 Perl_warner(aTHX_ packWARN(warn_type),
3117 "%s%s on %s %s", func, pars, vile, type);
3118 if (gv && io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3120 aTHX_ packWARN(warn_type),
3121 "\t(Are you trying to call %s%s on dirhandle?)\n",
3130 /* in ASCII order, not that it matters */
3131 static const char controllablechars[] = "?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_";
3134 Perl_ebcdic_control(pTHX_ int ch)
3142 if ((ctlp = strchr(controllablechars, ch)) == 0) {
3143 Perl_die(aTHX_ "unrecognised control character '%c'\n", ch);
3146 if (ctlp == controllablechars)
3147 return('\177'); /* DEL */
3149 return((unsigned char)(ctlp - controllablechars - 1));
3150 } else { /* Want uncontrol */
3151 if (ch == '\177' || ch == -1)
3153 else if (ch == '\157')
3155 else if (ch == '\174')
3157 else if (ch == '^') /* '\137' in 1047, '\260' in 819 */
3159 else if (ch == '\155')
3161 else if (0 < ch && ch < (sizeof(controllablechars) - 1))
3162 return(controllablechars[ch+1]);
3164 Perl_die(aTHX_ "invalid control request: '\\%03o'\n", ch & 0xFF);
3169 /* To workaround core dumps from the uninitialised tm_zone we get the
3170 * system to give us a reasonable struct to copy. This fix means that
3171 * strftime uses the tm_zone and tm_gmtoff values returned by
3172 * localtime(time()). That should give the desired result most of the
3173 * time. But probably not always!
3175 * This does not address tzname aspects of NETaa14816.
3180 # ifndef STRUCT_TM_HASZONE
3181 # define STRUCT_TM_HASZONE
3185 #ifdef STRUCT_TM_HASZONE /* Backward compat */
3186 # ifndef HAS_TM_TM_ZONE
3187 # define HAS_TM_TM_ZONE
3192 Perl_init_tm(pTHX_ struct tm *ptm) /* see mktime, strftime and asctime */
3194 #ifdef HAS_TM_TM_ZONE
3197 Copy(localtime(&now), ptm, 1, struct tm);
3202 * mini_mktime - normalise struct tm values without the localtime()
3203 * semantics (and overhead) of mktime().
3206 Perl_mini_mktime(pTHX_ struct tm *ptm)
3210 int month, mday, year, jday;
3211 int odd_cent, odd_year;
3213 #define DAYS_PER_YEAR 365
3214 #define DAYS_PER_QYEAR (4*DAYS_PER_YEAR+1)
3215 #define DAYS_PER_CENT (25*DAYS_PER_QYEAR-1)
3216 #define DAYS_PER_QCENT (4*DAYS_PER_CENT+1)
3217 #define SECS_PER_HOUR (60*60)
3218 #define SECS_PER_DAY (24*SECS_PER_HOUR)
3219 /* parentheses deliberately absent on these two, otherwise they don't work */
3220 #define MONTH_TO_DAYS 153/5
3221 #define DAYS_TO_MONTH 5/153
3222 /* offset to bias by March (month 4) 1st between month/mday & year finding */
3223 #define YEAR_ADJUST (4*MONTH_TO_DAYS+1)
3224 /* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */
3225 #define WEEKDAY_BIAS 6 /* (1+6)%7 makes Sunday 0 again */
3228 * Year/day algorithm notes:
3230 * With a suitable offset for numeric value of the month, one can find
3231 * an offset into the year by considering months to have 30.6 (153/5) days,
3232 * using integer arithmetic (i.e., with truncation). To avoid too much
3233 * messing about with leap days, we consider January and February to be
3234 * the 13th and 14th month of the previous year. After that transformation,
3235 * we need the month index we use to be high by 1 from 'normal human' usage,
3236 * so the month index values we use run from 4 through 15.
3238 * Given that, and the rules for the Gregorian calendar (leap years are those
3239 * divisible by 4 unless also divisible by 100, when they must be divisible
3240 * by 400 instead), we can simply calculate the number of days since some
3241 * arbitrary 'beginning of time' by futzing with the (adjusted) year number,
3242 * the days we derive from our month index, and adding in the day of the
3243 * month. The value used here is not adjusted for the actual origin which
3244 * it normally would use (1 January A.D. 1), since we're not exposing it.
3245 * We're only building the value so we can turn around and get the
3246 * normalised values for the year, month, day-of-month, and day-of-year.
3248 * For going backward, we need to bias the value we're using so that we find
3249 * the right year value. (Basically, we don't want the contribution of
3250 * March 1st to the number to apply while deriving the year). Having done
3251 * that, we 'count up' the contribution to the year number by accounting for
3252 * full quadracenturies (400-year periods) with their extra leap days, plus
3253 * the contribution from full centuries (to avoid counting in the lost leap
3254 * days), plus the contribution from full quad-years (to count in the normal
3255 * leap days), plus the leftover contribution from any non-leap years.
3256 * At this point, if we were working with an actual leap day, we'll have 0
3257 * days left over. This is also true for March 1st, however. So, we have
3258 * to special-case that result, and (earlier) keep track of the 'odd'
3259 * century and year contributions. If we got 4 extra centuries in a qcent,
3260 * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb.
3261 * Otherwise, we add back in the earlier bias we removed (the 123 from
3262 * figuring in March 1st), find the month index (integer division by 30.6),
3263 * and the remainder is the day-of-month. We then have to convert back to
3264 * 'real' months (including fixing January and February from being 14/15 in
3265 * the previous year to being in the proper year). After that, to get
3266 * tm_yday, we work with the normalised year and get a new yearday value for
3267 * January 1st, which we subtract from the yearday value we had earlier,
3268 * representing the date we've re-built. This is done from January 1
3269 * because tm_yday is 0-origin.
3271 * Since POSIX time routines are only guaranteed to work for times since the
3272 * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm
3273 * applies Gregorian calendar rules even to dates before the 16th century
3274 * doesn't bother me. Besides, you'd need cultural context for a given
3275 * date to know whether it was Julian or Gregorian calendar, and that's
3276 * outside the scope for this routine. Since we convert back based on the
3277 * same rules we used to build the yearday, you'll only get strange results
3278 * for input which needed normalising, or for the 'odd' century years which
3279 * were leap years in the Julian calander but not in the Gregorian one.
3280 * I can live with that.
3282 * This algorithm also fails to handle years before A.D. 1 gracefully, but
3283 * that's still outside the scope for POSIX time manipulation, so I don't
3287 year = 1900 + ptm->tm_year;
3288 month = ptm->tm_mon;
3289 mday = ptm->tm_mday;
3290 /* allow given yday with no month & mday to dominate the result */
3291 if (ptm->tm_yday >= 0 && mday <= 0 && month <= 0) {
3294 jday = 1 + ptm->tm_yday;
3303 yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400;
3304 yearday += month*MONTH_TO_DAYS + mday + jday;
3306 * Note that we don't know when leap-seconds were or will be,
3307 * so we have to trust the user if we get something which looks
3308 * like a sensible leap-second. Wild values for seconds will
3309 * be rationalised, however.
3311 if ((unsigned) ptm->tm_sec <= 60) {
3318 secs += 60 * ptm->tm_min;
3319 secs += SECS_PER_HOUR * ptm->tm_hour;
3321 if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) {
3322 /* got negative remainder, but need positive time */
3323 /* back off an extra day to compensate */
3324 yearday += (secs/SECS_PER_DAY)-1;
3325 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1);
3328 yearday += (secs/SECS_PER_DAY);
3329 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY);
3332 else if (secs >= SECS_PER_DAY) {
3333 yearday += (secs/SECS_PER_DAY);
3334 secs %= SECS_PER_DAY;
3336 ptm->tm_hour = secs/SECS_PER_HOUR;
3337 secs %= SECS_PER_HOUR;
3338 ptm->tm_min = secs/60;
3340 ptm->tm_sec += secs;
3341 /* done with time of day effects */
3343 * The algorithm for yearday has (so far) left it high by 428.
3344 * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to
3345 * bias it by 123 while trying to figure out what year it
3346 * really represents. Even with this tweak, the reverse
3347 * translation fails for years before A.D. 0001.
3348 * It would still fail for Feb 29, but we catch that one below.
3350 jday = yearday; /* save for later fixup vis-a-vis Jan 1 */
3351 yearday -= YEAR_ADJUST;
3352 year = (yearday / DAYS_PER_QCENT) * 400;
3353 yearday %= DAYS_PER_QCENT;
3354 odd_cent = yearday / DAYS_PER_CENT;
3355 year += odd_cent * 100;
3356 yearday %= DAYS_PER_CENT;
3357 year += (yearday / DAYS_PER_QYEAR) * 4;
3358 yearday %= DAYS_PER_QYEAR;
3359 odd_year = yearday / DAYS_PER_YEAR;
3361 yearday %= DAYS_PER_YEAR;
3362 if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */
3367 yearday += YEAR_ADJUST; /* recover March 1st crock */
3368 month = yearday*DAYS_TO_MONTH;
3369 yearday -= month*MONTH_TO_DAYS;
3370 /* recover other leap-year adjustment */
3379 ptm->tm_year = year - 1900;
3381 ptm->tm_mday = yearday;
3382 ptm->tm_mon = month;
3386 ptm->tm_mon = month - 1;
3388 /* re-build yearday based on Jan 1 to get tm_yday */
3390 yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400;
3391 yearday += 14*MONTH_TO_DAYS + 1;
3392 ptm->tm_yday = jday - yearday;
3393 /* fix tm_wday if not overridden by caller */
3394 if ((unsigned)ptm->tm_wday > 6)
3395 ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
3399 Perl_my_strftime(pTHX_ char *fmt, int sec, int min, int hour, int mday, int mon, int year, int wday, int yday, int isdst)
3407 init_tm(&mytm); /* XXX workaround - see init_tm() above */
3410 mytm.tm_hour = hour;
3411 mytm.tm_mday = mday;
3413 mytm.tm_year = year;
3414 mytm.tm_wday = wday;
3415 mytm.tm_yday = yday;
3416 mytm.tm_isdst = isdst;
3418 /* use libc to get the values for tm_gmtoff and tm_zone [perl #18238] */
3419 #if defined(HAS_MKTIME) && (defined(HAS_TM_TM_GMTOFF) || defined(HAS_TM_TM_ZONE))
3424 #ifdef HAS_TM_TM_GMTOFF
3425 mytm.tm_gmtoff = mytm2.tm_gmtoff;
3427 #ifdef HAS_TM_TM_ZONE
3428 mytm.tm_zone = mytm2.tm_zone;
3433 New(0, buf, buflen, char);
3434 len = strftime(buf, buflen, fmt, &mytm);
3436 ** The following is needed to handle to the situation where
3437 ** tmpbuf overflows. Basically we want to allocate a buffer
3438 ** and try repeatedly. The reason why it is so complicated
3439 ** is that getting a return value of 0 from strftime can indicate
3440 ** one of the following:
3441 ** 1. buffer overflowed,
3442 ** 2. illegal conversion specifier, or
3443 ** 3. the format string specifies nothing to be returned(not
3444 ** an error). This could be because format is an empty string
3445 ** or it specifies %p that yields an empty string in some locale.
3446 ** If there is a better way to make it portable, go ahead by
3449 if ((len > 0 && len < buflen) || (len == 0 && *fmt == '\0'))
3452 /* Possibly buf overflowed - try again with a bigger buf */
3453 int fmtlen = strlen(fmt);
3454 int bufsize = fmtlen + buflen;
3456 New(0, buf, bufsize, char);
3458 buflen = strftime(buf, bufsize, fmt, &mytm);
3459 if (buflen > 0 && buflen < bufsize)
3461 /* heuristic to prevent out-of-memory errors */
3462 if (bufsize > 100*fmtlen) {
3468 Renew(buf, bufsize, char);
3473 Perl_croak(aTHX_ "panic: no strftime");
3478 #define SV_CWD_RETURN_UNDEF \
3479 sv_setsv(sv, &PL_sv_undef); \
3482 #define SV_CWD_ISDOT(dp) \
3483 (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
3484 (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
3487 =head1 Miscellaneous Functions
3489 =for apidoc getcwd_sv
3491 Fill the sv with current working directory
3496 /* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars.
3497 * rewritten again by dougm, optimized for use with xs TARG, and to prefer
3498 * getcwd(3) if available
3499 * Comments from the orignal:
3500 * This is a faster version of getcwd. It's also more dangerous
3501 * because you might chdir out of a directory that you can't chdir
3505 Perl_getcwd_sv(pTHX_ register SV *sv)
3509 #ifndef INCOMPLETE_TAINTS
3515 char buf[MAXPATHLEN];
3517 /* Some getcwd()s automatically allocate a buffer of the given
3518 * size from the heap if they are given a NULL buffer pointer.
3519 * The problem is that this behaviour is not portable. */
3520 if (getcwd(buf, sizeof(buf) - 1)) {
3521 STRLEN len = strlen(buf);
3522 sv_setpvn(sv, buf, len);
3526 sv_setsv(sv, &PL_sv_undef);
3534 int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
3535 int namelen, pathlen=0;
3539 (void)SvUPGRADE(sv, SVt_PV);
3541 if (PerlLIO_lstat(".", &statbuf) < 0) {
3542 SV_CWD_RETURN_UNDEF;
3545 orig_cdev = statbuf.st_dev;
3546 orig_cino = statbuf.st_ino;
3554 if (PerlDir_chdir("..") < 0) {
3555 SV_CWD_RETURN_UNDEF;
3557 if (PerlLIO_stat(".", &statbuf) < 0) {
3558 SV_CWD_RETURN_UNDEF;
3561 cdev = statbuf.st_dev;
3562 cino = statbuf.st_ino;
3564 if (odev == cdev && oino == cino) {
3567 if (!(dir = PerlDir_open("."))) {
3568 SV_CWD_RETURN_UNDEF;
3571 while ((dp = PerlDir_read(dir)) != NULL) {
3573 namelen = dp->d_namlen;
3575 namelen = strlen(dp->d_name);
3578 if (SV_CWD_ISDOT(dp)) {
3582 if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
3583 SV_CWD_RETURN_UNDEF;
3586 tdev = statbuf.st_dev;
3587 tino = statbuf.st_ino;
3588 if (tino == oino && tdev == odev) {
3594 SV_CWD_RETURN_UNDEF;
3597 if (pathlen + namelen + 1 >= MAXPATHLEN) {
3598 SV_CWD_RETURN_UNDEF;
3601 SvGROW(sv, pathlen + namelen + 1);
3605 Move(SvPVX(sv), SvPVX(sv) + namelen + 1, pathlen, char);
3608 /* prepend current directory to the front */
3610 Move(dp->d_name, SvPVX(sv)+1, namelen, char);
3611 pathlen += (namelen + 1);
3613 #ifdef VOID_CLOSEDIR
3616 if (PerlDir_close(dir) < 0) {
3617 SV_CWD_RETURN_UNDEF;
3623 SvCUR_set(sv, pathlen);
3627 if (PerlDir_chdir(SvPVX(sv)) < 0) {
3628 SV_CWD_RETURN_UNDEF;
3631 if (PerlLIO_stat(".", &statbuf) < 0) {
3632 SV_CWD_RETURN_UNDEF;
3635 cdev = statbuf.st_dev;
3636 cino = statbuf.st_ino;
3638 if (cdev != orig_cdev || cino != orig_cino) {
3639 Perl_croak(aTHX_ "Unstable directory path, "
3640 "current directory changed unexpectedly");
3652 =for apidoc scan_version
3654 Returns a pointer to the next character after the parsed
3655 version string, as well as upgrading the passed in SV to
3658 Function must be called with an already existing SV like
3661 s = scan_version(s,sv);
3663 Performs some preprocessing to the string to ensure that
3664 it has the correct characteristics of a version. Flags the
3665 object if it contains an underscore (which denotes this
3672 Perl_scan_version(pTHX_ char *s, SV *rv)
3674 const char *start = s;
3678 SV* sv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
3679 (void)sv_upgrade(sv, SVt_PVAV); /* needs to be an AV type */
3681 /* pre-scan the imput string to check for decimals */
3682 while ( *pos == '.' || *pos == '_' || isDIGIT(*pos) )
3687 Perl_croak(aTHX_ "Invalid version format (underscores before decimal)");
3690 else if ( *pos == '_' )
3693 Perl_croak(aTHX_ "Invalid version format (multiple underscores)");
3700 if (*pos == 'v') pos++; /* get past 'v' */
3701 while (isDIGIT(*pos))
3703 if (!isALPHA(*pos)) {
3706 if (*s == 'v') s++; /* get past 'v' */
3711 /* this is atoi() that delimits on underscores */
3715 if ( s < pos && s > start && *(s-1) == '_' ) {
3716 mult *= -1; /* beta version */
3718 /* the following if() will only be true after the decimal
3719 * point of a version originally created with a bare
3720 * floating point number, i.e. not quoted in any way
3722 if ( s > start+1 && saw_period == 1 && !saw_under ) {
3726 rev += (*s - '0') * mult;
3728 if ( PERL_ABS(orev) > PERL_ABS(rev) )
3729 Perl_croak(aTHX_ "Integer overflow in version");
3734 while (--end >= s) {
3736 rev += (*end - '0') * mult;
3738 if ( PERL_ABS(orev) > PERL_ABS(rev) )
3739 Perl_croak(aTHX_ "Integer overflow in version");
3744 /* Append revision */
3745 av_push((AV *)sv, newSViv(rev));
3746 if ( (*pos == '.' || *pos == '_') && isDIGIT(pos[1]))
3748 else if ( isDIGIT(*pos) )
3754 while ( isDIGIT(*pos) ) {
3755 if ( !saw_under && saw_period == 1 && pos-s == 3 )
3765 =for apidoc new_version
3767 Returns a new version object based on the passed in SV:
3769 SV *sv = new_version(SV *ver);
3771 Does not alter the passed in ver SV. See "upg_version" if you
3772 want to upgrade the SV.
3778 Perl_new_version(pTHX_ SV *ver)
3782 if ( SvNOK(ver) ) /* may get too much accuracy */
3785 sprintf(tbuf,"%.9"NVgf, SvNVX(ver));
3786 version = savepv(tbuf);
3789 else if ( SvVOK(ver) ) { /* already a v-string */
3790 MAGIC* mg = mg_find(ver,PERL_MAGIC_vstring);
3791 version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
3794 else /* must be a string or something like a string */
3796 version = (char *)SvPV(ver,PL_na);
3798 version = scan_version(version,rv);
3803 =for apidoc upg_version
3805 In-place upgrade of the supplied SV to a version object.
3807 SV *sv = upg_version(SV *sv);
3809 Returns a pointer to the upgraded SV.
3815 Perl_upg_version(pTHX_ SV *ver)
3817 char *version = savepvn(SvPVX(ver),SvCUR(ver));
3819 if ( SvVOK(ver) ) { /* already a v-string */
3820 MAGIC* mg = mg_find(ver,PERL_MAGIC_vstring);
3821 version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
3824 version = scan_version(version,ver);
3832 Accepts a version object and returns the normalized floating
3833 point representation. Call like:
3837 NOTE: you can pass either the object directly or the SV
3838 contained within the RV.
3844 Perl_vnumify(pTHX_ SV *vs)
3847 SV *sv = NEWSV(92,0);
3850 len = av_len((AV *)vs);
3853 Perl_sv_catpv(aTHX_ sv,"0");
3856 digit = SvIVX(*av_fetch((AV *)vs, 0, 0));
3857 Perl_sv_setpvf(aTHX_ sv,"%d.", PERL_ABS(digit));
3858 for ( i = 1 ; i <= len ; i++ )
3860 digit = SvIVX(*av_fetch((AV *)vs, i, 0));
3861 Perl_sv_catpvf(aTHX_ sv,"%03d", PERL_ABS(digit));
3864 Perl_sv_catpv(aTHX_ sv,"000");
3865 sv_setnv(sv, SvNV(sv));
3870 =for apidoc vstringify
3872 Accepts a version object and returns the normalized string
3873 representation. Call like:
3875 sv = vstringify(rv);
3877 NOTE: you can pass either the object directly or the SV
3878 contained within the RV.
3884 Perl_vstringify(pTHX_ SV *vs)
3887 SV *sv = NEWSV(92,0);
3890 len = av_len((AV *)vs);
3893 Perl_sv_catpv(aTHX_ sv,"");
3896 digit = SvIVX(*av_fetch((AV *)vs, 0, 0));
3897 Perl_sv_setpvf(aTHX_ sv,"%"IVdf,(IV)digit);
3898 for ( i = 1 ; i <= len ; i++ )
3900 digit = SvIVX(*av_fetch((AV *)vs, i, 0));
3902 Perl_sv_catpvf(aTHX_ sv,"_%"IVdf,(IV)-digit);
3904 Perl_sv_catpvf(aTHX_ sv,".%"IVdf,(IV)digit);
3907 Perl_sv_catpv(aTHX_ sv,".0");
3914 Version object aware cmp. Both operands must already have been
3915 converted into version objects.
3921 Perl_vcmp(pTHX_ SV *lsv, SV *rsv)
3928 l = av_len((AV *)lsv);
3929 r = av_len((AV *)rsv);
3933 while ( i <= m && retval == 0 )
3935 I32 left = SvIV(*av_fetch((AV *)lsv,i,0));
3936 I32 right = SvIV(*av_fetch((AV *)rsv,i,0));
3937 bool lbeta = left < 0 ? 1 : 0;
3938 bool rbeta = right < 0 ? 1 : 0;
3939 left = PERL_ABS(left);
3940 right = PERL_ABS(right);
3941 if ( left < right || (left == right && lbeta && !rbeta) )
3943 if ( left > right || (left == right && rbeta && !lbeta) )
3948 if ( l != r && retval == 0 ) /* possible match except for trailing 0 */
3950 if ( !( l < r && r-l == 1 && SvIV(*av_fetch((AV *)rsv,r,0)) == 0 ) &&
3951 !( l-r == 1 && SvIV(*av_fetch((AV *)lsv,l,0)) == 0 ) )
3953 retval = l < r ? -1 : +1; /* not a match after all */
3959 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT)
3960 # define EMULATE_SOCKETPAIR_UDP
3963 #ifdef EMULATE_SOCKETPAIR_UDP
3965 S_socketpair_udp (int fd[2]) {
3967 /* Fake a datagram socketpair using UDP to localhost. */
3968 int sockets[2] = {-1, -1};
3969 struct sockaddr_in addresses[2];
3971 Sock_size_t size = sizeof(struct sockaddr_in);
3972 unsigned short port;
3975 memset(&addresses, 0, sizeof(addresses));
3978 sockets[i] = PerlSock_socket(AF_INET, SOCK_DGRAM, PF_INET);
3979 if (sockets[i] == -1)
3980 goto tidy_up_and_fail;
3982 addresses[i].sin_family = AF_INET;
3983 addresses[i].sin_addr.s_addr = htonl(INADDR_LOOPBACK);
3984 addresses[i].sin_port = 0; /* kernel choses port. */
3985 if (PerlSock_bind(sockets[i], (struct sockaddr *) &addresses[i],
3986 sizeof(struct sockaddr_in)) == -1)
3987 goto tidy_up_and_fail;
3990 /* Now have 2 UDP sockets. Find out which port each is connected to, and
3991 for each connect the other socket to it. */
3994 if (PerlSock_getsockname(sockets[i], (struct sockaddr *) &addresses[i],
3996 goto tidy_up_and_fail;
3997 if (size != sizeof(struct sockaddr_in))
3998 goto abort_tidy_up_and_fail;
3999 /* !1 is 0, !0 is 1 */
4000 if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i],
4001 sizeof(struct sockaddr_in)) == -1)
4002 goto tidy_up_and_fail;
4005 /* Now we have 2 sockets connected to each other. I don't trust some other
4006 process not to have already sent a packet to us (by random) so send
4007 a packet from each to the other. */
4010 /* I'm going to send my own port number. As a short.
4011 (Who knows if someone somewhere has sin_port as a bitfield and needs
4012 this routine. (I'm assuming crays have socketpair)) */
4013 port = addresses[i].sin_port;
4014 got = PerlLIO_write(sockets[i], &port, sizeof(port));
4015 if (got != sizeof(port)) {
4017 goto tidy_up_and_fail;
4018 goto abort_tidy_up_and_fail;
4022 /* Packets sent. I don't trust them to have arrived though.
4023 (As I understand it Solaris TCP stack is multithreaded. Non-blocking
4024 connect to localhost will use a second kernel thread. In 2.6 the
4025 first thread running the connect() returns before the second completes,
4026 so EINPROGRESS> In 2.7 the improved stack is faster and connect()
4027 returns 0. Poor programs have tripped up. One poor program's authors'
4028 had a 50-1 reverse stock split. Not sure how connected these were.)
4029 So I don't trust someone not to have an unpredictable UDP stack.
4033 struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */
4034 int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0];
4038 FD_SET(sockets[0], &rset);
4039 FD_SET(sockets[1], &rset);
4041 got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor);
4042 if (got != 2 || !FD_ISSET(sockets[0], &rset)
4043 || !FD_ISSET(sockets[1], &rset)) {
4044 /* I hope this is portable and appropriate. */
4046 goto tidy_up_and_fail;
4047 goto abort_tidy_up_and_fail;
4051 /* And the paranoia department even now doesn't trust it to have arrive
4052 (hence MSG_DONTWAIT). Or that what arrives was sent by us. */
4054 struct sockaddr_in readfrom;
4055 unsigned short buffer[2];
4060 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4061 sizeof(buffer), MSG_DONTWAIT,
4062 (struct sockaddr *) &readfrom, &size);
4064 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4066 (struct sockaddr *) &readfrom, &size);
4070 goto tidy_up_and_fail;
4071 if (got != sizeof(port)
4072 || size != sizeof(struct sockaddr_in)
4073 /* Check other socket sent us its port. */
4074 || buffer[0] != (unsigned short) addresses[!i].sin_port
4075 /* Check kernel says we got the datagram from that socket */
4076 || readfrom.sin_family != addresses[!i].sin_family
4077 || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr
4078 || readfrom.sin_port != addresses[!i].sin_port)
4079 goto abort_tidy_up_and_fail;
4082 /* My caller (my_socketpair) has validated that this is non-NULL */
4085 /* I hereby declare this connection open. May God bless all who cross
4089 abort_tidy_up_and_fail:
4090 errno = ECONNABORTED;
4093 int save_errno = errno;
4094 if (sockets[0] != -1)
4095 PerlLIO_close(sockets[0]);
4096 if (sockets[1] != -1)
4097 PerlLIO_close(sockets[1]);
4102 #endif /* EMULATE_SOCKETPAIR_UDP */
4104 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET)
4106 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4107 /* Stevens says that family must be AF_LOCAL, protocol 0.
4108 I'm going to enforce that, then ignore it, and use TCP (or UDP). */
4113 struct sockaddr_in listen_addr;
4114 struct sockaddr_in connect_addr;
4119 || family != AF_UNIX
4122 errno = EAFNOSUPPORT;
4130 #ifdef EMULATE_SOCKETPAIR_UDP
4131 if (type == SOCK_DGRAM)
4132 return S_socketpair_udp(fd);
4135 listener = PerlSock_socket(AF_INET, type, 0);
4138 memset(&listen_addr, 0, sizeof(listen_addr));
4139 listen_addr.sin_family = AF_INET;
4140 listen_addr.sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4141 listen_addr.sin_port = 0; /* kernel choses port. */
4142 if (PerlSock_bind(listener, (struct sockaddr *) &listen_addr,
4143 sizeof(listen_addr)) == -1)
4144 goto tidy_up_and_fail;
4145 if (PerlSock_listen(listener, 1) == -1)
4146 goto tidy_up_and_fail;
4148 connector = PerlSock_socket(AF_INET, type, 0);
4149 if (connector == -1)
4150 goto tidy_up_and_fail;
4151 /* We want to find out the port number to connect to. */
4152 size = sizeof(connect_addr);
4153 if (PerlSock_getsockname(listener, (struct sockaddr *) &connect_addr,
4155 goto tidy_up_and_fail;
4156 if (size != sizeof(connect_addr))
4157 goto abort_tidy_up_and_fail;
4158 if (PerlSock_connect(connector, (struct sockaddr *) &connect_addr,
4159 sizeof(connect_addr)) == -1)
4160 goto tidy_up_and_fail;
4162 size = sizeof(listen_addr);
4163 acceptor = PerlSock_accept(listener, (struct sockaddr *) &listen_addr,
4166 goto tidy_up_and_fail;
4167 if (size != sizeof(listen_addr))
4168 goto abort_tidy_up_and_fail;
4169 PerlLIO_close(listener);
4170 /* Now check we are talking to ourself by matching port and host on the
4172 if (PerlSock_getsockname(connector, (struct sockaddr *) &connect_addr,
4174 goto tidy_up_and_fail;
4175 if (size != sizeof(connect_addr)
4176 || listen_addr.sin_family != connect_addr.sin_family
4177 || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr
4178 || listen_addr.sin_port != connect_addr.sin_port) {
4179 goto abort_tidy_up_and_fail;
4185 abort_tidy_up_and_fail:
4186 errno = ECONNABORTED; /* I hope this is portable and appropriate. */
4189 int save_errno = errno;
4191 PerlLIO_close(listener);
4192 if (connector != -1)
4193 PerlLIO_close(connector);
4195 PerlLIO_close(acceptor);
4201 /* In any case have a stub so that there's code corresponding
4202 * to the my_socketpair in global.sym. */
4204 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4205 #ifdef HAS_SOCKETPAIR
4206 return socketpair(family, type, protocol, fd);
4215 =for apidoc sv_nosharing
4217 Dummy routine which "shares" an SV when there is no sharing module present.
4218 Exists to avoid test for a NULL function pointer and because it could potentially warn under
4219 some level of strict-ness.
4225 Perl_sv_nosharing(pTHX_ SV *sv)
4230 =for apidoc sv_nolocking
4232 Dummy routine which "locks" an SV when there is no locking module present.
4233 Exists to avoid test for a NULL function pointer and because it could potentially warn under
4234 some level of strict-ness.
4240 Perl_sv_nolocking(pTHX_ SV *sv)
4246 =for apidoc sv_nounlocking
4248 Dummy routine which "unlocks" an SV when there is no locking module present.
4249 Exists to avoid test for a NULL function pointer and because it could potentially warn under
4250 some level of strict-ness.
4256 Perl_sv_nounlocking(pTHX_ SV *sv)
4261 Perl_parse_unicode_opts(pTHX_ char **popt)
4268 opt = (U32) atoi(p);
4269 while (isDIGIT(*p)) p++;
4270 if (*p && *p != '\n' && *p != '\r')
4271 Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
4276 case PERL_UNICODE_STDIN:
4277 opt |= PERL_UNICODE_STDIN_FLAG; break;
4278 case PERL_UNICODE_STDOUT:
4279 opt |= PERL_UNICODE_STDOUT_FLAG; break;
4280 case PERL_UNICODE_STDERR:
4281 opt |= PERL_UNICODE_STDERR_FLAG; break;
4282 case PERL_UNICODE_STD:
4283 opt |= PERL_UNICODE_STD_FLAG; break;
4284 case PERL_UNICODE_IN:
4285 opt |= PERL_UNICODE_IN_FLAG; break;
4286 case PERL_UNICODE_OUT:
4287 opt |= PERL_UNICODE_OUT_FLAG; break;
4288 case PERL_UNICODE_INOUT:
4289 opt |= PERL_UNICODE_INOUT_FLAG; break;
4290 case PERL_UNICODE_LOCALE:
4291 opt |= PERL_UNICODE_LOCALE_FLAG; break;
4292 case PERL_UNICODE_ARGV:
4293 opt |= PERL_UNICODE_ARGV_FLAG; break;
4295 if (*p != '\n' && *p != '\r')
4297 "Unknown Unicode option letter '%c'", *p);
4303 opt = PERL_UNICODE_DEFAULT_FLAGS;
4305 if (opt & ~PERL_UNICODE_ALL_FLAGS)
4306 Perl_croak(aTHX_ "Unknown Unicode option value %"UVuf,
4307 (UV) (opt & ~PERL_UNICODE_ALL_FLAGS));
4318 * This is really just a quick hack which grabs various garbage
4319 * values. It really should be a real hash algorithm which
4320 * spreads the effect of every input bit onto every output bit,
4321 * if someone who knows about such things would bother to write it.
4322 * Might be a good idea to add that function to CORE as well.
4323 * No numbers below come from careful analysis or anything here,
4324 * except they are primes and SEED_C1 > 1E6 to get a full-width
4325 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
4326 * probably be bigger too.
4329 # define SEED_C1 1000003
4330 #define SEED_C4 73819
4332 # define SEED_C1 25747
4333 #define SEED_C4 20639
4337 #define SEED_C5 26107
4339 #ifndef PERL_NO_DEV_RANDOM
4344 # include <starlet.h>
4345 /* when[] = (low 32 bits, high 32 bits) of time since epoch
4346 * in 100-ns units, typically incremented ever 10 ms. */
4347 unsigned int when[2];
4349 # ifdef HAS_GETTIMEOFDAY
4350 struct timeval when;
4356 /* This test is an escape hatch, this symbol isn't set by Configure. */
4357 #ifndef PERL_NO_DEV_RANDOM
4358 #ifndef PERL_RANDOM_DEVICE
4359 /* /dev/random isn't used by default because reads from it will block
4360 * if there isn't enough entropy available. You can compile with
4361 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
4362 * is enough real entropy to fill the seed. */
4363 # define PERL_RANDOM_DEVICE "/dev/urandom"
4365 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
4367 if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
4376 _ckvmssts(sys$gettim(when));
4377 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
4379 # ifdef HAS_GETTIMEOFDAY
4380 PerlProc_gettimeofday(&when,NULL);
4381 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
4384 u = (U32)SEED_C1 * when;
4387 u += SEED_C3 * (U32)PerlProc_getpid();
4388 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
4389 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
4390 u += SEED_C5 * (U32)PTR2UV(&when);
4396 Perl_get_hash_seed(pTHX)
4398 char *s = PerlEnv_getenv("PERL_HASH_SEED");
4402 while (isSPACE(*s)) s++;
4403 if (s && isDIGIT(*s))
4404 myseed = (UV)Atoul(s);
4406 #ifdef USE_HASH_SEED_EXPLICIT
4410 /* Compute a random seed */
4411 (void)seedDrand01((Rand_seed_t)seed());
4412 myseed = (UV)(Drand01() * (NV)UV_MAX);
4413 #if RANDBITS < (UVSIZE * 8)
4414 /* Since there are not enough randbits to to reach all
4415 * the bits of a UV, the low bits might need extra
4416 * help. Sum in another random number that will
4417 * fill in the low bits. */
4419 (UV)(Drand01() * (NV)((1 << ((UVSIZE * 8 - RANDBITS))) - 1));
4420 #endif /* RANDBITS < (UVSIZE * 8) */
4421 if (myseed == 0) { /* Superparanoia. */
4422 myseed = (UV)(Drand01() * (NV)UV_MAX); /* One more chance. */
4424 Perl_croak(aTHX_ "Your random numbers are not that random");
4427 PL_rehash_seed_set = TRUE;