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 # include <sys/wait.h>
39 # include <sys/select.h>
45 #if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC)
46 # define FD_CLOEXEC 1 /* NeXT needs this */
49 /* NOTE: Do not call the next three routines directly. Use the macros
50 * in handy.h, so that we can easily redefine everything to do tracking of
51 * allocated hunks back to the original New to track down any memory leaks.
52 * XXX This advice seems to be widely ignored :-( --AD August 1996.
55 /* paranoid version of system's malloc() */
58 Perl_safesysmalloc(MEM_SIZE size)
64 PerlIO_printf(Perl_error_log,
65 "Allocation too large: %lx\n", size) FLUSH;
68 #endif /* HAS_64K_LIMIT */
71 Perl_croak_nocontext("panic: malloc");
73 ptr = (Malloc_t)PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */
74 PERL_ALLOC_CHECK(ptr);
75 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
81 /* Can't use PerlIO to write as it allocates memory */
82 PerlLIO_write(PerlIO_fileno(Perl_error_log),
83 PL_no_mem, strlen(PL_no_mem));
90 /* paranoid version of system's realloc() */
93 Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
97 #if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) && !defined(PERL_MICRO)
98 Malloc_t PerlMem_realloc();
99 #endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */
103 PerlIO_printf(Perl_error_log,
104 "Reallocation too large: %lx\n", size) FLUSH;
107 #endif /* HAS_64K_LIMIT */
114 return safesysmalloc(size);
117 Perl_croak_nocontext("panic: realloc");
119 ptr = (Malloc_t)PerlMem_realloc(where,size);
120 PERL_ALLOC_CHECK(ptr);
122 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++));
123 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
130 /* Can't use PerlIO to write as it allocates memory */
131 PerlLIO_write(PerlIO_fileno(Perl_error_log),
132 PL_no_mem, strlen(PL_no_mem));
139 /* safe version of system's free() */
142 Perl_safesysfree(Malloc_t where)
145 #ifdef PERL_IMPLICIT_SYS
148 DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) free\n",PTR2UV(where),(long)PL_an++));
155 /* safe version of system's calloc() */
158 Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
164 if (size * count > 0xffff) {
165 PerlIO_printf(Perl_error_log,
166 "Allocation too large: %lx\n", size * count) FLUSH;
169 #endif /* HAS_64K_LIMIT */
171 if ((long)size < 0 || (long)count < 0)
172 Perl_croak_nocontext("panic: calloc");
175 ptr = (Malloc_t)PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */
176 PERL_ALLOC_CHECK(ptr);
177 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));
179 memset((void*)ptr, 0, size);
185 /* Can't use PerlIO to write as it allocates memory */
186 PerlLIO_write(PerlIO_fileno(Perl_error_log),
187 PL_no_mem, strlen(PL_no_mem));
194 /* These must be defined when not using Perl's malloc for binary
199 Malloc_t Perl_malloc (MEM_SIZE nbytes)
202 return (Malloc_t)PerlMem_malloc(nbytes);
205 Malloc_t Perl_calloc (MEM_SIZE elements, MEM_SIZE size)
208 return (Malloc_t)PerlMem_calloc(elements, size);
211 Malloc_t Perl_realloc (Malloc_t where, MEM_SIZE nbytes)
214 return (Malloc_t)PerlMem_realloc(where, nbytes);
217 Free_t Perl_mfree (Malloc_t where)
225 /* copy a string up to some (non-backslashed) delimiter, if any */
228 Perl_delimcpy(pTHX_ register char *to, register const char *toend, register const char *from, register const char *fromend, register int delim, I32 *retlen)
231 for (tolen = 0; from < fromend; from++, tolen++) {
233 if (from[1] == delim)
242 else if (*from == delim)
253 /* return ptr to little string in big string, NULL if not found */
254 /* This routine was donated by Corey Satten. */
257 Perl_instr(pTHX_ register const char *big, register const char *little)
259 register const char *s, *x;
270 for (x=big,s=little; *s; /**/ ) {
279 return (char*)(big-1);
284 /* same as instr but allow embedded nulls */
287 Perl_ninstr(pTHX_ register const char *big, register const char *bigend, const char *little, const char *lend)
289 register const char *s, *x;
290 register const I32 first = *little;
291 register const char *littleend = lend;
293 if (!first && little >= littleend)
295 if (bigend - big < littleend - little)
297 bigend -= littleend - little++;
298 while (big <= bigend) {
301 for (x=big,s=little; s < littleend; /**/ ) {
308 return (char*)(big-1);
313 /* reverse of the above--find last substring */
316 Perl_rninstr(pTHX_ register const char *big, const char *bigend, const char *little, const char *lend)
318 register const char *bigbeg;
319 register const char *s, *x;
320 register const I32 first = *little;
321 register const char *littleend = lend;
323 if (!first && little >= littleend)
324 return (char*)bigend;
326 big = bigend - (littleend - little++);
327 while (big >= bigbeg) {
330 for (x=big+2,s=little; s < littleend; /**/ ) {
337 return (char*)(big+1);
342 #define FBM_TABLE_OFFSET 2 /* Number of bytes between EOS and table*/
344 /* As a space optimization, we do not compile tables for strings of length
345 0 and 1, and for strings of length 2 unless FBMcf_TAIL. These are
346 special-cased in fbm_instr().
348 If FBMcf_TAIL, the table is created as if the string has a trailing \n. */
351 =head1 Miscellaneous Functions
353 =for apidoc fbm_compile
355 Analyses the string in order to make fast searches on it using fbm_instr()
356 -- the Boyer-Moore algorithm.
362 Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
371 if (flags & FBMcf_TAIL) {
372 MAGIC *mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
373 sv_catpvn(sv, "\n", 1); /* Taken into account in fbm_instr() */
374 if (mg && mg->mg_len >= 0)
377 s = (U8*)SvPV_force(sv, len);
378 (void)SvUPGRADE(sv, SVt_PVBM);
379 if (len == 0) /* TAIL might be on a zero-length string. */
389 Sv_Grow(sv, len + 256 + FBM_TABLE_OFFSET);
390 table = (unsigned char*)(SvPVX(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 = (unsigned char*)(SvPVX(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 unsigned char *little = (unsigned char *)SvPV(littlestr,l);
442 register STRLEN littlelen = l;
443 register const I32 multiline = flags & FBMrf_MULTILINE;
445 if ((STRLEN)(bigend - big) < littlelen) {
446 if ( SvTAIL(littlestr)
447 && ((STRLEN)(bigend - big) == littlelen - 1)
449 || (*big == *little &&
450 memEQ((char *)big, (char *)little, littlelen - 1))))
455 if (littlelen <= 2) { /* Special-cased */
457 if (littlelen == 1) {
458 if (SvTAIL(littlestr) && !multiline) { /* Anchor only! */
459 /* Know that bigend != big. */
460 if (bigend[-1] == '\n')
461 return (char *)(bigend - 1);
462 return (char *) bigend;
470 if (SvTAIL(littlestr))
471 return (char *) bigend;
475 return (char*)big; /* Cannot be SvTAIL! */
478 if (SvTAIL(littlestr) && !multiline) {
479 if (bigend[-1] == '\n' && bigend[-2] == *little)
480 return (char*)bigend - 2;
481 if (bigend[-1] == *little)
482 return (char*)bigend - 1;
486 /* This should be better than FBM if c1 == c2, and almost
487 as good otherwise: maybe better since we do less indirection.
488 And we save a lot of memory by caching no table. */
489 register unsigned char c1 = little[0];
490 register unsigned char c2 = little[1];
495 while (s <= bigend) {
505 goto check_1char_anchor;
516 goto check_1char_anchor;
519 while (s <= bigend) {
524 goto check_1char_anchor;
533 check_1char_anchor: /* One char and anchor! */
534 if (SvTAIL(littlestr) && (*bigend == *little))
535 return (char *)bigend; /* bigend is already decremented. */
538 if (SvTAIL(littlestr) && !multiline) { /* tail anchored? */
539 s = bigend - littlelen;
540 if (s >= big && bigend[-1] == '\n' && *s == *little
541 /* Automatically of length > 2 */
542 && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
544 return (char*)s; /* how sweet it is */
547 && memEQ((char*)s + 2, (char*)little + 1, littlelen - 2))
549 return (char*)s + 1; /* how sweet it is */
553 if (SvTYPE(littlestr) != SVt_PVBM || !SvVALID(littlestr)) {
554 char *b = ninstr((char*)big,(char*)bigend,
555 (char*)little, (char*)little + littlelen);
557 if (!b && SvTAIL(littlestr)) { /* Automatically multiline! */
558 /* Chop \n from littlestr: */
559 s = bigend - littlelen + 1;
561 && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
570 { /* Do actual FBM. */
571 register const unsigned char *table = little + littlelen + FBM_TABLE_OFFSET;
572 register unsigned char *oldlittle;
574 if (littlelen > (STRLEN)(bigend - big))
576 --littlelen; /* Last char found by table lookup */
579 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 *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 unsigned char *s, *x;
636 register unsigned char *big;
638 register I32 previous;
640 register unsigned char *little;
641 register I32 stop_pos;
642 register unsigned char *littleend;
646 ? (pos = PL_screamfirst[BmRARE(littlestr)]) < 0
647 : (((pos = *old_posp), pos += PL_screamnext[pos]) == 0)) {
649 if ( BmRARE(littlestr) == '\n'
650 && BmPREVIOUS(littlestr) == SvCUR(littlestr) - 1) {
651 little = (unsigned char *)(SvPVX(littlestr));
652 littleend = little + SvCUR(littlestr);
659 little = (unsigned char *)(SvPVX(littlestr));
660 littleend = little + SvCUR(littlestr);
662 /* The value of pos we can start at: */
663 previous = BmPREVIOUS(littlestr);
664 big = (unsigned char *)(SvPVX(bigstr));
665 /* The value of pos we can stop at: */
666 stop_pos = SvCUR(bigstr) - end_shift - (SvCUR(littlestr) - 1 - previous);
667 if (previous + start_shift > stop_pos) {
669 stop_pos does not include SvTAIL in the count, so this check is incorrect
670 (I think) - see [ID 20010618.006] and t/op/study.t. HVDS 2001/06/19
673 if (previous + start_shift == stop_pos + 1) /* A fake '\n'? */
678 while (pos < previous + start_shift) {
679 if (!(pos += PL_screamnext[pos]))
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 = (unsigned char *)(SvPVX(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)
762 register char *newaddr;
763 #ifdef PERL_MALLOC_WRAP
769 #ifdef PERL_MALLOC_WRAP
770 pvlen = strlen(pv)+1;
771 New(902,newaddr,pvlen,char);
773 New(902,newaddr,strlen(pv)+1,char);
775 return strcpy(newaddr,pv);
778 /* same thing but with a known length */
783 Perl's version of what C<strndup()> would be if it existed. Returns a
784 pointer to a newly allocated string which is a duplicate of the first
785 C<len> bytes from C<pv>. The memory allocated for the new string can be
786 freed with the C<Safefree()> function.
792 Perl_savepvn(pTHX_ const char *pv, register I32 len)
794 register char *newaddr;
796 New(903,newaddr,len+1,char);
797 /* Give a meaning to NULL pointer mainly for the use in sv_magic() */
799 /* might not be null terminated */
801 return (char *) CopyD(pv,newaddr,len,char);
804 return (char *) ZeroD(newaddr,len+1,char);
809 =for apidoc savesharedpv
811 A version of C<savepv()> which allocates the duplicate string in memory
812 which is shared between threads.
817 Perl_savesharedpv(pTHX_ const char *pv)
819 register char *newaddr;
823 newaddr = (char*)PerlMemShared_malloc(strlen(pv)+1);
825 PerlLIO_write(PerlIO_fileno(Perl_error_log),
826 PL_no_mem, strlen(PL_no_mem));
829 return strcpy(newaddr,pv);
835 A version of C<savepv()>/C<savepvn()> which gets the string to duplicate from
836 the passed in SV using C<SvPV()>
842 Perl_savesvpv(pTHX_ SV *sv)
845 const char *pv = SvPV(sv, len);
846 register char *newaddr;
849 New(903,newaddr,len,char);
850 return (char *) CopyD(pv,newaddr,len,char);
854 /* the SV for Perl_form() and mess() is not kept in an arena */
863 return sv_2mortal(newSVpvn("",0));
868 /* Create as PVMG now, to avoid any upgrading later */
870 Newz(905, any, 1, XPVMG);
871 SvFLAGS(sv) = SVt_PVMG;
872 SvANY(sv) = (void*)any;
873 SvREFCNT(sv) = 1 << 30; /* practically infinite */
878 #if defined(PERL_IMPLICIT_CONTEXT)
880 Perl_form_nocontext(const char* pat, ...)
886 retval = vform(pat, &args);
890 #endif /* PERL_IMPLICIT_CONTEXT */
893 =head1 Miscellaneous Functions
896 Takes a sprintf-style format pattern and conventional
897 (non-SV) arguments and returns the formatted string.
899 (char *) Perl_form(pTHX_ const char* pat, ...)
901 can be used any place a string (char *) is required:
903 char * s = Perl_form("%d.%d",major,minor);
905 Uses a single private buffer so if you want to format several strings you
906 must explicitly copy the earlier strings away (and free the copies when you
913 Perl_form(pTHX_ const char* pat, ...)
918 retval = vform(pat, &args);
924 Perl_vform(pTHX_ const char *pat, va_list *args)
926 SV *sv = mess_alloc();
927 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
931 #if defined(PERL_IMPLICIT_CONTEXT)
933 Perl_mess_nocontext(const char *pat, ...)
939 retval = vmess(pat, &args);
943 #endif /* PERL_IMPLICIT_CONTEXT */
946 Perl_mess(pTHX_ const char *pat, ...)
951 retval = vmess(pat, &args);
957 S_closest_cop(pTHX_ COP *cop, OP *o)
959 /* Look for PL_op starting from o. cop is the last COP we've seen. */
961 if (!o || o == PL_op) return cop;
963 if (o->op_flags & OPf_KIDS) {
965 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
969 /* If the OP_NEXTSTATE has been optimised away we can still use it
970 * the get the file and line number. */
972 if (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE)
975 /* Keep searching, and return when we've found something. */
977 new_cop = closest_cop(cop, kid);
978 if (new_cop) return new_cop;
988 Perl_vmess(pTHX_ const char *pat, va_list *args)
990 SV *sv = mess_alloc();
991 static const char dgd[] = " during global destruction.\n";
993 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
994 if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
997 * Try and find the file and line for PL_op. This will usually be
998 * PL_curcop, but it might be a cop that has been optimised away. We
999 * can try to find such a cop by searching through the optree starting
1000 * from the sibling of PL_curcop.
1003 const COP *cop = closest_cop(PL_curcop, PL_curcop->op_sibling);
1004 if (!cop) cop = PL_curcop;
1007 Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf,
1008 OutCopFILE(cop), (IV)CopLINE(cop));
1009 if (GvIO(PL_last_in_gv) && IoLINES(GvIOp(PL_last_in_gv))) {
1010 const bool line_mode = (RsSIMPLE(PL_rs) &&
1011 SvCUR(PL_rs) == 1 && *SvPVX(PL_rs) == '\n');
1012 Perl_sv_catpvf(aTHX_ sv, ", <%s> %s %"IVdf,
1013 PL_last_in_gv == PL_argvgv ?
1014 "" : GvNAME(PL_last_in_gv),
1015 line_mode ? "line" : "chunk",
1016 (IV)IoLINES(GvIOp(PL_last_in_gv)));
1018 sv_catpv(sv, PL_dirty ? dgd : ".\n");
1024 Perl_write_to_stderr(pTHX_ const char* message, int msglen)
1030 if (PL_stderrgv && SvREFCNT(PL_stderrgv)
1031 && (io = GvIO(PL_stderrgv))
1032 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
1039 SAVESPTR(PL_stderrgv);
1040 PL_stderrgv = Nullgv;
1042 PUSHSTACKi(PERLSI_MAGIC);
1046 PUSHs(SvTIED_obj((SV*)io, mg));
1047 PUSHs(sv_2mortal(newSVpvn(message, msglen)));
1049 call_method("PRINT", G_SCALAR);
1057 /* SFIO can really mess with your errno */
1060 PerlIO *serr = Perl_error_log;
1062 PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
1063 (void)PerlIO_flush(serr);
1070 /* Common code used by vcroak, vdie and vwarner */
1072 void S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8);
1075 S_vdie_croak_common(pTHX_ const char* pat, va_list* args, STRLEN* msglen,
1082 SV *msv = vmess(pat, args);
1083 if (PL_errors && SvCUR(PL_errors)) {
1084 sv_catsv(PL_errors, msv);
1085 message = SvPV(PL_errors, *msglen);
1086 SvCUR_set(PL_errors, 0);
1089 message = SvPV(msv,*msglen);
1090 *utf8 = SvUTF8(msv);
1096 DEBUG_S(PerlIO_printf(Perl_debug_log,
1097 "%p: die/croak: message = %s\ndiehook = %p\n",
1098 thr, message, PL_diehook));
1100 S_vdie_common(aTHX_ message, *msglen, *utf8);
1106 S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8)
1111 /* sv_2cv might call Perl_croak() */
1112 SV *olddiehook = PL_diehook;
1116 SAVESPTR(PL_diehook);
1117 PL_diehook = Nullsv;
1118 cv = sv_2cv(olddiehook, &stash, &gv, 0);
1120 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1127 msg = newSVpvn(message, msglen);
1128 SvFLAGS(msg) |= utf8;
1136 PUSHSTACKi(PERLSI_DIEHOOK);
1140 call_sv((SV*)cv, G_DISCARD);
1147 Perl_vdie(pTHX_ const char* pat, va_list *args)
1149 const char *message;
1150 const int was_in_eval = PL_in_eval;
1154 DEBUG_S(PerlIO_printf(Perl_debug_log,
1155 "%p: die: curstack = %p, mainstack = %p\n",
1156 thr, PL_curstack, PL_mainstack));
1158 message = S_vdie_croak_common(aTHX_ pat, args, &msglen, &utf8);
1160 PL_restartop = die_where(message, msglen);
1161 SvFLAGS(ERRSV) |= utf8;
1162 DEBUG_S(PerlIO_printf(Perl_debug_log,
1163 "%p: die: restartop = %p, was_in_eval = %d, top_env = %p\n",
1164 thr, PL_restartop, was_in_eval, PL_top_env));
1165 if ((!PL_restartop && was_in_eval) || PL_top_env->je_prev)
1167 return PL_restartop;
1170 #if defined(PERL_IMPLICIT_CONTEXT)
1172 Perl_die_nocontext(const char* pat, ...)
1177 va_start(args, pat);
1178 o = vdie(pat, &args);
1182 #endif /* PERL_IMPLICIT_CONTEXT */
1185 Perl_die(pTHX_ const char* pat, ...)
1189 va_start(args, pat);
1190 o = vdie(pat, &args);
1196 Perl_vcroak(pTHX_ const char* pat, va_list *args)
1198 const char *message;
1202 message = S_vdie_croak_common(aTHX_ pat, args, &msglen, &utf8);
1205 PL_restartop = die_where(message, msglen);
1206 SvFLAGS(ERRSV) |= utf8;
1210 message = SvPVx(ERRSV, msglen);
1212 write_to_stderr(message, msglen);
1216 #if defined(PERL_IMPLICIT_CONTEXT)
1218 Perl_croak_nocontext(const char *pat, ...)
1222 va_start(args, pat);
1227 #endif /* PERL_IMPLICIT_CONTEXT */
1230 =head1 Warning and Dieing
1234 This is the XSUB-writer's interface to Perl's C<die> function.
1235 Normally call this function the same way you call the C C<printf>
1236 function. Calling C<croak> returns control directly to Perl,
1237 sidestepping the normal C order of execution. See C<warn>.
1239 If you want to throw an exception object, assign the object to
1240 C<$@> and then pass C<Nullch> to croak():
1242 errsv = get_sv("@", TRUE);
1243 sv_setsv(errsv, exception_object);
1250 Perl_croak(pTHX_ const char *pat, ...)
1253 va_start(args, pat);
1260 Perl_vwarn(pTHX_ const char* pat, va_list *args)
1271 msv = vmess(pat, args);
1273 message = SvPV(msv, msglen);
1276 /* sv_2cv might call Perl_warn() */
1277 SV *oldwarnhook = PL_warnhook;
1279 SAVESPTR(PL_warnhook);
1280 PL_warnhook = Nullsv;
1281 cv = sv_2cv(oldwarnhook, &stash, &gv, 0);
1283 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1289 msg = newSVpvn(message, msglen);
1290 SvFLAGS(msg) |= utf8;
1294 PUSHSTACKi(PERLSI_WARNHOOK);
1298 call_sv((SV*)cv, G_DISCARD);
1305 write_to_stderr(message, msglen);
1308 #if defined(PERL_IMPLICIT_CONTEXT)
1310 Perl_warn_nocontext(const char *pat, ...)
1314 va_start(args, pat);
1318 #endif /* PERL_IMPLICIT_CONTEXT */
1323 This is the XSUB-writer's interface to Perl's C<warn> function. Call this
1324 function the same way you call the C C<printf> function. See C<croak>.
1330 Perl_warn(pTHX_ const char *pat, ...)
1333 va_start(args, pat);
1338 #if defined(PERL_IMPLICIT_CONTEXT)
1340 Perl_warner_nocontext(U32 err, const char *pat, ...)
1344 va_start(args, pat);
1345 vwarner(err, pat, &args);
1348 #endif /* PERL_IMPLICIT_CONTEXT */
1351 Perl_warner(pTHX_ U32 err, const char* pat,...)
1354 va_start(args, pat);
1355 vwarner(err, pat, &args);
1360 Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args)
1364 SV * const msv = vmess(pat, args);
1366 const char *message = SvPV(msv, msglen);
1367 const I32 utf8 = SvUTF8(msv);
1371 S_vdie_common(aTHX_ message, msglen, utf8);
1374 PL_restartop = die_where(message, msglen);
1375 SvFLAGS(ERRSV) |= utf8;
1378 write_to_stderr(message, msglen);
1382 Perl_vwarn(aTHX_ pat, args);
1386 /* since we've already done strlen() for both nam and val
1387 * we can use that info to make things faster than
1388 * sprintf(s, "%s=%s", nam, val)
1390 #define my_setenv_format(s, nam, nlen, val, vlen) \
1391 Copy(nam, s, nlen, char); \
1393 Copy(val, s+(nlen+1), vlen, char); \
1394 *(s+(nlen+1+vlen)) = '\0'
1396 #ifdef USE_ENVIRON_ARRAY
1397 /* VMS' my_setenv() is in vms.c */
1398 #if !defined(WIN32) && !defined(NETWARE)
1400 Perl_my_setenv(pTHX_ const char *nam, const char *val)
1404 /* only parent thread can modify process environment */
1405 if (PL_curinterp == aTHX)
1408 #ifndef PERL_USE_SAFE_PUTENV
1409 if (!PL_use_safe_putenv) {
1410 /* most putenv()s leak, so we manipulate environ directly */
1411 register I32 i=setenv_getix(nam); /* where does it go? */
1414 if (environ == PL_origenviron) { /* need we copy environment? */
1420 for (max = i; environ[max]; max++) ;
1421 tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*));
1422 for (j=0; j<max; j++) { /* copy environment */
1423 const int len = strlen(environ[j]);
1424 tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char));
1425 Copy(environ[j], tmpenv[j], len+1, char);
1427 tmpenv[max] = Nullch;
1428 environ = tmpenv; /* tell exec where it is now */
1431 safesysfree(environ[i]);
1432 while (environ[i]) {
1433 environ[i] = environ[i+1];
1438 if (!environ[i]) { /* does not exist yet */
1439 environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
1440 environ[i+1] = Nullch; /* make sure it's null terminated */
1443 safesysfree(environ[i]);
1447 environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char));
1448 /* all that work just for this */
1449 my_setenv_format(environ[i], nam, nlen, val, vlen);
1452 # if defined(__CYGWIN__) || defined(EPOC) || defined(SYMBIAN)
1453 setenv(nam, val, 1);
1456 int nlen = strlen(nam), vlen;
1461 new_env = (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
1462 /* all that work just for this */
1463 my_setenv_format(new_env, nam, nlen, val, vlen);
1464 (void)putenv(new_env);
1465 # endif /* __CYGWIN__ */
1466 #ifndef PERL_USE_SAFE_PUTENV
1472 #else /* WIN32 || NETWARE */
1475 Perl_my_setenv(pTHX_ const char *nam, const char *val)
1478 register char *envstr;
1479 const int nlen = strlen(nam);
1486 New(904, envstr, nlen+vlen+2, char);
1487 my_setenv_format(envstr, nam, nlen, val, vlen);
1488 (void)PerlEnv_putenv(envstr);
1492 #endif /* WIN32 || NETWARE */
1496 Perl_setenv_getix(pTHX_ const char *nam)
1498 register I32 i, len = strlen(nam);
1500 for (i = 0; environ[i]; i++) {
1503 strnicmp(environ[i],nam,len) == 0
1505 strnEQ(environ[i],nam,len)
1507 && environ[i][len] == '=')
1508 break; /* strnEQ must come first to avoid */
1509 } /* potential SEGV's */
1512 #endif /* !PERL_MICRO */
1514 #endif /* !VMS && !EPOC*/
1516 #ifdef UNLINK_ALL_VERSIONS
1518 Perl_unlnk(pTHX_ char *f) /* unlink all versions of a file */
1522 for (i = 0; PerlLIO_unlink(f) >= 0; i++) ;
1527 /* this is a drop-in replacement for bcopy() */
1528 #if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY))
1530 Perl_my_bcopy(register const char *from,register char *to,register I32 len)
1534 if (from - to >= 0) {
1542 *(--to) = *(--from);
1548 /* this is a drop-in replacement for memset() */
1551 Perl_my_memset(register char *loc, register I32 ch, register I32 len)
1561 /* this is a drop-in replacement for bzero() */
1562 #if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
1564 Perl_my_bzero(register char *loc, register I32 len)
1574 /* this is a drop-in replacement for memcmp() */
1575 #if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
1577 Perl_my_memcmp(const char *s1, const char *s2, register I32 len)
1579 register const U8 *a = (const U8 *)s1;
1580 register const U8 *b = (const U8 *)s2;
1584 if ((tmp = *a++ - *b++))
1589 #endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */
1593 #ifdef USE_CHAR_VSPRINTF
1598 vsprintf(char *dest, const char *pat, char *args)
1602 fakebuf._ptr = dest;
1603 fakebuf._cnt = 32767;
1607 fakebuf._flag = _IOWRT|_IOSTRG;
1608 _doprnt(pat, args, &fakebuf); /* what a kludge */
1609 (void)putc('\0', &fakebuf);
1610 #ifdef USE_CHAR_VSPRINTF
1613 return 0; /* perl doesn't use return value */
1617 #endif /* HAS_VPRINTF */
1620 #if BYTEORDER != 0x4321
1622 Perl_my_swap(pTHX_ short s)
1624 #if (BYTEORDER & 1) == 0
1627 result = ((s & 255) << 8) + ((s >> 8) & 255);
1635 Perl_my_htonl(pTHX_ long l)
1639 char c[sizeof(long)];
1642 #if BYTEORDER == 0x1234
1643 u.c[0] = (l >> 24) & 255;
1644 u.c[1] = (l >> 16) & 255;
1645 u.c[2] = (l >> 8) & 255;
1649 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
1650 Perl_croak(aTHX_ "Unknown BYTEORDER\n");
1655 for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
1656 u.c[o & 0xf] = (l >> s) & 255;
1664 Perl_my_ntohl(pTHX_ long l)
1668 char c[sizeof(long)];
1671 #if BYTEORDER == 0x1234
1672 u.c[0] = (l >> 24) & 255;
1673 u.c[1] = (l >> 16) & 255;
1674 u.c[2] = (l >> 8) & 255;
1678 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
1679 Perl_croak(aTHX_ "Unknown BYTEORDER\n");
1686 for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
1687 l |= (u.c[o & 0xf] & 255) << s;
1694 #endif /* BYTEORDER != 0x4321 */
1698 * Little-endian byte order functions - 'v' for 'VAX', or 'reVerse'.
1699 * If these functions are defined,
1700 * the BYTEORDER is neither 0x1234 nor 0x4321.
1701 * However, this is not assumed.
1705 #define HTOLE(name,type) \
1707 name (register type n) \
1711 char c[sizeof(type)]; \
1714 register I32 s = 0; \
1715 for (i = 0; i < sizeof(u.c); i++, s += 8) { \
1716 u.c[i] = (n >> s) & 0xFF; \
1721 #define LETOH(name,type) \
1723 name (register type n) \
1727 char c[sizeof(type)]; \
1730 register I32 s = 0; \
1733 for (i = 0; i < sizeof(u.c); i++, s += 8) { \
1734 n |= ((type)(u.c[i] & 0xFF)) << s; \
1740 * Big-endian byte order functions.
1743 #define HTOBE(name,type) \
1745 name (register type n) \
1749 char c[sizeof(type)]; \
1752 register I32 s = 8*(sizeof(u.c)-1); \
1753 for (i = 0; i < sizeof(u.c); i++, s -= 8) { \
1754 u.c[i] = (n >> s) & 0xFF; \
1759 #define BETOH(name,type) \
1761 name (register type n) \
1765 char c[sizeof(type)]; \
1768 register I32 s = 8*(sizeof(u.c)-1); \
1771 for (i = 0; i < sizeof(u.c); i++, s -= 8) { \
1772 n |= ((type)(u.c[i] & 0xFF)) << s; \
1778 * If we just can't do it...
1781 #define NOT_AVAIL(name,type) \
1783 name (register type n) \
1785 Perl_croak_nocontext(#name "() not available"); \
1786 return n; /* not reached */ \
1790 #if defined(HAS_HTOVS) && !defined(htovs)
1793 #if defined(HAS_HTOVL) && !defined(htovl)
1796 #if defined(HAS_VTOHS) && !defined(vtohs)
1799 #if defined(HAS_VTOHL) && !defined(vtohl)
1803 #ifdef PERL_NEED_MY_HTOLE16
1805 HTOLE(Perl_my_htole16,U16)
1807 NOT_AVAIL(Perl_my_htole16,U16)
1810 #ifdef PERL_NEED_MY_LETOH16
1812 LETOH(Perl_my_letoh16,U16)
1814 NOT_AVAIL(Perl_my_letoh16,U16)
1817 #ifdef PERL_NEED_MY_HTOBE16
1819 HTOBE(Perl_my_htobe16,U16)
1821 NOT_AVAIL(Perl_my_htobe16,U16)
1824 #ifdef PERL_NEED_MY_BETOH16
1826 BETOH(Perl_my_betoh16,U16)
1828 NOT_AVAIL(Perl_my_betoh16,U16)
1832 #ifdef PERL_NEED_MY_HTOLE32
1834 HTOLE(Perl_my_htole32,U32)
1836 NOT_AVAIL(Perl_my_htole32,U32)
1839 #ifdef PERL_NEED_MY_LETOH32
1841 LETOH(Perl_my_letoh32,U32)
1843 NOT_AVAIL(Perl_my_letoh32,U32)
1846 #ifdef PERL_NEED_MY_HTOBE32
1848 HTOBE(Perl_my_htobe32,U32)
1850 NOT_AVAIL(Perl_my_htobe32,U32)
1853 #ifdef PERL_NEED_MY_BETOH32
1855 BETOH(Perl_my_betoh32,U32)
1857 NOT_AVAIL(Perl_my_betoh32,U32)
1861 #ifdef PERL_NEED_MY_HTOLE64
1863 HTOLE(Perl_my_htole64,U64)
1865 NOT_AVAIL(Perl_my_htole64,U64)
1868 #ifdef PERL_NEED_MY_LETOH64
1870 LETOH(Perl_my_letoh64,U64)
1872 NOT_AVAIL(Perl_my_letoh64,U64)
1875 #ifdef PERL_NEED_MY_HTOBE64
1877 HTOBE(Perl_my_htobe64,U64)
1879 NOT_AVAIL(Perl_my_htobe64,U64)
1882 #ifdef PERL_NEED_MY_BETOH64
1884 BETOH(Perl_my_betoh64,U64)
1886 NOT_AVAIL(Perl_my_betoh64,U64)
1890 #ifdef PERL_NEED_MY_HTOLES
1891 HTOLE(Perl_my_htoles,short)
1893 #ifdef PERL_NEED_MY_LETOHS
1894 LETOH(Perl_my_letohs,short)
1896 #ifdef PERL_NEED_MY_HTOBES
1897 HTOBE(Perl_my_htobes,short)
1899 #ifdef PERL_NEED_MY_BETOHS
1900 BETOH(Perl_my_betohs,short)
1903 #ifdef PERL_NEED_MY_HTOLEI
1904 HTOLE(Perl_my_htolei,int)
1906 #ifdef PERL_NEED_MY_LETOHI
1907 LETOH(Perl_my_letohi,int)
1909 #ifdef PERL_NEED_MY_HTOBEI
1910 HTOBE(Perl_my_htobei,int)
1912 #ifdef PERL_NEED_MY_BETOHI
1913 BETOH(Perl_my_betohi,int)
1916 #ifdef PERL_NEED_MY_HTOLEL
1917 HTOLE(Perl_my_htolel,long)
1919 #ifdef PERL_NEED_MY_LETOHL
1920 LETOH(Perl_my_letohl,long)
1922 #ifdef PERL_NEED_MY_HTOBEL
1923 HTOBE(Perl_my_htobel,long)
1925 #ifdef PERL_NEED_MY_BETOHL
1926 BETOH(Perl_my_betohl,long)
1930 Perl_my_swabn(void *ptr, int n)
1932 register char *s = (char *)ptr;
1933 register char *e = s + (n-1);
1936 for (n /= 2; n > 0; s++, e--, n--) {
1944 Perl_my_popen_list(pTHX_ char *mode, int n, SV **args)
1946 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) && !defined(NETWARE)
1948 register I32 This, that;
1954 PERL_FLUSHALL_FOR_CHILD;
1955 This = (*mode == 'w');
1959 taint_proper("Insecure %s%s", "EXEC");
1961 if (PerlProc_pipe(p) < 0)
1963 /* Try for another pipe pair for error return */
1964 if (PerlProc_pipe(pp) >= 0)
1966 while ((pid = PerlProc_fork()) < 0) {
1967 if (errno != EAGAIN) {
1968 PerlLIO_close(p[This]);
1969 PerlLIO_close(p[that]);
1971 PerlLIO_close(pp[0]);
1972 PerlLIO_close(pp[1]);
1984 /* Close parent's end of error status pipe (if any) */
1986 PerlLIO_close(pp[0]);
1987 #if defined(HAS_FCNTL) && defined(F_SETFD)
1988 /* Close error pipe automatically if exec works */
1989 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
1992 /* Now dup our end of _the_ pipe to right position */
1993 if (p[THIS] != (*mode == 'r')) {
1994 PerlLIO_dup2(p[THIS], *mode == 'r');
1995 PerlLIO_close(p[THIS]);
1996 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
1997 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
2000 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
2001 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2002 /* No automatic close - do it by hand */
2009 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) {
2015 do_aexec5(Nullsv, args-1, args-1+n, pp[1], did_pipes);
2021 do_execfree(); /* free any memory malloced by child on fork */
2023 PerlLIO_close(pp[1]);
2024 /* Keep the lower of the two fd numbers */
2025 if (p[that] < p[This]) {
2026 PerlLIO_dup2(p[This], p[that]);
2027 PerlLIO_close(p[This]);
2031 PerlLIO_close(p[that]); /* close child's end of pipe */
2034 sv = *av_fetch(PL_fdpid,p[This],TRUE);
2036 (void)SvUPGRADE(sv,SVt_IV);
2038 PL_forkprocess = pid;
2039 /* If we managed to get status pipe check for exec fail */
2040 if (did_pipes && pid > 0) {
2044 while (n < sizeof(int)) {
2045 n1 = PerlLIO_read(pp[0],
2046 (void*)(((char*)&errkid)+n),
2052 PerlLIO_close(pp[0]);
2054 if (n) { /* Error */
2056 PerlLIO_close(p[This]);
2057 if (n != sizeof(int))
2058 Perl_croak(aTHX_ "panic: kid popen errno read");
2060 pid2 = wait4pid(pid, &status, 0);
2061 } while (pid2 == -1 && errno == EINTR);
2062 errno = errkid; /* Propagate errno from kid */
2067 PerlLIO_close(pp[0]);
2068 return PerlIO_fdopen(p[This], mode);
2070 Perl_croak(aTHX_ "List form of piped open not implemented");
2071 return (PerlIO *) NULL;
2075 /* VMS' my_popen() is in VMS.c, same with OS/2. */
2076 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
2078 Perl_my_popen(pTHX_ char *cmd, char *mode)
2081 register I32 This, that;
2084 I32 doexec = !(*cmd == '-' && cmd[1] == '\0');
2088 PERL_FLUSHALL_FOR_CHILD;
2091 return my_syspopen(aTHX_ cmd,mode);
2094 This = (*mode == 'w');
2096 if (doexec && PL_tainting) {
2098 taint_proper("Insecure %s%s", "EXEC");
2100 if (PerlProc_pipe(p) < 0)
2102 if (doexec && PerlProc_pipe(pp) >= 0)
2104 while ((pid = PerlProc_fork()) < 0) {
2105 if (errno != EAGAIN) {
2106 PerlLIO_close(p[This]);
2107 PerlLIO_close(p[that]);
2109 PerlLIO_close(pp[0]);
2110 PerlLIO_close(pp[1]);
2113 Perl_croak(aTHX_ "Can't fork");
2126 PerlLIO_close(pp[0]);
2127 #if defined(HAS_FCNTL) && defined(F_SETFD)
2128 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2131 if (p[THIS] != (*mode == 'r')) {
2132 PerlLIO_dup2(p[THIS], *mode == 'r');
2133 PerlLIO_close(p[THIS]);
2134 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2135 PerlLIO_close(p[THAT]);
2138 PerlLIO_close(p[THAT]);
2141 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2148 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
2153 /* may or may not use the shell */
2154 do_exec3(cmd, pp[1], did_pipes);
2157 #endif /* defined OS2 */
2159 if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) {
2160 SvREADONLY_off(GvSV(tmpgv));
2161 sv_setiv(GvSV(tmpgv), PerlProc_getpid());
2162 SvREADONLY_on(GvSV(tmpgv));
2164 #ifdef THREADS_HAVE_PIDS
2165 PL_ppid = (IV)getppid();
2168 hv_clear(PL_pidstatus); /* we have no children */
2173 do_execfree(); /* free any memory malloced by child on vfork */
2175 PerlLIO_close(pp[1]);
2176 if (p[that] < p[This]) {
2177 PerlLIO_dup2(p[This], p[that]);
2178 PerlLIO_close(p[This]);
2182 PerlLIO_close(p[that]);
2185 sv = *av_fetch(PL_fdpid,p[This],TRUE);
2187 (void)SvUPGRADE(sv,SVt_IV);
2189 PL_forkprocess = pid;
2190 if (did_pipes && pid > 0) {
2194 while (n < sizeof(int)) {
2195 n1 = PerlLIO_read(pp[0],
2196 (void*)(((char*)&errkid)+n),
2202 PerlLIO_close(pp[0]);
2204 if (n) { /* Error */
2206 PerlLIO_close(p[This]);
2207 if (n != sizeof(int))
2208 Perl_croak(aTHX_ "panic: kid popen errno read");
2210 pid2 = wait4pid(pid, &status, 0);
2211 } while (pid2 == -1 && errno == EINTR);
2212 errno = errkid; /* Propagate errno from kid */
2217 PerlLIO_close(pp[0]);
2218 return PerlIO_fdopen(p[This], mode);
2221 #if defined(atarist) || defined(EPOC)
2224 Perl_my_popen(pTHX_ char *cmd, char *mode)
2226 PERL_FLUSHALL_FOR_CHILD;
2227 /* Call system's popen() to get a FILE *, then import it.
2228 used 0 for 2nd parameter to PerlIO_importFILE;
2231 return PerlIO_importFILE(popen(cmd, mode), 0);
2235 FILE *djgpp_popen();
2237 Perl_my_popen(pTHX_ char *cmd, char *mode)
2239 PERL_FLUSHALL_FOR_CHILD;
2240 /* Call system's popen() to get a FILE *, then import it.
2241 used 0 for 2nd parameter to PerlIO_importFILE;
2244 return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
2249 #endif /* !DOSISH */
2251 /* this is called in parent before the fork() */
2253 Perl_atfork_lock(void)
2256 #if defined(USE_ITHREADS)
2257 /* locks must be held in locking order (if any) */
2259 MUTEX_LOCK(&PL_malloc_mutex);
2265 /* this is called in both parent and child after the fork() */
2267 Perl_atfork_unlock(void)
2270 #if defined(USE_ITHREADS)
2271 /* locks must be released in same order as in atfork_lock() */
2273 MUTEX_UNLOCK(&PL_malloc_mutex);
2282 #if defined(HAS_FORK)
2284 #if defined(USE_ITHREADS) && !defined(HAS_PTHREAD_ATFORK)
2289 /* atfork_lock() and atfork_unlock() are installed as pthread_atfork()
2290 * handlers elsewhere in the code */
2295 /* this "canna happen" since nothing should be calling here if !HAS_FORK */
2296 Perl_croak_nocontext("fork() not available");
2298 #endif /* HAS_FORK */
2303 Perl_dump_fds(pTHX_ char *s)
2308 PerlIO_printf(Perl_debug_log,"%s", s);
2309 for (fd = 0; fd < 32; fd++) {
2310 if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0)
2311 PerlIO_printf(Perl_debug_log," %d",fd);
2313 PerlIO_printf(Perl_debug_log,"\n");
2316 #endif /* DUMP_FDS */
2320 dup2(int oldfd, int newfd)
2322 #if defined(HAS_FCNTL) && defined(F_DUPFD)
2325 PerlLIO_close(newfd);
2326 return fcntl(oldfd, F_DUPFD, newfd);
2328 #define DUP2_MAX_FDS 256
2329 int fdtmp[DUP2_MAX_FDS];
2335 PerlLIO_close(newfd);
2336 /* good enough for low fd's... */
2337 while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
2338 if (fdx >= DUP2_MAX_FDS) {
2346 PerlLIO_close(fdtmp[--fdx]);
2353 #ifdef HAS_SIGACTION
2355 #ifdef MACOS_TRADITIONAL
2356 /* We don't want restart behavior on MacOS */
2361 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2364 struct sigaction act, oact;
2367 /* only "parent" interpreter can diddle signals */
2368 if (PL_curinterp != aTHX)
2372 act.sa_handler = handler;
2373 sigemptyset(&act.sa_mask);
2376 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2377 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
2379 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2380 if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN)
2381 act.sa_flags |= SA_NOCLDWAIT;
2383 if (sigaction(signo, &act, &oact) == -1)
2386 return oact.sa_handler;
2390 Perl_rsignal_state(pTHX_ int signo)
2392 struct sigaction oact;
2394 if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
2397 return oact.sa_handler;
2401 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2404 struct sigaction act;
2407 /* only "parent" interpreter can diddle signals */
2408 if (PL_curinterp != aTHX)
2412 act.sa_handler = handler;
2413 sigemptyset(&act.sa_mask);
2416 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2417 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
2419 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2420 if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN)
2421 act.sa_flags |= SA_NOCLDWAIT;
2423 return sigaction(signo, &act, save);
2427 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2431 /* only "parent" interpreter can diddle signals */
2432 if (PL_curinterp != aTHX)
2436 return sigaction(signo, save, (struct sigaction *)NULL);
2439 #else /* !HAS_SIGACTION */
2442 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2444 #if defined(USE_ITHREADS) && !defined(WIN32)
2445 /* only "parent" interpreter can diddle signals */
2446 if (PL_curinterp != aTHX)
2450 return PerlProc_signal(signo, handler);
2462 Perl_rsignal_state(pTHX_ int signo)
2465 Sighandler_t oldsig;
2467 #if defined(USE_ITHREADS) && !defined(WIN32)
2468 /* only "parent" interpreter can diddle signals */
2469 if (PL_curinterp != aTHX)
2474 oldsig = PerlProc_signal(signo, sig_trap);
2475 PerlProc_signal(signo, oldsig);
2477 PerlProc_kill(PerlProc_getpid(), signo);
2482 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2484 #if defined(USE_ITHREADS) && !defined(WIN32)
2485 /* only "parent" interpreter can diddle signals */
2486 if (PL_curinterp != aTHX)
2489 *save = PerlProc_signal(signo, handler);
2490 return (*save == SIG_ERR) ? -1 : 0;
2494 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2496 #if defined(USE_ITHREADS) && !defined(WIN32)
2497 /* only "parent" interpreter can diddle signals */
2498 if (PL_curinterp != aTHX)
2501 return (PerlProc_signal(signo, *save) == SIG_ERR) ? -1 : 0;
2504 #endif /* !HAS_SIGACTION */
2505 #endif /* !PERL_MICRO */
2507 /* VMS' my_pclose() is in VMS.c; same with OS/2 */
2508 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
2510 Perl_my_pclose(pTHX_ PerlIO *ptr)
2512 Sigsave_t hstat, istat, qstat;
2518 int saved_errno = 0;
2520 int saved_vaxc_errno;
2523 int saved_win32_errno;
2527 svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE);
2529 pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
2531 *svp = &PL_sv_undef;
2533 if (pid == -1) { /* Opened by popen. */
2534 return my_syspclose(ptr);
2537 if ((close_failed = (PerlIO_close(ptr) == EOF))) {
2538 saved_errno = errno;
2540 saved_vaxc_errno = vaxc$errno;
2543 saved_win32_errno = GetLastError();
2547 if(PerlProc_kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */
2550 rsignal_save(SIGHUP, SIG_IGN, &hstat);
2551 rsignal_save(SIGINT, SIG_IGN, &istat);
2552 rsignal_save(SIGQUIT, SIG_IGN, &qstat);
2555 pid2 = wait4pid(pid, &status, 0);
2556 } while (pid2 == -1 && errno == EINTR);
2558 rsignal_restore(SIGHUP, &hstat);
2559 rsignal_restore(SIGINT, &istat);
2560 rsignal_restore(SIGQUIT, &qstat);
2563 SETERRNO(saved_errno, saved_vaxc_errno);
2566 return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status));
2568 #endif /* !DOSISH */
2570 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(MACOS_TRADITIONAL)
2572 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
2577 #if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME)
2579 char spid[TYPE_CHARS(IV)];
2583 sprintf(spid, "%"IVdf, (IV)pid);
2584 svp = hv_fetch(PL_pidstatus,spid,strlen(spid),FALSE);
2585 if (svp && *svp != &PL_sv_undef) {
2586 *statusp = SvIVX(*svp);
2587 (void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD);
2594 hv_iterinit(PL_pidstatus);
2595 if ((entry = hv_iternext(PL_pidstatus))) {
2596 SV *sv = hv_iterval(PL_pidstatus,entry);
2598 pid = atoi(hv_iterkey(entry,(I32*)statusp));
2599 *statusp = SvIVX(sv);
2600 sprintf(spid, "%"IVdf, (IV)pid);
2601 (void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD);
2608 # ifdef HAS_WAITPID_RUNTIME
2609 if (!HAS_WAITPID_RUNTIME)
2612 result = PerlProc_waitpid(pid,statusp,flags);
2615 #if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
2616 result = wait4((pid==-1)?0:pid,statusp,flags,Null(struct rusage *));
2619 #if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME)
2620 #if defined(HAS_WAITPID) && defined(HAS_WAITPID_RUNTIME)
2625 Perl_croak(aTHX_ "Can't do waitpid with flags");
2627 while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
2628 pidgone(result,*statusp);
2634 #if defined(HAS_WAITPID) || defined(HAS_WAIT4)
2637 if (result < 0 && errno == EINTR) {
2642 #endif /* !DOSISH || OS2 || WIN32 || NETWARE */
2646 Perl_pidgone(pTHX_ Pid_t pid, int status)
2649 char spid[TYPE_CHARS(IV)];
2651 sprintf(spid, "%"IVdf, (IV)pid);
2652 sv = *hv_fetch(PL_pidstatus,spid,strlen(spid),TRUE);
2653 (void)SvUPGRADE(sv,SVt_IV);
2654 SvIV_set(sv, status);
2658 #if defined(atarist) || defined(OS2) || defined(EPOC)
2661 int /* Cannot prototype with I32
2663 my_syspclose(PerlIO *ptr)
2666 Perl_my_pclose(pTHX_ PerlIO *ptr)
2669 /* Needs work for PerlIO ! */
2670 FILE *f = PerlIO_findFILE(ptr);
2671 I32 result = pclose(f);
2672 PerlIO_releaseFILE(ptr,f);
2680 Perl_my_pclose(pTHX_ PerlIO *ptr)
2682 /* Needs work for PerlIO ! */
2683 FILE *f = PerlIO_findFILE(ptr);
2684 I32 result = djgpp_pclose(f);
2685 result = (result << 8) & 0xff00;
2686 PerlIO_releaseFILE(ptr,f);
2692 Perl_repeatcpy(pTHX_ register char *to, register const char *from, I32 len, register I32 count)
2695 register const char *frombase = from;
2698 register const char c = *from;
2703 while (count-- > 0) {
2704 for (todo = len; todo > 0; todo--) {
2713 Perl_same_dirent(pTHX_ const char *a, const char *b)
2715 char *fa = strrchr(a,'/');
2716 char *fb = strrchr(b,'/');
2719 SV *tmpsv = sv_newmortal();
2732 sv_setpv(tmpsv, ".");
2734 sv_setpvn(tmpsv, a, fa - a);
2735 if (PerlLIO_stat(SvPVX(tmpsv), &tmpstatbuf1) < 0)
2738 sv_setpv(tmpsv, ".");
2740 sv_setpvn(tmpsv, b, fb - b);
2741 if (PerlLIO_stat(SvPVX(tmpsv), &tmpstatbuf2) < 0)
2743 return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
2744 tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
2746 #endif /* !HAS_RENAME */
2749 Perl_find_script(pTHX_ const char *scriptname, bool dosearch, const char **search_ext, I32 flags)
2751 const char *xfound = Nullch;
2752 char *xfailed = Nullch;
2753 char tmpbuf[MAXPATHLEN];
2757 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
2758 # define SEARCH_EXTS ".bat", ".cmd", NULL
2759 # define MAX_EXT_LEN 4
2762 # define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
2763 # define MAX_EXT_LEN 4
2766 # define SEARCH_EXTS ".pl", ".com", NULL
2767 # define MAX_EXT_LEN 4
2769 /* additional extensions to try in each dir if scriptname not found */
2771 const char *exts[] = { SEARCH_EXTS };
2772 const char **ext = search_ext ? search_ext : exts;
2773 int extidx = 0, i = 0;
2774 const char *curext = Nullch;
2777 # define MAX_EXT_LEN 0
2781 * If dosearch is true and if scriptname does not contain path
2782 * delimiters, search the PATH for scriptname.
2784 * If SEARCH_EXTS is also defined, will look for each
2785 * scriptname{SEARCH_EXTS} whenever scriptname is not found
2786 * while searching the PATH.
2788 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
2789 * proceeds as follows:
2790 * If DOSISH or VMSISH:
2791 * + look for ./scriptname{,.foo,.bar}
2792 * + search the PATH for scriptname{,.foo,.bar}
2795 * + look *only* in the PATH for scriptname{,.foo,.bar} (note
2796 * this will not look in '.' if it's not in the PATH)
2801 # ifdef ALWAYS_DEFTYPES
2802 len = strlen(scriptname);
2803 if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
2804 int hasdir, idx = 0, deftypes = 1;
2807 hasdir = !dosearch || (strpbrk(scriptname,":[</") != Nullch) ;
2810 int hasdir, idx = 0, deftypes = 1;
2813 hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
2815 /* The first time through, just add SEARCH_EXTS to whatever we
2816 * already have, so we can check for default file types. */
2818 (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
2824 if ((strlen(tmpbuf) + strlen(scriptname)
2825 + MAX_EXT_LEN) >= sizeof tmpbuf)
2826 continue; /* don't search dir with too-long name */
2827 strcat(tmpbuf, scriptname);
2831 if (strEQ(scriptname, "-"))
2833 if (dosearch) { /* Look in '.' first. */
2834 const char *cur = scriptname;
2836 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
2838 if (strEQ(ext[i++],curext)) {
2839 extidx = -1; /* already has an ext */
2844 DEBUG_p(PerlIO_printf(Perl_debug_log,
2845 "Looking for %s\n",cur));
2846 if (PerlLIO_stat(cur,&PL_statbuf) >= 0
2847 && !S_ISDIR(PL_statbuf.st_mode)) {
2855 if (cur == scriptname) {
2856 len = strlen(scriptname);
2857 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
2859 cur = strcpy(tmpbuf, scriptname);
2861 } while (extidx >= 0 && ext[extidx] /* try an extension? */
2862 && strcpy(tmpbuf+len, ext[extidx++]));
2867 #ifdef MACOS_TRADITIONAL
2868 if (dosearch && !strchr(scriptname, ':') &&
2869 (s = PerlEnv_getenv("Commands")))
2871 if (dosearch && !strchr(scriptname, '/')
2873 && !strchr(scriptname, '\\')
2875 && (s = PerlEnv_getenv("PATH")))
2880 PL_bufend = s + strlen(s);
2881 while (s < PL_bufend) {
2882 #ifdef MACOS_TRADITIONAL
2883 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
2887 #if defined(atarist) || defined(DOSISH)
2892 && *s != ';'; len++, s++) {
2893 if (len < sizeof tmpbuf)
2896 if (len < sizeof tmpbuf)
2898 #else /* ! (atarist || DOSISH) */
2899 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
2902 #endif /* ! (atarist || DOSISH) */
2903 #endif /* MACOS_TRADITIONAL */
2906 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
2907 continue; /* don't search dir with too-long name */
2908 #ifdef MACOS_TRADITIONAL
2909 if (len && tmpbuf[len - 1] != ':')
2910 tmpbuf[len++] = ':';
2913 #if defined(atarist) || defined(__MINT__) || defined(DOSISH)
2914 && tmpbuf[len - 1] != '/'
2915 && tmpbuf[len - 1] != '\\'
2918 tmpbuf[len++] = '/';
2919 if (len == 2 && tmpbuf[0] == '.')
2922 (void)strcpy(tmpbuf + len, scriptname);
2926 len = strlen(tmpbuf);
2927 if (extidx > 0) /* reset after previous loop */
2931 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
2932 retval = PerlLIO_stat(tmpbuf,&PL_statbuf);
2933 if (S_ISDIR(PL_statbuf.st_mode)) {
2937 } while ( retval < 0 /* not there */
2938 && extidx>=0 && ext[extidx] /* try an extension? */
2939 && strcpy(tmpbuf+len, ext[extidx++])
2944 if (S_ISREG(PL_statbuf.st_mode)
2945 && cando(S_IRUSR,TRUE,&PL_statbuf)
2946 #if !defined(DOSISH) && !defined(MACOS_TRADITIONAL)
2947 && cando(S_IXUSR,TRUE,&PL_statbuf)
2951 xfound = tmpbuf; /* bingo! */
2955 xfailed = savepv(tmpbuf);
2958 if (!xfound && !seen_dot && !xfailed &&
2959 (PerlLIO_stat(scriptname,&PL_statbuf) < 0
2960 || S_ISDIR(PL_statbuf.st_mode)))
2962 seen_dot = 1; /* Disable message. */
2964 if (flags & 1) { /* do or die? */
2965 Perl_croak(aTHX_ "Can't %s %s%s%s",
2966 (xfailed ? "execute" : "find"),
2967 (xfailed ? xfailed : scriptname),
2968 (xfailed ? "" : " on PATH"),
2969 (xfailed || seen_dot) ? "" : ", '.' not in PATH");
2971 scriptname = Nullch;
2975 scriptname = xfound;
2977 return (scriptname ? savepv(scriptname) : Nullch);
2980 #ifndef PERL_GET_CONTEXT_DEFINED
2983 Perl_get_context(void)
2986 #if defined(USE_ITHREADS)
2987 # ifdef OLD_PTHREADS_API
2989 if (pthread_getspecific(PL_thr_key, &t))
2990 Perl_croak_nocontext("panic: pthread_getspecific");
2993 # ifdef I_MACH_CTHREADS
2994 return (void*)cthread_data(cthread_self());
2996 return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
3005 Perl_set_context(void *t)
3008 #if defined(USE_ITHREADS)
3009 # ifdef I_MACH_CTHREADS
3010 cthread_set_data(cthread_self(), t);
3012 if (pthread_setspecific(PL_thr_key, t))
3013 Perl_croak_nocontext("panic: pthread_setspecific");
3018 #endif /* !PERL_GET_CONTEXT_DEFINED */
3020 #if defined(PERL_GLOBAL_STRUCT) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
3029 Perl_get_op_names(pTHX)
3031 return (char **)PL_op_name;
3035 Perl_get_op_descs(pTHX)
3037 return (char **)PL_op_desc;
3041 Perl_get_no_modify(pTHX)
3043 return PL_no_modify;
3047 Perl_get_opargs(pTHX)
3049 return (U32 *)PL_opargs;
3053 Perl_get_ppaddr(pTHX)
3056 return (PPADDR_t*)PL_ppaddr;
3059 #ifndef HAS_GETENV_LEN
3061 Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
3063 char *env_trans = PerlEnv_getenv(env_elem);
3065 *len = strlen(env_trans);
3072 Perl_get_vtbl(pTHX_ int vtbl_id)
3074 const MGVTBL* result = Null(MGVTBL*);
3078 result = &PL_vtbl_sv;
3081 result = &PL_vtbl_env;
3083 case want_vtbl_envelem:
3084 result = &PL_vtbl_envelem;
3087 result = &PL_vtbl_sig;
3089 case want_vtbl_sigelem:
3090 result = &PL_vtbl_sigelem;
3092 case want_vtbl_pack:
3093 result = &PL_vtbl_pack;
3095 case want_vtbl_packelem:
3096 result = &PL_vtbl_packelem;
3098 case want_vtbl_dbline:
3099 result = &PL_vtbl_dbline;
3102 result = &PL_vtbl_isa;
3104 case want_vtbl_isaelem:
3105 result = &PL_vtbl_isaelem;
3107 case want_vtbl_arylen:
3108 result = &PL_vtbl_arylen;
3110 case want_vtbl_glob:
3111 result = &PL_vtbl_glob;
3113 case want_vtbl_mglob:
3114 result = &PL_vtbl_mglob;
3116 case want_vtbl_nkeys:
3117 result = &PL_vtbl_nkeys;
3119 case want_vtbl_taint:
3120 result = &PL_vtbl_taint;
3122 case want_vtbl_substr:
3123 result = &PL_vtbl_substr;
3126 result = &PL_vtbl_vec;
3129 result = &PL_vtbl_pos;
3132 result = &PL_vtbl_bm;
3135 result = &PL_vtbl_fm;
3137 case want_vtbl_uvar:
3138 result = &PL_vtbl_uvar;
3140 case want_vtbl_defelem:
3141 result = &PL_vtbl_defelem;
3143 case want_vtbl_regexp:
3144 result = &PL_vtbl_regexp;
3146 case want_vtbl_regdata:
3147 result = &PL_vtbl_regdata;
3149 case want_vtbl_regdatum:
3150 result = &PL_vtbl_regdatum;
3152 #ifdef USE_LOCALE_COLLATE
3153 case want_vtbl_collxfrm:
3154 result = &PL_vtbl_collxfrm;
3157 case want_vtbl_amagic:
3158 result = &PL_vtbl_amagic;
3160 case want_vtbl_amagicelem:
3161 result = &PL_vtbl_amagicelem;
3163 case want_vtbl_backref:
3164 result = &PL_vtbl_backref;
3166 case want_vtbl_utf8:
3167 result = &PL_vtbl_utf8;
3170 return (MGVTBL*)result;
3174 Perl_my_fflush_all(pTHX)
3176 #if defined(USE_PERLIO) || defined(FFLUSH_NULL) || defined(USE_SFIO)
3177 return PerlIO_flush(NULL);
3179 # if defined(HAS__FWALK)
3180 extern int fflush(FILE *);
3181 /* undocumented, unprototyped, but very useful BSDism */
3182 extern void _fwalk(int (*)(FILE *));
3186 # if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
3188 # ifdef PERL_FFLUSH_ALL_FOPEN_MAX
3189 open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
3191 # if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
3192 open_max = sysconf(_SC_OPEN_MAX);
3195 open_max = FOPEN_MAX;
3198 open_max = OPEN_MAX;
3209 for (i = 0; i < open_max; i++)
3210 if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
3211 STDIO_STREAM_ARRAY[i]._file < open_max &&
3212 STDIO_STREAM_ARRAY[i]._flag)
3213 PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
3217 SETERRNO(EBADF,RMS_IFI);
3224 Perl_report_evil_fh(pTHX_ const GV *gv, const IO *io, I32 op)
3227 op == OP_READLINE ? "readline" : /* "<HANDLE>" not nice */
3228 op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */
3230 const char *pars = OP_IS_FILETEST(op) ? "" : "()";
3231 const char *type = OP_IS_SOCKET(op)
3232 || (gv && io && IoTYPE(io) == IoTYPE_SOCKET)
3233 ? "socket" : "filehandle";
3234 const char *name = NULL;
3236 if (gv && isGV(gv)) {
3240 if (op == OP_phoney_OUTPUT_ONLY || op == OP_phoney_INPUT_ONLY) {
3241 if (ckWARN(WARN_IO)) {
3242 const char *direction = (op == OP_phoney_INPUT_ONLY) ? "in" : "out";
3244 Perl_warner(aTHX_ packWARN(WARN_IO),
3245 "Filehandle %s opened only for %sput",
3248 Perl_warner(aTHX_ packWARN(WARN_IO),
3249 "Filehandle opened only for %sput", direction);
3256 if (gv && io && IoTYPE(io) == IoTYPE_CLOSED) {
3258 warn_type = WARN_CLOSED;
3262 warn_type = WARN_UNOPENED;
3265 if (ckWARN(warn_type)) {
3266 if (name && *name) {
3267 Perl_warner(aTHX_ packWARN(warn_type),
3268 "%s%s on %s %s %s", func, pars, vile, type, name);
3269 if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3271 aTHX_ packWARN(warn_type),
3272 "\t(Are you trying to call %s%s on dirhandle %s?)\n",
3277 Perl_warner(aTHX_ packWARN(warn_type),
3278 "%s%s on %s %s", func, pars, vile, type);
3279 if (gv && io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3281 aTHX_ packWARN(warn_type),
3282 "\t(Are you trying to call %s%s on dirhandle?)\n",
3291 /* in ASCII order, not that it matters */
3292 static const char controllablechars[] = "?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_";
3295 Perl_ebcdic_control(pTHX_ int ch)
3303 if ((ctlp = strchr(controllablechars, ch)) == 0) {
3304 Perl_die(aTHX_ "unrecognised control character '%c'\n", ch);
3307 if (ctlp == controllablechars)
3308 return('\177'); /* DEL */
3310 return((unsigned char)(ctlp - controllablechars - 1));
3311 } else { /* Want uncontrol */
3312 if (ch == '\177' || ch == -1)
3314 else if (ch == '\157')
3316 else if (ch == '\174')
3318 else if (ch == '^') /* '\137' in 1047, '\260' in 819 */
3320 else if (ch == '\155')
3322 else if (0 < ch && ch < (sizeof(controllablechars) - 1))
3323 return(controllablechars[ch+1]);
3325 Perl_die(aTHX_ "invalid control request: '\\%03o'\n", ch & 0xFF);
3330 /* To workaround core dumps from the uninitialised tm_zone we get the
3331 * system to give us a reasonable struct to copy. This fix means that
3332 * strftime uses the tm_zone and tm_gmtoff values returned by
3333 * localtime(time()). That should give the desired result most of the
3334 * time. But probably not always!
3336 * This does not address tzname aspects of NETaa14816.
3341 # ifndef STRUCT_TM_HASZONE
3342 # define STRUCT_TM_HASZONE
3346 #ifdef STRUCT_TM_HASZONE /* Backward compat */
3347 # ifndef HAS_TM_TM_ZONE
3348 # define HAS_TM_TM_ZONE
3353 Perl_init_tm(pTHX_ struct tm *ptm) /* see mktime, strftime and asctime */
3355 #ifdef HAS_TM_TM_ZONE
3359 my_tm = localtime(&now);
3361 Copy(my_tm, ptm, 1, struct tm);
3366 * mini_mktime - normalise struct tm values without the localtime()
3367 * semantics (and overhead) of mktime().
3370 Perl_mini_mktime(pTHX_ struct tm *ptm)
3374 int month, mday, year, jday;
3375 int odd_cent, odd_year;
3377 #define DAYS_PER_YEAR 365
3378 #define DAYS_PER_QYEAR (4*DAYS_PER_YEAR+1)
3379 #define DAYS_PER_CENT (25*DAYS_PER_QYEAR-1)
3380 #define DAYS_PER_QCENT (4*DAYS_PER_CENT+1)
3381 #define SECS_PER_HOUR (60*60)
3382 #define SECS_PER_DAY (24*SECS_PER_HOUR)
3383 /* parentheses deliberately absent on these two, otherwise they don't work */
3384 #define MONTH_TO_DAYS 153/5
3385 #define DAYS_TO_MONTH 5/153
3386 /* offset to bias by March (month 4) 1st between month/mday & year finding */
3387 #define YEAR_ADJUST (4*MONTH_TO_DAYS+1)
3388 /* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */
3389 #define WEEKDAY_BIAS 6 /* (1+6)%7 makes Sunday 0 again */
3392 * Year/day algorithm notes:
3394 * With a suitable offset for numeric value of the month, one can find
3395 * an offset into the year by considering months to have 30.6 (153/5) days,
3396 * using integer arithmetic (i.e., with truncation). To avoid too much
3397 * messing about with leap days, we consider January and February to be
3398 * the 13th and 14th month of the previous year. After that transformation,
3399 * we need the month index we use to be high by 1 from 'normal human' usage,
3400 * so the month index values we use run from 4 through 15.
3402 * Given that, and the rules for the Gregorian calendar (leap years are those
3403 * divisible by 4 unless also divisible by 100, when they must be divisible
3404 * by 400 instead), we can simply calculate the number of days since some
3405 * arbitrary 'beginning of time' by futzing with the (adjusted) year number,
3406 * the days we derive from our month index, and adding in the day of the
3407 * month. The value used here is not adjusted for the actual origin which
3408 * it normally would use (1 January A.D. 1), since we're not exposing it.
3409 * We're only building the value so we can turn around and get the
3410 * normalised values for the year, month, day-of-month, and day-of-year.
3412 * For going backward, we need to bias the value we're using so that we find
3413 * the right year value. (Basically, we don't want the contribution of
3414 * March 1st to the number to apply while deriving the year). Having done
3415 * that, we 'count up' the contribution to the year number by accounting for
3416 * full quadracenturies (400-year periods) with their extra leap days, plus
3417 * the contribution from full centuries (to avoid counting in the lost leap
3418 * days), plus the contribution from full quad-years (to count in the normal
3419 * leap days), plus the leftover contribution from any non-leap years.
3420 * At this point, if we were working with an actual leap day, we'll have 0
3421 * days left over. This is also true for March 1st, however. So, we have
3422 * to special-case that result, and (earlier) keep track of the 'odd'
3423 * century and year contributions. If we got 4 extra centuries in a qcent,
3424 * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb.
3425 * Otherwise, we add back in the earlier bias we removed (the 123 from
3426 * figuring in March 1st), find the month index (integer division by 30.6),
3427 * and the remainder is the day-of-month. We then have to convert back to
3428 * 'real' months (including fixing January and February from being 14/15 in
3429 * the previous year to being in the proper year). After that, to get
3430 * tm_yday, we work with the normalised year and get a new yearday value for
3431 * January 1st, which we subtract from the yearday value we had earlier,
3432 * representing the date we've re-built. This is done from January 1
3433 * because tm_yday is 0-origin.
3435 * Since POSIX time routines are only guaranteed to work for times since the
3436 * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm
3437 * applies Gregorian calendar rules even to dates before the 16th century
3438 * doesn't bother me. Besides, you'd need cultural context for a given
3439 * date to know whether it was Julian or Gregorian calendar, and that's
3440 * outside the scope for this routine. Since we convert back based on the
3441 * same rules we used to build the yearday, you'll only get strange results
3442 * for input which needed normalising, or for the 'odd' century years which
3443 * were leap years in the Julian calander but not in the Gregorian one.
3444 * I can live with that.
3446 * This algorithm also fails to handle years before A.D. 1 gracefully, but
3447 * that's still outside the scope for POSIX time manipulation, so I don't
3451 year = 1900 + ptm->tm_year;
3452 month = ptm->tm_mon;
3453 mday = ptm->tm_mday;
3454 /* allow given yday with no month & mday to dominate the result */
3455 if (ptm->tm_yday >= 0 && mday <= 0 && month <= 0) {
3458 jday = 1 + ptm->tm_yday;
3467 yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400;
3468 yearday += month*MONTH_TO_DAYS + mday + jday;
3470 * Note that we don't know when leap-seconds were or will be,
3471 * so we have to trust the user if we get something which looks
3472 * like a sensible leap-second. Wild values for seconds will
3473 * be rationalised, however.
3475 if ((unsigned) ptm->tm_sec <= 60) {
3482 secs += 60 * ptm->tm_min;
3483 secs += SECS_PER_HOUR * ptm->tm_hour;
3485 if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) {
3486 /* got negative remainder, but need positive time */
3487 /* back off an extra day to compensate */
3488 yearday += (secs/SECS_PER_DAY)-1;
3489 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1);
3492 yearday += (secs/SECS_PER_DAY);
3493 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY);
3496 else if (secs >= SECS_PER_DAY) {
3497 yearday += (secs/SECS_PER_DAY);
3498 secs %= SECS_PER_DAY;
3500 ptm->tm_hour = secs/SECS_PER_HOUR;
3501 secs %= SECS_PER_HOUR;
3502 ptm->tm_min = secs/60;
3504 ptm->tm_sec += secs;
3505 /* done with time of day effects */
3507 * The algorithm for yearday has (so far) left it high by 428.
3508 * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to
3509 * bias it by 123 while trying to figure out what year it
3510 * really represents. Even with this tweak, the reverse
3511 * translation fails for years before A.D. 0001.
3512 * It would still fail for Feb 29, but we catch that one below.
3514 jday = yearday; /* save for later fixup vis-a-vis Jan 1 */
3515 yearday -= YEAR_ADJUST;
3516 year = (yearday / DAYS_PER_QCENT) * 400;
3517 yearday %= DAYS_PER_QCENT;
3518 odd_cent = yearday / DAYS_PER_CENT;
3519 year += odd_cent * 100;
3520 yearday %= DAYS_PER_CENT;
3521 year += (yearday / DAYS_PER_QYEAR) * 4;
3522 yearday %= DAYS_PER_QYEAR;
3523 odd_year = yearday / DAYS_PER_YEAR;
3525 yearday %= DAYS_PER_YEAR;
3526 if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */
3531 yearday += YEAR_ADJUST; /* recover March 1st crock */
3532 month = yearday*DAYS_TO_MONTH;
3533 yearday -= month*MONTH_TO_DAYS;
3534 /* recover other leap-year adjustment */
3543 ptm->tm_year = year - 1900;
3545 ptm->tm_mday = yearday;
3546 ptm->tm_mon = month;
3550 ptm->tm_mon = month - 1;
3552 /* re-build yearday based on Jan 1 to get tm_yday */
3554 yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400;
3555 yearday += 14*MONTH_TO_DAYS + 1;
3556 ptm->tm_yday = jday - yearday;
3557 /* fix tm_wday if not overridden by caller */
3558 if ((unsigned)ptm->tm_wday > 6)
3559 ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
3563 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)
3571 init_tm(&mytm); /* XXX workaround - see init_tm() above */
3574 mytm.tm_hour = hour;
3575 mytm.tm_mday = mday;
3577 mytm.tm_year = year;
3578 mytm.tm_wday = wday;
3579 mytm.tm_yday = yday;
3580 mytm.tm_isdst = isdst;
3582 /* use libc to get the values for tm_gmtoff and tm_zone [perl #18238] */
3583 #if defined(HAS_MKTIME) && (defined(HAS_TM_TM_GMTOFF) || defined(HAS_TM_TM_ZONE))
3588 #ifdef HAS_TM_TM_GMTOFF
3589 mytm.tm_gmtoff = mytm2.tm_gmtoff;
3591 #ifdef HAS_TM_TM_ZONE
3592 mytm.tm_zone = mytm2.tm_zone;
3597 New(0, buf, buflen, char);
3598 len = strftime(buf, buflen, fmt, &mytm);
3600 ** The following is needed to handle to the situation where
3601 ** tmpbuf overflows. Basically we want to allocate a buffer
3602 ** and try repeatedly. The reason why it is so complicated
3603 ** is that getting a return value of 0 from strftime can indicate
3604 ** one of the following:
3605 ** 1. buffer overflowed,
3606 ** 2. illegal conversion specifier, or
3607 ** 3. the format string specifies nothing to be returned(not
3608 ** an error). This could be because format is an empty string
3609 ** or it specifies %p that yields an empty string in some locale.
3610 ** If there is a better way to make it portable, go ahead by
3613 if ((len > 0 && len < buflen) || (len == 0 && *fmt == '\0'))
3616 /* Possibly buf overflowed - try again with a bigger buf */
3617 const int fmtlen = strlen(fmt);
3618 const int bufsize = fmtlen + buflen;
3620 New(0, buf, bufsize, char);
3622 buflen = strftime(buf, bufsize, fmt, &mytm);
3623 if (buflen > 0 && buflen < bufsize)
3625 /* heuristic to prevent out-of-memory errors */
3626 if (bufsize > 100*fmtlen) {
3631 Renew(buf, bufsize*2, char);
3636 Perl_croak(aTHX_ "panic: no strftime");
3642 #define SV_CWD_RETURN_UNDEF \
3643 sv_setsv(sv, &PL_sv_undef); \
3646 #define SV_CWD_ISDOT(dp) \
3647 (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
3648 (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
3651 =head1 Miscellaneous Functions
3653 =for apidoc getcwd_sv
3655 Fill the sv with current working directory
3660 /* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars.
3661 * rewritten again by dougm, optimized for use with xs TARG, and to prefer
3662 * getcwd(3) if available
3663 * Comments from the orignal:
3664 * This is a faster version of getcwd. It's also more dangerous
3665 * because you might chdir out of a directory that you can't chdir
3669 Perl_getcwd_sv(pTHX_ register SV *sv)
3673 #ifndef INCOMPLETE_TAINTS
3679 char buf[MAXPATHLEN];
3681 /* Some getcwd()s automatically allocate a buffer of the given
3682 * size from the heap if they are given a NULL buffer pointer.
3683 * The problem is that this behaviour is not portable. */
3684 if (getcwd(buf, sizeof(buf) - 1)) {
3685 sv_setpvn(sv, buf, strlen(buf));
3689 sv_setsv(sv, &PL_sv_undef);
3697 int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
3701 (void)SvUPGRADE(sv, SVt_PV);
3703 if (PerlLIO_lstat(".", &statbuf) < 0) {
3704 SV_CWD_RETURN_UNDEF;
3707 orig_cdev = statbuf.st_dev;
3708 orig_cino = statbuf.st_ino;
3717 if (PerlDir_chdir("..") < 0) {
3718 SV_CWD_RETURN_UNDEF;
3720 if (PerlLIO_stat(".", &statbuf) < 0) {
3721 SV_CWD_RETURN_UNDEF;
3724 cdev = statbuf.st_dev;
3725 cino = statbuf.st_ino;
3727 if (odev == cdev && oino == cino) {
3730 if (!(dir = PerlDir_open("."))) {
3731 SV_CWD_RETURN_UNDEF;
3734 while ((dp = PerlDir_read(dir)) != NULL) {
3736 const int namelen = dp->d_namlen;
3738 const int namelen = strlen(dp->d_name);
3741 if (SV_CWD_ISDOT(dp)) {
3745 if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
3746 SV_CWD_RETURN_UNDEF;
3749 tdev = statbuf.st_dev;
3750 tino = statbuf.st_ino;
3751 if (tino == oino && tdev == odev) {
3757 SV_CWD_RETURN_UNDEF;
3760 if (pathlen + namelen + 1 >= MAXPATHLEN) {
3761 SV_CWD_RETURN_UNDEF;
3764 SvGROW(sv, pathlen + namelen + 1);
3768 Move(SvPVX(sv), SvPVX(sv) + namelen + 1, pathlen, char);
3771 /* prepend current directory to the front */
3773 Move(dp->d_name, SvPVX(sv)+1, namelen, char);
3774 pathlen += (namelen + 1);
3776 #ifdef VOID_CLOSEDIR
3779 if (PerlDir_close(dir) < 0) {
3780 SV_CWD_RETURN_UNDEF;
3786 SvCUR_set(sv, pathlen);
3790 if (PerlDir_chdir(SvPVX(sv)) < 0) {
3791 SV_CWD_RETURN_UNDEF;
3794 if (PerlLIO_stat(".", &statbuf) < 0) {
3795 SV_CWD_RETURN_UNDEF;
3798 cdev = statbuf.st_dev;
3799 cino = statbuf.st_ino;
3801 if (cdev != orig_cdev || cino != orig_cino) {
3802 Perl_croak(aTHX_ "Unstable directory path, "
3803 "current directory changed unexpectedly");
3815 =for apidoc scan_version
3817 Returns a pointer to the next character after the parsed
3818 version string, as well as upgrading the passed in SV to
3821 Function must be called with an already existing SV like
3824 s = scan_version(s,SV *sv, bool qv);
3826 Performs some preprocessing to the string to ensure that
3827 it has the correct characteristics of a version. Flags the
3828 object if it contains an underscore (which denotes this
3829 is a alpha version). The boolean qv denotes that the version
3830 should be interpreted as if it had multiple decimals, even if
3837 Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
3839 const char *start = s;
3840 const char *pos = s;
3843 SV* sv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
3844 (void)sv_upgrade(sv, SVt_PVAV); /* needs to be an AV type */
3847 /* pre-scan the imput string to check for decimals */
3848 while ( *pos == '.' || *pos == '_' || isDIGIT(*pos) )
3853 Perl_croak(aTHX_ "Invalid version format (underscores before decimal)");
3856 else if ( *pos == '_' )
3859 Perl_croak(aTHX_ "Invalid version format (multiple underscores)");
3867 pos++; /* get past 'v' */
3868 qv = 1; /* force quoted version processing */
3870 while (isDIGIT(*pos))
3872 if (!isALPHA(*pos)) {
3875 if (*s == 'v') s++; /* get past 'v' */
3880 /* this is atoi() that delimits on underscores */
3881 const char *end = pos;
3884 if ( s < pos && s > start && *(s-1) == '_' ) {
3885 mult *= -1; /* alpha version */
3887 /* the following if() will only be true after the decimal
3888 * point of a version originally created with a bare
3889 * floating point number, i.e. not quoted in any way
3891 if ( !qv && s > start+1 && saw_period == 1 ) {
3895 rev += (*s - '0') * mult;
3897 if ( PERL_ABS(orev) > PERL_ABS(rev) )
3898 Perl_croak(aTHX_ "Integer overflow in version");
3903 while (--end >= s) {
3905 rev += (*end - '0') * mult;
3907 if ( PERL_ABS(orev) > PERL_ABS(rev) )
3908 Perl_croak(aTHX_ "Integer overflow in version");
3913 /* Append revision */
3914 av_push((AV *)sv, newSViv(rev));
3915 if ( (*pos == '.' || *pos == '_') && isDIGIT(pos[1]))
3917 else if ( isDIGIT(*pos) )
3923 while ( isDIGIT(*pos) ) {
3924 if ( saw_period == 1 && pos-s == 3 )
3930 if ( qv ) { /* quoted versions always become full version objects */
3931 I32 len = av_len((AV *)sv);
3932 /* This for loop appears to trigger a compiler bug on OS X, as it
3933 loops infinitely. Yes, len is negative. No, it makes no sense.
3934 Compiler in question is:
3935 gcc version 3.3 20030304 (Apple Computer, Inc. build 1640)
3936 for ( len = 2 - len; len > 0; len-- )
3937 av_push((AV *)sv, newSViv(0));
3941 av_push((AV *)sv, newSViv(0));
3947 =for apidoc new_version
3949 Returns a new version object based on the passed in SV:
3951 SV *sv = new_version(SV *ver);
3953 Does not alter the passed in ver SV. See "upg_version" if you
3954 want to upgrade the SV.
3960 Perl_new_version(pTHX_ SV *ver)
3963 if ( sv_derived_from(ver,"version") ) /* can just copy directly */
3966 AV *av = (AV *)SvRV(ver);
3967 SV* sv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
3968 (void)sv_upgrade(sv, SVt_PVAV); /* needs to be an AV type */
3970 for ( key = 0; key <= av_len(av); key++ )
3972 const I32 rev = SvIV(*av_fetch(av, key, FALSE));
3973 av_push((AV *)sv, newSViv(rev));
3978 if ( SvVOK(ver) ) { /* already a v-string */
3980 MAGIC* mg = mg_find(ver,PERL_MAGIC_vstring);
3981 version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
3982 sv_setpv(rv,version);
3987 sv_setsv(rv,ver); /* make a duplicate */
3996 =for apidoc upg_version
3998 In-place upgrade of the supplied SV to a version object.
4000 SV *sv = upg_version(SV *sv);
4002 Returns a pointer to the upgraded SV.
4008 Perl_upg_version(pTHX_ SV *ver)
4013 if ( SvNOK(ver) ) /* may get too much accuracy */
4016 sprintf(tbuf,"%.9"NVgf, SvNVX(ver));
4017 version = savepv(tbuf);
4020 else if ( SvVOK(ver) ) { /* already a v-string */
4021 MAGIC* mg = mg_find(ver,PERL_MAGIC_vstring);
4022 version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
4026 else /* must be a string or something like a string */
4028 version = savesvpv(ver);
4030 (void)scan_version(version, ver, qv);
4039 Accepts a version object and returns the normalized floating
4040 point representation. Call like:
4044 NOTE: you can pass either the object directly or the SV
4045 contained within the RV.
4051 Perl_vnumify(pTHX_ SV *vs)
4057 len = av_len((AV *)vs);
4060 Perl_sv_catpv(aTHX_ sv,"0");
4063 digit = SvIVX(*av_fetch((AV *)vs, 0, 0));
4064 Perl_sv_setpvf(aTHX_ sv,"%d.", (int)PERL_ABS(digit));
4065 for ( i = 1 ; i < len ; i++ )
4067 digit = SvIVX(*av_fetch((AV *)vs, i, 0));
4068 Perl_sv_catpvf(aTHX_ sv,"%03d", (int)PERL_ABS(digit));
4073 digit = SvIVX(*av_fetch((AV *)vs, len, 0));
4074 if ( (int)PERL_ABS(digit) != 0 || len == 1 )
4076 if ( digit < 0 ) /* alpha version */
4077 Perl_sv_catpv(aTHX_ sv,"_");
4078 /* Don't display additional trailing zeros */
4079 Perl_sv_catpvf(aTHX_ sv,"%03d", (int)PERL_ABS(digit));
4084 Perl_sv_catpv(aTHX_ sv,"000");
4092 Accepts a version object and returns the normalized string
4093 representation. Call like:
4097 NOTE: you can pass either the object directly or the SV
4098 contained within the RV.
4104 Perl_vnormal(pTHX_ SV *vs)
4110 len = av_len((AV *)vs);
4113 Perl_sv_catpv(aTHX_ sv,"");
4116 digit = SvIVX(*av_fetch((AV *)vs, 0, 0));
4117 Perl_sv_setpvf(aTHX_ sv,"%"IVdf,(IV)digit);
4118 for ( i = 1 ; i <= len ; i++ )
4120 digit = SvIVX(*av_fetch((AV *)vs, i, 0));
4122 Perl_sv_catpvf(aTHX_ sv,"_%"IVdf,(IV)-digit);
4124 Perl_sv_catpvf(aTHX_ sv,".%"IVdf,(IV)digit);
4127 if ( len <= 2 ) { /* short version, must be at least three */
4128 for ( len = 2 - len; len != 0; len-- )
4129 Perl_sv_catpv(aTHX_ sv,".0");
4136 =for apidoc vstringify
4138 In order to maintain maximum compatibility with earlier versions
4139 of Perl, this function will return either the floating point
4140 notation or the multiple dotted notation, depending on whether
4141 the original version contained 1 or more dots, respectively
4147 Perl_vstringify(pTHX_ SV *vs)
4152 len = av_len((AV *)vs);
4153 digit = SvIVX(*av_fetch((AV *)vs, len, 0));
4155 if ( len < 2 || ( len == 2 && digit < 0 ) )
4164 Version object aware cmp. Both operands must already have been
4165 converted into version objects.
4171 Perl_vcmp(pTHX_ SV *lsv, SV *rsv)
4178 l = av_len((AV *)lsv);
4179 r = av_len((AV *)rsv);
4183 while ( i <= m && retval == 0 )
4185 I32 left = SvIV(*av_fetch((AV *)lsv,i,0));
4186 I32 right = SvIV(*av_fetch((AV *)rsv,i,0));
4187 bool lalpha = left < 0 ? 1 : 0;
4188 bool ralpha = right < 0 ? 1 : 0;
4191 if ( left < right || (left == right && lalpha && !ralpha) )
4193 if ( left > right || (left == right && ralpha && !lalpha) )
4198 if ( l != r && retval == 0 ) /* possible match except for trailing 0's */
4202 while ( i <= r && retval == 0 )
4204 if ( SvIV(*av_fetch((AV *)rsv,i,0)) != 0 )
4205 retval = -1; /* not a match after all */
4211 while ( i <= l && retval == 0 )
4213 if ( SvIV(*av_fetch((AV *)lsv,i,0)) != 0 )
4214 retval = +1; /* not a match after all */
4222 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT)
4223 # define EMULATE_SOCKETPAIR_UDP
4226 #ifdef EMULATE_SOCKETPAIR_UDP
4228 S_socketpair_udp (int fd[2]) {
4230 /* Fake a datagram socketpair using UDP to localhost. */
4231 int sockets[2] = {-1, -1};
4232 struct sockaddr_in addresses[2];
4234 Sock_size_t size = sizeof(struct sockaddr_in);
4235 unsigned short port;
4238 memset(&addresses, 0, sizeof(addresses));
4241 sockets[i] = PerlSock_socket(AF_INET, SOCK_DGRAM, PF_INET);
4242 if (sockets[i] == -1)
4243 goto tidy_up_and_fail;
4245 addresses[i].sin_family = AF_INET;
4246 addresses[i].sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4247 addresses[i].sin_port = 0; /* kernel choses port. */
4248 if (PerlSock_bind(sockets[i], (struct sockaddr *) &addresses[i],
4249 sizeof(struct sockaddr_in)) == -1)
4250 goto tidy_up_and_fail;
4253 /* Now have 2 UDP sockets. Find out which port each is connected to, and
4254 for each connect the other socket to it. */
4257 if (PerlSock_getsockname(sockets[i], (struct sockaddr *) &addresses[i],
4259 goto tidy_up_and_fail;
4260 if (size != sizeof(struct sockaddr_in))
4261 goto abort_tidy_up_and_fail;
4262 /* !1 is 0, !0 is 1 */
4263 if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i],
4264 sizeof(struct sockaddr_in)) == -1)
4265 goto tidy_up_and_fail;
4268 /* Now we have 2 sockets connected to each other. I don't trust some other
4269 process not to have already sent a packet to us (by random) so send
4270 a packet from each to the other. */
4273 /* I'm going to send my own port number. As a short.
4274 (Who knows if someone somewhere has sin_port as a bitfield and needs
4275 this routine. (I'm assuming crays have socketpair)) */
4276 port = addresses[i].sin_port;
4277 got = PerlLIO_write(sockets[i], &port, sizeof(port));
4278 if (got != sizeof(port)) {
4280 goto tidy_up_and_fail;
4281 goto abort_tidy_up_and_fail;
4285 /* Packets sent. I don't trust them to have arrived though.
4286 (As I understand it Solaris TCP stack is multithreaded. Non-blocking
4287 connect to localhost will use a second kernel thread. In 2.6 the
4288 first thread running the connect() returns before the second completes,
4289 so EINPROGRESS> In 2.7 the improved stack is faster and connect()
4290 returns 0. Poor programs have tripped up. One poor program's authors'
4291 had a 50-1 reverse stock split. Not sure how connected these were.)
4292 So I don't trust someone not to have an unpredictable UDP stack.
4296 struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */
4297 int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0];
4301 FD_SET(sockets[0], &rset);
4302 FD_SET(sockets[1], &rset);
4304 got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor);
4305 if (got != 2 || !FD_ISSET(sockets[0], &rset)
4306 || !FD_ISSET(sockets[1], &rset)) {
4307 /* I hope this is portable and appropriate. */
4309 goto tidy_up_and_fail;
4310 goto abort_tidy_up_and_fail;
4314 /* And the paranoia department even now doesn't trust it to have arrive
4315 (hence MSG_DONTWAIT). Or that what arrives was sent by us. */
4317 struct sockaddr_in readfrom;
4318 unsigned short buffer[2];
4323 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4324 sizeof(buffer), MSG_DONTWAIT,
4325 (struct sockaddr *) &readfrom, &size);
4327 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4329 (struct sockaddr *) &readfrom, &size);
4333 goto tidy_up_and_fail;
4334 if (got != sizeof(port)
4335 || size != sizeof(struct sockaddr_in)
4336 /* Check other socket sent us its port. */
4337 || buffer[0] != (unsigned short) addresses[!i].sin_port
4338 /* Check kernel says we got the datagram from that socket */
4339 || readfrom.sin_family != addresses[!i].sin_family
4340 || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr
4341 || readfrom.sin_port != addresses[!i].sin_port)
4342 goto abort_tidy_up_and_fail;
4345 /* My caller (my_socketpair) has validated that this is non-NULL */
4348 /* I hereby declare this connection open. May God bless all who cross
4352 abort_tidy_up_and_fail:
4353 errno = ECONNABORTED;
4356 const int save_errno = errno;
4357 if (sockets[0] != -1)
4358 PerlLIO_close(sockets[0]);
4359 if (sockets[1] != -1)
4360 PerlLIO_close(sockets[1]);
4365 #endif /* EMULATE_SOCKETPAIR_UDP */
4367 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET)
4369 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4370 /* Stevens says that family must be AF_LOCAL, protocol 0.
4371 I'm going to enforce that, then ignore it, and use TCP (or UDP). */
4376 struct sockaddr_in listen_addr;
4377 struct sockaddr_in connect_addr;
4382 || family != AF_UNIX
4385 errno = EAFNOSUPPORT;
4393 #ifdef EMULATE_SOCKETPAIR_UDP
4394 if (type == SOCK_DGRAM)
4395 return S_socketpair_udp(fd);
4398 listener = PerlSock_socket(AF_INET, type, 0);
4401 memset(&listen_addr, 0, sizeof(listen_addr));
4402 listen_addr.sin_family = AF_INET;
4403 listen_addr.sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4404 listen_addr.sin_port = 0; /* kernel choses port. */
4405 if (PerlSock_bind(listener, (struct sockaddr *) &listen_addr,
4406 sizeof(listen_addr)) == -1)
4407 goto tidy_up_and_fail;
4408 if (PerlSock_listen(listener, 1) == -1)
4409 goto tidy_up_and_fail;
4411 connector = PerlSock_socket(AF_INET, type, 0);
4412 if (connector == -1)
4413 goto tidy_up_and_fail;
4414 /* We want to find out the port number to connect to. */
4415 size = sizeof(connect_addr);
4416 if (PerlSock_getsockname(listener, (struct sockaddr *) &connect_addr,
4418 goto tidy_up_and_fail;
4419 if (size != sizeof(connect_addr))
4420 goto abort_tidy_up_and_fail;
4421 if (PerlSock_connect(connector, (struct sockaddr *) &connect_addr,
4422 sizeof(connect_addr)) == -1)
4423 goto tidy_up_and_fail;
4425 size = sizeof(listen_addr);
4426 acceptor = PerlSock_accept(listener, (struct sockaddr *) &listen_addr,
4429 goto tidy_up_and_fail;
4430 if (size != sizeof(listen_addr))
4431 goto abort_tidy_up_and_fail;
4432 PerlLIO_close(listener);
4433 /* Now check we are talking to ourself by matching port and host on the
4435 if (PerlSock_getsockname(connector, (struct sockaddr *) &connect_addr,
4437 goto tidy_up_and_fail;
4438 if (size != sizeof(connect_addr)
4439 || listen_addr.sin_family != connect_addr.sin_family
4440 || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr
4441 || listen_addr.sin_port != connect_addr.sin_port) {
4442 goto abort_tidy_up_and_fail;
4448 abort_tidy_up_and_fail:
4450 errno = ECONNABORTED; /* This would be the standard thing to do. */
4452 # ifdef ECONNREFUSED
4453 errno = ECONNREFUSED; /* E.g. Symbian does not have ECONNABORTED. */
4455 errno = ETIMEDOUT; /* Desperation time. */
4460 int save_errno = errno;
4462 PerlLIO_close(listener);
4463 if (connector != -1)
4464 PerlLIO_close(connector);
4466 PerlLIO_close(acceptor);
4472 /* In any case have a stub so that there's code corresponding
4473 * to the my_socketpair in global.sym. */
4475 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4476 #ifdef HAS_SOCKETPAIR
4477 return socketpair(family, type, protocol, fd);
4486 =for apidoc sv_nosharing
4488 Dummy routine which "shares" an SV when there is no sharing module present.
4489 Exists to avoid test for a NULL function pointer and because it could potentially warn under
4490 some level of strict-ness.
4496 Perl_sv_nosharing(pTHX_ SV *sv)
4502 =for apidoc sv_nolocking
4504 Dummy routine which "locks" an SV when there is no locking module present.
4505 Exists to avoid test for a NULL function pointer and because it could potentially warn under
4506 some level of strict-ness.
4512 Perl_sv_nolocking(pTHX_ SV *sv)
4519 =for apidoc sv_nounlocking
4521 Dummy routine which "unlocks" an SV when there is no locking module present.
4522 Exists to avoid test for a NULL function pointer and because it could potentially warn under
4523 some level of strict-ness.
4529 Perl_sv_nounlocking(pTHX_ SV *sv)
4535 Perl_parse_unicode_opts(pTHX_ const char **popt)
4537 const char *p = *popt;
4542 opt = (U32) atoi(p);
4543 while (isDIGIT(*p)) p++;
4544 if (*p && *p != '\n' && *p != '\r')
4545 Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
4550 case PERL_UNICODE_STDIN:
4551 opt |= PERL_UNICODE_STDIN_FLAG; break;
4552 case PERL_UNICODE_STDOUT:
4553 opt |= PERL_UNICODE_STDOUT_FLAG; break;
4554 case PERL_UNICODE_STDERR:
4555 opt |= PERL_UNICODE_STDERR_FLAG; break;
4556 case PERL_UNICODE_STD:
4557 opt |= PERL_UNICODE_STD_FLAG; break;
4558 case PERL_UNICODE_IN:
4559 opt |= PERL_UNICODE_IN_FLAG; break;
4560 case PERL_UNICODE_OUT:
4561 opt |= PERL_UNICODE_OUT_FLAG; break;
4562 case PERL_UNICODE_INOUT:
4563 opt |= PERL_UNICODE_INOUT_FLAG; break;
4564 case PERL_UNICODE_LOCALE:
4565 opt |= PERL_UNICODE_LOCALE_FLAG; break;
4566 case PERL_UNICODE_ARGV:
4567 opt |= PERL_UNICODE_ARGV_FLAG; break;
4569 if (*p != '\n' && *p != '\r')
4571 "Unknown Unicode option letter '%c'", *p);
4577 opt = PERL_UNICODE_DEFAULT_FLAGS;
4579 if (opt & ~PERL_UNICODE_ALL_FLAGS)
4580 Perl_croak(aTHX_ "Unknown Unicode option value %"UVuf,
4581 (UV) (opt & ~PERL_UNICODE_ALL_FLAGS));
4592 * This is really just a quick hack which grabs various garbage
4593 * values. It really should be a real hash algorithm which
4594 * spreads the effect of every input bit onto every output bit,
4595 * if someone who knows about such things would bother to write it.
4596 * Might be a good idea to add that function to CORE as well.
4597 * No numbers below come from careful analysis or anything here,
4598 * except they are primes and SEED_C1 > 1E6 to get a full-width
4599 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
4600 * probably be bigger too.
4603 # define SEED_C1 1000003
4604 #define SEED_C4 73819
4606 # define SEED_C1 25747
4607 #define SEED_C4 20639
4611 #define SEED_C5 26107
4613 #ifndef PERL_NO_DEV_RANDOM
4618 # include <starlet.h>
4619 /* when[] = (low 32 bits, high 32 bits) of time since epoch
4620 * in 100-ns units, typically incremented ever 10 ms. */
4621 unsigned int when[2];
4623 # ifdef HAS_GETTIMEOFDAY
4624 struct timeval when;
4630 /* This test is an escape hatch, this symbol isn't set by Configure. */
4631 #ifndef PERL_NO_DEV_RANDOM
4632 #ifndef PERL_RANDOM_DEVICE
4633 /* /dev/random isn't used by default because reads from it will block
4634 * if there isn't enough entropy available. You can compile with
4635 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
4636 * is enough real entropy to fill the seed. */
4637 # define PERL_RANDOM_DEVICE "/dev/urandom"
4639 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
4641 if (PerlLIO_read(fd, (void*)&u, sizeof u) != sizeof u)
4650 _ckvmssts(sys$gettim(when));
4651 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
4653 # ifdef HAS_GETTIMEOFDAY
4654 PerlProc_gettimeofday(&when,NULL);
4655 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
4658 u = (U32)SEED_C1 * when;
4661 u += SEED_C3 * (U32)PerlProc_getpid();
4662 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
4663 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
4664 u += SEED_C5 * (U32)PTR2UV(&when);
4670 Perl_get_hash_seed(pTHX)
4672 const char *s = PerlEnv_getenv("PERL_HASH_SEED");
4676 while (isSPACE(*s)) s++;
4677 if (s && isDIGIT(*s))
4678 myseed = (UV)Atoul(s);
4680 #ifdef USE_HASH_SEED_EXPLICIT
4684 /* Compute a random seed */
4685 (void)seedDrand01((Rand_seed_t)seed());
4686 myseed = (UV)(Drand01() * (NV)UV_MAX);
4687 #if RANDBITS < (UVSIZE * 8)
4688 /* Since there are not enough randbits to to reach all
4689 * the bits of a UV, the low bits might need extra
4690 * help. Sum in another random number that will
4691 * fill in the low bits. */
4693 (UV)(Drand01() * (NV)((1 << ((UVSIZE * 8 - RANDBITS))) - 1));
4694 #endif /* RANDBITS < (UVSIZE * 8) */
4695 if (myseed == 0) { /* Superparanoia. */
4696 myseed = (UV)(Drand01() * (NV)UV_MAX); /* One more chance. */
4698 Perl_croak(aTHX_ "Your random numbers are not that random");
4701 PL_rehash_seed_set = TRUE;
4706 #ifdef PERL_GLOBAL_STRUCT
4709 Perl_init_global_struct(pTHX)
4711 struct perl_vars *plvarsp = NULL;
4712 #ifdef PERL_GLOBAL_STRUCT
4713 # define PERL_GLOBAL_STRUCT_INIT
4714 # include "opcode.h" /* the ppaddr and check */
4715 IV nppaddr = sizeof(Gppaddr)/sizeof(Perl_ppaddr_t);
4716 IV ncheck = sizeof(Gcheck) /sizeof(Perl_check_t);
4717 # ifdef PERL_GLOBAL_STRUCT_PRIVATE
4718 /* PerlMem_malloc() because can't use even safesysmalloc() this early. */
4719 plvarsp = (struct perl_vars*)PerlMem_malloc(sizeof(struct perl_vars));
4723 plvarsp = PL_VarsPtr;
4724 # endif /* PERL_GLOBAL_STRUCT_PRIVATE */
4730 # define PERLVAR(var,type) /**/
4731 # define PERLVARA(var,n,type) /**/
4732 # define PERLVARI(var,type,init) plvarsp->var = init;
4733 # define PERLVARIC(var,type,init) plvarsp->var = init;
4734 # define PERLVARISC(var,init) Copy(init, plvarsp->var, sizeof(init), char);
4735 # include "perlvars.h"
4741 # ifdef PERL_GLOBAL_STRUCT
4742 plvarsp->Gppaddr = PerlMem_malloc(nppaddr * sizeof(Perl_ppaddr_t));
4743 if (!plvarsp->Gppaddr)
4745 plvarsp->Gcheck = PerlMem_malloc(ncheck * sizeof(Perl_check_t));
4746 if (!plvarsp->Gcheck)
4748 Copy(Gppaddr, plvarsp->Gppaddr, nppaddr, Perl_ppaddr_t);
4749 Copy(Gcheck, plvarsp->Gcheck, ncheck, Perl_check_t);
4751 # ifdef PERL_SET_VARS
4752 PERL_SET_VARS(plvarsp);
4754 # undef PERL_GLOBAL_STRUCT_INIT
4759 #endif /* PERL_GLOBAL_STRUCT */
4761 #ifdef PERL_GLOBAL_STRUCT
4764 Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp)
4766 #ifdef PERL_GLOBAL_STRUCT
4767 # ifdef PERL_UNSET_VARS
4768 PERL_UNSET_VARS(plvarsp);
4770 free(plvarsp->Gppaddr);
4771 free(plvarsp->Gcheck);
4772 # ifdef PERL_GLOBAL_STRUCT_PRIVATE
4778 #endif /* PERL_GLOBAL_STRUCT */
4782 * c-indentation-style: bsd
4784 * indent-tabs-mode: t
4787 * ex: set ts=8 sts=4 sw=4 noet: