3 * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * "Very useful, no doubt, that was to Saruman; yet it seems that he was
13 * not content." --Gandalf
16 /* This file contains assorted utility routines.
17 * Which is a polite way of saying any stuff that people couldn't think of
18 * a better place for. Amongst other things, it includes the warning and
19 * dieing stuff, plus wrappers for malloc code.
23 #define PERL_IN_UTIL_C
29 # define SIG_ERR ((Sighandler_t) -1)
34 /* Missing protos on LynxOS */
39 # include <sys/wait.h>
44 # include <sys/select.h>
50 #if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC)
51 # define FD_CLOEXEC 1 /* NeXT needs this */
54 /* NOTE: Do not call the next three routines directly. Use the macros
55 * in handy.h, so that we can easily redefine everything to do tracking of
56 * allocated hunks back to the original New to track down any memory leaks.
57 * XXX This advice seems to be widely ignored :-( --AD August 1996.
60 /* paranoid version of system's malloc() */
63 Perl_safesysmalloc(MEM_SIZE size)
69 PerlIO_printf(Perl_error_log,
70 "Allocation too large: %lx\n", size) FLUSH;
73 #endif /* HAS_64K_LIMIT */
76 Perl_croak_nocontext("panic: malloc");
78 ptr = (Malloc_t)PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */
79 PERL_ALLOC_CHECK(ptr);
80 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
86 /* Can't use PerlIO to write as it allocates memory */
87 PerlLIO_write(PerlIO_fileno(Perl_error_log),
88 PL_no_mem, strlen(PL_no_mem));
95 /* paranoid version of system's realloc() */
98 Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
102 #if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) && !defined(PERL_MICRO)
103 Malloc_t PerlMem_realloc();
104 #endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */
108 PerlIO_printf(Perl_error_log,
109 "Reallocation too large: %lx\n", size) FLUSH;
112 #endif /* HAS_64K_LIMIT */
119 return safesysmalloc(size);
122 Perl_croak_nocontext("panic: realloc");
124 ptr = (Malloc_t)PerlMem_realloc(where,size);
125 PERL_ALLOC_CHECK(ptr);
127 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++));
128 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
135 /* Can't use PerlIO to write as it allocates memory */
136 PerlLIO_write(PerlIO_fileno(Perl_error_log),
137 PL_no_mem, strlen(PL_no_mem));
144 /* safe version of system's free() */
147 Perl_safesysfree(Malloc_t where)
150 #ifdef PERL_IMPLICIT_SYS
153 DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) free\n",PTR2UV(where),(long)PL_an++));
159 /* safe version of system's calloc() */
162 Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
168 if (size * count > 0xffff) {
169 PerlIO_printf(Perl_error_log,
170 "Allocation too large: %lx\n", size * count) FLUSH;
173 #endif /* HAS_64K_LIMIT */
175 if ((long)size < 0 || (long)count < 0)
176 Perl_croak_nocontext("panic: calloc");
179 ptr = (Malloc_t)PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */
180 PERL_ALLOC_CHECK(ptr);
181 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));
183 memset((void*)ptr, 0, size);
189 /* Can't use PerlIO to write as it allocates memory */
190 PerlLIO_write(PerlIO_fileno(Perl_error_log),
191 PL_no_mem, strlen(PL_no_mem));
198 /* These must be defined when not using Perl's malloc for binary
203 Malloc_t Perl_malloc (MEM_SIZE nbytes)
206 return (Malloc_t)PerlMem_malloc(nbytes);
209 Malloc_t Perl_calloc (MEM_SIZE elements, MEM_SIZE size)
212 return (Malloc_t)PerlMem_calloc(elements, size);
215 Malloc_t Perl_realloc (Malloc_t where, MEM_SIZE nbytes)
218 return (Malloc_t)PerlMem_realloc(where, nbytes);
221 Free_t Perl_mfree (Malloc_t where)
229 /* copy a string up to some (non-backslashed) delimiter, if any */
232 Perl_delimcpy(pTHX_ register char *to, register const char *toend, register const char *from, register const char *fromend, register int delim, I32 *retlen)
235 for (tolen = 0; from < fromend; from++, tolen++) {
237 if (from[1] == delim)
246 else if (*from == delim)
257 /* return ptr to little string in big string, NULL if not found */
258 /* This routine was donated by Corey Satten. */
261 Perl_instr(pTHX_ register const char *big, register const char *little)
271 register const char *s, *x;
274 for (x=big,s=little; *s; /**/ ) {
283 return (char*)(big-1);
288 /* same as instr but allow embedded nulls */
291 Perl_ninstr(pTHX_ register const char *big, register const char *bigend, const char *little, const char *lend)
293 register const I32 first = *little;
294 register const char *littleend = lend;
296 if (!first && little >= littleend)
298 if (bigend - big < littleend - little)
300 bigend -= littleend - little++;
301 while (big <= bigend) {
302 register const char *s, *x;
305 for (x=big,s=little; s < littleend; /**/ ) {
312 return (char*)(big-1);
317 /* reverse of the above--find last substring */
320 Perl_rninstr(pTHX_ register const char *big, const char *bigend, const char *little, const char *lend)
322 register const char *bigbeg;
323 register const I32 first = *little;
324 register const char *littleend = lend;
326 if (!first && little >= littleend)
327 return (char*)bigend;
329 big = bigend - (littleend - little++);
330 while (big >= bigbeg) {
331 register const char *s, *x;
334 for (x=big+2,s=little; s < littleend; /**/ ) {
341 return (char*)(big+1);
346 #define FBM_TABLE_OFFSET 2 /* Number of bytes between EOS and table*/
348 /* As a space optimization, we do not compile tables for strings of length
349 0 and 1, and for strings of length 2 unless FBMcf_TAIL. These are
350 special-cased in fbm_instr().
352 If FBMcf_TAIL, the table is created as if the string has a trailing \n. */
355 =head1 Miscellaneous Functions
357 =for apidoc fbm_compile
359 Analyses the string in order to make fast searches on it using fbm_instr()
360 -- the Boyer-Moore algorithm.
366 Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
368 register const U8 *s;
374 if (flags & FBMcf_TAIL) {
375 MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
376 sv_catpvn(sv, "\n", 1); /* Taken into account in fbm_instr() */
377 if (mg && mg->mg_len >= 0)
380 s = (U8*)SvPV_force_mutable(sv, len);
381 SvUPGRADE(sv, SVt_PVBM);
382 if (len == 0) /* TAIL might be on a zero-length string. */
385 const unsigned char *sb;
386 const U8 mlen = (len>255) ? 255 : (U8)len;
389 Sv_Grow(sv, len + 256 + FBM_TABLE_OFFSET);
390 table = (unsigned char*)(SvPVX_mutable(sv) + len + FBM_TABLE_OFFSET);
391 s = table - 1 - FBM_TABLE_OFFSET; /* last char */
392 memset((void*)table, mlen, 256);
393 table[-1] = (U8)flags;
395 sb = s - mlen + 1; /* first char (maybe) */
397 if (table[*s] == mlen)
402 sv_magic(sv, Nullsv, PERL_MAGIC_bm, Nullch, 0); /* deep magic */
405 s = (const unsigned char*)(SvPVX_const(sv)); /* deeper magic */
406 for (i = 0; i < len; i++) {
407 if (PL_freq[s[i]] < frequency) {
409 frequency = PL_freq[s[i]];
412 BmRARE(sv) = s[rarest];
413 BmPREVIOUS(sv) = (U16)rarest;
414 BmUSEFUL(sv) = 100; /* Initial value */
415 if (flags & FBMcf_TAIL)
417 DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %d\n",
418 BmRARE(sv),BmPREVIOUS(sv)));
421 /* If SvTAIL(littlestr), it has a fake '\n' at end. */
422 /* If SvTAIL is actually due to \Z or \z, this gives false positives
426 =for apidoc fbm_instr
428 Returns the location of the SV in the string delimited by C<str> and
429 C<strend>. It returns C<Nullch> if the string can't be found. The C<sv>
430 does not have to be fbm_compiled, but the search will not be as fast
437 Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *littlestr, U32 flags)
439 register unsigned char *s;
441 register const unsigned char *little
442 = (const unsigned char *)SvPV_const(littlestr,l);
443 register STRLEN littlelen = l;
444 register const I32 multiline = flags & FBMrf_MULTILINE;
446 if ((STRLEN)(bigend - big) < littlelen) {
447 if ( SvTAIL(littlestr)
448 && ((STRLEN)(bigend - big) == littlelen - 1)
450 || (*big == *little &&
451 memEQ((char *)big, (char *)little, littlelen - 1))))
456 if (littlelen <= 2) { /* Special-cased */
458 if (littlelen == 1) {
459 if (SvTAIL(littlestr) && !multiline) { /* Anchor only! */
460 /* Know that bigend != big. */
461 if (bigend[-1] == '\n')
462 return (char *)(bigend - 1);
463 return (char *) bigend;
471 if (SvTAIL(littlestr))
472 return (char *) bigend;
476 return (char*)big; /* Cannot be SvTAIL! */
479 if (SvTAIL(littlestr) && !multiline) {
480 if (bigend[-1] == '\n' && bigend[-2] == *little)
481 return (char*)bigend - 2;
482 if (bigend[-1] == *little)
483 return (char*)bigend - 1;
487 /* This should be better than FBM if c1 == c2, and almost
488 as good otherwise: maybe better since we do less indirection.
489 And we save a lot of memory by caching no table. */
490 const unsigned char c1 = little[0];
491 const unsigned char c2 = little[1];
496 while (s <= bigend) {
506 goto check_1char_anchor;
517 goto check_1char_anchor;
520 while (s <= bigend) {
525 goto check_1char_anchor;
534 check_1char_anchor: /* One char and anchor! */
535 if (SvTAIL(littlestr) && (*bigend == *little))
536 return (char *)bigend; /* bigend is already decremented. */
539 if (SvTAIL(littlestr) && !multiline) { /* tail anchored? */
540 s = bigend - littlelen;
541 if (s >= big && bigend[-1] == '\n' && *s == *little
542 /* Automatically of length > 2 */
543 && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
545 return (char*)s; /* how sweet it is */
548 && memEQ((char*)s + 2, (char*)little + 1, littlelen - 2))
550 return (char*)s + 1; /* how sweet it is */
554 if (SvTYPE(littlestr) != SVt_PVBM || !SvVALID(littlestr)) {
555 char *b = ninstr((char*)big,(char*)bigend,
556 (char*)little, (char*)little + littlelen);
558 if (!b && SvTAIL(littlestr)) { /* Automatically multiline! */
559 /* Chop \n from littlestr: */
560 s = bigend - littlelen + 1;
562 && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
571 { /* Do actual FBM. */
572 register const unsigned char *table = little + littlelen + FBM_TABLE_OFFSET;
573 register const unsigned char *oldlittle;
575 if (littlelen > (STRLEN)(bigend - big))
577 --littlelen; /* Last char found by table lookup */
580 little += littlelen; /* last char */
586 if ((tmp = table[*s])) {
587 if ((s += tmp) < bigend)
591 else { /* less expensive than calling strncmp() */
592 register unsigned char * const olds = s;
597 if (*--s == *--little)
599 s = olds + 1; /* here we pay the price for failure */
601 if (s < bigend) /* fake up continue to outer loop */
609 if ( s == bigend && (table[-1] & FBMcf_TAIL)
610 && memEQ((char *)(bigend - littlelen),
611 (char *)(oldlittle - littlelen), littlelen) )
612 return (char*)bigend - littlelen;
617 /* start_shift, end_shift are positive quantities which give offsets
618 of ends of some substring of bigstr.
619 If "last" we want the last occurrence.
620 old_posp is the way of communication between consequent calls if
621 the next call needs to find the .
622 The initial *old_posp should be -1.
624 Note that we take into account SvTAIL, so one can get extra
625 optimizations if _ALL flag is set.
628 /* If SvTAIL is actually due to \Z or \z, this gives false positives
629 if PL_multiline. In fact if !PL_multiline the authoritative answer
630 is not supported yet. */
633 Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last)
635 register const unsigned char *big;
637 register I32 previous;
639 register const unsigned char *little;
640 register I32 stop_pos;
641 register const unsigned char *littleend;
645 ? (pos = PL_screamfirst[BmRARE(littlestr)]) < 0
646 : (((pos = *old_posp), pos += PL_screamnext[pos]) == 0)) {
648 if ( BmRARE(littlestr) == '\n'
649 && BmPREVIOUS(littlestr) == SvCUR(littlestr) - 1) {
650 little = (const unsigned char *)(SvPVX_const(littlestr));
651 littleend = little + SvCUR(littlestr);
658 little = (const unsigned char *)(SvPVX_const(littlestr));
659 littleend = little + SvCUR(littlestr);
661 /* The value of pos we can start at: */
662 previous = BmPREVIOUS(littlestr);
663 big = (const unsigned char *)(SvPVX_const(bigstr));
664 /* The value of pos we can stop at: */
665 stop_pos = SvCUR(bigstr) - end_shift - (SvCUR(littlestr) - 1 - previous);
666 if (previous + start_shift > stop_pos) {
668 stop_pos does not include SvTAIL in the count, so this check is incorrect
669 (I think) - see [ID 20010618.006] and t/op/study.t. HVDS 2001/06/19
672 if (previous + start_shift == stop_pos + 1) /* A fake '\n'? */
677 while (pos < previous + start_shift) {
678 if (!(pos += PL_screamnext[pos]))
683 register const unsigned char *s, *x;
684 if (pos >= stop_pos) break;
685 if (big[pos] != first)
687 for (x=big+pos+1,s=little; s < littleend; /**/ ) {
693 if (s == littleend) {
695 if (!last) return (char *)(big+pos);
698 } while ( pos += PL_screamnext[pos] );
700 return (char *)(big+(*old_posp));
702 if (!SvTAIL(littlestr) || (end_shift > 0))
704 /* Ignore the trailing "\n". This code is not microoptimized */
705 big = (const unsigned char *)(SvPVX_const(bigstr) + SvCUR(bigstr));
706 stop_pos = littleend - little; /* Actual littlestr len */
711 && ((stop_pos == 1) ||
712 memEQ((char *)(big + 1), (char *)little, stop_pos - 1)))
718 Perl_ibcmp(pTHX_ const char *s1, const char *s2, register I32 len)
720 register const U8 *a = (const U8 *)s1;
721 register const U8 *b = (const U8 *)s2;
723 if (*a != *b && *a != PL_fold[*b])
731 Perl_ibcmp_locale(pTHX_ const char *s1, const char *s2, register I32 len)
734 register const U8 *a = (const U8 *)s1;
735 register const U8 *b = (const U8 *)s2;
737 if (*a != *b && *a != PL_fold_locale[*b])
744 /* copy a string to a safe spot */
747 =head1 Memory Management
751 Perl's version of C<strdup()>. Returns a pointer to a newly allocated
752 string which is a duplicate of C<pv>. The size of the string is
753 determined by C<strlen()>. The memory allocated for the new string can
754 be freed with the C<Safefree()> function.
760 Perl_savepv(pTHX_ const char *pv)
766 const STRLEN pvlen = strlen(pv)+1;
767 Newx(newaddr,pvlen,char);
768 return memcpy(newaddr,pv,pvlen);
773 /* same thing but with a known length */
778 Perl's version of what C<strndup()> would be if it existed. Returns a
779 pointer to a newly allocated string which is a duplicate of the first
780 C<len> bytes from C<pv>. The memory allocated for the new string can be
781 freed with the C<Safefree()> function.
787 Perl_savepvn(pTHX_ const char *pv, register I32 len)
789 register char *newaddr;
791 Newx(newaddr,len+1,char);
792 /* Give a meaning to NULL pointer mainly for the use in sv_magic() */
794 /* might not be null terminated */
796 return (char *) CopyD(pv,newaddr,len,char);
799 return (char *) ZeroD(newaddr,len+1,char);
804 =for apidoc savesharedpv
806 A version of C<savepv()> which allocates the duplicate string in memory
807 which is shared between threads.
812 Perl_savesharedpv(pTHX_ const char *pv)
814 register char *newaddr;
819 pvlen = strlen(pv)+1;
820 newaddr = (char*)PerlMemShared_malloc(pvlen);
822 PerlLIO_write(PerlIO_fileno(Perl_error_log),
823 PL_no_mem, strlen(PL_no_mem));
826 return memcpy(newaddr,pv,pvlen);
832 A version of C<savepv()>/C<savepvn()> which gets the string to duplicate from
833 the passed in SV using C<SvPV()>
839 Perl_savesvpv(pTHX_ SV *sv)
842 const char *pv = SvPV_const(sv, len);
843 register char *newaddr;
846 Newx(newaddr,len,char);
847 return (char *) CopyD(pv,newaddr,len,char);
851 /* the SV for Perl_form() and mess() is not kept in an arena */
860 return sv_2mortal(newSVpvn("",0));
865 /* Create as PVMG now, to avoid any upgrading later */
867 Newxz(any, 1, XPVMG);
868 SvFLAGS(sv) = SVt_PVMG;
869 SvANY(sv) = (void*)any;
871 SvREFCNT(sv) = 1 << 30; /* practically infinite */
876 #if defined(PERL_IMPLICIT_CONTEXT)
878 Perl_form_nocontext(const char* pat, ...)
884 retval = vform(pat, &args);
888 #endif /* PERL_IMPLICIT_CONTEXT */
891 =head1 Miscellaneous Functions
894 Takes a sprintf-style format pattern and conventional
895 (non-SV) arguments and returns the formatted string.
897 (char *) Perl_form(pTHX_ const char* pat, ...)
899 can be used any place a string (char *) is required:
901 char * s = Perl_form("%d.%d",major,minor);
903 Uses a single private buffer so if you want to format several strings you
904 must explicitly copy the earlier strings away (and free the copies when you
911 Perl_form(pTHX_ const char* pat, ...)
916 retval = vform(pat, &args);
922 Perl_vform(pTHX_ const char *pat, va_list *args)
924 SV * const sv = mess_alloc();
925 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
929 #if defined(PERL_IMPLICIT_CONTEXT)
931 Perl_mess_nocontext(const char *pat, ...)
937 retval = vmess(pat, &args);
941 #endif /* PERL_IMPLICIT_CONTEXT */
944 Perl_mess(pTHX_ const char *pat, ...)
949 retval = vmess(pat, &args);
955 S_closest_cop(pTHX_ COP *cop, const OP *o)
957 /* Look for PL_op starting from o. cop is the last COP we've seen. */
959 if (!o || o == PL_op) return cop;
961 if (o->op_flags & OPf_KIDS) {
963 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
967 /* If the OP_NEXTSTATE has been optimised away we can still use it
968 * the get the file and line number. */
970 if (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE)
973 /* Keep searching, and return when we've found something. */
975 new_cop = closest_cop(cop, kid);
976 if (new_cop) return new_cop;
986 Perl_vmess(pTHX_ const char *pat, va_list *args)
988 SV *sv = mess_alloc();
989 static const char dgd[] = " during global destruction.\n";
991 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
992 if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
995 * Try and find the file and line for PL_op. This will usually be
996 * PL_curcop, but it might be a cop that has been optimised away. We
997 * can try to find such a cop by searching through the optree starting
998 * from the sibling of PL_curcop.
1001 const COP *cop = closest_cop(PL_curcop, PL_curcop->op_sibling);
1002 if (!cop) cop = PL_curcop;
1005 Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf,
1006 OutCopFILE(cop), (IV)CopLINE(cop));
1007 if (GvIO(PL_last_in_gv) && IoLINES(GvIOp(PL_last_in_gv))) {
1008 const bool line_mode = (RsSIMPLE(PL_rs) &&
1009 SvCUR(PL_rs) == 1 && *SvPVX_const(PL_rs) == '\n');
1010 Perl_sv_catpvf(aTHX_ sv, ", <%s> %s %"IVdf,
1011 PL_last_in_gv == PL_argvgv ?
1012 "" : GvNAME(PL_last_in_gv),
1013 line_mode ? "line" : "chunk",
1014 (IV)IoLINES(GvIOp(PL_last_in_gv)));
1016 sv_catpv(sv, PL_dirty ? dgd : ".\n");
1022 Perl_write_to_stderr(pTHX_ const char* message, int msglen)
1028 if (PL_stderrgv && SvREFCNT(PL_stderrgv)
1029 && (io = GvIO(PL_stderrgv))
1030 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
1037 SAVESPTR(PL_stderrgv);
1038 PL_stderrgv = Nullgv;
1040 PUSHSTACKi(PERLSI_MAGIC);
1044 PUSHs(SvTIED_obj((SV*)io, mg));
1045 PUSHs(sv_2mortal(newSVpvn(message, msglen)));
1047 call_method("PRINT", G_SCALAR);
1055 /* SFIO can really mess with your errno */
1056 const int e = errno;
1058 PerlIO * const serr = Perl_error_log;
1060 PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
1061 (void)PerlIO_flush(serr);
1068 /* Common code used by vcroak, vdie and vwarner */
1071 S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8)
1076 /* sv_2cv might call Perl_croak() */
1077 SV * const olddiehook = PL_diehook;
1081 SAVESPTR(PL_diehook);
1082 PL_diehook = Nullsv;
1083 cv = sv_2cv(olddiehook, &stash, &gv, 0);
1085 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1092 msg = newSVpvn(message, msglen);
1093 SvFLAGS(msg) |= utf8;
1101 PUSHSTACKi(PERLSI_DIEHOOK);
1105 call_sv((SV*)cv, G_DISCARD);
1112 S_vdie_croak_common(pTHX_ const char* pat, va_list* args, STRLEN* msglen,
1116 const char *message;
1119 SV * const msv = vmess(pat, args);
1120 if (PL_errors && SvCUR(PL_errors)) {
1121 sv_catsv(PL_errors, msv);
1122 message = SvPV_const(PL_errors, *msglen);
1123 SvCUR_set(PL_errors, 0);
1126 message = SvPV_const(msv,*msglen);
1127 *utf8 = SvUTF8(msv);
1133 DEBUG_S(PerlIO_printf(Perl_debug_log,
1134 "%p: die/croak: message = %s\ndiehook = %p\n",
1135 thr, message, PL_diehook));
1137 S_vdie_common(aTHX_ message, *msglen, *utf8);
1143 Perl_vdie(pTHX_ const char* pat, va_list *args)
1145 const char *message;
1146 const int was_in_eval = PL_in_eval;
1150 DEBUG_S(PerlIO_printf(Perl_debug_log,
1151 "%p: die: curstack = %p, mainstack = %p\n",
1152 thr, PL_curstack, PL_mainstack));
1154 message = vdie_croak_common(pat, args, &msglen, &utf8);
1156 PL_restartop = die_where(message, msglen);
1157 SvFLAGS(ERRSV) |= utf8;
1158 DEBUG_S(PerlIO_printf(Perl_debug_log,
1159 "%p: die: restartop = %p, was_in_eval = %d, top_env = %p\n",
1160 thr, PL_restartop, was_in_eval, PL_top_env));
1161 if ((!PL_restartop && was_in_eval) || PL_top_env->je_prev)
1163 return PL_restartop;
1166 #if defined(PERL_IMPLICIT_CONTEXT)
1168 Perl_die_nocontext(const char* pat, ...)
1173 va_start(args, pat);
1174 o = vdie(pat, &args);
1178 #endif /* PERL_IMPLICIT_CONTEXT */
1181 Perl_die(pTHX_ const char* pat, ...)
1185 va_start(args, pat);
1186 o = vdie(pat, &args);
1192 Perl_vcroak(pTHX_ const char* pat, va_list *args)
1194 const char *message;
1198 message = S_vdie_croak_common(aTHX_ pat, args, &msglen, &utf8);
1201 PL_restartop = die_where(message, msglen);
1202 SvFLAGS(ERRSV) |= utf8;
1206 message = SvPVx_const(ERRSV, msglen);
1208 write_to_stderr(message, msglen);
1212 #if defined(PERL_IMPLICIT_CONTEXT)
1214 Perl_croak_nocontext(const char *pat, ...)
1218 va_start(args, pat);
1223 #endif /* PERL_IMPLICIT_CONTEXT */
1226 =head1 Warning and Dieing
1230 This is the XSUB-writer's interface to Perl's C<die> function.
1231 Normally call this function the same way you call the C C<printf>
1232 function. Calling C<croak> returns control directly to Perl,
1233 sidestepping the normal C order of execution. See C<warn>.
1235 If you want to throw an exception object, assign the object to
1236 C<$@> and then pass C<Nullch> to croak():
1238 errsv = get_sv("@", TRUE);
1239 sv_setsv(errsv, exception_object);
1246 Perl_croak(pTHX_ const char *pat, ...)
1249 va_start(args, pat);
1256 Perl_vwarn(pTHX_ const char* pat, va_list *args)
1260 SV * const msv = vmess(pat, args);
1261 const I32 utf8 = SvUTF8(msv);
1262 const char * const message = SvPV_const(msv, msglen);
1265 /* sv_2cv might call Perl_warn() */
1266 SV * const oldwarnhook = PL_warnhook;
1272 SAVESPTR(PL_warnhook);
1273 PL_warnhook = Nullsv;
1274 cv = sv_2cv(oldwarnhook, &stash, &gv, 0);
1276 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1281 SAVESPTR(PL_warnhook);
1282 PL_warnhook = Nullsv;
1284 msg = newSVpvn(message, msglen);
1285 SvFLAGS(msg) |= utf8;
1289 PUSHSTACKi(PERLSI_WARNHOOK);
1293 call_sv((SV*)cv, G_DISCARD);
1300 write_to_stderr(message, msglen);
1303 #if defined(PERL_IMPLICIT_CONTEXT)
1305 Perl_warn_nocontext(const char *pat, ...)
1309 va_start(args, pat);
1313 #endif /* PERL_IMPLICIT_CONTEXT */
1318 This is the XSUB-writer's interface to Perl's C<warn> function. Call this
1319 function the same way you call the C C<printf> function. See C<croak>.
1325 Perl_warn(pTHX_ const char *pat, ...)
1328 va_start(args, pat);
1333 #if defined(PERL_IMPLICIT_CONTEXT)
1335 Perl_warner_nocontext(U32 err, const char *pat, ...)
1339 va_start(args, pat);
1340 vwarner(err, pat, &args);
1343 #endif /* PERL_IMPLICIT_CONTEXT */
1346 Perl_warner(pTHX_ U32 err, const char* pat,...)
1349 va_start(args, pat);
1350 vwarner(err, pat, &args);
1355 Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args)
1359 SV * const msv = vmess(pat, args);
1361 const char *message = SvPV_const(msv, msglen);
1362 const I32 utf8 = SvUTF8(msv);
1366 S_vdie_common(aTHX_ message, msglen, utf8);
1369 PL_restartop = die_where(message, msglen);
1370 SvFLAGS(ERRSV) |= utf8;
1373 write_to_stderr(message, msglen);
1377 Perl_vwarn(aTHX_ pat, args);
1381 /* implements the ckWARN? macros */
1384 Perl_ckwarn(pTHX_ U32 w)
1389 && PL_curcop->cop_warnings != pWARN_NONE
1391 PL_curcop->cop_warnings == pWARN_ALL
1392 || isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w))
1393 || (unpackWARN2(w) &&
1394 isWARN_on(PL_curcop->cop_warnings, unpackWARN2(w)))
1395 || (unpackWARN3(w) &&
1396 isWARN_on(PL_curcop->cop_warnings, unpackWARN3(w)))
1397 || (unpackWARN4(w) &&
1398 isWARN_on(PL_curcop->cop_warnings, unpackWARN4(w)))
1403 isLEXWARN_off && PL_dowarn & G_WARN_ON
1408 /* implements the ckWARN?_d macro */
1411 Perl_ckwarn_d(pTHX_ U32 w)
1415 || PL_curcop->cop_warnings == pWARN_ALL
1417 PL_curcop->cop_warnings != pWARN_NONE
1419 isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w))
1420 || (unpackWARN2(w) &&
1421 isWARN_on(PL_curcop->cop_warnings, unpackWARN2(w)))
1422 || (unpackWARN3(w) &&
1423 isWARN_on(PL_curcop->cop_warnings, unpackWARN3(w)))
1424 || (unpackWARN4(w) &&
1425 isWARN_on(PL_curcop->cop_warnings, unpackWARN4(w)))
1433 /* since we've already done strlen() for both nam and val
1434 * we can use that info to make things faster than
1435 * sprintf(s, "%s=%s", nam, val)
1437 #define my_setenv_format(s, nam, nlen, val, vlen) \
1438 Copy(nam, s, nlen, char); \
1440 Copy(val, s+(nlen+1), vlen, char); \
1441 *(s+(nlen+1+vlen)) = '\0'
1443 #ifdef USE_ENVIRON_ARRAY
1444 /* VMS' my_setenv() is in vms.c */
1445 #if !defined(WIN32) && !defined(NETWARE)
1447 Perl_my_setenv(pTHX_ const char *nam, const char *val)
1451 /* only parent thread can modify process environment */
1452 if (PL_curinterp == aTHX)
1455 #ifndef PERL_USE_SAFE_PUTENV
1456 if (!PL_use_safe_putenv) {
1457 /* most putenv()s leak, so we manipulate environ directly */
1458 register I32 i=setenv_getix(nam); /* where does it go? */
1461 if (environ == PL_origenviron) { /* need we copy environment? */
1466 for (max = i; environ[max]; max++) ;
1467 tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*));
1468 for (j=0; j<max; j++) { /* copy environment */
1469 const int len = strlen(environ[j]);
1470 tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char));
1471 Copy(environ[j], tmpenv[j], len+1, char);
1473 tmpenv[max] = Nullch;
1474 environ = tmpenv; /* tell exec where it is now */
1477 safesysfree(environ[i]);
1478 while (environ[i]) {
1479 environ[i] = environ[i+1];
1484 if (!environ[i]) { /* does not exist yet */
1485 environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
1486 environ[i+1] = Nullch; /* make sure it's null terminated */
1489 safesysfree(environ[i]);
1493 environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char));
1494 /* all that work just for this */
1495 my_setenv_format(environ[i], nam, nlen, val, vlen);
1498 # if defined(__CYGWIN__) || defined(EPOC) || defined(__SYMBIAN32__)
1499 # if defined(HAS_UNSETENV)
1501 (void)unsetenv(nam);
1503 (void)setenv(nam, val, 1);
1505 # else /* ! HAS_UNSETENV */
1506 (void)setenv(nam, val, 1);
1507 # endif /* HAS_UNSETENV */
1509 # if defined(HAS_UNSETENV)
1511 (void)unsetenv(nam);
1513 int nlen = strlen(nam);
1514 int vlen = strlen(val);
1516 (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
1517 my_setenv_format(new_env, nam, nlen, val, vlen);
1518 (void)putenv(new_env);
1520 # else /* ! HAS_UNSETENV */
1522 int nlen = strlen(nam), vlen;
1527 new_env = (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
1528 /* all that work just for this */
1529 my_setenv_format(new_env, nam, nlen, val, vlen);
1530 (void)putenv(new_env);
1531 # endif /* HAS_UNSETENV */
1532 # endif /* __CYGWIN__ */
1533 #ifndef PERL_USE_SAFE_PUTENV
1539 #else /* WIN32 || NETWARE */
1542 Perl_my_setenv(pTHX_ const char *nam, const char *val)
1545 register char *envstr;
1546 const int nlen = strlen(nam);
1553 Newx(envstr, nlen+vlen+2, char);
1554 my_setenv_format(envstr, nam, nlen, val, vlen);
1555 (void)PerlEnv_putenv(envstr);
1559 #endif /* WIN32 || NETWARE */
1563 Perl_setenv_getix(pTHX_ const char *nam)
1566 register const I32 len = strlen(nam);
1568 for (i = 0; environ[i]; i++) {
1571 strnicmp(environ[i],nam,len) == 0
1573 strnEQ(environ[i],nam,len)
1575 && environ[i][len] == '=')
1576 break; /* strnEQ must come first to avoid */
1577 } /* potential SEGV's */
1580 #endif /* !PERL_MICRO */
1582 #endif /* !VMS && !EPOC*/
1584 #ifdef UNLINK_ALL_VERSIONS
1586 Perl_unlnk(pTHX_ const char *f) /* unlink all versions of a file */
1590 for (i = 0; PerlLIO_unlink(f) >= 0; i++) ;
1595 /* this is a drop-in replacement for bcopy() */
1596 #if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY))
1598 Perl_my_bcopy(register const char *from,register char *to,register I32 len)
1600 char * const retval = to;
1602 if (from - to >= 0) {
1610 *(--to) = *(--from);
1616 /* this is a drop-in replacement for memset() */
1619 Perl_my_memset(register char *loc, register I32 ch, register I32 len)
1621 char * const retval = loc;
1629 /* this is a drop-in replacement for bzero() */
1630 #if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
1632 Perl_my_bzero(register char *loc, register I32 len)
1634 char * const retval = loc;
1642 /* this is a drop-in replacement for memcmp() */
1643 #if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
1645 Perl_my_memcmp(const char *s1, const char *s2, register I32 len)
1647 register const U8 *a = (const U8 *)s1;
1648 register const U8 *b = (const U8 *)s2;
1652 if ((tmp = *a++ - *b++))
1657 #endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */
1661 #ifdef USE_CHAR_VSPRINTF
1666 vsprintf(char *dest, const char *pat, char *args)
1670 fakebuf._ptr = dest;
1671 fakebuf._cnt = 32767;
1675 fakebuf._flag = _IOWRT|_IOSTRG;
1676 _doprnt(pat, args, &fakebuf); /* what a kludge */
1677 (void)putc('\0', &fakebuf);
1678 #ifdef USE_CHAR_VSPRINTF
1681 return 0; /* perl doesn't use return value */
1685 #endif /* HAS_VPRINTF */
1688 #if BYTEORDER != 0x4321
1690 Perl_my_swap(pTHX_ short s)
1692 #if (BYTEORDER & 1) == 0
1695 result = ((s & 255) << 8) + ((s >> 8) & 255);
1703 Perl_my_htonl(pTHX_ long l)
1707 char c[sizeof(long)];
1710 #if BYTEORDER == 0x1234
1711 u.c[0] = (l >> 24) & 255;
1712 u.c[1] = (l >> 16) & 255;
1713 u.c[2] = (l >> 8) & 255;
1717 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
1718 Perl_croak(aTHX_ "Unknown BYTEORDER\n");
1723 for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
1724 u.c[o & 0xf] = (l >> s) & 255;
1732 Perl_my_ntohl(pTHX_ long l)
1736 char c[sizeof(long)];
1739 #if BYTEORDER == 0x1234
1740 u.c[0] = (l >> 24) & 255;
1741 u.c[1] = (l >> 16) & 255;
1742 u.c[2] = (l >> 8) & 255;
1746 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
1747 Perl_croak(aTHX_ "Unknown BYTEORDER\n");
1754 for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
1755 l |= (u.c[o & 0xf] & 255) << s;
1762 #endif /* BYTEORDER != 0x4321 */
1766 * Little-endian byte order functions - 'v' for 'VAX', or 'reVerse'.
1767 * If these functions are defined,
1768 * the BYTEORDER is neither 0x1234 nor 0x4321.
1769 * However, this is not assumed.
1773 #define HTOLE(name,type) \
1775 name (register type n) \
1779 char c[sizeof(type)]; \
1782 register I32 s = 0; \
1783 for (i = 0; i < sizeof(u.c); i++, s += 8) { \
1784 u.c[i] = (n >> s) & 0xFF; \
1789 #define LETOH(name,type) \
1791 name (register type n) \
1795 char c[sizeof(type)]; \
1798 register I32 s = 0; \
1801 for (i = 0; i < sizeof(u.c); i++, s += 8) { \
1802 n |= ((type)(u.c[i] & 0xFF)) << s; \
1808 * Big-endian byte order functions.
1811 #define HTOBE(name,type) \
1813 name (register type n) \
1817 char c[sizeof(type)]; \
1820 register I32 s = 8*(sizeof(u.c)-1); \
1821 for (i = 0; i < sizeof(u.c); i++, s -= 8) { \
1822 u.c[i] = (n >> s) & 0xFF; \
1827 #define BETOH(name,type) \
1829 name (register type n) \
1833 char c[sizeof(type)]; \
1836 register I32 s = 8*(sizeof(u.c)-1); \
1839 for (i = 0; i < sizeof(u.c); i++, s -= 8) { \
1840 n |= ((type)(u.c[i] & 0xFF)) << s; \
1846 * If we just can't do it...
1849 #define NOT_AVAIL(name,type) \
1851 name (register type n) \
1853 Perl_croak_nocontext(#name "() not available"); \
1854 return n; /* not reached */ \
1858 #if defined(HAS_HTOVS) && !defined(htovs)
1861 #if defined(HAS_HTOVL) && !defined(htovl)
1864 #if defined(HAS_VTOHS) && !defined(vtohs)
1867 #if defined(HAS_VTOHL) && !defined(vtohl)
1871 #ifdef PERL_NEED_MY_HTOLE16
1873 HTOLE(Perl_my_htole16,U16)
1875 NOT_AVAIL(Perl_my_htole16,U16)
1878 #ifdef PERL_NEED_MY_LETOH16
1880 LETOH(Perl_my_letoh16,U16)
1882 NOT_AVAIL(Perl_my_letoh16,U16)
1885 #ifdef PERL_NEED_MY_HTOBE16
1887 HTOBE(Perl_my_htobe16,U16)
1889 NOT_AVAIL(Perl_my_htobe16,U16)
1892 #ifdef PERL_NEED_MY_BETOH16
1894 BETOH(Perl_my_betoh16,U16)
1896 NOT_AVAIL(Perl_my_betoh16,U16)
1900 #ifdef PERL_NEED_MY_HTOLE32
1902 HTOLE(Perl_my_htole32,U32)
1904 NOT_AVAIL(Perl_my_htole32,U32)
1907 #ifdef PERL_NEED_MY_LETOH32
1909 LETOH(Perl_my_letoh32,U32)
1911 NOT_AVAIL(Perl_my_letoh32,U32)
1914 #ifdef PERL_NEED_MY_HTOBE32
1916 HTOBE(Perl_my_htobe32,U32)
1918 NOT_AVAIL(Perl_my_htobe32,U32)
1921 #ifdef PERL_NEED_MY_BETOH32
1923 BETOH(Perl_my_betoh32,U32)
1925 NOT_AVAIL(Perl_my_betoh32,U32)
1929 #ifdef PERL_NEED_MY_HTOLE64
1931 HTOLE(Perl_my_htole64,U64)
1933 NOT_AVAIL(Perl_my_htole64,U64)
1936 #ifdef PERL_NEED_MY_LETOH64
1938 LETOH(Perl_my_letoh64,U64)
1940 NOT_AVAIL(Perl_my_letoh64,U64)
1943 #ifdef PERL_NEED_MY_HTOBE64
1945 HTOBE(Perl_my_htobe64,U64)
1947 NOT_AVAIL(Perl_my_htobe64,U64)
1950 #ifdef PERL_NEED_MY_BETOH64
1952 BETOH(Perl_my_betoh64,U64)
1954 NOT_AVAIL(Perl_my_betoh64,U64)
1958 #ifdef PERL_NEED_MY_HTOLES
1959 HTOLE(Perl_my_htoles,short)
1961 #ifdef PERL_NEED_MY_LETOHS
1962 LETOH(Perl_my_letohs,short)
1964 #ifdef PERL_NEED_MY_HTOBES
1965 HTOBE(Perl_my_htobes,short)
1967 #ifdef PERL_NEED_MY_BETOHS
1968 BETOH(Perl_my_betohs,short)
1971 #ifdef PERL_NEED_MY_HTOLEI
1972 HTOLE(Perl_my_htolei,int)
1974 #ifdef PERL_NEED_MY_LETOHI
1975 LETOH(Perl_my_letohi,int)
1977 #ifdef PERL_NEED_MY_HTOBEI
1978 HTOBE(Perl_my_htobei,int)
1980 #ifdef PERL_NEED_MY_BETOHI
1981 BETOH(Perl_my_betohi,int)
1984 #ifdef PERL_NEED_MY_HTOLEL
1985 HTOLE(Perl_my_htolel,long)
1987 #ifdef PERL_NEED_MY_LETOHL
1988 LETOH(Perl_my_letohl,long)
1990 #ifdef PERL_NEED_MY_HTOBEL
1991 HTOBE(Perl_my_htobel,long)
1993 #ifdef PERL_NEED_MY_BETOHL
1994 BETOH(Perl_my_betohl,long)
1998 Perl_my_swabn(void *ptr, int n)
2000 register char *s = (char *)ptr;
2001 register char *e = s + (n-1);
2004 for (n /= 2; n > 0; s++, e--, n--) {
2012 Perl_my_popen_list(pTHX_ char *mode, int n, SV **args)
2014 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) && !defined(NETWARE)
2016 register I32 This, that;
2022 PERL_FLUSHALL_FOR_CHILD;
2023 This = (*mode == 'w');
2027 taint_proper("Insecure %s%s", "EXEC");
2029 if (PerlProc_pipe(p) < 0)
2031 /* Try for another pipe pair for error return */
2032 if (PerlProc_pipe(pp) >= 0)
2034 while ((pid = PerlProc_fork()) < 0) {
2035 if (errno != EAGAIN) {
2036 PerlLIO_close(p[This]);
2037 PerlLIO_close(p[that]);
2039 PerlLIO_close(pp[0]);
2040 PerlLIO_close(pp[1]);
2052 /* Close parent's end of error status pipe (if any) */
2054 PerlLIO_close(pp[0]);
2055 #if defined(HAS_FCNTL) && defined(F_SETFD)
2056 /* Close error pipe automatically if exec works */
2057 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2060 /* Now dup our end of _the_ pipe to right position */
2061 if (p[THIS] != (*mode == 'r')) {
2062 PerlLIO_dup2(p[THIS], *mode == 'r');
2063 PerlLIO_close(p[THIS]);
2064 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2065 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
2068 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
2069 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2070 /* No automatic close - do it by hand */
2077 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) {
2083 do_aexec5(Nullsv, args-1, args-1+n, pp[1], did_pipes);
2089 do_execfree(); /* free any memory malloced by child on fork */
2091 PerlLIO_close(pp[1]);
2092 /* Keep the lower of the two fd numbers */
2093 if (p[that] < p[This]) {
2094 PerlLIO_dup2(p[This], p[that]);
2095 PerlLIO_close(p[This]);
2099 PerlLIO_close(p[that]); /* close child's end of pipe */
2102 sv = *av_fetch(PL_fdpid,p[This],TRUE);
2104 SvUPGRADE(sv,SVt_IV);
2106 PL_forkprocess = pid;
2107 /* If we managed to get status pipe check for exec fail */
2108 if (did_pipes && pid > 0) {
2112 while (n < sizeof(int)) {
2113 n1 = PerlLIO_read(pp[0],
2114 (void*)(((char*)&errkid)+n),
2120 PerlLIO_close(pp[0]);
2122 if (n) { /* Error */
2124 PerlLIO_close(p[This]);
2125 if (n != sizeof(int))
2126 Perl_croak(aTHX_ "panic: kid popen errno read");
2128 pid2 = wait4pid(pid, &status, 0);
2129 } while (pid2 == -1 && errno == EINTR);
2130 errno = errkid; /* Propagate errno from kid */
2135 PerlLIO_close(pp[0]);
2136 return PerlIO_fdopen(p[This], mode);
2138 Perl_croak(aTHX_ "List form of piped open not implemented");
2139 return (PerlIO *) NULL;
2143 /* VMS' my_popen() is in VMS.c, same with OS/2. */
2144 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
2146 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2149 register I32 This, that;
2152 const I32 doexec = !(*cmd == '-' && cmd[1] == '\0');
2156 PERL_FLUSHALL_FOR_CHILD;
2159 return my_syspopen(aTHX_ cmd,mode);
2162 This = (*mode == 'w');
2164 if (doexec && PL_tainting) {
2166 taint_proper("Insecure %s%s", "EXEC");
2168 if (PerlProc_pipe(p) < 0)
2170 if (doexec && PerlProc_pipe(pp) >= 0)
2172 while ((pid = PerlProc_fork()) < 0) {
2173 if (errno != EAGAIN) {
2174 PerlLIO_close(p[This]);
2175 PerlLIO_close(p[that]);
2177 PerlLIO_close(pp[0]);
2178 PerlLIO_close(pp[1]);
2181 Perl_croak(aTHX_ "Can't fork");
2194 PerlLIO_close(pp[0]);
2195 #if defined(HAS_FCNTL) && defined(F_SETFD)
2196 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2199 if (p[THIS] != (*mode == 'r')) {
2200 PerlLIO_dup2(p[THIS], *mode == 'r');
2201 PerlLIO_close(p[THIS]);
2202 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2203 PerlLIO_close(p[THAT]);
2206 PerlLIO_close(p[THAT]);
2209 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2216 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
2221 /* may or may not use the shell */
2222 do_exec3(cmd, pp[1], did_pipes);
2225 #endif /* defined OS2 */
2226 if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) {
2227 SvREADONLY_off(GvSV(tmpgv));
2228 sv_setiv(GvSV(tmpgv), PerlProc_getpid());
2229 SvREADONLY_on(GvSV(tmpgv));
2231 #ifdef THREADS_HAVE_PIDS
2232 PL_ppid = (IV)getppid();
2235 hv_clear(PL_pidstatus); /* we have no children */
2240 do_execfree(); /* free any memory malloced by child on vfork */
2242 PerlLIO_close(pp[1]);
2243 if (p[that] < p[This]) {
2244 PerlLIO_dup2(p[This], p[that]);
2245 PerlLIO_close(p[This]);
2249 PerlLIO_close(p[that]);
2252 sv = *av_fetch(PL_fdpid,p[This],TRUE);
2254 SvUPGRADE(sv,SVt_IV);
2256 PL_forkprocess = pid;
2257 if (did_pipes && pid > 0) {
2261 while (n < sizeof(int)) {
2262 n1 = PerlLIO_read(pp[0],
2263 (void*)(((char*)&errkid)+n),
2269 PerlLIO_close(pp[0]);
2271 if (n) { /* Error */
2273 PerlLIO_close(p[This]);
2274 if (n != sizeof(int))
2275 Perl_croak(aTHX_ "panic: kid popen errno read");
2277 pid2 = wait4pid(pid, &status, 0);
2278 } while (pid2 == -1 && errno == EINTR);
2279 errno = errkid; /* Propagate errno from kid */
2284 PerlLIO_close(pp[0]);
2285 return PerlIO_fdopen(p[This], mode);
2288 #if defined(atarist) || defined(EPOC)
2291 Perl_my_popen(pTHX_ char *cmd, char *mode)
2293 PERL_FLUSHALL_FOR_CHILD;
2294 /* Call system's popen() to get a FILE *, then import it.
2295 used 0 for 2nd parameter to PerlIO_importFILE;
2298 return PerlIO_importFILE(popen(cmd, mode), 0);
2302 FILE *djgpp_popen();
2304 Perl_my_popen(pTHX_ char *cmd, char *mode)
2306 PERL_FLUSHALL_FOR_CHILD;
2307 /* Call system's popen() to get a FILE *, then import it.
2308 used 0 for 2nd parameter to PerlIO_importFILE;
2311 return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
2316 #endif /* !DOSISH */
2318 /* this is called in parent before the fork() */
2320 Perl_atfork_lock(void)
2323 #if defined(USE_ITHREADS)
2324 /* locks must be held in locking order (if any) */
2326 MUTEX_LOCK(&PL_malloc_mutex);
2332 /* this is called in both parent and child after the fork() */
2334 Perl_atfork_unlock(void)
2337 #if defined(USE_ITHREADS)
2338 /* locks must be released in same order as in atfork_lock() */
2340 MUTEX_UNLOCK(&PL_malloc_mutex);
2349 #if defined(HAS_FORK)
2351 #if defined(USE_ITHREADS) && !defined(HAS_PTHREAD_ATFORK)
2356 /* atfork_lock() and atfork_unlock() are installed as pthread_atfork()
2357 * handlers elsewhere in the code */
2362 /* this "canna happen" since nothing should be calling here if !HAS_FORK */
2363 Perl_croak_nocontext("fork() not available");
2365 #endif /* HAS_FORK */
2370 Perl_dump_fds(pTHX_ char *s)
2375 PerlIO_printf(Perl_debug_log,"%s", s);
2376 for (fd = 0; fd < 32; fd++) {
2377 if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0)
2378 PerlIO_printf(Perl_debug_log," %d",fd);
2380 PerlIO_printf(Perl_debug_log,"\n");
2383 #endif /* DUMP_FDS */
2387 dup2(int oldfd, int newfd)
2389 #if defined(HAS_FCNTL) && defined(F_DUPFD)
2392 PerlLIO_close(newfd);
2393 return fcntl(oldfd, F_DUPFD, newfd);
2395 #define DUP2_MAX_FDS 256
2396 int fdtmp[DUP2_MAX_FDS];
2402 PerlLIO_close(newfd);
2403 /* good enough for low fd's... */
2404 while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
2405 if (fdx >= DUP2_MAX_FDS) {
2413 PerlLIO_close(fdtmp[--fdx]);
2420 #ifdef HAS_SIGACTION
2422 #ifdef MACOS_TRADITIONAL
2423 /* We don't want restart behavior on MacOS */
2428 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2431 struct sigaction act, oact;
2434 /* only "parent" interpreter can diddle signals */
2435 if (PL_curinterp != aTHX)
2436 return (Sighandler_t) SIG_ERR;
2439 act.sa_handler = (void(*)(int))handler;
2440 sigemptyset(&act.sa_mask);
2443 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2444 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
2446 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2447 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
2448 act.sa_flags |= SA_NOCLDWAIT;
2450 if (sigaction(signo, &act, &oact) == -1)
2451 return (Sighandler_t) SIG_ERR;
2453 return (Sighandler_t) oact.sa_handler;
2457 Perl_rsignal_state(pTHX_ int signo)
2459 struct sigaction oact;
2461 if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
2462 return (Sighandler_t) SIG_ERR;
2464 return (Sighandler_t) oact.sa_handler;
2468 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2471 struct sigaction act;
2474 /* only "parent" interpreter can diddle signals */
2475 if (PL_curinterp != aTHX)
2479 act.sa_handler = (void(*)(int))handler;
2480 sigemptyset(&act.sa_mask);
2483 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2484 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
2486 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2487 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
2488 act.sa_flags |= SA_NOCLDWAIT;
2490 return sigaction(signo, &act, save);
2494 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2498 /* only "parent" interpreter can diddle signals */
2499 if (PL_curinterp != aTHX)
2503 return sigaction(signo, save, (struct sigaction *)NULL);
2506 #else /* !HAS_SIGACTION */
2509 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2511 #if defined(USE_ITHREADS) && !defined(WIN32)
2512 /* only "parent" interpreter can diddle signals */
2513 if (PL_curinterp != aTHX)
2514 return (Sighandler_t) SIG_ERR;
2517 return PerlProc_signal(signo, handler);
2529 Perl_rsignal_state(pTHX_ int signo)
2532 Sighandler_t oldsig;
2534 #if defined(USE_ITHREADS) && !defined(WIN32)
2535 /* only "parent" interpreter can diddle signals */
2536 if (PL_curinterp != aTHX)
2537 return (Sighandler_t) SIG_ERR;
2541 oldsig = PerlProc_signal(signo, sig_trap);
2542 PerlProc_signal(signo, oldsig);
2544 PerlProc_kill(PerlProc_getpid(), signo);
2549 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2551 #if defined(USE_ITHREADS) && !defined(WIN32)
2552 /* only "parent" interpreter can diddle signals */
2553 if (PL_curinterp != aTHX)
2556 *save = PerlProc_signal(signo, handler);
2557 return (*save == (Sighandler_t) SIG_ERR) ? -1 : 0;
2561 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2563 #if defined(USE_ITHREADS) && !defined(WIN32)
2564 /* only "parent" interpreter can diddle signals */
2565 if (PL_curinterp != aTHX)
2568 return (PerlProc_signal(signo, *save) == (Sighandler_t) SIG_ERR) ? -1 : 0;
2571 #endif /* !HAS_SIGACTION */
2572 #endif /* !PERL_MICRO */
2574 /* VMS' my_pclose() is in VMS.c; same with OS/2 */
2575 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
2577 Perl_my_pclose(pTHX_ PerlIO *ptr)
2579 Sigsave_t hstat, istat, qstat;
2585 int saved_errno = 0;
2587 int saved_win32_errno;
2591 svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE);
2593 pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
2595 *svp = &PL_sv_undef;
2597 if (pid == -1) { /* Opened by popen. */
2598 return my_syspclose(ptr);
2601 if ((close_failed = (PerlIO_close(ptr) == EOF))) {
2602 saved_errno = errno;
2604 saved_win32_errno = GetLastError();
2608 if(PerlProc_kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */
2611 rsignal_save(SIGHUP, (Sighandler_t) SIG_IGN, &hstat);
2612 rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &istat);
2613 rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qstat);
2616 pid2 = wait4pid(pid, &status, 0);
2617 } while (pid2 == -1 && errno == EINTR);
2619 rsignal_restore(SIGHUP, &hstat);
2620 rsignal_restore(SIGINT, &istat);
2621 rsignal_restore(SIGQUIT, &qstat);
2624 SETERRNO(saved_errno, 0);
2627 return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status));
2629 #endif /* !DOSISH */
2631 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(MACOS_TRADITIONAL)
2633 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
2638 #if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME)
2640 char spid[TYPE_CHARS(IV)];
2644 const I32 len = my_sprintf(spid, "%"IVdf, (IV)pid);
2646 svp = hv_fetch(PL_pidstatus,spid,len,FALSE);
2647 if (svp && *svp != &PL_sv_undef) {
2648 *statusp = SvIVX(*svp);
2649 (void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD);
2656 hv_iterinit(PL_pidstatus);
2657 if ((entry = hv_iternext(PL_pidstatus))) {
2658 SV *sv = hv_iterval(PL_pidstatus,entry);
2661 pid = atoi(hv_iterkey(entry,(I32*)statusp));
2662 *statusp = SvIVX(sv);
2663 len = my_sprintf(spid, "%"IVdf, (IV)pid);
2664 /* The hash iterator is currently on this entry, so simply
2665 calling hv_delete would trigger the lazy delete, which on
2666 aggregate does more work, beacuse next call to hv_iterinit()
2667 would spot the flag, and have to call the delete routine,
2668 while in the meantime any new entries can't re-use that
2670 hv_iterinit(PL_pidstatus);
2671 (void)hv_delete(PL_pidstatus,spid,len,G_DISCARD);
2678 # ifdef HAS_WAITPID_RUNTIME
2679 if (!HAS_WAITPID_RUNTIME)
2682 result = PerlProc_waitpid(pid,statusp,flags);
2685 #if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
2686 result = wait4((pid==-1)?0:pid,statusp,flags,Null(struct rusage *));
2689 #if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME)
2690 #if defined(HAS_WAITPID) && defined(HAS_WAITPID_RUNTIME)
2695 Perl_croak(aTHX_ "Can't do waitpid with flags");
2697 while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
2698 pidgone(result,*statusp);
2704 #if defined(HAS_WAITPID) || defined(HAS_WAIT4)
2707 if (result < 0 && errno == EINTR) {
2712 #endif /* !DOSISH || OS2 || WIN32 || NETWARE */
2715 Perl_pidgone(pTHX_ Pid_t pid, int status)
2718 char spid[TYPE_CHARS(IV)];
2719 const size_t len = my_sprintf(spid, "%"IVdf, (IV)pid);
2721 sv = *hv_fetch(PL_pidstatus,spid,len,TRUE);
2722 SvUPGRADE(sv,SVt_IV);
2723 SvIV_set(sv, status);
2727 #if defined(atarist) || defined(OS2) || defined(EPOC)
2730 int /* Cannot prototype with I32
2732 my_syspclose(PerlIO *ptr)
2735 Perl_my_pclose(pTHX_ PerlIO *ptr)
2738 /* Needs work for PerlIO ! */
2739 FILE *f = PerlIO_findFILE(ptr);
2740 I32 result = pclose(f);
2741 PerlIO_releaseFILE(ptr,f);
2749 Perl_my_pclose(pTHX_ PerlIO *ptr)
2751 /* Needs work for PerlIO ! */
2752 FILE *f = PerlIO_findFILE(ptr);
2753 I32 result = djgpp_pclose(f);
2754 result = (result << 8) & 0xff00;
2755 PerlIO_releaseFILE(ptr,f);
2761 Perl_repeatcpy(pTHX_ register char *to, register const char *from, I32 len, register I32 count)
2764 register const char *frombase = from;
2767 register const char c = *from;
2772 while (count-- > 0) {
2773 for (todo = len; todo > 0; todo--) {
2782 Perl_same_dirent(pTHX_ const char *a, const char *b)
2784 char *fa = strrchr(a,'/');
2785 char *fb = strrchr(b,'/');
2788 SV *tmpsv = sv_newmortal();
2801 sv_setpvn(tmpsv, ".", 1);
2803 sv_setpvn(tmpsv, a, fa - a);
2804 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0)
2807 sv_setpvn(tmpsv, ".", 1);
2809 sv_setpvn(tmpsv, b, fb - b);
2810 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0)
2812 return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
2813 tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
2815 #endif /* !HAS_RENAME */
2818 Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
2819 const char *const *const search_ext, I32 flags)
2821 const char *xfound = Nullch;
2822 char *xfailed = Nullch;
2823 char tmpbuf[MAXPATHLEN];
2827 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
2828 # define SEARCH_EXTS ".bat", ".cmd", NULL
2829 # define MAX_EXT_LEN 4
2832 # define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
2833 # define MAX_EXT_LEN 4
2836 # define SEARCH_EXTS ".pl", ".com", NULL
2837 # define MAX_EXT_LEN 4
2839 /* additional extensions to try in each dir if scriptname not found */
2841 const char *const exts[] = { SEARCH_EXTS };
2842 const char *const *const ext = search_ext ? search_ext : exts;
2843 int extidx = 0, i = 0;
2844 const char *curext = Nullch;
2846 PERL_UNUSED_ARG(search_ext);
2847 # define MAX_EXT_LEN 0
2851 * If dosearch is true and if scriptname does not contain path
2852 * delimiters, search the PATH for scriptname.
2854 * If SEARCH_EXTS is also defined, will look for each
2855 * scriptname{SEARCH_EXTS} whenever scriptname is not found
2856 * while searching the PATH.
2858 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
2859 * proceeds as follows:
2860 * If DOSISH or VMSISH:
2861 * + look for ./scriptname{,.foo,.bar}
2862 * + search the PATH for scriptname{,.foo,.bar}
2865 * + look *only* in the PATH for scriptname{,.foo,.bar} (note
2866 * this will not look in '.' if it's not in the PATH)
2871 # ifdef ALWAYS_DEFTYPES
2872 len = strlen(scriptname);
2873 if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
2874 int hasdir, idx = 0, deftypes = 1;
2877 hasdir = !dosearch || (strpbrk(scriptname,":[</") != Nullch) ;
2880 int hasdir, idx = 0, deftypes = 1;
2883 hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
2885 /* The first time through, just add SEARCH_EXTS to whatever we
2886 * already have, so we can check for default file types. */
2888 (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
2894 if ((strlen(tmpbuf) + strlen(scriptname)
2895 + MAX_EXT_LEN) >= sizeof tmpbuf)
2896 continue; /* don't search dir with too-long name */
2897 strcat(tmpbuf, scriptname);
2901 if (strEQ(scriptname, "-"))
2903 if (dosearch) { /* Look in '.' first. */
2904 const char *cur = scriptname;
2906 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
2908 if (strEQ(ext[i++],curext)) {
2909 extidx = -1; /* already has an ext */
2914 DEBUG_p(PerlIO_printf(Perl_debug_log,
2915 "Looking for %s\n",cur));
2916 if (PerlLIO_stat(cur,&PL_statbuf) >= 0
2917 && !S_ISDIR(PL_statbuf.st_mode)) {
2925 if (cur == scriptname) {
2926 len = strlen(scriptname);
2927 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
2929 /* FIXME? Convert to memcpy */
2930 cur = strcpy(tmpbuf, scriptname);
2932 } while (extidx >= 0 && ext[extidx] /* try an extension? */
2933 && strcpy(tmpbuf+len, ext[extidx++]));
2938 #ifdef MACOS_TRADITIONAL
2939 if (dosearch && !strchr(scriptname, ':') &&
2940 (s = PerlEnv_getenv("Commands")))
2942 if (dosearch && !strchr(scriptname, '/')
2944 && !strchr(scriptname, '\\')
2946 && (s = PerlEnv_getenv("PATH")))
2951 PL_bufend = s + strlen(s);
2952 while (s < PL_bufend) {
2953 #ifdef MACOS_TRADITIONAL
2954 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
2958 #if defined(atarist) || defined(DOSISH)
2963 && *s != ';'; len++, s++) {
2964 if (len < sizeof tmpbuf)
2967 if (len < sizeof tmpbuf)
2969 #else /* ! (atarist || DOSISH) */
2970 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
2973 #endif /* ! (atarist || DOSISH) */
2974 #endif /* MACOS_TRADITIONAL */
2977 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
2978 continue; /* don't search dir with too-long name */
2979 #ifdef MACOS_TRADITIONAL
2980 if (len && tmpbuf[len - 1] != ':')
2981 tmpbuf[len++] = ':';
2984 # if defined(atarist) || defined(__MINT__) || defined(DOSISH)
2985 && tmpbuf[len - 1] != '/'
2986 && tmpbuf[len - 1] != '\\'
2989 tmpbuf[len++] = '/';
2990 if (len == 2 && tmpbuf[0] == '.')
2993 /* FIXME? Convert to memcpy by storing previous strlen(scriptname)
2995 (void)strcpy(tmpbuf + len, scriptname);
2999 len = strlen(tmpbuf);
3000 if (extidx > 0) /* reset after previous loop */
3004 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
3005 retval = PerlLIO_stat(tmpbuf,&PL_statbuf);
3006 if (S_ISDIR(PL_statbuf.st_mode)) {
3010 } while ( retval < 0 /* not there */
3011 && extidx>=0 && ext[extidx] /* try an extension? */
3012 && strcpy(tmpbuf+len, ext[extidx++])
3017 if (S_ISREG(PL_statbuf.st_mode)
3018 && cando(S_IRUSR,TRUE,&PL_statbuf)
3019 #if !defined(DOSISH) && !defined(MACOS_TRADITIONAL)
3020 && cando(S_IXUSR,TRUE,&PL_statbuf)
3024 xfound = tmpbuf; /* bingo! */
3028 xfailed = savepv(tmpbuf);
3031 if (!xfound && !seen_dot && !xfailed &&
3032 (PerlLIO_stat(scriptname,&PL_statbuf) < 0
3033 || S_ISDIR(PL_statbuf.st_mode)))
3035 seen_dot = 1; /* Disable message. */
3037 if (flags & 1) { /* do or die? */
3038 Perl_croak(aTHX_ "Can't %s %s%s%s",
3039 (xfailed ? "execute" : "find"),
3040 (xfailed ? xfailed : scriptname),
3041 (xfailed ? "" : " on PATH"),
3042 (xfailed || seen_dot) ? "" : ", '.' not in PATH");
3044 scriptname = Nullch;
3047 scriptname = xfound;
3049 return (scriptname ? savepv(scriptname) : Nullch);
3052 #ifndef PERL_GET_CONTEXT_DEFINED
3055 Perl_get_context(void)
3058 #if defined(USE_ITHREADS)
3059 # ifdef OLD_PTHREADS_API
3061 if (pthread_getspecific(PL_thr_key, &t))
3062 Perl_croak_nocontext("panic: pthread_getspecific");
3065 # ifdef I_MACH_CTHREADS
3066 return (void*)cthread_data(cthread_self());
3068 return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
3077 Perl_set_context(void *t)
3080 #if defined(USE_ITHREADS)
3081 # ifdef I_MACH_CTHREADS
3082 cthread_set_data(cthread_self(), t);
3084 if (pthread_setspecific(PL_thr_key, t))
3085 Perl_croak_nocontext("panic: pthread_setspecific");
3092 #endif /* !PERL_GET_CONTEXT_DEFINED */
3094 #if defined(PERL_GLOBAL_STRUCT) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
3103 Perl_get_op_names(pTHX)
3105 return (char **)PL_op_name;
3109 Perl_get_op_descs(pTHX)
3111 return (char **)PL_op_desc;
3115 Perl_get_no_modify(pTHX)
3117 return PL_no_modify;
3121 Perl_get_opargs(pTHX)
3123 return (U32 *)PL_opargs;
3127 Perl_get_ppaddr(pTHX)
3130 return (PPADDR_t*)PL_ppaddr;
3133 #ifndef HAS_GETENV_LEN
3135 Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
3137 char * const env_trans = PerlEnv_getenv(env_elem);
3139 *len = strlen(env_trans);
3146 Perl_get_vtbl(pTHX_ int vtbl_id)
3148 const MGVTBL* result = Null(MGVTBL*);
3152 result = &PL_vtbl_sv;
3155 result = &PL_vtbl_env;
3157 case want_vtbl_envelem:
3158 result = &PL_vtbl_envelem;
3161 result = &PL_vtbl_sig;
3163 case want_vtbl_sigelem:
3164 result = &PL_vtbl_sigelem;
3166 case want_vtbl_pack:
3167 result = &PL_vtbl_pack;
3169 case want_vtbl_packelem:
3170 result = &PL_vtbl_packelem;
3172 case want_vtbl_dbline:
3173 result = &PL_vtbl_dbline;
3176 result = &PL_vtbl_isa;
3178 case want_vtbl_isaelem:
3179 result = &PL_vtbl_isaelem;
3181 case want_vtbl_arylen:
3182 result = &PL_vtbl_arylen;
3184 case want_vtbl_glob:
3185 result = &PL_vtbl_glob;
3187 case want_vtbl_mglob:
3188 result = &PL_vtbl_mglob;
3190 case want_vtbl_nkeys:
3191 result = &PL_vtbl_nkeys;
3193 case want_vtbl_taint:
3194 result = &PL_vtbl_taint;
3196 case want_vtbl_substr:
3197 result = &PL_vtbl_substr;
3200 result = &PL_vtbl_vec;
3203 result = &PL_vtbl_pos;
3206 result = &PL_vtbl_bm;
3209 result = &PL_vtbl_fm;
3211 case want_vtbl_uvar:
3212 result = &PL_vtbl_uvar;
3214 case want_vtbl_defelem:
3215 result = &PL_vtbl_defelem;
3217 case want_vtbl_regexp:
3218 result = &PL_vtbl_regexp;
3220 case want_vtbl_regdata:
3221 result = &PL_vtbl_regdata;
3223 case want_vtbl_regdatum:
3224 result = &PL_vtbl_regdatum;
3226 #ifdef USE_LOCALE_COLLATE
3227 case want_vtbl_collxfrm:
3228 result = &PL_vtbl_collxfrm;
3231 case want_vtbl_amagic:
3232 result = &PL_vtbl_amagic;
3234 case want_vtbl_amagicelem:
3235 result = &PL_vtbl_amagicelem;
3237 case want_vtbl_backref:
3238 result = &PL_vtbl_backref;
3240 case want_vtbl_utf8:
3241 result = &PL_vtbl_utf8;
3244 return (MGVTBL*)result;
3248 Perl_my_fflush_all(pTHX)
3250 #if defined(USE_PERLIO) || defined(FFLUSH_NULL) || defined(USE_SFIO)
3251 return PerlIO_flush(NULL);
3253 # if defined(HAS__FWALK)
3254 extern int fflush(FILE *);
3255 /* undocumented, unprototyped, but very useful BSDism */
3256 extern void _fwalk(int (*)(FILE *));
3260 # if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
3262 # ifdef PERL_FFLUSH_ALL_FOPEN_MAX
3263 open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
3265 # if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
3266 open_max = sysconf(_SC_OPEN_MAX);
3269 open_max = FOPEN_MAX;
3272 open_max = OPEN_MAX;
3283 for (i = 0; i < open_max; i++)
3284 if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
3285 STDIO_STREAM_ARRAY[i]._file < open_max &&
3286 STDIO_STREAM_ARRAY[i]._flag)
3287 PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
3291 SETERRNO(EBADF,RMS_IFI);
3298 Perl_report_evil_fh(pTHX_ const GV *gv, const IO *io, I32 op)
3300 const char * const func =
3301 op == OP_READLINE ? "readline" : /* "<HANDLE>" not nice */
3302 op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */
3304 const char * const pars = OP_IS_FILETEST(op) ? "" : "()";
3305 const char * const type = OP_IS_SOCKET(op)
3306 || (gv && io && IoTYPE(io) == IoTYPE_SOCKET)
3307 ? "socket" : "filehandle";
3308 const char * const name = gv && isGV(gv) ? GvENAME(gv) : NULL;
3310 if (op == OP_phoney_OUTPUT_ONLY || op == OP_phoney_INPUT_ONLY) {
3311 if (ckWARN(WARN_IO)) {
3312 const char * const direction = (op == OP_phoney_INPUT_ONLY) ? "in" : "out";
3314 Perl_warner(aTHX_ packWARN(WARN_IO),
3315 "Filehandle %s opened only for %sput",
3318 Perl_warner(aTHX_ packWARN(WARN_IO),
3319 "Filehandle opened only for %sput", direction);
3326 if (gv && io && IoTYPE(io) == IoTYPE_CLOSED) {
3328 warn_type = WARN_CLOSED;
3332 warn_type = WARN_UNOPENED;
3335 if (ckWARN(warn_type)) {
3336 if (name && *name) {
3337 Perl_warner(aTHX_ packWARN(warn_type),
3338 "%s%s on %s %s %s", func, pars, vile, type, name);
3339 if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3341 aTHX_ packWARN(warn_type),
3342 "\t(Are you trying to call %s%s on dirhandle %s?)\n",
3347 Perl_warner(aTHX_ packWARN(warn_type),
3348 "%s%s on %s %s", func, pars, vile, type);
3349 if (gv && io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3351 aTHX_ packWARN(warn_type),
3352 "\t(Are you trying to call %s%s on dirhandle?)\n",
3361 /* in ASCII order, not that it matters */
3362 static const char controllablechars[] = "?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_";
3365 Perl_ebcdic_control(pTHX_ int ch)
3373 if ((ctlp = strchr(controllablechars, ch)) == 0) {
3374 Perl_die(aTHX_ "unrecognised control character '%c'\n", ch);
3377 if (ctlp == controllablechars)
3378 return('\177'); /* DEL */
3380 return((unsigned char)(ctlp - controllablechars - 1));
3381 } else { /* Want uncontrol */
3382 if (ch == '\177' || ch == -1)
3384 else if (ch == '\157')
3386 else if (ch == '\174')
3388 else if (ch == '^') /* '\137' in 1047, '\260' in 819 */
3390 else if (ch == '\155')
3392 else if (0 < ch && ch < (sizeof(controllablechars) - 1))
3393 return(controllablechars[ch+1]);
3395 Perl_die(aTHX_ "invalid control request: '\\%03o'\n", ch & 0xFF);
3400 /* To workaround core dumps from the uninitialised tm_zone we get the
3401 * system to give us a reasonable struct to copy. This fix means that
3402 * strftime uses the tm_zone and tm_gmtoff values returned by
3403 * localtime(time()). That should give the desired result most of the
3404 * time. But probably not always!
3406 * This does not address tzname aspects of NETaa14816.
3411 # ifndef STRUCT_TM_HASZONE
3412 # define STRUCT_TM_HASZONE
3416 #ifdef STRUCT_TM_HASZONE /* Backward compat */
3417 # ifndef HAS_TM_TM_ZONE
3418 # define HAS_TM_TM_ZONE
3423 Perl_init_tm(pTHX_ struct tm *ptm) /* see mktime, strftime and asctime */
3425 #ifdef HAS_TM_TM_ZONE
3427 const struct tm* my_tm;
3429 my_tm = localtime(&now);
3431 Copy(my_tm, ptm, 1, struct tm);
3433 PERL_UNUSED_ARG(ptm);
3438 * mini_mktime - normalise struct tm values without the localtime()
3439 * semantics (and overhead) of mktime().
3442 Perl_mini_mktime(pTHX_ struct tm *ptm)
3446 int month, mday, year, jday;
3447 int odd_cent, odd_year;
3449 #define DAYS_PER_YEAR 365
3450 #define DAYS_PER_QYEAR (4*DAYS_PER_YEAR+1)
3451 #define DAYS_PER_CENT (25*DAYS_PER_QYEAR-1)
3452 #define DAYS_PER_QCENT (4*DAYS_PER_CENT+1)
3453 #define SECS_PER_HOUR (60*60)
3454 #define SECS_PER_DAY (24*SECS_PER_HOUR)
3455 /* parentheses deliberately absent on these two, otherwise they don't work */
3456 #define MONTH_TO_DAYS 153/5
3457 #define DAYS_TO_MONTH 5/153
3458 /* offset to bias by March (month 4) 1st between month/mday & year finding */
3459 #define YEAR_ADJUST (4*MONTH_TO_DAYS+1)
3460 /* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */
3461 #define WEEKDAY_BIAS 6 /* (1+6)%7 makes Sunday 0 again */
3464 * Year/day algorithm notes:
3466 * With a suitable offset for numeric value of the month, one can find
3467 * an offset into the year by considering months to have 30.6 (153/5) days,
3468 * using integer arithmetic (i.e., with truncation). To avoid too much
3469 * messing about with leap days, we consider January and February to be
3470 * the 13th and 14th month of the previous year. After that transformation,
3471 * we need the month index we use to be high by 1 from 'normal human' usage,
3472 * so the month index values we use run from 4 through 15.
3474 * Given that, and the rules for the Gregorian calendar (leap years are those
3475 * divisible by 4 unless also divisible by 100, when they must be divisible
3476 * by 400 instead), we can simply calculate the number of days since some
3477 * arbitrary 'beginning of time' by futzing with the (adjusted) year number,
3478 * the days we derive from our month index, and adding in the day of the
3479 * month. The value used here is not adjusted for the actual origin which
3480 * it normally would use (1 January A.D. 1), since we're not exposing it.
3481 * We're only building the value so we can turn around and get the
3482 * normalised values for the year, month, day-of-month, and day-of-year.
3484 * For going backward, we need to bias the value we're using so that we find
3485 * the right year value. (Basically, we don't want the contribution of
3486 * March 1st to the number to apply while deriving the year). Having done
3487 * that, we 'count up' the contribution to the year number by accounting for
3488 * full quadracenturies (400-year periods) with their extra leap days, plus
3489 * the contribution from full centuries (to avoid counting in the lost leap
3490 * days), plus the contribution from full quad-years (to count in the normal
3491 * leap days), plus the leftover contribution from any non-leap years.
3492 * At this point, if we were working with an actual leap day, we'll have 0
3493 * days left over. This is also true for March 1st, however. So, we have
3494 * to special-case that result, and (earlier) keep track of the 'odd'
3495 * century and year contributions. If we got 4 extra centuries in a qcent,
3496 * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb.
3497 * Otherwise, we add back in the earlier bias we removed (the 123 from
3498 * figuring in March 1st), find the month index (integer division by 30.6),
3499 * and the remainder is the day-of-month. We then have to convert back to
3500 * 'real' months (including fixing January and February from being 14/15 in
3501 * the previous year to being in the proper year). After that, to get
3502 * tm_yday, we work with the normalised year and get a new yearday value for
3503 * January 1st, which we subtract from the yearday value we had earlier,
3504 * representing the date we've re-built. This is done from January 1
3505 * because tm_yday is 0-origin.
3507 * Since POSIX time routines are only guaranteed to work for times since the
3508 * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm
3509 * applies Gregorian calendar rules even to dates before the 16th century
3510 * doesn't bother me. Besides, you'd need cultural context for a given
3511 * date to know whether it was Julian or Gregorian calendar, and that's
3512 * outside the scope for this routine. Since we convert back based on the
3513 * same rules we used to build the yearday, you'll only get strange results
3514 * for input which needed normalising, or for the 'odd' century years which
3515 * were leap years in the Julian calander but not in the Gregorian one.
3516 * I can live with that.
3518 * This algorithm also fails to handle years before A.D. 1 gracefully, but
3519 * that's still outside the scope for POSIX time manipulation, so I don't
3523 year = 1900 + ptm->tm_year;
3524 month = ptm->tm_mon;
3525 mday = ptm->tm_mday;
3526 /* allow given yday with no month & mday to dominate the result */
3527 if (ptm->tm_yday >= 0 && mday <= 0 && month <= 0) {
3530 jday = 1 + ptm->tm_yday;
3539 yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400;
3540 yearday += month*MONTH_TO_DAYS + mday + jday;
3542 * Note that we don't know when leap-seconds were or will be,
3543 * so we have to trust the user if we get something which looks
3544 * like a sensible leap-second. Wild values for seconds will
3545 * be rationalised, however.
3547 if ((unsigned) ptm->tm_sec <= 60) {
3554 secs += 60 * ptm->tm_min;
3555 secs += SECS_PER_HOUR * ptm->tm_hour;
3557 if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) {
3558 /* got negative remainder, but need positive time */
3559 /* back off an extra day to compensate */
3560 yearday += (secs/SECS_PER_DAY)-1;
3561 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1);
3564 yearday += (secs/SECS_PER_DAY);
3565 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY);
3568 else if (secs >= SECS_PER_DAY) {
3569 yearday += (secs/SECS_PER_DAY);
3570 secs %= SECS_PER_DAY;
3572 ptm->tm_hour = secs/SECS_PER_HOUR;
3573 secs %= SECS_PER_HOUR;
3574 ptm->tm_min = secs/60;
3576 ptm->tm_sec += secs;
3577 /* done with time of day effects */
3579 * The algorithm for yearday has (so far) left it high by 428.
3580 * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to
3581 * bias it by 123 while trying to figure out what year it
3582 * really represents. Even with this tweak, the reverse
3583 * translation fails for years before A.D. 0001.
3584 * It would still fail for Feb 29, but we catch that one below.
3586 jday = yearday; /* save for later fixup vis-a-vis Jan 1 */
3587 yearday -= YEAR_ADJUST;
3588 year = (yearday / DAYS_PER_QCENT) * 400;
3589 yearday %= DAYS_PER_QCENT;
3590 odd_cent = yearday / DAYS_PER_CENT;
3591 year += odd_cent * 100;
3592 yearday %= DAYS_PER_CENT;
3593 year += (yearday / DAYS_PER_QYEAR) * 4;
3594 yearday %= DAYS_PER_QYEAR;
3595 odd_year = yearday / DAYS_PER_YEAR;
3597 yearday %= DAYS_PER_YEAR;
3598 if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */
3603 yearday += YEAR_ADJUST; /* recover March 1st crock */
3604 month = yearday*DAYS_TO_MONTH;
3605 yearday -= month*MONTH_TO_DAYS;
3606 /* recover other leap-year adjustment */
3615 ptm->tm_year = year - 1900;
3617 ptm->tm_mday = yearday;
3618 ptm->tm_mon = month;
3622 ptm->tm_mon = month - 1;
3624 /* re-build yearday based on Jan 1 to get tm_yday */
3626 yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400;
3627 yearday += 14*MONTH_TO_DAYS + 1;
3628 ptm->tm_yday = jday - yearday;
3629 /* fix tm_wday if not overridden by caller */
3630 if ((unsigned)ptm->tm_wday > 6)
3631 ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
3635 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)
3643 init_tm(&mytm); /* XXX workaround - see init_tm() above */
3646 mytm.tm_hour = hour;
3647 mytm.tm_mday = mday;
3649 mytm.tm_year = year;
3650 mytm.tm_wday = wday;
3651 mytm.tm_yday = yday;
3652 mytm.tm_isdst = isdst;
3654 /* use libc to get the values for tm_gmtoff and tm_zone [perl #18238] */
3655 #if defined(HAS_MKTIME) && (defined(HAS_TM_TM_GMTOFF) || defined(HAS_TM_TM_ZONE))
3660 #ifdef HAS_TM_TM_GMTOFF
3661 mytm.tm_gmtoff = mytm2.tm_gmtoff;
3663 #ifdef HAS_TM_TM_ZONE
3664 mytm.tm_zone = mytm2.tm_zone;
3669 Newx(buf, buflen, char);
3670 len = strftime(buf, buflen, fmt, &mytm);
3672 ** The following is needed to handle to the situation where
3673 ** tmpbuf overflows. Basically we want to allocate a buffer
3674 ** and try repeatedly. The reason why it is so complicated
3675 ** is that getting a return value of 0 from strftime can indicate
3676 ** one of the following:
3677 ** 1. buffer overflowed,
3678 ** 2. illegal conversion specifier, or
3679 ** 3. the format string specifies nothing to be returned(not
3680 ** an error). This could be because format is an empty string
3681 ** or it specifies %p that yields an empty string in some locale.
3682 ** If there is a better way to make it portable, go ahead by
3685 if ((len > 0 && len < buflen) || (len == 0 && *fmt == '\0'))
3688 /* Possibly buf overflowed - try again with a bigger buf */
3689 const int fmtlen = strlen(fmt);
3690 const int bufsize = fmtlen + buflen;
3692 Newx(buf, bufsize, char);
3694 buflen = strftime(buf, bufsize, fmt, &mytm);
3695 if (buflen > 0 && buflen < bufsize)
3697 /* heuristic to prevent out-of-memory errors */
3698 if (bufsize > 100*fmtlen) {
3703 Renew(buf, bufsize*2, char);
3708 Perl_croak(aTHX_ "panic: no strftime");
3714 #define SV_CWD_RETURN_UNDEF \
3715 sv_setsv(sv, &PL_sv_undef); \
3718 #define SV_CWD_ISDOT(dp) \
3719 (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
3720 (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
3723 =head1 Miscellaneous Functions
3725 =for apidoc getcwd_sv
3727 Fill the sv with current working directory
3732 /* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars.
3733 * rewritten again by dougm, optimized for use with xs TARG, and to prefer
3734 * getcwd(3) if available
3735 * Comments from the orignal:
3736 * This is a faster version of getcwd. It's also more dangerous
3737 * because you might chdir out of a directory that you can't chdir
3741 Perl_getcwd_sv(pTHX_ register SV *sv)
3745 #ifndef INCOMPLETE_TAINTS
3751 char buf[MAXPATHLEN];
3753 /* Some getcwd()s automatically allocate a buffer of the given
3754 * size from the heap if they are given a NULL buffer pointer.
3755 * The problem is that this behaviour is not portable. */
3756 if (getcwd(buf, sizeof(buf) - 1)) {
3757 sv_setpvn(sv, buf, strlen(buf));
3761 sv_setsv(sv, &PL_sv_undef);
3769 int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
3773 SvUPGRADE(sv, SVt_PV);
3775 if (PerlLIO_lstat(".", &statbuf) < 0) {
3776 SV_CWD_RETURN_UNDEF;
3779 orig_cdev = statbuf.st_dev;
3780 orig_cino = statbuf.st_ino;
3789 if (PerlDir_chdir("..") < 0) {
3790 SV_CWD_RETURN_UNDEF;
3792 if (PerlLIO_stat(".", &statbuf) < 0) {
3793 SV_CWD_RETURN_UNDEF;
3796 cdev = statbuf.st_dev;
3797 cino = statbuf.st_ino;
3799 if (odev == cdev && oino == cino) {
3802 if (!(dir = PerlDir_open("."))) {
3803 SV_CWD_RETURN_UNDEF;
3806 while ((dp = PerlDir_read(dir)) != NULL) {
3808 const int namelen = dp->d_namlen;
3810 const int namelen = strlen(dp->d_name);
3813 if (SV_CWD_ISDOT(dp)) {
3817 if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
3818 SV_CWD_RETURN_UNDEF;
3821 tdev = statbuf.st_dev;
3822 tino = statbuf.st_ino;
3823 if (tino == oino && tdev == odev) {
3829 SV_CWD_RETURN_UNDEF;
3832 if (pathlen + namelen + 1 >= MAXPATHLEN) {
3833 SV_CWD_RETURN_UNDEF;
3836 SvGROW(sv, pathlen + namelen + 1);
3840 Move(SvPVX_const(sv), SvPVX(sv) + namelen + 1, pathlen, char);
3843 /* prepend current directory to the front */
3845 Move(dp->d_name, SvPVX(sv)+1, namelen, char);
3846 pathlen += (namelen + 1);
3848 #ifdef VOID_CLOSEDIR
3851 if (PerlDir_close(dir) < 0) {
3852 SV_CWD_RETURN_UNDEF;
3858 SvCUR_set(sv, pathlen);
3862 if (PerlDir_chdir(SvPVX_const(sv)) < 0) {
3863 SV_CWD_RETURN_UNDEF;
3866 if (PerlLIO_stat(".", &statbuf) < 0) {
3867 SV_CWD_RETURN_UNDEF;
3870 cdev = statbuf.st_dev;
3871 cino = statbuf.st_ino;
3873 if (cdev != orig_cdev || cino != orig_cino) {
3874 Perl_croak(aTHX_ "Unstable directory path, "
3875 "current directory changed unexpectedly");
3887 =for apidoc scan_version
3889 Returns a pointer to the next character after the parsed
3890 version string, as well as upgrading the passed in SV to
3893 Function must be called with an already existing SV like
3896 s = scan_version(s,SV *sv, bool qv);
3898 Performs some preprocessing to the string to ensure that
3899 it has the correct characteristics of a version. Flags the
3900 object if it contains an underscore (which denotes this
3901 is a alpha version). The boolean qv denotes that the version
3902 should be interpreted as if it had multiple decimals, even if
3909 Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
3918 SV *hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
3919 (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
3921 #ifndef NODEFAULT_SHAREKEYS
3922 HvSHAREKEYS_on(hv); /* key-sharing on by default */
3925 while (isSPACE(*s)) /* leading whitespace is OK */
3929 s++; /* get past 'v' */
3930 qv = 1; /* force quoted version processing */
3933 start = last = pos = s;
3935 /* pre-scan the input string to check for decimals/underbars */
3936 while ( *pos == '.' || *pos == '_' || isDIGIT(*pos) )
3941 Perl_croak(aTHX_ "Invalid version format (underscores before decimal)");
3945 else if ( *pos == '_' )
3948 Perl_croak(aTHX_ "Invalid version format (multiple underscores)");
3950 width = pos - last - 1; /* natural width of sub-version */
3955 if ( saw_period > 1 )
3956 qv = 1; /* force quoted version processing */
3961 hv_store((HV *)hv, "qv", 2, newSViv(qv), 0);
3963 hv_store((HV *)hv, "alpha", 5, newSViv(alpha), 0);
3964 if ( !qv && width < 3 )
3965 hv_store((HV *)hv, "width", 5, newSViv(width), 0);
3967 while (isDIGIT(*pos))
3969 if (!isALPHA(*pos)) {
3975 /* this is atoi() that delimits on underscores */
3976 const char *end = pos;
3980 /* the following if() will only be true after the decimal
3981 * point of a version originally created with a bare
3982 * floating point number, i.e. not quoted in any way
3984 if ( !qv && s > start && saw_period == 1 ) {
3988 rev += (*s - '0') * mult;
3990 if ( PERL_ABS(orev) > PERL_ABS(rev) )
3991 Perl_croak(aTHX_ "Integer overflow in version");
3998 while (--end >= s) {
4000 rev += (*end - '0') * mult;
4002 if ( PERL_ABS(orev) > PERL_ABS(rev) )
4003 Perl_croak(aTHX_ "Integer overflow in version");
4008 /* Append revision */
4009 av_push(av, newSViv(rev));
4010 if ( *pos == '.' && isDIGIT(pos[1]) )
4012 else if ( *pos == '_' && isDIGIT(pos[1]) )
4014 else if ( isDIGIT(*pos) )
4021 while ( isDIGIT(*pos) )
4026 while ( ( isDIGIT(*pos) || *pos == '_' ) && digits < 3 ) {
4034 if ( qv ) { /* quoted versions always get at least three terms*/
4035 I32 len = av_len(av);
4036 /* This for loop appears to trigger a compiler bug on OS X, as it
4037 loops infinitely. Yes, len is negative. No, it makes no sense.
4038 Compiler in question is:
4039 gcc version 3.3 20030304 (Apple Computer, Inc. build 1640)
4040 for ( len = 2 - len; len > 0; len-- )
4041 av_push((AV *)sv, newSViv(0));
4045 av_push(av, newSViv(0));
4048 if ( av_len(av) == -1 ) /* oops, someone forgot to pass a value */
4049 av_push(av, newSViv(0));
4051 /* And finally, store the AV in the hash */
4052 hv_store((HV *)hv, "version", 7, newRV_noinc((SV *)av), 0);
4057 =for apidoc new_version
4059 Returns a new version object based on the passed in SV:
4061 SV *sv = new_version(SV *ver);
4063 Does not alter the passed in ver SV. See "upg_version" if you
4064 want to upgrade the SV.
4070 Perl_new_version(pTHX_ SV *ver)
4072 SV * const rv = newSV(0);
4073 if ( sv_derived_from(ver,"version") ) /* can just copy directly */
4076 AV * const av = newAV();
4078 /* This will get reblessed later if a derived class*/
4079 SV * const hv = newSVrv(rv, "version");
4080 (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
4081 #ifndef NODEFAULT_SHAREKEYS
4082 HvSHAREKEYS_on(hv); /* key-sharing on by default */
4088 /* Begin copying all of the elements */
4089 if ( hv_exists((HV *)ver, "qv", 2) )
4090 hv_store((HV *)hv, "qv", 2, &PL_sv_yes, 0);
4092 if ( hv_exists((HV *)ver, "alpha", 5) )
4093 hv_store((HV *)hv, "alpha", 5, &PL_sv_yes, 0);
4095 if ( hv_exists((HV*)ver, "width", 5 ) )
4097 const I32 width = SvIV(*hv_fetch((HV*)ver, "width", 5, FALSE));
4098 hv_store((HV *)hv, "width", 5, newSViv(width), 0);
4101 sav = (AV *)SvRV(*hv_fetch((HV*)ver, "version", 7, FALSE));
4102 /* This will get reblessed later if a derived class*/
4103 for ( key = 0; key <= av_len(sav); key++ )
4105 const I32 rev = SvIV(*av_fetch(sav, key, FALSE));
4106 av_push(av, newSViv(rev));
4109 hv_store((HV *)hv, "version", 7, newRV_noinc((SV *)av), 0);
4113 if ( SvVOK(ver) ) { /* already a v-string */
4114 const MAGIC* const mg = mg_find(ver,PERL_MAGIC_vstring);
4115 const STRLEN len = mg->mg_len;
4116 char * const version = savepvn( (const char*)mg->mg_ptr, len);
4117 sv_setpvn(rv,version,len);
4122 sv_setsv(rv,ver); /* make a duplicate */
4131 =for apidoc upg_version
4133 In-place upgrade of the supplied SV to a version object.
4135 SV *sv = upg_version(SV *sv);
4137 Returns a pointer to the upgraded SV.
4143 Perl_upg_version(pTHX_ SV *ver)
4148 if ( SvNOK(ver) ) /* may get too much accuracy */
4151 sprintf(tbuf,"%.9"NVgf, SvNVX(ver));
4152 version = savepv(tbuf);
4155 else if ( SvVOK(ver) ) { /* already a v-string */
4156 const MAGIC* const mg = mg_find(ver,PERL_MAGIC_vstring);
4157 version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
4161 else /* must be a string or something like a string */
4163 version = savepv(SvPV_nolen(ver));
4165 (void)scan_version(version, ver, qv);
4173 Validates that the SV contains a valid version object.
4175 bool vverify(SV *vobj);
4177 Note that it only confirms the bare minimum structure (so as not to get
4178 confused by derived classes which may contain additional hash entries):
4182 =item * The SV contains a [reference to a] hash
4184 =item * The hash contains a "version" key
4186 =item * The "version" key has [a reference to] an AV as its value
4194 Perl_vverify(pTHX_ SV *vs)
4200 /* see if the appropriate elements exist */
4201 if ( SvTYPE(vs) == SVt_PVHV
4202 && hv_exists((HV*)vs, "version", 7)
4203 && (sv = SvRV(*hv_fetch((HV*)vs, "version", 7, FALSE)))
4204 && SvTYPE(sv) == SVt_PVAV )
4213 Accepts a version object and returns the normalized floating
4214 point representation. Call like:
4218 NOTE: you can pass either the object directly or the SV
4219 contained within the RV.
4225 Perl_vnumify(pTHX_ SV *vs)
4230 SV * const sv = newSV(0);
4236 Perl_croak(aTHX_ "Invalid version object");
4238 /* see if various flags exist */
4239 if ( hv_exists((HV*)vs, "alpha", 5 ) )
4241 if ( hv_exists((HV*)vs, "width", 5 ) )
4242 width = SvIV(*hv_fetch((HV*)vs, "width", 5, FALSE));
4247 /* attempt to retrieve the version array */
4248 if ( !(av = (AV *)SvRV(*hv_fetch((HV*)vs, "version", 7, FALSE)) ) ) {
4249 sv_catpvn(sv,"0",1);
4256 sv_catpvn(sv,"0",1);
4260 digit = SvIV(*av_fetch(av, 0, 0));
4261 Perl_sv_setpvf(aTHX_ sv, "%d.", (int)PERL_ABS(digit));
4262 for ( i = 1 ; i < len ; i++ )
4264 digit = SvIV(*av_fetch(av, i, 0));
4266 const int denom = (int)pow(10,(3-width));
4267 const div_t term = div((int)PERL_ABS(digit),denom);
4268 Perl_sv_catpvf(aTHX_ sv, "%0*d_%d", width, term.quot, term.rem);
4271 Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
4277 digit = SvIV(*av_fetch(av, len, 0));
4278 if ( alpha && width == 3 ) /* alpha version */
4279 sv_catpvn(sv,"_",1);
4280 Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
4284 sv_catpvn(sv,"000",3);
4292 Accepts a version object and returns the normalized string
4293 representation. Call like:
4297 NOTE: you can pass either the object directly or the SV
4298 contained within the RV.
4304 Perl_vnormal(pTHX_ SV *vs)
4308 SV * const sv = newSV(0);
4314 Perl_croak(aTHX_ "Invalid version object");
4316 if ( hv_exists((HV*)vs, "alpha", 5 ) )
4318 av = (AV *)SvRV(*hv_fetch((HV*)vs, "version", 7, FALSE));
4326 digit = SvIV(*av_fetch(av, 0, 0));
4327 Perl_sv_setpvf(aTHX_ sv, "v%"IVdf, (IV)digit);
4328 for ( i = 1 ; i < len ; i++ ) {
4329 digit = SvIV(*av_fetch(av, i, 0));
4330 Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
4335 /* handle last digit specially */
4336 digit = SvIV(*av_fetch(av, len, 0));
4338 Perl_sv_catpvf(aTHX_ sv, "_%"IVdf, (IV)digit);
4340 Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
4343 if ( len <= 2 ) { /* short version, must be at least three */
4344 for ( len = 2 - len; len != 0; len-- )
4345 sv_catpvn(sv,".0",2);
4351 =for apidoc vstringify
4353 In order to maintain maximum compatibility with earlier versions
4354 of Perl, this function will return either the floating point
4355 notation or the multiple dotted notation, depending on whether
4356 the original version contained 1 or more dots, respectively
4362 Perl_vstringify(pTHX_ SV *vs)
4368 Perl_croak(aTHX_ "Invalid version object");
4370 if ( hv_exists((HV *)vs, "qv", 2) )
4379 Version object aware cmp. Both operands must already have been
4380 converted into version objects.
4386 Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
4389 bool lalpha = FALSE;
4390 bool ralpha = FALSE;
4399 if ( !vverify(lhv) )
4400 Perl_croak(aTHX_ "Invalid version object");
4402 if ( !vverify(rhv) )
4403 Perl_croak(aTHX_ "Invalid version object");
4405 /* get the left hand term */
4406 lav = (AV *)SvRV(*hv_fetch((HV*)lhv, "version", 7, FALSE));
4407 if ( hv_exists((HV*)lhv, "alpha", 5 ) )
4410 /* and the right hand term */
4411 rav = (AV *)SvRV(*hv_fetch((HV*)rhv, "version", 7, FALSE));
4412 if ( hv_exists((HV*)rhv, "alpha", 5 ) )
4420 while ( i <= m && retval == 0 )
4422 left = SvIV(*av_fetch(lav,i,0));
4423 right = SvIV(*av_fetch(rav,i,0));
4431 /* tiebreaker for alpha with identical terms */
4432 if ( retval == 0 && l == r && left == right && ( lalpha || ralpha ) )
4434 if ( lalpha && !ralpha )
4438 else if ( ralpha && !lalpha)
4444 if ( l != r && retval == 0 ) /* possible match except for trailing 0's */
4448 while ( i <= r && retval == 0 )
4450 if ( SvIV(*av_fetch(rav,i,0)) != 0 )
4451 retval = -1; /* not a match after all */
4457 while ( i <= l && retval == 0 )
4459 if ( SvIV(*av_fetch(lav,i,0)) != 0 )
4460 retval = +1; /* not a match after all */
4468 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT)
4469 # define EMULATE_SOCKETPAIR_UDP
4472 #ifdef EMULATE_SOCKETPAIR_UDP
4474 S_socketpair_udp (int fd[2]) {
4476 /* Fake a datagram socketpair using UDP to localhost. */
4477 int sockets[2] = {-1, -1};
4478 struct sockaddr_in addresses[2];
4480 Sock_size_t size = sizeof(struct sockaddr_in);
4481 unsigned short port;
4484 memset(&addresses, 0, sizeof(addresses));
4487 sockets[i] = PerlSock_socket(AF_INET, SOCK_DGRAM, PF_INET);
4488 if (sockets[i] == -1)
4489 goto tidy_up_and_fail;
4491 addresses[i].sin_family = AF_INET;
4492 addresses[i].sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4493 addresses[i].sin_port = 0; /* kernel choses port. */
4494 if (PerlSock_bind(sockets[i], (struct sockaddr *) &addresses[i],
4495 sizeof(struct sockaddr_in)) == -1)
4496 goto tidy_up_and_fail;
4499 /* Now have 2 UDP sockets. Find out which port each is connected to, and
4500 for each connect the other socket to it. */
4503 if (PerlSock_getsockname(sockets[i], (struct sockaddr *) &addresses[i],
4505 goto tidy_up_and_fail;
4506 if (size != sizeof(struct sockaddr_in))
4507 goto abort_tidy_up_and_fail;
4508 /* !1 is 0, !0 is 1 */
4509 if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i],
4510 sizeof(struct sockaddr_in)) == -1)
4511 goto tidy_up_and_fail;
4514 /* Now we have 2 sockets connected to each other. I don't trust some other
4515 process not to have already sent a packet to us (by random) so send
4516 a packet from each to the other. */
4519 /* I'm going to send my own port number. As a short.
4520 (Who knows if someone somewhere has sin_port as a bitfield and needs
4521 this routine. (I'm assuming crays have socketpair)) */
4522 port = addresses[i].sin_port;
4523 got = PerlLIO_write(sockets[i], &port, sizeof(port));
4524 if (got != sizeof(port)) {
4526 goto tidy_up_and_fail;
4527 goto abort_tidy_up_and_fail;
4531 /* Packets sent. I don't trust them to have arrived though.
4532 (As I understand it Solaris TCP stack is multithreaded. Non-blocking
4533 connect to localhost will use a second kernel thread. In 2.6 the
4534 first thread running the connect() returns before the second completes,
4535 so EINPROGRESS> In 2.7 the improved stack is faster and connect()
4536 returns 0. Poor programs have tripped up. One poor program's authors'
4537 had a 50-1 reverse stock split. Not sure how connected these were.)
4538 So I don't trust someone not to have an unpredictable UDP stack.
4542 struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */
4543 int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0];
4547 FD_SET(sockets[0], &rset);
4548 FD_SET(sockets[1], &rset);
4550 got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor);
4551 if (got != 2 || !FD_ISSET(sockets[0], &rset)
4552 || !FD_ISSET(sockets[1], &rset)) {
4553 /* I hope this is portable and appropriate. */
4555 goto tidy_up_and_fail;
4556 goto abort_tidy_up_and_fail;
4560 /* And the paranoia department even now doesn't trust it to have arrive
4561 (hence MSG_DONTWAIT). Or that what arrives was sent by us. */
4563 struct sockaddr_in readfrom;
4564 unsigned short buffer[2];
4569 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4570 sizeof(buffer), MSG_DONTWAIT,
4571 (struct sockaddr *) &readfrom, &size);
4573 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4575 (struct sockaddr *) &readfrom, &size);
4579 goto tidy_up_and_fail;
4580 if (got != sizeof(port)
4581 || size != sizeof(struct sockaddr_in)
4582 /* Check other socket sent us its port. */
4583 || buffer[0] != (unsigned short) addresses[!i].sin_port
4584 /* Check kernel says we got the datagram from that socket */
4585 || readfrom.sin_family != addresses[!i].sin_family
4586 || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr
4587 || readfrom.sin_port != addresses[!i].sin_port)
4588 goto abort_tidy_up_and_fail;
4591 /* My caller (my_socketpair) has validated that this is non-NULL */
4594 /* I hereby declare this connection open. May God bless all who cross
4598 abort_tidy_up_and_fail:
4599 errno = ECONNABORTED;
4602 const int save_errno = errno;
4603 if (sockets[0] != -1)
4604 PerlLIO_close(sockets[0]);
4605 if (sockets[1] != -1)
4606 PerlLIO_close(sockets[1]);
4611 #endif /* EMULATE_SOCKETPAIR_UDP */
4613 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET)
4615 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4616 /* Stevens says that family must be AF_LOCAL, protocol 0.
4617 I'm going to enforce that, then ignore it, and use TCP (or UDP). */
4622 struct sockaddr_in listen_addr;
4623 struct sockaddr_in connect_addr;
4628 || family != AF_UNIX
4631 errno = EAFNOSUPPORT;
4639 #ifdef EMULATE_SOCKETPAIR_UDP
4640 if (type == SOCK_DGRAM)
4641 return S_socketpair_udp(fd);
4644 listener = PerlSock_socket(AF_INET, type, 0);
4647 memset(&listen_addr, 0, sizeof(listen_addr));
4648 listen_addr.sin_family = AF_INET;
4649 listen_addr.sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4650 listen_addr.sin_port = 0; /* kernel choses port. */
4651 if (PerlSock_bind(listener, (struct sockaddr *) &listen_addr,
4652 sizeof(listen_addr)) == -1)
4653 goto tidy_up_and_fail;
4654 if (PerlSock_listen(listener, 1) == -1)
4655 goto tidy_up_and_fail;
4657 connector = PerlSock_socket(AF_INET, type, 0);
4658 if (connector == -1)
4659 goto tidy_up_and_fail;
4660 /* We want to find out the port number to connect to. */
4661 size = sizeof(connect_addr);
4662 if (PerlSock_getsockname(listener, (struct sockaddr *) &connect_addr,
4664 goto tidy_up_and_fail;
4665 if (size != sizeof(connect_addr))
4666 goto abort_tidy_up_and_fail;
4667 if (PerlSock_connect(connector, (struct sockaddr *) &connect_addr,
4668 sizeof(connect_addr)) == -1)
4669 goto tidy_up_and_fail;
4671 size = sizeof(listen_addr);
4672 acceptor = PerlSock_accept(listener, (struct sockaddr *) &listen_addr,
4675 goto tidy_up_and_fail;
4676 if (size != sizeof(listen_addr))
4677 goto abort_tidy_up_and_fail;
4678 PerlLIO_close(listener);
4679 /* Now check we are talking to ourself by matching port and host on the
4681 if (PerlSock_getsockname(connector, (struct sockaddr *) &connect_addr,
4683 goto tidy_up_and_fail;
4684 if (size != sizeof(connect_addr)
4685 || listen_addr.sin_family != connect_addr.sin_family
4686 || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr
4687 || listen_addr.sin_port != connect_addr.sin_port) {
4688 goto abort_tidy_up_and_fail;
4694 abort_tidy_up_and_fail:
4696 errno = ECONNABORTED; /* This would be the standard thing to do. */
4698 # ifdef ECONNREFUSED
4699 errno = ECONNREFUSED; /* E.g. Symbian does not have ECONNABORTED. */
4701 errno = ETIMEDOUT; /* Desperation time. */
4706 int save_errno = errno;
4708 PerlLIO_close(listener);
4709 if (connector != -1)
4710 PerlLIO_close(connector);
4712 PerlLIO_close(acceptor);
4718 /* In any case have a stub so that there's code corresponding
4719 * to the my_socketpair in global.sym. */
4721 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4722 #ifdef HAS_SOCKETPAIR
4723 return socketpair(family, type, protocol, fd);
4732 =for apidoc sv_nosharing
4734 Dummy routine which "shares" an SV when there is no sharing module present.
4735 Exists to avoid test for a NULL function pointer and because it could potentially warn under
4736 some level of strict-ness.
4742 Perl_sv_nosharing(pTHX_ SV *sv)
4744 PERL_UNUSED_ARG(sv);
4748 =for apidoc sv_nolocking
4750 Dummy routine which "locks" an SV when there is no locking module present.
4751 Exists to avoid test for a NULL function pointer and because it could potentially warn under
4752 some level of strict-ness.
4758 Perl_sv_nolocking(pTHX_ SV *sv)
4760 PERL_UNUSED_ARG(sv);
4765 =for apidoc sv_nounlocking
4767 Dummy routine which "unlocks" an SV when there is no locking module present.
4768 Exists to avoid test for a NULL function pointer and because it could potentially warn under
4769 some level of strict-ness.
4775 Perl_sv_nounlocking(pTHX_ SV *sv)
4777 PERL_UNUSED_ARG(sv);
4781 Perl_parse_unicode_opts(pTHX_ const char **popt)
4783 const char *p = *popt;
4788 opt = (U32) atoi(p);
4789 while (isDIGIT(*p)) p++;
4790 if (*p && *p != '\n' && *p != '\r')
4791 Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
4796 case PERL_UNICODE_STDIN:
4797 opt |= PERL_UNICODE_STDIN_FLAG; break;
4798 case PERL_UNICODE_STDOUT:
4799 opt |= PERL_UNICODE_STDOUT_FLAG; break;
4800 case PERL_UNICODE_STDERR:
4801 opt |= PERL_UNICODE_STDERR_FLAG; break;
4802 case PERL_UNICODE_STD:
4803 opt |= PERL_UNICODE_STD_FLAG; break;
4804 case PERL_UNICODE_IN:
4805 opt |= PERL_UNICODE_IN_FLAG; break;
4806 case PERL_UNICODE_OUT:
4807 opt |= PERL_UNICODE_OUT_FLAG; break;
4808 case PERL_UNICODE_INOUT:
4809 opt |= PERL_UNICODE_INOUT_FLAG; break;
4810 case PERL_UNICODE_LOCALE:
4811 opt |= PERL_UNICODE_LOCALE_FLAG; break;
4812 case PERL_UNICODE_ARGV:
4813 opt |= PERL_UNICODE_ARGV_FLAG; break;
4815 if (*p != '\n' && *p != '\r')
4817 "Unknown Unicode option letter '%c'", *p);
4823 opt = PERL_UNICODE_DEFAULT_FLAGS;
4825 if (opt & ~PERL_UNICODE_ALL_FLAGS)
4826 Perl_croak(aTHX_ "Unknown Unicode option value %"UVuf,
4827 (UV) (opt & ~PERL_UNICODE_ALL_FLAGS));
4838 * This is really just a quick hack which grabs various garbage
4839 * values. It really should be a real hash algorithm which
4840 * spreads the effect of every input bit onto every output bit,
4841 * if someone who knows about such things would bother to write it.
4842 * Might be a good idea to add that function to CORE as well.
4843 * No numbers below come from careful analysis or anything here,
4844 * except they are primes and SEED_C1 > 1E6 to get a full-width
4845 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
4846 * probably be bigger too.
4849 # define SEED_C1 1000003
4850 #define SEED_C4 73819
4852 # define SEED_C1 25747
4853 #define SEED_C4 20639
4857 #define SEED_C5 26107
4859 #ifndef PERL_NO_DEV_RANDOM
4864 # include <starlet.h>
4865 /* when[] = (low 32 bits, high 32 bits) of time since epoch
4866 * in 100-ns units, typically incremented ever 10 ms. */
4867 unsigned int when[2];
4869 # ifdef HAS_GETTIMEOFDAY
4870 struct timeval when;
4876 /* This test is an escape hatch, this symbol isn't set by Configure. */
4877 #ifndef PERL_NO_DEV_RANDOM
4878 #ifndef PERL_RANDOM_DEVICE
4879 /* /dev/random isn't used by default because reads from it will block
4880 * if there isn't enough entropy available. You can compile with
4881 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
4882 * is enough real entropy to fill the seed. */
4883 # define PERL_RANDOM_DEVICE "/dev/urandom"
4885 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
4887 if (PerlLIO_read(fd, (void*)&u, sizeof u) != sizeof u)
4896 _ckvmssts(sys$gettim(when));
4897 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
4899 # ifdef HAS_GETTIMEOFDAY
4900 PerlProc_gettimeofday(&when,NULL);
4901 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
4904 u = (U32)SEED_C1 * when;
4907 u += SEED_C3 * (U32)PerlProc_getpid();
4908 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
4909 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
4910 u += SEED_C5 * (U32)PTR2UV(&when);
4916 Perl_get_hash_seed(pTHX)
4918 const char *s = PerlEnv_getenv("PERL_HASH_SEED");
4922 while (isSPACE(*s)) s++;
4923 if (s && isDIGIT(*s))
4924 myseed = (UV)Atoul(s);
4926 #ifdef USE_HASH_SEED_EXPLICIT
4930 /* Compute a random seed */
4931 (void)seedDrand01((Rand_seed_t)seed());
4932 myseed = (UV)(Drand01() * (NV)UV_MAX);
4933 #if RANDBITS < (UVSIZE * 8)
4934 /* Since there are not enough randbits to to reach all
4935 * the bits of a UV, the low bits might need extra
4936 * help. Sum in another random number that will
4937 * fill in the low bits. */
4939 (UV)(Drand01() * (NV)((1 << ((UVSIZE * 8 - RANDBITS))) - 1));
4940 #endif /* RANDBITS < (UVSIZE * 8) */
4941 if (myseed == 0) { /* Superparanoia. */
4942 myseed = (UV)(Drand01() * (NV)UV_MAX); /* One more chance. */
4944 Perl_croak(aTHX_ "Your random numbers are not that random");
4947 PL_rehash_seed_set = TRUE;
4954 Perl_stashpv_hvname_match(pTHX_ const COP *c, const HV *hv)
4956 const char * const stashpv = CopSTASHPV(c);
4957 const char * const name = HvNAME_get(hv);
4959 if (stashpv == name)
4961 if (stashpv && name)
4962 if (strEQ(stashpv, name))
4969 #ifdef PERL_GLOBAL_STRUCT
4972 Perl_init_global_struct(pTHX)
4974 struct perl_vars *plvarsp = NULL;
4975 #ifdef PERL_GLOBAL_STRUCT
4976 # define PERL_GLOBAL_STRUCT_INIT
4977 # include "opcode.h" /* the ppaddr and check */
4978 IV nppaddr = sizeof(Gppaddr)/sizeof(Perl_ppaddr_t);
4979 IV ncheck = sizeof(Gcheck) /sizeof(Perl_check_t);
4980 # ifdef PERL_GLOBAL_STRUCT_PRIVATE
4981 /* PerlMem_malloc() because can't use even safesysmalloc() this early. */
4982 plvarsp = (struct perl_vars*)PerlMem_malloc(sizeof(struct perl_vars));
4986 plvarsp = PL_VarsPtr;
4987 # endif /* PERL_GLOBAL_STRUCT_PRIVATE */
4993 # define PERLVAR(var,type) /**/
4994 # define PERLVARA(var,n,type) /**/
4995 # define PERLVARI(var,type,init) plvarsp->var = init;
4996 # define PERLVARIC(var,type,init) plvarsp->var = init;
4997 # define PERLVARISC(var,init) Copy(init, plvarsp->var, sizeof(init), char);
4998 # include "perlvars.h"
5004 # ifdef PERL_GLOBAL_STRUCT
5005 plvarsp->Gppaddr = PerlMem_malloc(nppaddr * sizeof(Perl_ppaddr_t));
5006 if (!plvarsp->Gppaddr)
5008 plvarsp->Gcheck = PerlMem_malloc(ncheck * sizeof(Perl_check_t));
5009 if (!plvarsp->Gcheck)
5011 Copy(Gppaddr, plvarsp->Gppaddr, nppaddr, Perl_ppaddr_t);
5012 Copy(Gcheck, plvarsp->Gcheck, ncheck, Perl_check_t);
5014 # ifdef PERL_SET_VARS
5015 PERL_SET_VARS(plvarsp);
5017 # undef PERL_GLOBAL_STRUCT_INIT
5022 #endif /* PERL_GLOBAL_STRUCT */
5024 #ifdef PERL_GLOBAL_STRUCT
5027 Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp)
5029 #ifdef PERL_GLOBAL_STRUCT
5030 # ifdef PERL_UNSET_VARS
5031 PERL_UNSET_VARS(plvarsp);
5033 free(plvarsp->Gppaddr);
5034 free(plvarsp->Gcheck);
5035 # ifdef PERL_GLOBAL_STRUCT_PRIVATE
5041 #endif /* PERL_GLOBAL_STRUCT */
5045 #define PERL_MEM_LOG_SPRINTF_BUF_SIZE 128
5048 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)
5050 #ifdef PERL_MEM_LOG_STDERR
5051 /* We can't use PerlIO for obvious reasons. */
5052 char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
5054 "alloc: %s:%d:%s: %"IVdf" %"UVuf" %s = %"IVdf": %"UVxf"\n",
5055 filename, linenumber, funcname,
5056 n, typesize, typename, n * typesize, PTR2UV(newalloc));
5057 PerlLIO_write(2, buf, strlen(buf));
5063 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)
5065 #ifdef PERL_MEM_LOG_STDERR
5066 /* We can't use PerlIO for obvious reasons. */
5067 char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
5069 "realloc: %s:%d:%s: %"IVdf" %"UVuf" %s = %"IVdf": %"UVxf" -> %"UVxf"\n",
5070 filename, linenumber, funcname,
5071 n, typesize, typename, n * typesize, PTR2UV(oldalloc), PTR2UV(newalloc));
5072 PerlLIO_write(2, buf, strlen(buf));
5078 Perl_mem_log_free(Malloc_t oldalloc, const char *filename, const int linenumber, const char *funcname)
5080 #ifdef PERL_MEM_LOG_STDERR
5081 /* We can't use PerlIO for obvious reasons. */
5082 char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
5083 sprintf(buf, "free: %s:%d:%s: %"UVxf"\n",
5084 filename, linenumber, funcname, PTR2UV(oldalloc));
5085 PerlLIO_write(2, buf, strlen(buf));
5090 #endif /* PERL_MEM_LOG */
5093 =for apidoc my_sprintf
5095 The C library C<sprintf>, wrapped if necessary, to ensure that it will return
5096 the length of the string written to the buffer. Only rare pre-ANSI systems
5097 need the wrapper function - usually this is a direct call to C<sprintf>.
5101 #ifndef SPRINTF_RETURNS_STRLEN
5103 Perl_my_sprintf(char *buffer, const char* pat, ...)
5106 va_start(args, pat);
5107 vsprintf(buffer, pat, args);
5109 return strlen(buffer);
5115 * c-indentation-style: bsd
5117 * indent-tabs-mode: t
5120 * ex: set ts=8 sts=4 sw=4 noet: