3 * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * "Very useful, no doubt, that was to Saruman; yet it seems that he was
13 * not content." --Gandalf
16 /* This file contains assorted utility routines.
17 * Which is a polite way of saying any stuff that people couldn't think of
18 * a better place for. Amongst other things, it includes the warning and
19 * dieing stuff, plus wrappers for malloc code.
23 #define PERL_IN_UTIL_C
29 # define SIG_ERR ((Sighandler_t) -1)
34 /* Missing protos on LynxOS */
39 # include <sys/wait.h>
44 # include <sys/select.h>
50 #if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC)
51 # define FD_CLOEXEC 1 /* NeXT needs this */
54 /* NOTE: Do not call the next three routines directly. Use the macros
55 * in handy.h, so that we can easily redefine everything to do tracking of
56 * allocated hunks back to the original New to track down any memory leaks.
57 * XXX This advice seems to be widely ignored :-( --AD August 1996.
63 /* Can't use PerlIO to write as it allocates memory */
64 PerlLIO_write(PerlIO_fileno(Perl_error_log),
65 PL_no_mem, strlen(PL_no_mem));
70 /* paranoid version of system's malloc() */
73 Perl_safesysmalloc(MEM_SIZE size)
79 PerlIO_printf(Perl_error_log,
80 "Allocation too large: %lx\n", size) FLUSH;
83 #endif /* HAS_64K_LIMIT */
86 Perl_croak_nocontext("panic: malloc");
88 ptr = (Malloc_t)PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */
89 PERL_ALLOC_CHECK(ptr);
90 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
96 return S_write_no_mem(aTHX);
101 /* paranoid version of system's realloc() */
104 Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
108 #if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) && !defined(PERL_MICRO)
109 Malloc_t PerlMem_realloc();
110 #endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */
114 PerlIO_printf(Perl_error_log,
115 "Reallocation too large: %lx\n", size) FLUSH;
118 #endif /* HAS_64K_LIMIT */
125 return safesysmalloc(size);
128 Perl_croak_nocontext("panic: realloc");
130 ptr = (Malloc_t)PerlMem_realloc(where,size);
131 PERL_ALLOC_CHECK(ptr);
133 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++));
134 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
141 return S_write_no_mem(aTHX);
146 /* safe version of system's free() */
149 Perl_safesysfree(Malloc_t where)
152 #ifdef PERL_IMPLICIT_SYS
155 DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) free\n",PTR2UV(where),(long)PL_an++));
161 /* safe version of system's calloc() */
164 Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
170 if (size * count > 0xffff) {
171 PerlIO_printf(Perl_error_log,
172 "Allocation too large: %lx\n", size * count) FLUSH;
175 #endif /* HAS_64K_LIMIT */
177 if ((long)size < 0 || (long)count < 0)
178 Perl_croak_nocontext("panic: calloc");
181 ptr = (Malloc_t)PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */
182 PERL_ALLOC_CHECK(ptr);
183 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));
185 memset((void*)ptr, 0, size);
191 return S_write_no_mem(aTHX);
196 /* These must be defined when not using Perl's malloc for binary
201 Malloc_t Perl_malloc (MEM_SIZE nbytes)
204 return (Malloc_t)PerlMem_malloc(nbytes);
207 Malloc_t Perl_calloc (MEM_SIZE elements, MEM_SIZE size)
210 return (Malloc_t)PerlMem_calloc(elements, size);
213 Malloc_t Perl_realloc (Malloc_t where, MEM_SIZE nbytes)
216 return (Malloc_t)PerlMem_realloc(where, nbytes);
219 Free_t Perl_mfree (Malloc_t where)
227 /* copy a string up to some (non-backslashed) delimiter, if any */
230 Perl_delimcpy(pTHX_ register char *to, register const char *toend, register const char *from, register const char *fromend, register int delim, I32 *retlen)
233 for (tolen = 0; from < fromend; from++, tolen++) {
235 if (from[1] == delim)
244 else if (*from == delim)
255 /* return ptr to little string in big string, NULL if not found */
256 /* This routine was donated by Corey Satten. */
259 Perl_instr(pTHX_ register const char *big, register const char *little)
269 register const char *s, *x;
272 for (x=big,s=little; *s; /**/ ) {
281 return (char*)(big-1);
286 /* same as instr but allow embedded nulls */
289 Perl_ninstr(pTHX_ register const char *big, register const char *bigend, const char *little, const char *lend)
291 register const I32 first = *little;
292 register const char * const littleend = lend;
294 if (!first && little >= littleend)
296 if (bigend - big < littleend - little)
298 bigend -= littleend - little++;
299 while (big <= bigend) {
300 register const char *s, *x;
303 for (x=big,s=little; s < littleend; /**/ ) {
310 return (char*)(big-1);
315 /* reverse of the above--find last substring */
318 Perl_rninstr(pTHX_ register const char *big, const char *bigend, const char *little, const char *lend)
320 register const char *bigbeg;
321 register const I32 first = *little;
322 register const char * const littleend = lend;
324 if (!first && little >= littleend)
325 return (char*)bigend;
327 big = bigend - (littleend - little++);
328 while (big >= bigbeg) {
329 register const char *s, *x;
332 for (x=big+2,s=little; s < littleend; /**/ ) {
339 return (char*)(big+1);
344 #define FBM_TABLE_OFFSET 2 /* Number of bytes between EOS and table*/
346 /* As a space optimization, we do not compile tables for strings of length
347 0 and 1, and for strings of length 2 unless FBMcf_TAIL. These are
348 special-cased in fbm_instr().
350 If FBMcf_TAIL, the table is created as if the string has a trailing \n. */
353 =head1 Miscellaneous Functions
355 =for apidoc fbm_compile
357 Analyses the string in order to make fast searches on it using fbm_instr()
358 -- the Boyer-Moore algorithm.
364 Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
366 register const U8 *s;
372 if (flags & FBMcf_TAIL) {
373 MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
374 sv_catpvn(sv, "\n", 1); /* Taken into account in fbm_instr() */
375 if (mg && mg->mg_len >= 0)
378 s = (U8*)SvPV_force_mutable(sv, len);
379 SvUPGRADE(sv, SVt_PVBM);
380 if (len == 0) /* TAIL might be on a zero-length string. */
383 const unsigned char *sb;
384 const U8 mlen = (len>255) ? 255 : (U8)len;
387 Sv_Grow(sv, len + 256 + FBM_TABLE_OFFSET);
388 table = (unsigned char*)(SvPVX_mutable(sv) + len + FBM_TABLE_OFFSET);
389 s = table - 1 - FBM_TABLE_OFFSET; /* last char */
390 memset((void*)table, mlen, 256);
391 table[-1] = (U8)flags;
393 sb = s - mlen + 1; /* first char (maybe) */
395 if (table[*s] == mlen)
400 sv_magic(sv, Nullsv, PERL_MAGIC_bm, Nullch, 0); /* deep magic */
403 s = (const unsigned char*)(SvPVX_const(sv)); /* deeper magic */
404 for (i = 0; i < len; i++) {
405 if (PL_freq[s[i]] < frequency) {
407 frequency = PL_freq[s[i]];
410 BmRARE(sv) = s[rarest];
411 BmPREVIOUS(sv) = (U16)rarest;
412 BmUSEFUL(sv) = 100; /* Initial value */
413 if (flags & FBMcf_TAIL)
415 DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %d\n",
416 BmRARE(sv),BmPREVIOUS(sv)));
419 /* If SvTAIL(littlestr), it has a fake '\n' at end. */
420 /* If SvTAIL is actually due to \Z or \z, this gives false positives
424 =for apidoc fbm_instr
426 Returns the location of the SV in the string delimited by C<str> and
427 C<strend>. It returns C<Nullch> if the string can't be found. The C<sv>
428 does not have to be fbm_compiled, but the search will not be as fast
435 Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *littlestr, U32 flags)
437 register unsigned char *s;
439 register const unsigned char *little
440 = (const unsigned char *)SvPV_const(littlestr,l);
441 register STRLEN littlelen = l;
442 register const 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 const unsigned char c1 = little[0];
489 const 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 * const 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 const unsigned char * const table = little + littlelen + FBM_TABLE_OFFSET;
571 register const unsigned char *oldlittle;
573 if (littlelen > (STRLEN)(bigend - big))
575 --littlelen; /* Last char found by table lookup */
578 little += littlelen; /* last char */
584 if ((tmp = table[*s])) {
585 if ((s += tmp) < bigend)
589 else { /* less expensive than calling strncmp() */
590 register unsigned char * const olds = s;
595 if (*--s == *--little)
597 s = olds + 1; /* here we pay the price for failure */
599 if (s < bigend) /* fake up continue to outer loop */
607 if ( s == bigend && (table[-1] & FBMcf_TAIL)
608 && memEQ((char *)(bigend - littlelen),
609 (char *)(oldlittle - littlelen), littlelen) )
610 return (char*)bigend - littlelen;
615 /* start_shift, end_shift are positive quantities which give offsets
616 of ends of some substring of bigstr.
617 If "last" we want the last occurrence.
618 old_posp is the way of communication between consequent calls if
619 the next call needs to find the .
620 The initial *old_posp should be -1.
622 Note that we take into account SvTAIL, so one can get extra
623 optimizations if _ALL flag is set.
626 /* If SvTAIL is actually due to \Z or \z, this gives false positives
627 if PL_multiline. In fact if !PL_multiline the authoritative answer
628 is not supported yet. */
631 Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last)
633 register const unsigned char *big;
635 register I32 previous;
637 register const unsigned char *little;
638 register I32 stop_pos;
639 register const unsigned char *littleend;
643 ? (pos = PL_screamfirst[BmRARE(littlestr)]) < 0
644 : (((pos = *old_posp), pos += PL_screamnext[pos]) == 0)) {
646 if ( BmRARE(littlestr) == '\n'
647 && BmPREVIOUS(littlestr) == SvCUR(littlestr) - 1) {
648 little = (const unsigned char *)(SvPVX_const(littlestr));
649 littleend = little + SvCUR(littlestr);
656 little = (const unsigned char *)(SvPVX_const(littlestr));
657 littleend = little + SvCUR(littlestr);
659 /* The value of pos we can start at: */
660 previous = BmPREVIOUS(littlestr);
661 big = (const unsigned char *)(SvPVX_const(bigstr));
662 /* The value of pos we can stop at: */
663 stop_pos = SvCUR(bigstr) - end_shift - (SvCUR(littlestr) - 1 - previous);
664 if (previous + start_shift > stop_pos) {
666 stop_pos does not include SvTAIL in the count, so this check is incorrect
667 (I think) - see [ID 20010618.006] and t/op/study.t. HVDS 2001/06/19
670 if (previous + start_shift == stop_pos + 1) /* A fake '\n'? */
675 while (pos < previous + start_shift) {
676 if (!(pos += PL_screamnext[pos]))
681 register const unsigned char *s, *x;
682 if (pos >= stop_pos) break;
683 if (big[pos] != first)
685 for (x=big+pos+1,s=little; s < littleend; /**/ ) {
691 if (s == littleend) {
693 if (!last) return (char *)(big+pos);
696 } while ( pos += PL_screamnext[pos] );
698 return (char *)(big+(*old_posp));
700 if (!SvTAIL(littlestr) || (end_shift > 0))
702 /* Ignore the trailing "\n". This code is not microoptimized */
703 big = (const unsigned char *)(SvPVX_const(bigstr) + SvCUR(bigstr));
704 stop_pos = littleend - little; /* Actual littlestr len */
709 && ((stop_pos == 1) ||
710 memEQ((char *)(big + 1), (char *)little, stop_pos - 1)))
716 Perl_ibcmp(pTHX_ const char *s1, const char *s2, register I32 len)
718 register const U8 *a = (const U8 *)s1;
719 register const U8 *b = (const U8 *)s2;
721 if (*a != *b && *a != PL_fold[*b])
729 Perl_ibcmp_locale(pTHX_ const char *s1, const char *s2, register I32 len)
732 register const U8 *a = (const U8 *)s1;
733 register const U8 *b = (const 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)
764 const STRLEN pvlen = strlen(pv)+1;
765 Newx(newaddr,pvlen,char);
766 return memcpy(newaddr,pv,pvlen);
771 /* same thing but with a known length */
776 Perl's version of what C<strndup()> would be if it existed. Returns a
777 pointer to a newly allocated string which is a duplicate of the first
778 C<len> bytes from C<pv>. The memory allocated for the new string can be
779 freed with the C<Safefree()> function.
785 Perl_savepvn(pTHX_ const char *pv, register I32 len)
787 register char *newaddr;
789 Newx(newaddr,len+1,char);
790 /* Give a meaning to NULL pointer mainly for the use in sv_magic() */
792 /* might not be null terminated */
794 return (char *) CopyD(pv,newaddr,len,char);
797 return (char *) ZeroD(newaddr,len+1,char);
802 =for apidoc savesharedpv
804 A version of C<savepv()> which allocates the duplicate string in memory
805 which is shared between threads.
810 Perl_savesharedpv(pTHX_ const char *pv)
812 register char *newaddr;
817 pvlen = strlen(pv)+1;
818 newaddr = (char*)PerlMemShared_malloc(pvlen);
820 return S_write_no_mem(aTHX);
822 return memcpy(newaddr,pv,pvlen);
828 A version of C<savepv()>/C<savepvn()> which gets the string to duplicate from
829 the passed in SV using C<SvPV()>
835 Perl_savesvpv(pTHX_ SV *sv)
838 const char * const pv = SvPV_const(sv, len);
839 register char *newaddr;
842 Newx(newaddr,len,char);
843 return (char *) CopyD(pv,newaddr,len,char);
847 /* the SV for Perl_form() and mess() is not kept in an arena */
856 return sv_2mortal(newSVpvn("",0));
861 /* Create as PVMG now, to avoid any upgrading later */
863 Newxz(any, 1, XPVMG);
864 SvFLAGS(sv) = SVt_PVMG;
865 SvANY(sv) = (void*)any;
867 SvREFCNT(sv) = 1 << 30; /* practically infinite */
872 #if defined(PERL_IMPLICIT_CONTEXT)
874 Perl_form_nocontext(const char* pat, ...)
880 retval = vform(pat, &args);
884 #endif /* PERL_IMPLICIT_CONTEXT */
887 =head1 Miscellaneous Functions
890 Takes a sprintf-style format pattern and conventional
891 (non-SV) arguments and returns the formatted string.
893 (char *) Perl_form(pTHX_ const char* pat, ...)
895 can be used any place a string (char *) is required:
897 char * s = Perl_form("%d.%d",major,minor);
899 Uses a single private buffer so if you want to format several strings you
900 must explicitly copy the earlier strings away (and free the copies when you
907 Perl_form(pTHX_ const char* pat, ...)
912 retval = vform(pat, &args);
918 Perl_vform(pTHX_ const char *pat, va_list *args)
920 SV * const sv = mess_alloc();
921 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
925 #if defined(PERL_IMPLICIT_CONTEXT)
927 Perl_mess_nocontext(const char *pat, ...)
933 retval = vmess(pat, &args);
937 #endif /* PERL_IMPLICIT_CONTEXT */
940 Perl_mess(pTHX_ const char *pat, ...)
945 retval = vmess(pat, &args);
951 S_closest_cop(pTHX_ COP *cop, const OP *o)
953 /* Look for PL_op starting from o. cop is the last COP we've seen. */
955 if (!o || o == PL_op) return cop;
957 if (o->op_flags & OPf_KIDS) {
959 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
963 /* If the OP_NEXTSTATE has been optimised away we can still use it
964 * the get the file and line number. */
966 if (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE)
969 /* Keep searching, and return when we've found something. */
971 new_cop = closest_cop(cop, kid);
972 if (new_cop) return new_cop;
982 Perl_vmess(pTHX_ const char *pat, va_list *args)
984 SV * const sv = mess_alloc();
985 static const char dgd[] = " during global destruction.\n";
987 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
988 if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
991 * Try and find the file and line for PL_op. This will usually be
992 * PL_curcop, but it might be a cop that has been optimised away. We
993 * can try to find such a cop by searching through the optree starting
994 * from the sibling of PL_curcop.
997 const COP *cop = closest_cop(PL_curcop, PL_curcop->op_sibling);
998 if (!cop) cop = PL_curcop;
1001 Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf,
1002 OutCopFILE(cop), (IV)CopLINE(cop));
1003 if (GvIO(PL_last_in_gv) && IoLINES(GvIOp(PL_last_in_gv))) {
1004 const bool line_mode = (RsSIMPLE(PL_rs) &&
1005 SvCUR(PL_rs) == 1 && *SvPVX_const(PL_rs) == '\n');
1006 Perl_sv_catpvf(aTHX_ sv, ", <%s> %s %"IVdf,
1007 PL_last_in_gv == PL_argvgv ?
1008 "" : GvNAME(PL_last_in_gv),
1009 line_mode ? "line" : "chunk",
1010 (IV)IoLINES(GvIOp(PL_last_in_gv)));
1012 sv_catpv(sv, PL_dirty ? dgd : ".\n");
1018 Perl_write_to_stderr(pTHX_ const char* message, int msglen)
1024 if (PL_stderrgv && SvREFCNT(PL_stderrgv)
1025 && (io = GvIO(PL_stderrgv))
1026 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
1033 SAVESPTR(PL_stderrgv);
1034 PL_stderrgv = Nullgv;
1036 PUSHSTACKi(PERLSI_MAGIC);
1040 PUSHs(SvTIED_obj((SV*)io, mg));
1041 PUSHs(sv_2mortal(newSVpvn(message, msglen)));
1043 call_method("PRINT", G_SCALAR);
1051 /* SFIO can really mess with your errno */
1052 const int e = errno;
1054 PerlIO * const serr = Perl_error_log;
1056 PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
1057 (void)PerlIO_flush(serr);
1064 /* Common code used by vcroak, vdie and vwarner */
1067 S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8)
1072 /* sv_2cv might call Perl_croak() */
1073 SV * const olddiehook = PL_diehook;
1077 SAVESPTR(PL_diehook);
1078 PL_diehook = Nullsv;
1079 cv = sv_2cv(olddiehook, &stash, &gv, 0);
1081 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1088 msg = newSVpvn(message, msglen);
1089 SvFLAGS(msg) |= utf8;
1097 PUSHSTACKi(PERLSI_DIEHOOK);
1101 call_sv((SV*)cv, G_DISCARD);
1108 S_vdie_croak_common(pTHX_ const char* pat, va_list* args, STRLEN* msglen,
1112 const char *message;
1115 SV * const msv = vmess(pat, args);
1116 if (PL_errors && SvCUR(PL_errors)) {
1117 sv_catsv(PL_errors, msv);
1118 message = SvPV_const(PL_errors, *msglen);
1119 SvCUR_set(PL_errors, 0);
1122 message = SvPV_const(msv,*msglen);
1123 *utf8 = SvUTF8(msv);
1129 DEBUG_S(PerlIO_printf(Perl_debug_log,
1130 "%p: die/croak: message = %s\ndiehook = %p\n",
1131 thr, message, PL_diehook));
1133 S_vdie_common(aTHX_ message, *msglen, *utf8);
1139 Perl_vdie(pTHX_ const char* pat, va_list *args)
1141 const char *message;
1142 const int was_in_eval = PL_in_eval;
1146 DEBUG_S(PerlIO_printf(Perl_debug_log,
1147 "%p: die: curstack = %p, mainstack = %p\n",
1148 thr, PL_curstack, PL_mainstack));
1150 message = vdie_croak_common(pat, args, &msglen, &utf8);
1152 PL_restartop = die_where(message, msglen);
1153 SvFLAGS(ERRSV) |= utf8;
1154 DEBUG_S(PerlIO_printf(Perl_debug_log,
1155 "%p: die: restartop = %p, was_in_eval = %d, top_env = %p\n",
1156 thr, PL_restartop, was_in_eval, PL_top_env));
1157 if ((!PL_restartop && was_in_eval) || PL_top_env->je_prev)
1159 return PL_restartop;
1162 #if defined(PERL_IMPLICIT_CONTEXT)
1164 Perl_die_nocontext(const char* pat, ...)
1169 va_start(args, pat);
1170 o = vdie(pat, &args);
1174 #endif /* PERL_IMPLICIT_CONTEXT */
1177 Perl_die(pTHX_ const char* pat, ...)
1181 va_start(args, pat);
1182 o = vdie(pat, &args);
1188 Perl_vcroak(pTHX_ const char* pat, va_list *args)
1190 const char *message;
1194 message = S_vdie_croak_common(aTHX_ pat, args, &msglen, &utf8);
1197 PL_restartop = die_where(message, msglen);
1198 SvFLAGS(ERRSV) |= utf8;
1202 message = SvPVx_const(ERRSV, msglen);
1204 write_to_stderr(message, msglen);
1208 #if defined(PERL_IMPLICIT_CONTEXT)
1210 Perl_croak_nocontext(const char *pat, ...)
1214 va_start(args, pat);
1219 #endif /* PERL_IMPLICIT_CONTEXT */
1222 =head1 Warning and Dieing
1226 This is the XSUB-writer's interface to Perl's C<die> function.
1227 Normally call this function the same way you call the C C<printf>
1228 function. Calling C<croak> returns control directly to Perl,
1229 sidestepping the normal C order of execution. See C<warn>.
1231 If you want to throw an exception object, assign the object to
1232 C<$@> and then pass C<Nullch> to croak():
1234 errsv = get_sv("@", TRUE);
1235 sv_setsv(errsv, exception_object);
1242 Perl_croak(pTHX_ const char *pat, ...)
1245 va_start(args, pat);
1252 Perl_vwarn(pTHX_ const char* pat, va_list *args)
1256 SV * const msv = vmess(pat, args);
1257 const I32 utf8 = SvUTF8(msv);
1258 const char * const message = SvPV_const(msv, msglen);
1261 /* sv_2cv might call Perl_warn() */
1262 SV * const oldwarnhook = PL_warnhook;
1268 SAVESPTR(PL_warnhook);
1269 PL_warnhook = Nullsv;
1270 cv = sv_2cv(oldwarnhook, &stash, &gv, 0);
1272 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1277 SAVESPTR(PL_warnhook);
1278 PL_warnhook = Nullsv;
1280 msg = newSVpvn(message, msglen);
1281 SvFLAGS(msg) |= utf8;
1285 PUSHSTACKi(PERLSI_WARNHOOK);
1289 call_sv((SV*)cv, G_DISCARD);
1296 write_to_stderr(message, msglen);
1299 #if defined(PERL_IMPLICIT_CONTEXT)
1301 Perl_warn_nocontext(const char *pat, ...)
1305 va_start(args, pat);
1309 #endif /* PERL_IMPLICIT_CONTEXT */
1314 This is the XSUB-writer's interface to Perl's C<warn> function. Call this
1315 function the same way you call the C C<printf> function. See C<croak>.
1321 Perl_warn(pTHX_ const char *pat, ...)
1324 va_start(args, pat);
1329 #if defined(PERL_IMPLICIT_CONTEXT)
1331 Perl_warner_nocontext(U32 err, const char *pat, ...)
1335 va_start(args, pat);
1336 vwarner(err, pat, &args);
1339 #endif /* PERL_IMPLICIT_CONTEXT */
1342 Perl_warner(pTHX_ U32 err, const char* pat,...)
1345 va_start(args, pat);
1346 vwarner(err, pat, &args);
1351 Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args)
1355 SV * const msv = vmess(pat, args);
1357 const char * const message = SvPV_const(msv, msglen);
1358 const I32 utf8 = SvUTF8(msv);
1362 S_vdie_common(aTHX_ message, msglen, utf8);
1365 PL_restartop = die_where(message, msglen);
1366 SvFLAGS(ERRSV) |= utf8;
1369 write_to_stderr(message, msglen);
1373 Perl_vwarn(aTHX_ pat, args);
1377 /* implements the ckWARN? macros */
1380 Perl_ckwarn(pTHX_ U32 w)
1385 && PL_curcop->cop_warnings != pWARN_NONE
1387 PL_curcop->cop_warnings == pWARN_ALL
1388 || isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w))
1389 || (unpackWARN2(w) &&
1390 isWARN_on(PL_curcop->cop_warnings, unpackWARN2(w)))
1391 || (unpackWARN3(w) &&
1392 isWARN_on(PL_curcop->cop_warnings, unpackWARN3(w)))
1393 || (unpackWARN4(w) &&
1394 isWARN_on(PL_curcop->cop_warnings, unpackWARN4(w)))
1399 isLEXWARN_off && PL_dowarn & G_WARN_ON
1404 /* implements the ckWARN?_d macro */
1407 Perl_ckwarn_d(pTHX_ U32 w)
1411 || PL_curcop->cop_warnings == pWARN_ALL
1413 PL_curcop->cop_warnings != pWARN_NONE
1415 isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w))
1416 || (unpackWARN2(w) &&
1417 isWARN_on(PL_curcop->cop_warnings, unpackWARN2(w)))
1418 || (unpackWARN3(w) &&
1419 isWARN_on(PL_curcop->cop_warnings, unpackWARN3(w)))
1420 || (unpackWARN4(w) &&
1421 isWARN_on(PL_curcop->cop_warnings, unpackWARN4(w)))
1429 /* since we've already done strlen() for both nam and val
1430 * we can use that info to make things faster than
1431 * sprintf(s, "%s=%s", nam, val)
1433 #define my_setenv_format(s, nam, nlen, val, vlen) \
1434 Copy(nam, s, nlen, char); \
1436 Copy(val, s+(nlen+1), vlen, char); \
1437 *(s+(nlen+1+vlen)) = '\0'
1439 #ifdef USE_ENVIRON_ARRAY
1440 /* VMS' my_setenv() is in vms.c */
1441 #if !defined(WIN32) && !defined(NETWARE)
1443 Perl_my_setenv(pTHX_ const char *nam, const char *val)
1447 /* only parent thread can modify process environment */
1448 if (PL_curinterp == aTHX)
1451 #ifndef PERL_USE_SAFE_PUTENV
1452 if (!PL_use_safe_putenv) {
1453 /* most putenv()s leak, so we manipulate environ directly */
1454 register I32 i=setenv_getix(nam); /* where does it go? */
1457 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 const 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);
1494 # if defined(__CYGWIN__) || defined(EPOC) || defined(__SYMBIAN32__)
1495 # if defined(HAS_UNSETENV)
1497 (void)unsetenv(nam);
1499 (void)setenv(nam, val, 1);
1501 # else /* ! HAS_UNSETENV */
1502 (void)setenv(nam, val, 1);
1503 # endif /* HAS_UNSETENV */
1505 # if defined(HAS_UNSETENV)
1507 (void)unsetenv(nam);
1509 const int nlen = strlen(nam);
1510 const int vlen = strlen(val);
1511 char * const new_env =
1512 (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
1513 my_setenv_format(new_env, nam, nlen, val, vlen);
1514 (void)putenv(new_env);
1516 # else /* ! HAS_UNSETENV */
1518 const int nlen = strlen(nam);
1524 new_env = (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
1525 /* all that work just for this */
1526 my_setenv_format(new_env, nam, nlen, val, vlen);
1527 (void)putenv(new_env);
1528 # endif /* HAS_UNSETENV */
1529 # endif /* __CYGWIN__ */
1530 #ifndef PERL_USE_SAFE_PUTENV
1536 #else /* WIN32 || NETWARE */
1539 Perl_my_setenv(pTHX_ const char *nam, const char *val)
1542 register char *envstr;
1543 const int nlen = strlen(nam);
1550 Newx(envstr, nlen+vlen+2, char);
1551 my_setenv_format(envstr, nam, nlen, val, vlen);
1552 (void)PerlEnv_putenv(envstr);
1556 #endif /* WIN32 || NETWARE */
1560 Perl_setenv_getix(pTHX_ const char *nam)
1563 register const I32 len = strlen(nam);
1565 for (i = 0; environ[i]; i++) {
1568 strnicmp(environ[i],nam,len) == 0
1570 strnEQ(environ[i],nam,len)
1572 && environ[i][len] == '=')
1573 break; /* strnEQ must come first to avoid */
1574 } /* potential SEGV's */
1577 #endif /* !PERL_MICRO */
1579 #endif /* !VMS && !EPOC*/
1581 #ifdef UNLINK_ALL_VERSIONS
1583 Perl_unlnk(pTHX_ const char *f) /* unlink all versions of a file */
1587 for (i = 0; PerlLIO_unlink(f) >= 0; i++) ;
1592 /* this is a drop-in replacement for bcopy() */
1593 #if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY))
1595 Perl_my_bcopy(register const char *from,register char *to,register I32 len)
1597 char * const retval = to;
1599 if (from - to >= 0) {
1607 *(--to) = *(--from);
1613 /* this is a drop-in replacement for memset() */
1616 Perl_my_memset(register char *loc, register I32 ch, register I32 len)
1618 char * const retval = loc;
1626 /* this is a drop-in replacement for bzero() */
1627 #if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
1629 Perl_my_bzero(register char *loc, register I32 len)
1631 char * const retval = loc;
1639 /* this is a drop-in replacement for memcmp() */
1640 #if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
1642 Perl_my_memcmp(const char *s1, const char *s2, register I32 len)
1644 register const U8 *a = (const U8 *)s1;
1645 register const U8 *b = (const U8 *)s2;
1649 if ((tmp = *a++ - *b++))
1654 #endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */
1658 #ifdef USE_CHAR_VSPRINTF
1663 vsprintf(char *dest, const char *pat, char *args)
1667 fakebuf._ptr = dest;
1668 fakebuf._cnt = 32767;
1672 fakebuf._flag = _IOWRT|_IOSTRG;
1673 _doprnt(pat, args, &fakebuf); /* what a kludge */
1674 (void)putc('\0', &fakebuf);
1675 #ifdef USE_CHAR_VSPRINTF
1678 return 0; /* perl doesn't use return value */
1682 #endif /* HAS_VPRINTF */
1685 #if BYTEORDER != 0x4321
1687 Perl_my_swap(pTHX_ short s)
1689 #if (BYTEORDER & 1) == 0
1692 result = ((s & 255) << 8) + ((s >> 8) & 255);
1700 Perl_my_htonl(pTHX_ long l)
1704 char c[sizeof(long)];
1707 #if BYTEORDER == 0x1234
1708 u.c[0] = (l >> 24) & 255;
1709 u.c[1] = (l >> 16) & 255;
1710 u.c[2] = (l >> 8) & 255;
1714 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
1715 Perl_croak(aTHX_ "Unknown BYTEORDER\n");
1720 for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
1721 u.c[o & 0xf] = (l >> s) & 255;
1729 Perl_my_ntohl(pTHX_ long l)
1733 char c[sizeof(long)];
1736 #if BYTEORDER == 0x1234
1737 u.c[0] = (l >> 24) & 255;
1738 u.c[1] = (l >> 16) & 255;
1739 u.c[2] = (l >> 8) & 255;
1743 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
1744 Perl_croak(aTHX_ "Unknown BYTEORDER\n");
1751 for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
1752 l |= (u.c[o & 0xf] & 255) << s;
1759 #endif /* BYTEORDER != 0x4321 */
1763 * Little-endian byte order functions - 'v' for 'VAX', or 'reVerse'.
1764 * If these functions are defined,
1765 * the BYTEORDER is neither 0x1234 nor 0x4321.
1766 * However, this is not assumed.
1770 #define HTOLE(name,type) \
1772 name (register type n) \
1776 char c[sizeof(type)]; \
1779 register I32 s = 0; \
1780 for (i = 0; i < sizeof(u.c); i++, s += 8) { \
1781 u.c[i] = (n >> s) & 0xFF; \
1786 #define LETOH(name,type) \
1788 name (register type n) \
1792 char c[sizeof(type)]; \
1795 register I32 s = 0; \
1798 for (i = 0; i < sizeof(u.c); i++, s += 8) { \
1799 n |= ((type)(u.c[i] & 0xFF)) << s; \
1805 * Big-endian byte order functions.
1808 #define HTOBE(name,type) \
1810 name (register type n) \
1814 char c[sizeof(type)]; \
1817 register I32 s = 8*(sizeof(u.c)-1); \
1818 for (i = 0; i < sizeof(u.c); i++, s -= 8) { \
1819 u.c[i] = (n >> s) & 0xFF; \
1824 #define BETOH(name,type) \
1826 name (register type n) \
1830 char c[sizeof(type)]; \
1833 register I32 s = 8*(sizeof(u.c)-1); \
1836 for (i = 0; i < sizeof(u.c); i++, s -= 8) { \
1837 n |= ((type)(u.c[i] & 0xFF)) << s; \
1843 * If we just can't do it...
1846 #define NOT_AVAIL(name,type) \
1848 name (register type n) \
1850 Perl_croak_nocontext(#name "() not available"); \
1851 return n; /* not reached */ \
1855 #if defined(HAS_HTOVS) && !defined(htovs)
1858 #if defined(HAS_HTOVL) && !defined(htovl)
1861 #if defined(HAS_VTOHS) && !defined(vtohs)
1864 #if defined(HAS_VTOHL) && !defined(vtohl)
1868 #ifdef PERL_NEED_MY_HTOLE16
1870 HTOLE(Perl_my_htole16,U16)
1872 NOT_AVAIL(Perl_my_htole16,U16)
1875 #ifdef PERL_NEED_MY_LETOH16
1877 LETOH(Perl_my_letoh16,U16)
1879 NOT_AVAIL(Perl_my_letoh16,U16)
1882 #ifdef PERL_NEED_MY_HTOBE16
1884 HTOBE(Perl_my_htobe16,U16)
1886 NOT_AVAIL(Perl_my_htobe16,U16)
1889 #ifdef PERL_NEED_MY_BETOH16
1891 BETOH(Perl_my_betoh16,U16)
1893 NOT_AVAIL(Perl_my_betoh16,U16)
1897 #ifdef PERL_NEED_MY_HTOLE32
1899 HTOLE(Perl_my_htole32,U32)
1901 NOT_AVAIL(Perl_my_htole32,U32)
1904 #ifdef PERL_NEED_MY_LETOH32
1906 LETOH(Perl_my_letoh32,U32)
1908 NOT_AVAIL(Perl_my_letoh32,U32)
1911 #ifdef PERL_NEED_MY_HTOBE32
1913 HTOBE(Perl_my_htobe32,U32)
1915 NOT_AVAIL(Perl_my_htobe32,U32)
1918 #ifdef PERL_NEED_MY_BETOH32
1920 BETOH(Perl_my_betoh32,U32)
1922 NOT_AVAIL(Perl_my_betoh32,U32)
1926 #ifdef PERL_NEED_MY_HTOLE64
1928 HTOLE(Perl_my_htole64,U64)
1930 NOT_AVAIL(Perl_my_htole64,U64)
1933 #ifdef PERL_NEED_MY_LETOH64
1935 LETOH(Perl_my_letoh64,U64)
1937 NOT_AVAIL(Perl_my_letoh64,U64)
1940 #ifdef PERL_NEED_MY_HTOBE64
1942 HTOBE(Perl_my_htobe64,U64)
1944 NOT_AVAIL(Perl_my_htobe64,U64)
1947 #ifdef PERL_NEED_MY_BETOH64
1949 BETOH(Perl_my_betoh64,U64)
1951 NOT_AVAIL(Perl_my_betoh64,U64)
1955 #ifdef PERL_NEED_MY_HTOLES
1956 HTOLE(Perl_my_htoles,short)
1958 #ifdef PERL_NEED_MY_LETOHS
1959 LETOH(Perl_my_letohs,short)
1961 #ifdef PERL_NEED_MY_HTOBES
1962 HTOBE(Perl_my_htobes,short)
1964 #ifdef PERL_NEED_MY_BETOHS
1965 BETOH(Perl_my_betohs,short)
1968 #ifdef PERL_NEED_MY_HTOLEI
1969 HTOLE(Perl_my_htolei,int)
1971 #ifdef PERL_NEED_MY_LETOHI
1972 LETOH(Perl_my_letohi,int)
1974 #ifdef PERL_NEED_MY_HTOBEI
1975 HTOBE(Perl_my_htobei,int)
1977 #ifdef PERL_NEED_MY_BETOHI
1978 BETOH(Perl_my_betohi,int)
1981 #ifdef PERL_NEED_MY_HTOLEL
1982 HTOLE(Perl_my_htolel,long)
1984 #ifdef PERL_NEED_MY_LETOHL
1985 LETOH(Perl_my_letohl,long)
1987 #ifdef PERL_NEED_MY_HTOBEL
1988 HTOBE(Perl_my_htobel,long)
1990 #ifdef PERL_NEED_MY_BETOHL
1991 BETOH(Perl_my_betohl,long)
1995 Perl_my_swabn(void *ptr, int n)
1997 register char *s = (char *)ptr;
1998 register char *e = s + (n-1);
2001 for (n /= 2; n > 0; s++, e--, n--) {
2009 Perl_my_popen_list(pTHX_ char *mode, int n, SV **args)
2011 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) && !defined(NETWARE)
2013 register I32 This, that;
2019 PERL_FLUSHALL_FOR_CHILD;
2020 This = (*mode == 'w');
2024 taint_proper("Insecure %s%s", "EXEC");
2026 if (PerlProc_pipe(p) < 0)
2028 /* Try for another pipe pair for error return */
2029 if (PerlProc_pipe(pp) >= 0)
2031 while ((pid = PerlProc_fork()) < 0) {
2032 if (errno != EAGAIN) {
2033 PerlLIO_close(p[This]);
2034 PerlLIO_close(p[that]);
2036 PerlLIO_close(pp[0]);
2037 PerlLIO_close(pp[1]);
2049 /* Close parent's end of error status pipe (if any) */
2051 PerlLIO_close(pp[0]);
2052 #if defined(HAS_FCNTL) && defined(F_SETFD)
2053 /* Close error pipe automatically if exec works */
2054 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2057 /* Now dup our end of _the_ pipe to right position */
2058 if (p[THIS] != (*mode == 'r')) {
2059 PerlLIO_dup2(p[THIS], *mode == 'r');
2060 PerlLIO_close(p[THIS]);
2061 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2062 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
2065 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
2066 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2067 /* No automatic close - do it by hand */
2074 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) {
2080 do_aexec5(Nullsv, args-1, args-1+n, pp[1], did_pipes);
2086 do_execfree(); /* free any memory malloced by child on fork */
2088 PerlLIO_close(pp[1]);
2089 /* Keep the lower of the two fd numbers */
2090 if (p[that] < p[This]) {
2091 PerlLIO_dup2(p[This], p[that]);
2092 PerlLIO_close(p[This]);
2096 PerlLIO_close(p[that]); /* close child's end of pipe */
2099 sv = *av_fetch(PL_fdpid,p[This],TRUE);
2101 SvUPGRADE(sv,SVt_IV);
2103 PL_forkprocess = pid;
2104 /* If we managed to get status pipe check for exec fail */
2105 if (did_pipes && pid > 0) {
2109 while (n < sizeof(int)) {
2110 n1 = PerlLIO_read(pp[0],
2111 (void*)(((char*)&errkid)+n),
2117 PerlLIO_close(pp[0]);
2119 if (n) { /* Error */
2121 PerlLIO_close(p[This]);
2122 if (n != sizeof(int))
2123 Perl_croak(aTHX_ "panic: kid popen errno read");
2125 pid2 = wait4pid(pid, &status, 0);
2126 } while (pid2 == -1 && errno == EINTR);
2127 errno = errkid; /* Propagate errno from kid */
2132 PerlLIO_close(pp[0]);
2133 return PerlIO_fdopen(p[This], mode);
2135 Perl_croak(aTHX_ "List form of piped open not implemented");
2136 return (PerlIO *) NULL;
2140 /* VMS' my_popen() is in VMS.c, same with OS/2. */
2141 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
2143 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2146 register I32 This, that;
2149 const I32 doexec = !(*cmd == '-' && cmd[1] == '\0');
2153 PERL_FLUSHALL_FOR_CHILD;
2156 return my_syspopen(aTHX_ cmd,mode);
2159 This = (*mode == 'w');
2161 if (doexec && PL_tainting) {
2163 taint_proper("Insecure %s%s", "EXEC");
2165 if (PerlProc_pipe(p) < 0)
2167 if (doexec && PerlProc_pipe(pp) >= 0)
2169 while ((pid = PerlProc_fork()) < 0) {
2170 if (errno != EAGAIN) {
2171 PerlLIO_close(p[This]);
2172 PerlLIO_close(p[that]);
2174 PerlLIO_close(pp[0]);
2175 PerlLIO_close(pp[1]);
2178 Perl_croak(aTHX_ "Can't fork");
2191 PerlLIO_close(pp[0]);
2192 #if defined(HAS_FCNTL) && defined(F_SETFD)
2193 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2196 if (p[THIS] != (*mode == 'r')) {
2197 PerlLIO_dup2(p[THIS], *mode == 'r');
2198 PerlLIO_close(p[THIS]);
2199 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2200 PerlLIO_close(p[THAT]);
2203 PerlLIO_close(p[THAT]);
2206 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2213 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
2218 /* may or may not use the shell */
2219 do_exec3(cmd, pp[1], did_pipes);
2222 #endif /* defined OS2 */
2223 if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) {
2224 SvREADONLY_off(GvSV(tmpgv));
2225 sv_setiv(GvSV(tmpgv), PerlProc_getpid());
2226 SvREADONLY_on(GvSV(tmpgv));
2228 #ifdef THREADS_HAVE_PIDS
2229 PL_ppid = (IV)getppid();
2232 #ifdef PERL_USES_PL_PIDSTATUS
2233 hv_clear(PL_pidstatus); /* we have no children */
2239 do_execfree(); /* free any memory malloced by child on vfork */
2241 PerlLIO_close(pp[1]);
2242 if (p[that] < p[This]) {
2243 PerlLIO_dup2(p[This], p[that]);
2244 PerlLIO_close(p[This]);
2248 PerlLIO_close(p[that]);
2251 sv = *av_fetch(PL_fdpid,p[This],TRUE);
2253 SvUPGRADE(sv,SVt_IV);
2255 PL_forkprocess = pid;
2256 if (did_pipes && pid > 0) {
2260 while (n < sizeof(int)) {
2261 n1 = PerlLIO_read(pp[0],
2262 (void*)(((char*)&errkid)+n),
2268 PerlLIO_close(pp[0]);
2270 if (n) { /* Error */
2272 PerlLIO_close(p[This]);
2273 if (n != sizeof(int))
2274 Perl_croak(aTHX_ "panic: kid popen errno read");
2276 pid2 = wait4pid(pid, &status, 0);
2277 } while (pid2 == -1 && errno == EINTR);
2278 errno = errkid; /* Propagate errno from kid */
2283 PerlLIO_close(pp[0]);
2284 return PerlIO_fdopen(p[This], mode);
2287 #if defined(atarist) || defined(EPOC)
2290 Perl_my_popen(pTHX_ char *cmd, char *mode)
2292 PERL_FLUSHALL_FOR_CHILD;
2293 /* Call system's popen() to get a FILE *, then import it.
2294 used 0 for 2nd parameter to PerlIO_importFILE;
2297 return PerlIO_importFILE(popen(cmd, mode), 0);
2301 FILE *djgpp_popen();
2303 Perl_my_popen(pTHX_ char *cmd, char *mode)
2305 PERL_FLUSHALL_FOR_CHILD;
2306 /* Call system's popen() to get a FILE *, then import it.
2307 used 0 for 2nd parameter to PerlIO_importFILE;
2310 return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
2315 #endif /* !DOSISH */
2317 /* this is called in parent before the fork() */
2319 Perl_atfork_lock(void)
2322 #if defined(USE_ITHREADS)
2323 /* locks must be held in locking order (if any) */
2325 MUTEX_LOCK(&PL_malloc_mutex);
2331 /* this is called in both parent and child after the fork() */
2333 Perl_atfork_unlock(void)
2336 #if defined(USE_ITHREADS)
2337 /* locks must be released in same order as in atfork_lock() */
2339 MUTEX_UNLOCK(&PL_malloc_mutex);
2348 #if defined(HAS_FORK)
2350 #if defined(USE_ITHREADS) && !defined(HAS_PTHREAD_ATFORK)
2355 /* atfork_lock() and atfork_unlock() are installed as pthread_atfork()
2356 * handlers elsewhere in the code */
2361 /* this "canna happen" since nothing should be calling here if !HAS_FORK */
2362 Perl_croak_nocontext("fork() not available");
2364 #endif /* HAS_FORK */
2369 Perl_dump_fds(pTHX_ char *s)
2374 PerlIO_printf(Perl_debug_log,"%s", s);
2375 for (fd = 0; fd < 32; fd++) {
2376 if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0)
2377 PerlIO_printf(Perl_debug_log," %d",fd);
2379 PerlIO_printf(Perl_debug_log,"\n");
2382 #endif /* DUMP_FDS */
2386 dup2(int oldfd, int newfd)
2388 #if defined(HAS_FCNTL) && defined(F_DUPFD)
2391 PerlLIO_close(newfd);
2392 return fcntl(oldfd, F_DUPFD, newfd);
2394 #define DUP2_MAX_FDS 256
2395 int fdtmp[DUP2_MAX_FDS];
2401 PerlLIO_close(newfd);
2402 /* good enough for low fd's... */
2403 while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
2404 if (fdx >= DUP2_MAX_FDS) {
2412 PerlLIO_close(fdtmp[--fdx]);
2419 #ifdef HAS_SIGACTION
2421 #ifdef MACOS_TRADITIONAL
2422 /* We don't want restart behavior on MacOS */
2427 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2430 struct sigaction act, oact;
2433 /* only "parent" interpreter can diddle signals */
2434 if (PL_curinterp != aTHX)
2435 return (Sighandler_t) SIG_ERR;
2438 act.sa_handler = (void(*)(int))handler;
2439 sigemptyset(&act.sa_mask);
2442 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2443 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
2445 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2446 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
2447 act.sa_flags |= SA_NOCLDWAIT;
2449 if (sigaction(signo, &act, &oact) == -1)
2450 return (Sighandler_t) SIG_ERR;
2452 return (Sighandler_t) oact.sa_handler;
2456 Perl_rsignal_state(pTHX_ int signo)
2458 struct sigaction oact;
2460 if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
2461 return (Sighandler_t) SIG_ERR;
2463 return (Sighandler_t) oact.sa_handler;
2467 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2470 struct sigaction act;
2473 /* only "parent" interpreter can diddle signals */
2474 if (PL_curinterp != aTHX)
2478 act.sa_handler = (void(*)(int))handler;
2479 sigemptyset(&act.sa_mask);
2482 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2483 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
2485 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2486 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
2487 act.sa_flags |= SA_NOCLDWAIT;
2489 return sigaction(signo, &act, save);
2493 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2497 /* only "parent" interpreter can diddle signals */
2498 if (PL_curinterp != aTHX)
2502 return sigaction(signo, save, (struct sigaction *)NULL);
2505 #else /* !HAS_SIGACTION */
2508 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2510 #if defined(USE_ITHREADS) && !defined(WIN32)
2511 /* only "parent" interpreter can diddle signals */
2512 if (PL_curinterp != aTHX)
2513 return (Sighandler_t) SIG_ERR;
2516 return PerlProc_signal(signo, handler);
2528 Perl_rsignal_state(pTHX_ int signo)
2531 Sighandler_t oldsig;
2533 #if defined(USE_ITHREADS) && !defined(WIN32)
2534 /* only "parent" interpreter can diddle signals */
2535 if (PL_curinterp != aTHX)
2536 return (Sighandler_t) SIG_ERR;
2540 oldsig = PerlProc_signal(signo, sig_trap);
2541 PerlProc_signal(signo, oldsig);
2543 PerlProc_kill(PerlProc_getpid(), signo);
2548 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2550 #if defined(USE_ITHREADS) && !defined(WIN32)
2551 /* only "parent" interpreter can diddle signals */
2552 if (PL_curinterp != aTHX)
2555 *save = PerlProc_signal(signo, handler);
2556 return (*save == (Sighandler_t) SIG_ERR) ? -1 : 0;
2560 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2562 #if defined(USE_ITHREADS) && !defined(WIN32)
2563 /* only "parent" interpreter can diddle signals */
2564 if (PL_curinterp != aTHX)
2567 return (PerlProc_signal(signo, *save) == (Sighandler_t) SIG_ERR) ? -1 : 0;
2570 #endif /* !HAS_SIGACTION */
2571 #endif /* !PERL_MICRO */
2573 /* VMS' my_pclose() is in VMS.c; same with OS/2 */
2574 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
2576 Perl_my_pclose(pTHX_ PerlIO *ptr)
2578 Sigsave_t hstat, istat, qstat;
2584 int saved_errno = 0;
2586 int saved_win32_errno;
2590 svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE);
2592 pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
2594 *svp = &PL_sv_undef;
2596 if (pid == -1) { /* Opened by popen. */
2597 return my_syspclose(ptr);
2600 if ((close_failed = (PerlIO_close(ptr) == EOF))) {
2601 saved_errno = errno;
2603 saved_win32_errno = GetLastError();
2607 if(PerlProc_kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */
2610 rsignal_save(SIGHUP, (Sighandler_t) SIG_IGN, &hstat);
2611 rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &istat);
2612 rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qstat);
2615 pid2 = wait4pid(pid, &status, 0);
2616 } while (pid2 == -1 && errno == EINTR);
2618 rsignal_restore(SIGHUP, &hstat);
2619 rsignal_restore(SIGINT, &istat);
2620 rsignal_restore(SIGQUIT, &qstat);
2623 SETERRNO(saved_errno, 0);
2626 return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status));
2628 #endif /* !DOSISH */
2630 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(MACOS_TRADITIONAL)
2632 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
2637 #ifdef PERL_USES_PL_PIDSTATUS
2640 /* The keys in PL_pidstatus are now the raw 4 (or 8) bytes of the
2641 pid, rather than a string form. */
2642 SV * const * const svp = hv_fetch(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),FALSE);
2643 if (svp && *svp != &PL_sv_undef) {
2644 *statusp = SvIVX(*svp);
2645 (void)hv_delete(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),
2653 hv_iterinit(PL_pidstatus);
2654 if ((entry = hv_iternext(PL_pidstatus))) {
2655 SV * const sv = hv_iterval(PL_pidstatus,entry);
2657 const char * const spid = hv_iterkey(entry,&len);
2659 assert (len == sizeof(Pid_t));
2660 memcpy((char *)&pid, spid, len);
2661 *statusp = SvIVX(sv);
2662 /* The hash iterator is currently on this entry, so simply
2663 calling hv_delete would trigger the lazy delete, which on
2664 aggregate does more work, beacuse next call to hv_iterinit()
2665 would spot the flag, and have to call the delete routine,
2666 while in the meantime any new entries can't re-use that
2668 hv_iterinit(PL_pidstatus);
2669 (void)hv_delete(PL_pidstatus,spid,len,G_DISCARD);
2676 # ifdef HAS_WAITPID_RUNTIME
2677 if (!HAS_WAITPID_RUNTIME)
2680 result = PerlProc_waitpid(pid,statusp,flags);
2683 #if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
2684 result = wait4((pid==-1)?0:pid,statusp,flags,Null(struct rusage *));
2687 #ifdef PERL_USES_PL_PIDSTATUS
2688 #if defined(HAS_WAITPID) && defined(HAS_WAITPID_RUNTIME)
2693 Perl_croak(aTHX_ "Can't do waitpid with flags");
2695 while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
2696 pidgone(result,*statusp);
2702 #if defined(HAS_WAITPID) || defined(HAS_WAIT4)
2705 if (result < 0 && errno == EINTR) {
2710 #endif /* !DOSISH || OS2 || WIN32 || NETWARE */
2712 #ifdef PERL_USES_PL_PIDSTATUS
2714 Perl_pidgone(pTHX_ Pid_t pid, int status)
2718 sv = *hv_fetch(PL_pidstatus,(const char*)&pid,sizeof(Pid_t),TRUE);
2719 SvUPGRADE(sv,SVt_IV);
2720 SvIV_set(sv, status);
2725 #if defined(atarist) || defined(OS2) || defined(EPOC)
2728 int /* Cannot prototype with I32
2730 my_syspclose(PerlIO *ptr)
2733 Perl_my_pclose(pTHX_ PerlIO *ptr)
2736 /* Needs work for PerlIO ! */
2737 FILE * const f = PerlIO_findFILE(ptr);
2738 const I32 result = pclose(f);
2739 PerlIO_releaseFILE(ptr,f);
2747 Perl_my_pclose(pTHX_ PerlIO *ptr)
2749 /* Needs work for PerlIO ! */
2750 FILE * const f = PerlIO_findFILE(ptr);
2751 I32 result = djgpp_pclose(f);
2752 result = (result << 8) & 0xff00;
2753 PerlIO_releaseFILE(ptr,f);
2759 Perl_repeatcpy(pTHX_ register char *to, register const char *from, I32 len, register I32 count)
2762 register const char * const frombase = from;
2765 register const char c = *from;
2770 while (count-- > 0) {
2771 for (todo = len; todo > 0; todo--) {
2780 Perl_same_dirent(pTHX_ const char *a, const char *b)
2782 char *fa = strrchr(a,'/');
2783 char *fb = strrchr(b,'/');
2786 SV * const tmpsv = sv_newmortal();
2799 sv_setpvn(tmpsv, ".", 1);
2801 sv_setpvn(tmpsv, a, fa - a);
2802 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0)
2805 sv_setpvn(tmpsv, ".", 1);
2807 sv_setpvn(tmpsv, b, fb - b);
2808 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0)
2810 return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
2811 tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
2813 #endif /* !HAS_RENAME */
2816 Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
2817 const char *const *const search_ext, I32 flags)
2819 const char *xfound = Nullch;
2820 char *xfailed = Nullch;
2821 char tmpbuf[MAXPATHLEN];
2825 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
2826 # define SEARCH_EXTS ".bat", ".cmd", NULL
2827 # define MAX_EXT_LEN 4
2830 # define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
2831 # define MAX_EXT_LEN 4
2834 # define SEARCH_EXTS ".pl", ".com", NULL
2835 # define MAX_EXT_LEN 4
2837 /* additional extensions to try in each dir if scriptname not found */
2839 static const char *const exts[] = { SEARCH_EXTS };
2840 const char *const *const ext = search_ext ? search_ext : exts;
2841 int extidx = 0, i = 0;
2842 const char *curext = Nullch;
2844 PERL_UNUSED_ARG(search_ext);
2845 # define MAX_EXT_LEN 0
2849 * If dosearch is true and if scriptname does not contain path
2850 * delimiters, search the PATH for scriptname.
2852 * If SEARCH_EXTS is also defined, will look for each
2853 * scriptname{SEARCH_EXTS} whenever scriptname is not found
2854 * while searching the PATH.
2856 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
2857 * proceeds as follows:
2858 * If DOSISH or VMSISH:
2859 * + look for ./scriptname{,.foo,.bar}
2860 * + search the PATH for scriptname{,.foo,.bar}
2863 * + look *only* in the PATH for scriptname{,.foo,.bar} (note
2864 * this will not look in '.' if it's not in the PATH)
2869 # ifdef ALWAYS_DEFTYPES
2870 len = strlen(scriptname);
2871 if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
2872 int idx = 0, deftypes = 1;
2875 const int hasdir = !dosearch || (strpbrk(scriptname,":[</") != Nullch);
2878 int idx = 0, deftypes = 1;
2881 const int hasdir = (strpbrk(scriptname,":[</") != Nullch);
2883 /* The first time through, just add SEARCH_EXTS to whatever we
2884 * already have, so we can check for default file types. */
2886 (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
2892 if ((strlen(tmpbuf) + strlen(scriptname)
2893 + MAX_EXT_LEN) >= sizeof tmpbuf)
2894 continue; /* don't search dir with too-long name */
2895 strcat(tmpbuf, scriptname);
2899 if (strEQ(scriptname, "-"))
2901 if (dosearch) { /* Look in '.' first. */
2902 const char *cur = scriptname;
2904 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
2906 if (strEQ(ext[i++],curext)) {
2907 extidx = -1; /* already has an ext */
2912 DEBUG_p(PerlIO_printf(Perl_debug_log,
2913 "Looking for %s\n",cur));
2914 if (PerlLIO_stat(cur,&PL_statbuf) >= 0
2915 && !S_ISDIR(PL_statbuf.st_mode)) {
2923 if (cur == scriptname) {
2924 len = strlen(scriptname);
2925 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
2927 /* FIXME? Convert to memcpy */
2928 cur = strcpy(tmpbuf, scriptname);
2930 } while (extidx >= 0 && ext[extidx] /* try an extension? */
2931 && strcpy(tmpbuf+len, ext[extidx++]));
2936 #ifdef MACOS_TRADITIONAL
2937 if (dosearch && !strchr(scriptname, ':') &&
2938 (s = PerlEnv_getenv("Commands")))
2940 if (dosearch && !strchr(scriptname, '/')
2942 && !strchr(scriptname, '\\')
2944 && (s = PerlEnv_getenv("PATH")))
2949 PL_bufend = s + strlen(s);
2950 while (s < PL_bufend) {
2951 #ifdef MACOS_TRADITIONAL
2952 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
2956 #if defined(atarist) || defined(DOSISH)
2961 && *s != ';'; len++, s++) {
2962 if (len < sizeof tmpbuf)
2965 if (len < sizeof tmpbuf)
2967 #else /* ! (atarist || DOSISH) */
2968 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
2971 #endif /* ! (atarist || DOSISH) */
2972 #endif /* MACOS_TRADITIONAL */
2975 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
2976 continue; /* don't search dir with too-long name */
2977 #ifdef MACOS_TRADITIONAL
2978 if (len && tmpbuf[len - 1] != ':')
2979 tmpbuf[len++] = ':';
2982 # if defined(atarist) || defined(__MINT__) || defined(DOSISH)
2983 && tmpbuf[len - 1] != '/'
2984 && tmpbuf[len - 1] != '\\'
2987 tmpbuf[len++] = '/';
2988 if (len == 2 && tmpbuf[0] == '.')
2991 /* FIXME? Convert to memcpy by storing previous strlen(scriptname)
2993 (void)strcpy(tmpbuf + len, scriptname);
2997 len = strlen(tmpbuf);
2998 if (extidx > 0) /* reset after previous loop */
3002 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
3003 retval = PerlLIO_stat(tmpbuf,&PL_statbuf);
3004 if (S_ISDIR(PL_statbuf.st_mode)) {
3008 } while ( retval < 0 /* not there */
3009 && extidx>=0 && ext[extidx] /* try an extension? */
3010 && strcpy(tmpbuf+len, ext[extidx++])
3015 if (S_ISREG(PL_statbuf.st_mode)
3016 && cando(S_IRUSR,TRUE,&PL_statbuf)
3017 #if !defined(DOSISH) && !defined(MACOS_TRADITIONAL)
3018 && cando(S_IXUSR,TRUE,&PL_statbuf)
3022 xfound = tmpbuf; /* bingo! */
3026 xfailed = savepv(tmpbuf);
3029 if (!xfound && !seen_dot && !xfailed &&
3030 (PerlLIO_stat(scriptname,&PL_statbuf) < 0
3031 || S_ISDIR(PL_statbuf.st_mode)))
3033 seen_dot = 1; /* Disable message. */
3035 if (flags & 1) { /* do or die? */
3036 Perl_croak(aTHX_ "Can't %s %s%s%s",
3037 (xfailed ? "execute" : "find"),
3038 (xfailed ? xfailed : scriptname),
3039 (xfailed ? "" : " on PATH"),
3040 (xfailed || seen_dot) ? "" : ", '.' not in PATH");
3042 scriptname = Nullch;
3045 scriptname = xfound;
3047 return (scriptname ? savepv(scriptname) : Nullch);
3050 #ifndef PERL_GET_CONTEXT_DEFINED
3053 Perl_get_context(void)
3056 #if defined(USE_ITHREADS)
3057 # ifdef OLD_PTHREADS_API
3059 if (pthread_getspecific(PL_thr_key, &t))
3060 Perl_croak_nocontext("panic: pthread_getspecific");
3063 # ifdef I_MACH_CTHREADS
3064 return (void*)cthread_data(cthread_self());
3066 return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
3075 Perl_set_context(void *t)
3078 #if defined(USE_ITHREADS)
3079 # ifdef I_MACH_CTHREADS
3080 cthread_set_data(cthread_self(), t);
3082 if (pthread_setspecific(PL_thr_key, t))
3083 Perl_croak_nocontext("panic: pthread_setspecific");
3090 #endif /* !PERL_GET_CONTEXT_DEFINED */
3092 #if defined(PERL_GLOBAL_STRUCT) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
3101 Perl_get_op_names(pTHX)
3103 return (char **)PL_op_name;
3107 Perl_get_op_descs(pTHX)
3109 return (char **)PL_op_desc;
3113 Perl_get_no_modify(pTHX)
3115 return PL_no_modify;
3119 Perl_get_opargs(pTHX)
3121 return (U32 *)PL_opargs;
3125 Perl_get_ppaddr(pTHX)
3128 return (PPADDR_t*)PL_ppaddr;
3131 #ifndef HAS_GETENV_LEN
3133 Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
3135 char * const env_trans = PerlEnv_getenv(env_elem);
3137 *len = strlen(env_trans);
3144 Perl_get_vtbl(pTHX_ int vtbl_id)
3146 const MGVTBL* result;
3150 result = &PL_vtbl_sv;
3153 result = &PL_vtbl_env;
3155 case want_vtbl_envelem:
3156 result = &PL_vtbl_envelem;
3159 result = &PL_vtbl_sig;
3161 case want_vtbl_sigelem:
3162 result = &PL_vtbl_sigelem;
3164 case want_vtbl_pack:
3165 result = &PL_vtbl_pack;
3167 case want_vtbl_packelem:
3168 result = &PL_vtbl_packelem;
3170 case want_vtbl_dbline:
3171 result = &PL_vtbl_dbline;
3174 result = &PL_vtbl_isa;
3176 case want_vtbl_isaelem:
3177 result = &PL_vtbl_isaelem;
3179 case want_vtbl_arylen:
3180 result = &PL_vtbl_arylen;
3182 case want_vtbl_glob:
3183 result = &PL_vtbl_glob;
3185 case want_vtbl_mglob:
3186 result = &PL_vtbl_mglob;
3188 case want_vtbl_nkeys:
3189 result = &PL_vtbl_nkeys;
3191 case want_vtbl_taint:
3192 result = &PL_vtbl_taint;
3194 case want_vtbl_substr:
3195 result = &PL_vtbl_substr;
3198 result = &PL_vtbl_vec;
3201 result = &PL_vtbl_pos;
3204 result = &PL_vtbl_bm;
3207 result = &PL_vtbl_fm;
3209 case want_vtbl_uvar:
3210 result = &PL_vtbl_uvar;
3212 case want_vtbl_defelem:
3213 result = &PL_vtbl_defelem;
3215 case want_vtbl_regexp:
3216 result = &PL_vtbl_regexp;
3218 case want_vtbl_regdata:
3219 result = &PL_vtbl_regdata;
3221 case want_vtbl_regdatum:
3222 result = &PL_vtbl_regdatum;
3224 #ifdef USE_LOCALE_COLLATE
3225 case want_vtbl_collxfrm:
3226 result = &PL_vtbl_collxfrm;
3229 case want_vtbl_amagic:
3230 result = &PL_vtbl_amagic;
3232 case want_vtbl_amagicelem:
3233 result = &PL_vtbl_amagicelem;
3235 case want_vtbl_backref:
3236 result = &PL_vtbl_backref;
3238 case want_vtbl_utf8:
3239 result = &PL_vtbl_utf8;
3242 result = Null(MGVTBL*);
3245 return (MGVTBL*)result;
3249 Perl_my_fflush_all(pTHX)
3251 #if defined(USE_PERLIO) || defined(FFLUSH_NULL) || defined(USE_SFIO)
3252 return PerlIO_flush(NULL);
3254 # if defined(HAS__FWALK)
3255 extern int fflush(FILE *);
3256 /* undocumented, unprototyped, but very useful BSDism */
3257 extern void _fwalk(int (*)(FILE *));
3261 # if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
3263 # ifdef PERL_FFLUSH_ALL_FOPEN_MAX
3264 open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
3266 # if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
3267 open_max = sysconf(_SC_OPEN_MAX);
3270 open_max = FOPEN_MAX;
3273 open_max = OPEN_MAX;
3284 for (i = 0; i < open_max; i++)
3285 if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
3286 STDIO_STREAM_ARRAY[i]._file < open_max &&
3287 STDIO_STREAM_ARRAY[i]._flag)
3288 PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
3292 SETERRNO(EBADF,RMS_IFI);
3299 Perl_report_evil_fh(pTHX_ const GV *gv, const IO *io, I32 op)
3301 const char * const func =
3302 op == OP_READLINE ? "readline" : /* "<HANDLE>" not nice */
3303 op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */
3305 const char * const pars = OP_IS_FILETEST(op) ? "" : "()";
3306 const char * const type = OP_IS_SOCKET(op)
3307 || (gv && io && IoTYPE(io) == IoTYPE_SOCKET)
3308 ? "socket" : "filehandle";
3309 const char * const name = gv && isGV(gv) ? GvENAME(gv) : NULL;
3311 if (op == OP_phoney_OUTPUT_ONLY || op == OP_phoney_INPUT_ONLY) {
3312 if (ckWARN(WARN_IO)) {
3313 const char * const direction = (op == OP_phoney_INPUT_ONLY) ? "in" : "out";
3315 Perl_warner(aTHX_ packWARN(WARN_IO),
3316 "Filehandle %s opened only for %sput",
3319 Perl_warner(aTHX_ packWARN(WARN_IO),
3320 "Filehandle opened only for %sput", direction);
3327 if (gv && io && IoTYPE(io) == IoTYPE_CLOSED) {
3329 warn_type = WARN_CLOSED;
3333 warn_type = WARN_UNOPENED;
3336 if (ckWARN(warn_type)) {
3337 if (name && *name) {
3338 Perl_warner(aTHX_ packWARN(warn_type),
3339 "%s%s on %s %s %s", func, pars, vile, type, name);
3340 if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3342 aTHX_ packWARN(warn_type),
3343 "\t(Are you trying to call %s%s on dirhandle %s?)\n",
3348 Perl_warner(aTHX_ packWARN(warn_type),
3349 "%s%s on %s %s", func, pars, vile, type);
3350 if (gv && io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3352 aTHX_ packWARN(warn_type),
3353 "\t(Are you trying to call %s%s on dirhandle?)\n",
3362 /* in ASCII order, not that it matters */
3363 static const char controllablechars[] = "?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_";
3366 Perl_ebcdic_control(pTHX_ int ch)
3374 if ((ctlp = strchr(controllablechars, ch)) == 0) {
3375 Perl_die(aTHX_ "unrecognised control character '%c'\n", ch);
3378 if (ctlp == controllablechars)
3379 return('\177'); /* DEL */
3381 return((unsigned char)(ctlp - controllablechars - 1));
3382 } else { /* Want uncontrol */
3383 if (ch == '\177' || ch == -1)
3385 else if (ch == '\157')
3387 else if (ch == '\174')
3389 else if (ch == '^') /* '\137' in 1047, '\260' in 819 */
3391 else if (ch == '\155')
3393 else if (0 < ch && ch < (sizeof(controllablechars) - 1))
3394 return(controllablechars[ch+1]);
3396 Perl_die(aTHX_ "invalid control request: '\\%03o'\n", ch & 0xFF);
3401 /* To workaround core dumps from the uninitialised tm_zone we get the
3402 * system to give us a reasonable struct to copy. This fix means that
3403 * strftime uses the tm_zone and tm_gmtoff values returned by
3404 * localtime(time()). That should give the desired result most of the
3405 * time. But probably not always!
3407 * This does not address tzname aspects of NETaa14816.
3412 # ifndef STRUCT_TM_HASZONE
3413 # define STRUCT_TM_HASZONE
3417 #ifdef STRUCT_TM_HASZONE /* Backward compat */
3418 # ifndef HAS_TM_TM_ZONE
3419 # define HAS_TM_TM_ZONE
3424 Perl_init_tm(pTHX_ struct tm *ptm) /* see mktime, strftime and asctime */
3426 #ifdef HAS_TM_TM_ZONE
3428 const struct tm* my_tm;
3430 my_tm = localtime(&now);
3432 Copy(my_tm, ptm, 1, struct tm);
3434 PERL_UNUSED_ARG(ptm);
3439 * mini_mktime - normalise struct tm values without the localtime()
3440 * semantics (and overhead) of mktime().
3443 Perl_mini_mktime(pTHX_ struct tm *ptm)
3447 int month, mday, year, jday;
3448 int odd_cent, odd_year;
3450 #define DAYS_PER_YEAR 365
3451 #define DAYS_PER_QYEAR (4*DAYS_PER_YEAR+1)
3452 #define DAYS_PER_CENT (25*DAYS_PER_QYEAR-1)
3453 #define DAYS_PER_QCENT (4*DAYS_PER_CENT+1)
3454 #define SECS_PER_HOUR (60*60)
3455 #define SECS_PER_DAY (24*SECS_PER_HOUR)
3456 /* parentheses deliberately absent on these two, otherwise they don't work */
3457 #define MONTH_TO_DAYS 153/5
3458 #define DAYS_TO_MONTH 5/153
3459 /* offset to bias by March (month 4) 1st between month/mday & year finding */
3460 #define YEAR_ADJUST (4*MONTH_TO_DAYS+1)
3461 /* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */
3462 #define WEEKDAY_BIAS 6 /* (1+6)%7 makes Sunday 0 again */
3465 * Year/day algorithm notes:
3467 * With a suitable offset for numeric value of the month, one can find
3468 * an offset into the year by considering months to have 30.6 (153/5) days,
3469 * using integer arithmetic (i.e., with truncation). To avoid too much
3470 * messing about with leap days, we consider January and February to be
3471 * the 13th and 14th month of the previous year. After that transformation,
3472 * we need the month index we use to be high by 1 from 'normal human' usage,
3473 * so the month index values we use run from 4 through 15.
3475 * Given that, and the rules for the Gregorian calendar (leap years are those
3476 * divisible by 4 unless also divisible by 100, when they must be divisible
3477 * by 400 instead), we can simply calculate the number of days since some
3478 * arbitrary 'beginning of time' by futzing with the (adjusted) year number,
3479 * the days we derive from our month index, and adding in the day of the
3480 * month. The value used here is not adjusted for the actual origin which
3481 * it normally would use (1 January A.D. 1), since we're not exposing it.
3482 * We're only building the value so we can turn around and get the
3483 * normalised values for the year, month, day-of-month, and day-of-year.
3485 * For going backward, we need to bias the value we're using so that we find
3486 * the right year value. (Basically, we don't want the contribution of
3487 * March 1st to the number to apply while deriving the year). Having done
3488 * that, we 'count up' the contribution to the year number by accounting for
3489 * full quadracenturies (400-year periods) with their extra leap days, plus
3490 * the contribution from full centuries (to avoid counting in the lost leap
3491 * days), plus the contribution from full quad-years (to count in the normal
3492 * leap days), plus the leftover contribution from any non-leap years.
3493 * At this point, if we were working with an actual leap day, we'll have 0
3494 * days left over. This is also true for March 1st, however. So, we have
3495 * to special-case that result, and (earlier) keep track of the 'odd'
3496 * century and year contributions. If we got 4 extra centuries in a qcent,
3497 * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb.
3498 * Otherwise, we add back in the earlier bias we removed (the 123 from
3499 * figuring in March 1st), find the month index (integer division by 30.6),
3500 * and the remainder is the day-of-month. We then have to convert back to
3501 * 'real' months (including fixing January and February from being 14/15 in
3502 * the previous year to being in the proper year). After that, to get
3503 * tm_yday, we work with the normalised year and get a new yearday value for
3504 * January 1st, which we subtract from the yearday value we had earlier,
3505 * representing the date we've re-built. This is done from January 1
3506 * because tm_yday is 0-origin.
3508 * Since POSIX time routines are only guaranteed to work for times since the
3509 * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm
3510 * applies Gregorian calendar rules even to dates before the 16th century
3511 * doesn't bother me. Besides, you'd need cultural context for a given
3512 * date to know whether it was Julian or Gregorian calendar, and that's
3513 * outside the scope for this routine. Since we convert back based on the
3514 * same rules we used to build the yearday, you'll only get strange results
3515 * for input which needed normalising, or for the 'odd' century years which
3516 * were leap years in the Julian calander but not in the Gregorian one.
3517 * I can live with that.
3519 * This algorithm also fails to handle years before A.D. 1 gracefully, but
3520 * that's still outside the scope for POSIX time manipulation, so I don't
3524 year = 1900 + ptm->tm_year;
3525 month = ptm->tm_mon;
3526 mday = ptm->tm_mday;
3527 /* allow given yday with no month & mday to dominate the result */
3528 if (ptm->tm_yday >= 0 && mday <= 0 && month <= 0) {
3531 jday = 1 + ptm->tm_yday;
3540 yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400;
3541 yearday += month*MONTH_TO_DAYS + mday + jday;
3543 * Note that we don't know when leap-seconds were or will be,
3544 * so we have to trust the user if we get something which looks
3545 * like a sensible leap-second. Wild values for seconds will
3546 * be rationalised, however.
3548 if ((unsigned) ptm->tm_sec <= 60) {
3555 secs += 60 * ptm->tm_min;
3556 secs += SECS_PER_HOUR * ptm->tm_hour;
3558 if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) {
3559 /* got negative remainder, but need positive time */
3560 /* back off an extra day to compensate */
3561 yearday += (secs/SECS_PER_DAY)-1;
3562 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1);
3565 yearday += (secs/SECS_PER_DAY);
3566 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY);
3569 else if (secs >= SECS_PER_DAY) {
3570 yearday += (secs/SECS_PER_DAY);
3571 secs %= SECS_PER_DAY;
3573 ptm->tm_hour = secs/SECS_PER_HOUR;
3574 secs %= SECS_PER_HOUR;
3575 ptm->tm_min = secs/60;
3577 ptm->tm_sec += secs;
3578 /* done with time of day effects */
3580 * The algorithm for yearday has (so far) left it high by 428.
3581 * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to
3582 * bias it by 123 while trying to figure out what year it
3583 * really represents. Even with this tweak, the reverse
3584 * translation fails for years before A.D. 0001.
3585 * It would still fail for Feb 29, but we catch that one below.
3587 jday = yearday; /* save for later fixup vis-a-vis Jan 1 */
3588 yearday -= YEAR_ADJUST;
3589 year = (yearday / DAYS_PER_QCENT) * 400;
3590 yearday %= DAYS_PER_QCENT;
3591 odd_cent = yearday / DAYS_PER_CENT;
3592 year += odd_cent * 100;
3593 yearday %= DAYS_PER_CENT;
3594 year += (yearday / DAYS_PER_QYEAR) * 4;
3595 yearday %= DAYS_PER_QYEAR;
3596 odd_year = yearday / DAYS_PER_YEAR;
3598 yearday %= DAYS_PER_YEAR;
3599 if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */
3604 yearday += YEAR_ADJUST; /* recover March 1st crock */
3605 month = yearday*DAYS_TO_MONTH;
3606 yearday -= month*MONTH_TO_DAYS;
3607 /* recover other leap-year adjustment */
3616 ptm->tm_year = year - 1900;
3618 ptm->tm_mday = yearday;
3619 ptm->tm_mon = month;
3623 ptm->tm_mon = month - 1;
3625 /* re-build yearday based on Jan 1 to get tm_yday */
3627 yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400;
3628 yearday += 14*MONTH_TO_DAYS + 1;
3629 ptm->tm_yday = jday - yearday;
3630 /* fix tm_wday if not overridden by caller */
3631 if ((unsigned)ptm->tm_wday > 6)
3632 ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
3636 Perl_my_strftime(pTHX_ const char *fmt, int sec, int min, int hour, int mday, int mon, int year, int wday, int yday, int isdst)
3644 init_tm(&mytm); /* XXX workaround - see init_tm() above */
3647 mytm.tm_hour = hour;
3648 mytm.tm_mday = mday;
3650 mytm.tm_year = year;
3651 mytm.tm_wday = wday;
3652 mytm.tm_yday = yday;
3653 mytm.tm_isdst = isdst;
3655 /* use libc to get the values for tm_gmtoff and tm_zone [perl #18238] */
3656 #if defined(HAS_MKTIME) && (defined(HAS_TM_TM_GMTOFF) || defined(HAS_TM_TM_ZONE))
3661 #ifdef HAS_TM_TM_GMTOFF
3662 mytm.tm_gmtoff = mytm2.tm_gmtoff;
3664 #ifdef HAS_TM_TM_ZONE
3665 mytm.tm_zone = mytm2.tm_zone;
3670 Newx(buf, buflen, char);
3671 len = strftime(buf, buflen, fmt, &mytm);
3673 ** The following is needed to handle to the situation where
3674 ** tmpbuf overflows. Basically we want to allocate a buffer
3675 ** and try repeatedly. The reason why it is so complicated
3676 ** is that getting a return value of 0 from strftime can indicate
3677 ** one of the following:
3678 ** 1. buffer overflowed,
3679 ** 2. illegal conversion specifier, or
3680 ** 3. the format string specifies nothing to be returned(not
3681 ** an error). This could be because format is an empty string
3682 ** or it specifies %p that yields an empty string in some locale.
3683 ** If there is a better way to make it portable, go ahead by
3686 if ((len > 0 && len < buflen) || (len == 0 && *fmt == '\0'))
3689 /* Possibly buf overflowed - try again with a bigger buf */
3690 const int fmtlen = strlen(fmt);
3691 const int bufsize = fmtlen + buflen;
3693 Newx(buf, bufsize, char);
3695 buflen = strftime(buf, bufsize, fmt, &mytm);
3696 if (buflen > 0 && buflen < bufsize)
3698 /* heuristic to prevent out-of-memory errors */
3699 if (bufsize > 100*fmtlen) {
3704 Renew(buf, bufsize*2, char);
3709 Perl_croak(aTHX_ "panic: no strftime");
3715 #define SV_CWD_RETURN_UNDEF \
3716 sv_setsv(sv, &PL_sv_undef); \
3719 #define SV_CWD_ISDOT(dp) \
3720 (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
3721 (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
3724 =head1 Miscellaneous Functions
3726 =for apidoc getcwd_sv
3728 Fill the sv with current working directory
3733 /* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars.
3734 * rewritten again by dougm, optimized for use with xs TARG, and to prefer
3735 * getcwd(3) if available
3736 * Comments from the orignal:
3737 * This is a faster version of getcwd. It's also more dangerous
3738 * because you might chdir out of a directory that you can't chdir
3742 Perl_getcwd_sv(pTHX_ register SV *sv)
3746 #ifndef INCOMPLETE_TAINTS
3752 char buf[MAXPATHLEN];
3754 /* Some getcwd()s automatically allocate a buffer of the given
3755 * size from the heap if they are given a NULL buffer pointer.
3756 * The problem is that this behaviour is not portable. */
3757 if (getcwd(buf, sizeof(buf) - 1)) {
3762 sv_setsv(sv, &PL_sv_undef);
3770 int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
3774 SvUPGRADE(sv, SVt_PV);
3776 if (PerlLIO_lstat(".", &statbuf) < 0) {
3777 SV_CWD_RETURN_UNDEF;
3780 orig_cdev = statbuf.st_dev;
3781 orig_cino = statbuf.st_ino;
3790 if (PerlDir_chdir("..") < 0) {
3791 SV_CWD_RETURN_UNDEF;
3793 if (PerlLIO_stat(".", &statbuf) < 0) {
3794 SV_CWD_RETURN_UNDEF;
3797 cdev = statbuf.st_dev;
3798 cino = statbuf.st_ino;
3800 if (odev == cdev && oino == cino) {
3803 if (!(dir = PerlDir_open("."))) {
3804 SV_CWD_RETURN_UNDEF;
3807 while ((dp = PerlDir_read(dir)) != NULL) {
3809 const int namelen = dp->d_namlen;
3811 const int namelen = strlen(dp->d_name);
3814 if (SV_CWD_ISDOT(dp)) {
3818 if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
3819 SV_CWD_RETURN_UNDEF;
3822 tdev = statbuf.st_dev;
3823 tino = statbuf.st_ino;
3824 if (tino == oino && tdev == odev) {
3830 SV_CWD_RETURN_UNDEF;
3833 if (pathlen + namelen + 1 >= MAXPATHLEN) {
3834 SV_CWD_RETURN_UNDEF;
3837 SvGROW(sv, pathlen + namelen + 1);
3841 Move(SvPVX_const(sv), SvPVX(sv) + namelen + 1, pathlen, char);
3844 /* prepend current directory to the front */
3846 Move(dp->d_name, SvPVX(sv)+1, namelen, char);
3847 pathlen += (namelen + 1);
3849 #ifdef VOID_CLOSEDIR
3852 if (PerlDir_close(dir) < 0) {
3853 SV_CWD_RETURN_UNDEF;
3859 SvCUR_set(sv, pathlen);
3863 if (PerlDir_chdir(SvPVX_const(sv)) < 0) {
3864 SV_CWD_RETURN_UNDEF;
3867 if (PerlLIO_stat(".", &statbuf) < 0) {
3868 SV_CWD_RETURN_UNDEF;
3871 cdev = statbuf.st_dev;
3872 cino = statbuf.st_ino;
3874 if (cdev != orig_cdev || cino != orig_cino) {
3875 Perl_croak(aTHX_ "Unstable directory path, "
3876 "current directory changed unexpectedly");
3888 =for apidoc scan_version
3890 Returns a pointer to the next character after the parsed
3891 version string, as well as upgrading the passed in SV to
3894 Function must be called with an already existing SV like
3897 s = scan_version(s,SV *sv, bool qv);
3899 Performs some preprocessing to the string to ensure that
3900 it has the correct characteristics of a version. Flags the
3901 object if it contains an underscore (which denotes this
3902 is a alpha version). The boolean qv denotes that the version
3903 should be interpreted as if it had multiple decimals, even if
3910 Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
3918 AV * const av = newAV();
3919 SV * const hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
3920 (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
3922 #ifndef NODEFAULT_SHAREKEYS
3923 HvSHAREKEYS_on(hv); /* key-sharing on by default */
3926 while (isSPACE(*s)) /* leading whitespace is OK */
3930 s++; /* get past 'v' */
3931 qv = 1; /* force quoted version processing */
3934 start = last = pos = s;
3936 /* pre-scan the input string to check for decimals/underbars */
3937 while ( *pos == '.' || *pos == '_' || isDIGIT(*pos) )
3942 Perl_croak(aTHX_ "Invalid version format (underscores before decimal)");
3946 else if ( *pos == '_' )
3949 Perl_croak(aTHX_ "Invalid version format (multiple underscores)");
3951 width = pos - last - 1; /* natural width of sub-version */
3956 if ( saw_period > 1 )
3957 qv = 1; /* force quoted version processing */
3962 hv_store((HV *)hv, "qv", 2, newSViv(qv), 0);
3964 hv_store((HV *)hv, "alpha", 5, newSViv(alpha), 0);
3965 if ( !qv && width < 3 )
3966 hv_store((HV *)hv, "width", 5, newSViv(width), 0);
3968 while (isDIGIT(*pos))
3970 if (!isALPHA(*pos)) {
3976 /* this is atoi() that delimits on underscores */
3977 const char *end = pos;
3981 /* the following if() will only be true after the decimal
3982 * point of a version originally created with a bare
3983 * floating point number, i.e. not quoted in any way
3985 if ( !qv && s > start && saw_period == 1 ) {
3989 rev += (*s - '0') * mult;
3991 if ( PERL_ABS(orev) > PERL_ABS(rev) )
3992 Perl_croak(aTHX_ "Integer overflow in version");
3999 while (--end >= s) {
4001 rev += (*end - '0') * mult;
4003 if ( PERL_ABS(orev) > PERL_ABS(rev) )
4004 Perl_croak(aTHX_ "Integer overflow in version");
4009 /* Append revision */
4010 av_push(av, newSViv(rev));
4011 if ( *pos == '.' && isDIGIT(pos[1]) )
4013 else if ( *pos == '_' && isDIGIT(pos[1]) )
4015 else if ( isDIGIT(*pos) )
4022 while ( isDIGIT(*pos) )
4027 while ( ( isDIGIT(*pos) || *pos == '_' ) && digits < 3 ) {
4035 if ( qv ) { /* quoted versions always get at least three terms*/
4036 I32 len = av_len(av);
4037 /* This for loop appears to trigger a compiler bug on OS X, as it
4038 loops infinitely. Yes, len is negative. No, it makes no sense.
4039 Compiler in question is:
4040 gcc version 3.3 20030304 (Apple Computer, Inc. build 1640)
4041 for ( len = 2 - len; len > 0; len-- )
4042 av_push((AV *)sv, newSViv(0));
4046 av_push(av, newSViv(0));
4049 if ( av_len(av) == -1 ) /* oops, someone forgot to pass a value */
4050 av_push(av, newSViv(0));
4052 /* And finally, store the AV in the hash */
4053 hv_store((HV *)hv, "version", 7, newRV_noinc((SV *)av), 0);
4058 =for apidoc new_version
4060 Returns a new version object based on the passed in SV:
4062 SV *sv = new_version(SV *ver);
4064 Does not alter the passed in ver SV. See "upg_version" if you
4065 want to upgrade the SV.
4071 Perl_new_version(pTHX_ SV *ver)
4073 SV * const rv = newSV(0);
4074 if ( sv_derived_from(ver,"version") ) /* can just copy directly */
4077 AV * const av = newAV();
4079 /* This will get reblessed later if a derived class*/
4080 SV * const hv = newSVrv(rv, "version");
4081 (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
4082 #ifndef NODEFAULT_SHAREKEYS
4083 HvSHAREKEYS_on(hv); /* key-sharing on by default */
4089 /* Begin copying all of the elements */
4090 if ( hv_exists((HV *)ver, "qv", 2) )
4091 hv_store((HV *)hv, "qv", 2, &PL_sv_yes, 0);
4093 if ( hv_exists((HV *)ver, "alpha", 5) )
4094 hv_store((HV *)hv, "alpha", 5, &PL_sv_yes, 0);
4096 if ( hv_exists((HV*)ver, "width", 5 ) )
4098 const I32 width = SvIV(*hv_fetch((HV*)ver, "width", 5, FALSE));
4099 hv_store((HV *)hv, "width", 5, newSViv(width), 0);
4102 sav = (AV *)SvRV(*hv_fetch((HV*)ver, "version", 7, FALSE));
4103 /* This will get reblessed later if a derived class*/
4104 for ( key = 0; key <= av_len(sav); key++ )
4106 const I32 rev = SvIV(*av_fetch(sav, key, FALSE));
4107 av_push(av, newSViv(rev));
4110 hv_store((HV *)hv, "version", 7, newRV_noinc((SV *)av), 0);
4114 if ( SvVOK(ver) ) { /* already a v-string */
4115 const MAGIC* const mg = mg_find(ver,PERL_MAGIC_vstring);
4116 const STRLEN len = mg->mg_len;
4117 char * const version = savepvn( (const char*)mg->mg_ptr, len);
4118 sv_setpvn(rv,version,len);
4123 sv_setsv(rv,ver); /* make a duplicate */
4132 =for apidoc upg_version
4134 In-place upgrade of the supplied SV to a version object.
4136 SV *sv = upg_version(SV *sv);
4138 Returns a pointer to the upgraded SV.
4144 Perl_upg_version(pTHX_ SV *ver)
4149 if ( SvNOK(ver) ) /* may get too much accuracy */
4152 const STRLEN len = my_sprintf(tbuf,"%.9"NVgf, SvNVX(ver));
4153 version = savepvn(tbuf, len);
4156 else if ( SvVOK(ver) ) { /* already a v-string */
4157 const MAGIC* const mg = mg_find(ver,PERL_MAGIC_vstring);
4158 version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
4162 else /* must be a string or something like a string */
4164 version = savepv(SvPV_nolen(ver));
4166 (void)scan_version(version, ver, qv);
4174 Validates that the SV contains a valid version object.
4176 bool vverify(SV *vobj);
4178 Note that it only confirms the bare minimum structure (so as not to get
4179 confused by derived classes which may contain additional hash entries):
4183 =item * The SV contains a [reference to a] hash
4185 =item * The hash contains a "version" key
4187 =item * The "version" key has [a reference to] an AV as its value
4195 Perl_vverify(pTHX_ SV *vs)
4201 /* see if the appropriate elements exist */
4202 if ( SvTYPE(vs) == SVt_PVHV
4203 && hv_exists((HV*)vs, "version", 7)
4204 && (sv = SvRV(*hv_fetch((HV*)vs, "version", 7, FALSE)))
4205 && SvTYPE(sv) == SVt_PVAV )
4214 Accepts a version object and returns the normalized floating
4215 point representation. Call like:
4219 NOTE: you can pass either the object directly or the SV
4220 contained within the RV.
4226 Perl_vnumify(pTHX_ SV *vs)
4231 SV * const sv = newSV(0);
4237 Perl_croak(aTHX_ "Invalid version object");
4239 /* see if various flags exist */
4240 if ( hv_exists((HV*)vs, "alpha", 5 ) )
4242 if ( hv_exists((HV*)vs, "width", 5 ) )
4243 width = SvIV(*hv_fetch((HV*)vs, "width", 5, FALSE));
4248 /* attempt to retrieve the version array */
4249 if ( !(av = (AV *)SvRV(*hv_fetch((HV*)vs, "version", 7, FALSE)) ) ) {
4250 sv_catpvn(sv,"0",1);
4257 sv_catpvn(sv,"0",1);
4261 digit = SvIV(*av_fetch(av, 0, 0));
4262 Perl_sv_setpvf(aTHX_ sv, "%d.", (int)PERL_ABS(digit));
4263 for ( i = 1 ; i < len ; i++ )
4265 digit = SvIV(*av_fetch(av, i, 0));
4267 const int denom = (int)pow(10,(3-width));
4268 const div_t term = div((int)PERL_ABS(digit),denom);
4269 Perl_sv_catpvf(aTHX_ sv, "%0*d_%d", width, term.quot, term.rem);
4272 Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
4278 digit = SvIV(*av_fetch(av, len, 0));
4279 if ( alpha && width == 3 ) /* alpha version */
4280 sv_catpvn(sv,"_",1);
4281 Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
4285 sv_catpvn(sv,"000",3);
4293 Accepts a version object and returns the normalized string
4294 representation. Call like:
4298 NOTE: you can pass either the object directly or the SV
4299 contained within the RV.
4305 Perl_vnormal(pTHX_ SV *vs)
4309 SV * const sv = newSV(0);
4315 Perl_croak(aTHX_ "Invalid version object");
4317 if ( hv_exists((HV*)vs, "alpha", 5 ) )
4319 av = (AV *)SvRV(*hv_fetch((HV*)vs, "version", 7, FALSE));
4327 digit = SvIV(*av_fetch(av, 0, 0));
4328 Perl_sv_setpvf(aTHX_ sv, "v%"IVdf, (IV)digit);
4329 for ( i = 1 ; i < len ; i++ ) {
4330 digit = SvIV(*av_fetch(av, i, 0));
4331 Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
4336 /* handle last digit specially */
4337 digit = SvIV(*av_fetch(av, len, 0));
4339 Perl_sv_catpvf(aTHX_ sv, "_%"IVdf, (IV)digit);
4341 Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
4344 if ( len <= 2 ) { /* short version, must be at least three */
4345 for ( len = 2 - len; len != 0; len-- )
4346 sv_catpvn(sv,".0",2);
4352 =for apidoc vstringify
4354 In order to maintain maximum compatibility with earlier versions
4355 of Perl, this function will return either the floating point
4356 notation or the multiple dotted notation, depending on whether
4357 the original version contained 1 or more dots, respectively
4363 Perl_vstringify(pTHX_ SV *vs)
4369 Perl_croak(aTHX_ "Invalid version object");
4371 if ( hv_exists((HV *)vs, "qv", 2) )
4380 Version object aware cmp. Both operands must already have been
4381 converted into version objects.
4387 Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
4390 bool lalpha = FALSE;
4391 bool ralpha = FALSE;
4400 if ( !vverify(lhv) )
4401 Perl_croak(aTHX_ "Invalid version object");
4403 if ( !vverify(rhv) )
4404 Perl_croak(aTHX_ "Invalid version object");
4406 /* get the left hand term */
4407 lav = (AV *)SvRV(*hv_fetch((HV*)lhv, "version", 7, FALSE));
4408 if ( hv_exists((HV*)lhv, "alpha", 5 ) )
4411 /* and the right hand term */
4412 rav = (AV *)SvRV(*hv_fetch((HV*)rhv, "version", 7, FALSE));
4413 if ( hv_exists((HV*)rhv, "alpha", 5 ) )
4421 while ( i <= m && retval == 0 )
4423 left = SvIV(*av_fetch(lav,i,0));
4424 right = SvIV(*av_fetch(rav,i,0));
4432 /* tiebreaker for alpha with identical terms */
4433 if ( retval == 0 && l == r && left == right && ( lalpha || ralpha ) )
4435 if ( lalpha && !ralpha )
4439 else if ( ralpha && !lalpha)
4445 if ( l != r && retval == 0 ) /* possible match except for trailing 0's */
4449 while ( i <= r && retval == 0 )
4451 if ( SvIV(*av_fetch(rav,i,0)) != 0 )
4452 retval = -1; /* not a match after all */
4458 while ( i <= l && retval == 0 )
4460 if ( SvIV(*av_fetch(lav,i,0)) != 0 )
4461 retval = +1; /* not a match after all */
4469 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT)
4470 # define EMULATE_SOCKETPAIR_UDP
4473 #ifdef EMULATE_SOCKETPAIR_UDP
4475 S_socketpair_udp (int fd[2]) {
4477 /* Fake a datagram socketpair using UDP to localhost. */
4478 int sockets[2] = {-1, -1};
4479 struct sockaddr_in addresses[2];
4481 Sock_size_t size = sizeof(struct sockaddr_in);
4482 unsigned short port;
4485 memset(&addresses, 0, sizeof(addresses));
4488 sockets[i] = PerlSock_socket(AF_INET, SOCK_DGRAM, PF_INET);
4489 if (sockets[i] == -1)
4490 goto tidy_up_and_fail;
4492 addresses[i].sin_family = AF_INET;
4493 addresses[i].sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4494 addresses[i].sin_port = 0; /* kernel choses port. */
4495 if (PerlSock_bind(sockets[i], (struct sockaddr *) &addresses[i],
4496 sizeof(struct sockaddr_in)) == -1)
4497 goto tidy_up_and_fail;
4500 /* Now have 2 UDP sockets. Find out which port each is connected to, and
4501 for each connect the other socket to it. */
4504 if (PerlSock_getsockname(sockets[i], (struct sockaddr *) &addresses[i],
4506 goto tidy_up_and_fail;
4507 if (size != sizeof(struct sockaddr_in))
4508 goto abort_tidy_up_and_fail;
4509 /* !1 is 0, !0 is 1 */
4510 if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i],
4511 sizeof(struct sockaddr_in)) == -1)
4512 goto tidy_up_and_fail;
4515 /* Now we have 2 sockets connected to each other. I don't trust some other
4516 process not to have already sent a packet to us (by random) so send
4517 a packet from each to the other. */
4520 /* I'm going to send my own port number. As a short.
4521 (Who knows if someone somewhere has sin_port as a bitfield and needs
4522 this routine. (I'm assuming crays have socketpair)) */
4523 port = addresses[i].sin_port;
4524 got = PerlLIO_write(sockets[i], &port, sizeof(port));
4525 if (got != sizeof(port)) {
4527 goto tidy_up_and_fail;
4528 goto abort_tidy_up_and_fail;
4532 /* Packets sent. I don't trust them to have arrived though.
4533 (As I understand it Solaris TCP stack is multithreaded. Non-blocking
4534 connect to localhost will use a second kernel thread. In 2.6 the
4535 first thread running the connect() returns before the second completes,
4536 so EINPROGRESS> In 2.7 the improved stack is faster and connect()
4537 returns 0. Poor programs have tripped up. One poor program's authors'
4538 had a 50-1 reverse stock split. Not sure how connected these were.)
4539 So I don't trust someone not to have an unpredictable UDP stack.
4543 struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */
4544 int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0];
4548 FD_SET(sockets[0], &rset);
4549 FD_SET(sockets[1], &rset);
4551 got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor);
4552 if (got != 2 || !FD_ISSET(sockets[0], &rset)
4553 || !FD_ISSET(sockets[1], &rset)) {
4554 /* I hope this is portable and appropriate. */
4556 goto tidy_up_and_fail;
4557 goto abort_tidy_up_and_fail;
4561 /* And the paranoia department even now doesn't trust it to have arrive
4562 (hence MSG_DONTWAIT). Or that what arrives was sent by us. */
4564 struct sockaddr_in readfrom;
4565 unsigned short buffer[2];
4570 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4571 sizeof(buffer), MSG_DONTWAIT,
4572 (struct sockaddr *) &readfrom, &size);
4574 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4576 (struct sockaddr *) &readfrom, &size);
4580 goto tidy_up_and_fail;
4581 if (got != sizeof(port)
4582 || size != sizeof(struct sockaddr_in)
4583 /* Check other socket sent us its port. */
4584 || buffer[0] != (unsigned short) addresses[!i].sin_port
4585 /* Check kernel says we got the datagram from that socket */
4586 || readfrom.sin_family != addresses[!i].sin_family
4587 || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr
4588 || readfrom.sin_port != addresses[!i].sin_port)
4589 goto abort_tidy_up_and_fail;
4592 /* My caller (my_socketpair) has validated that this is non-NULL */
4595 /* I hereby declare this connection open. May God bless all who cross
4599 abort_tidy_up_and_fail:
4600 errno = ECONNABORTED;
4603 const int save_errno = errno;
4604 if (sockets[0] != -1)
4605 PerlLIO_close(sockets[0]);
4606 if (sockets[1] != -1)
4607 PerlLIO_close(sockets[1]);
4612 #endif /* EMULATE_SOCKETPAIR_UDP */
4614 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET)
4616 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4617 /* Stevens says that family must be AF_LOCAL, protocol 0.
4618 I'm going to enforce that, then ignore it, and use TCP (or UDP). */
4623 struct sockaddr_in listen_addr;
4624 struct sockaddr_in connect_addr;
4629 || family != AF_UNIX
4632 errno = EAFNOSUPPORT;
4640 #ifdef EMULATE_SOCKETPAIR_UDP
4641 if (type == SOCK_DGRAM)
4642 return S_socketpair_udp(fd);
4645 listener = PerlSock_socket(AF_INET, type, 0);
4648 memset(&listen_addr, 0, sizeof(listen_addr));
4649 listen_addr.sin_family = AF_INET;
4650 listen_addr.sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4651 listen_addr.sin_port = 0; /* kernel choses port. */
4652 if (PerlSock_bind(listener, (struct sockaddr *) &listen_addr,
4653 sizeof(listen_addr)) == -1)
4654 goto tidy_up_and_fail;
4655 if (PerlSock_listen(listener, 1) == -1)
4656 goto tidy_up_and_fail;
4658 connector = PerlSock_socket(AF_INET, type, 0);
4659 if (connector == -1)
4660 goto tidy_up_and_fail;
4661 /* We want to find out the port number to connect to. */
4662 size = sizeof(connect_addr);
4663 if (PerlSock_getsockname(listener, (struct sockaddr *) &connect_addr,
4665 goto tidy_up_and_fail;
4666 if (size != sizeof(connect_addr))
4667 goto abort_tidy_up_and_fail;
4668 if (PerlSock_connect(connector, (struct sockaddr *) &connect_addr,
4669 sizeof(connect_addr)) == -1)
4670 goto tidy_up_and_fail;
4672 size = sizeof(listen_addr);
4673 acceptor = PerlSock_accept(listener, (struct sockaddr *) &listen_addr,
4676 goto tidy_up_and_fail;
4677 if (size != sizeof(listen_addr))
4678 goto abort_tidy_up_and_fail;
4679 PerlLIO_close(listener);
4680 /* Now check we are talking to ourself by matching port and host on the
4682 if (PerlSock_getsockname(connector, (struct sockaddr *) &connect_addr,
4684 goto tidy_up_and_fail;
4685 if (size != sizeof(connect_addr)
4686 || listen_addr.sin_family != connect_addr.sin_family
4687 || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr
4688 || listen_addr.sin_port != connect_addr.sin_port) {
4689 goto abort_tidy_up_and_fail;
4695 abort_tidy_up_and_fail:
4697 errno = ECONNABORTED; /* This would be the standard thing to do. */
4699 # ifdef ECONNREFUSED
4700 errno = ECONNREFUSED; /* E.g. Symbian does not have ECONNABORTED. */
4702 errno = ETIMEDOUT; /* Desperation time. */
4707 const int save_errno = errno;
4709 PerlLIO_close(listener);
4710 if (connector != -1)
4711 PerlLIO_close(connector);
4713 PerlLIO_close(acceptor);
4719 /* In any case have a stub so that there's code corresponding
4720 * to the my_socketpair in global.sym. */
4722 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4723 #ifdef HAS_SOCKETPAIR
4724 return socketpair(family, type, protocol, fd);
4733 =for apidoc sv_nosharing
4735 Dummy routine which "shares" an SV when there is no sharing module present.
4736 Or "locks" it. Or "unlocks" it. In other words, ignores its single SV argument.
4737 Exists to avoid test for a NULL function pointer and because it could
4738 potentially warn under some level of strict-ness.
4744 Perl_sv_nosharing(pTHX_ SV *sv)
4746 PERL_UNUSED_ARG(sv);
4750 Perl_parse_unicode_opts(pTHX_ const char **popt)
4752 const char *p = *popt;
4757 opt = (U32) atoi(p);
4758 while (isDIGIT(*p)) p++;
4759 if (*p && *p != '\n' && *p != '\r')
4760 Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
4765 case PERL_UNICODE_STDIN:
4766 opt |= PERL_UNICODE_STDIN_FLAG; break;
4767 case PERL_UNICODE_STDOUT:
4768 opt |= PERL_UNICODE_STDOUT_FLAG; break;
4769 case PERL_UNICODE_STDERR:
4770 opt |= PERL_UNICODE_STDERR_FLAG; break;
4771 case PERL_UNICODE_STD:
4772 opt |= PERL_UNICODE_STD_FLAG; break;
4773 case PERL_UNICODE_IN:
4774 opt |= PERL_UNICODE_IN_FLAG; break;
4775 case PERL_UNICODE_OUT:
4776 opt |= PERL_UNICODE_OUT_FLAG; break;
4777 case PERL_UNICODE_INOUT:
4778 opt |= PERL_UNICODE_INOUT_FLAG; break;
4779 case PERL_UNICODE_LOCALE:
4780 opt |= PERL_UNICODE_LOCALE_FLAG; break;
4781 case PERL_UNICODE_ARGV:
4782 opt |= PERL_UNICODE_ARGV_FLAG; break;
4784 if (*p != '\n' && *p != '\r')
4786 "Unknown Unicode option letter '%c'", *p);
4792 opt = PERL_UNICODE_DEFAULT_FLAGS;
4794 if (opt & ~PERL_UNICODE_ALL_FLAGS)
4795 Perl_croak(aTHX_ "Unknown Unicode option value %"UVuf,
4796 (UV) (opt & ~PERL_UNICODE_ALL_FLAGS));
4807 * This is really just a quick hack which grabs various garbage
4808 * values. It really should be a real hash algorithm which
4809 * spreads the effect of every input bit onto every output bit,
4810 * if someone who knows about such things would bother to write it.
4811 * Might be a good idea to add that function to CORE as well.
4812 * No numbers below come from careful analysis or anything here,
4813 * except they are primes and SEED_C1 > 1E6 to get a full-width
4814 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
4815 * probably be bigger too.
4818 # define SEED_C1 1000003
4819 #define SEED_C4 73819
4821 # define SEED_C1 25747
4822 #define SEED_C4 20639
4826 #define SEED_C5 26107
4828 #ifndef PERL_NO_DEV_RANDOM
4833 # include <starlet.h>
4834 /* when[] = (low 32 bits, high 32 bits) of time since epoch
4835 * in 100-ns units, typically incremented ever 10 ms. */
4836 unsigned int when[2];
4838 # ifdef HAS_GETTIMEOFDAY
4839 struct timeval when;
4845 /* This test is an escape hatch, this symbol isn't set by Configure. */
4846 #ifndef PERL_NO_DEV_RANDOM
4847 #ifndef PERL_RANDOM_DEVICE
4848 /* /dev/random isn't used by default because reads from it will block
4849 * if there isn't enough entropy available. You can compile with
4850 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
4851 * is enough real entropy to fill the seed. */
4852 # define PERL_RANDOM_DEVICE "/dev/urandom"
4854 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
4856 if (PerlLIO_read(fd, (void*)&u, sizeof u) != sizeof u)
4865 _ckvmssts(sys$gettim(when));
4866 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
4868 # ifdef HAS_GETTIMEOFDAY
4869 PerlProc_gettimeofday(&when,NULL);
4870 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
4873 u = (U32)SEED_C1 * when;
4876 u += SEED_C3 * (U32)PerlProc_getpid();
4877 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
4878 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
4879 u += SEED_C5 * (U32)PTR2UV(&when);
4885 Perl_get_hash_seed(pTHX)
4887 const char *s = PerlEnv_getenv("PERL_HASH_SEED");
4891 while (isSPACE(*s)) s++;
4892 if (s && isDIGIT(*s))
4893 myseed = (UV)Atoul(s);
4895 #ifdef USE_HASH_SEED_EXPLICIT
4899 /* Compute a random seed */
4900 (void)seedDrand01((Rand_seed_t)seed());
4901 myseed = (UV)(Drand01() * (NV)UV_MAX);
4902 #if RANDBITS < (UVSIZE * 8)
4903 /* Since there are not enough randbits to to reach all
4904 * the bits of a UV, the low bits might need extra
4905 * help. Sum in another random number that will
4906 * fill in the low bits. */
4908 (UV)(Drand01() * (NV)((1 << ((UVSIZE * 8 - RANDBITS))) - 1));
4909 #endif /* RANDBITS < (UVSIZE * 8) */
4910 if (myseed == 0) { /* Superparanoia. */
4911 myseed = (UV)(Drand01() * (NV)UV_MAX); /* One more chance. */
4913 Perl_croak(aTHX_ "Your random numbers are not that random");
4916 PL_rehash_seed_set = TRUE;
4923 Perl_stashpv_hvname_match(pTHX_ const COP *c, const HV *hv)
4925 const char * const stashpv = CopSTASHPV(c);
4926 const char * const name = HvNAME_get(hv);
4928 if (stashpv == name)
4930 if (stashpv && name)
4931 if (strEQ(stashpv, name))
4938 #ifdef PERL_GLOBAL_STRUCT
4941 Perl_init_global_struct(pTHX)
4943 struct perl_vars *plvarsp = NULL;
4944 #ifdef PERL_GLOBAL_STRUCT
4945 # define PERL_GLOBAL_STRUCT_INIT
4946 # include "opcode.h" /* the ppaddr and check */
4947 const IV nppaddr = sizeof(Gppaddr)/sizeof(Perl_ppaddr_t);
4948 const IV ncheck = sizeof(Gcheck) /sizeof(Perl_check_t);
4949 # ifdef PERL_GLOBAL_STRUCT_PRIVATE
4950 /* PerlMem_malloc() because can't use even safesysmalloc() this early. */
4951 plvarsp = (struct perl_vars*)PerlMem_malloc(sizeof(struct perl_vars));
4955 plvarsp = PL_VarsPtr;
4956 # endif /* PERL_GLOBAL_STRUCT_PRIVATE */
4962 # define PERLVAR(var,type) /**/
4963 # define PERLVARA(var,n,type) /**/
4964 # define PERLVARI(var,type,init) plvarsp->var = init;
4965 # define PERLVARIC(var,type,init) plvarsp->var = init;
4966 # define PERLVARISC(var,init) Copy(init, plvarsp->var, sizeof(init), char);
4967 # include "perlvars.h"
4973 # ifdef PERL_GLOBAL_STRUCT
4974 plvarsp->Gppaddr = PerlMem_malloc(nppaddr * sizeof(Perl_ppaddr_t));
4975 if (!plvarsp->Gppaddr)
4977 plvarsp->Gcheck = PerlMem_malloc(ncheck * sizeof(Perl_check_t));
4978 if (!plvarsp->Gcheck)
4980 Copy(Gppaddr, plvarsp->Gppaddr, nppaddr, Perl_ppaddr_t);
4981 Copy(Gcheck, plvarsp->Gcheck, ncheck, Perl_check_t);
4983 # ifdef PERL_SET_VARS
4984 PERL_SET_VARS(plvarsp);
4986 # undef PERL_GLOBAL_STRUCT_INIT
4991 #endif /* PERL_GLOBAL_STRUCT */
4993 #ifdef PERL_GLOBAL_STRUCT
4996 Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp)
4998 #ifdef PERL_GLOBAL_STRUCT
4999 # ifdef PERL_UNSET_VARS
5000 PERL_UNSET_VARS(plvarsp);
5002 free(plvarsp->Gppaddr);
5003 free(plvarsp->Gcheck);
5004 # ifdef PERL_GLOBAL_STRUCT_PRIVATE
5010 #endif /* PERL_GLOBAL_STRUCT */
5014 #define PERL_MEM_LOG_SPRINTF_BUF_SIZE 128
5017 Perl_mem_log_alloc(const UV n, const UV typesize, const char *typename, Malloc_t newalloc, const char *filename, const int linenumber, const char *funcname)
5019 #ifdef PERL_MEM_LOG_STDERR
5020 /* We can't use PerlIO for obvious reasons. */
5021 char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
5022 const STRLEN len = my_sprintf(buf,
5023 "alloc: %s:%d:%s: %"IVdf" %"UVuf
5024 " %s = %"IVdf": %"UVxf"\n",
5025 filename, linenumber, funcname, n, typesize,
5026 typename, n * typesize, PTR2UV(newalloc));
5027 PerlLIO_write(2, buf, len));
5033 Perl_mem_log_realloc(const UV n, const UV typesize, const char *typename, Malloc_t oldalloc, Malloc_t newalloc, const char *filename, const int linenumber, const char *funcname)
5035 #ifdef PERL_MEM_LOG_STDERR
5036 /* We can't use PerlIO for obvious reasons. */
5037 char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
5038 const STRLEN len = my_sprintf(buf, "realloc: %s:%d:%s: %"IVdf" %"UVuf
5039 " %s = %"IVdf": %"UVxf" -> %"UVxf"\n",
5040 filename, linenumber, funcname, n, typesize,
5041 typename, n * typesize, PTR2UV(oldalloc),
5043 PerlLIO_write(2, buf, len);
5049 Perl_mem_log_free(Malloc_t oldalloc, const char *filename, const int linenumber, const char *funcname)
5051 #ifdef PERL_MEM_LOG_STDERR
5052 /* We can't use PerlIO for obvious reasons. */
5053 char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
5054 const STRLEN len = my_sprintf(buf, "free: %s:%d:%s: %"UVxf"\n",
5055 filename, linenumber, funcname,
5057 PerlLIO_write(2, buf, len);
5062 #endif /* PERL_MEM_LOG */
5065 =for apidoc my_sprintf
5067 The C library C<sprintf>, wrapped if necessary, to ensure that it will return
5068 the length of the string written to the buffer. Only rare pre-ANSI systems
5069 need the wrapper function - usually this is a direct call to C<sprintf>.
5073 #ifndef SPRINTF_RETURNS_STRLEN
5075 Perl_my_sprintf(char *buffer, const char* pat, ...)
5078 va_start(args, pat);
5079 vsprintf(buffer, pat, args);
5081 return strlen(buffer);
5086 Perl_my_clearenv(pTHX)
5089 #if ! defined(PERL_MICRO)
5090 # if defined(PERL_IMPLICIT_SYS) || defined(WIN32)
5092 # else /* ! (PERL_IMPLICIT_SYS || WIN32) */
5093 # if defined(USE_ENVIRON_ARRAY)
5094 # if defined(USE_ITHREADS)
5095 /* only the parent thread can clobber the process environment */
5096 if (PL_curinterp == aTHX)
5097 # endif /* USE_ITHREADS */
5099 # if ! defined(PERL_USE_SAFE_PUTENV)
5100 if ( !PL_use_safe_putenv) {
5102 if (environ == PL_origenviron)
5103 environ = (char**)safesysmalloc(sizeof(char*));
5105 for (i = 0; environ[i]; i++)
5106 (void)safesysfree(environ[i]);
5109 # else /* PERL_USE_SAFE_PUTENV */
5110 # if defined(HAS_CLEARENV)
5112 # elif defined(HAS_UNSETENV)
5113 int bsiz = 80; /* Most envvar names will be shorter than this. */
5114 char *buf = (char*)safesysmalloc(bsiz * sizeof(char));
5115 while (*environ != NULL) {
5116 char *e = strchr(*environ, '=');
5117 int l = e ? e - *environ : strlen(*environ);
5119 (void)safesysfree(buf);
5121 buf = (char*)safesysmalloc(bsiz * sizeof(char));
5123 strncpy(buf, *environ, l);
5125 (void)unsetenv(buf);
5127 (void)safesysfree(buf);
5128 # else /* ! HAS_CLEARENV && ! HAS_UNSETENV */
5129 /* Just null environ and accept the leakage. */
5131 # endif /* HAS_CLEARENV || HAS_UNSETENV */
5132 # endif /* ! PERL_USE_SAFE_PUTENV */
5134 # endif /* USE_ENVIRON_ARRAY */
5135 # endif /* PERL_IMPLICIT_SYS || WIN32 */
5136 #endif /* PERL_MICRO */
5141 * c-indentation-style: bsd
5143 * indent-tabs-mode: t
5146 * ex: set ts=8 sts=4 sw=4 noet: