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++));
160 /* safe version of system's calloc() */
163 Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
169 if (size * count > 0xffff) {
170 PerlIO_printf(Perl_error_log,
171 "Allocation too large: %lx\n", size * count) FLUSH;
174 #endif /* HAS_64K_LIMIT */
176 if ((long)size < 0 || (long)count < 0)
177 Perl_croak_nocontext("panic: calloc");
180 ptr = (Malloc_t)PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */
181 PERL_ALLOC_CHECK(ptr);
182 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));
184 memset((void*)ptr, 0, size);
190 /* Can't use PerlIO to write as it allocates memory */
191 PerlLIO_write(PerlIO_fileno(Perl_error_log),
192 PL_no_mem, strlen(PL_no_mem));
199 /* These must be defined when not using Perl's malloc for binary
204 Malloc_t Perl_malloc (MEM_SIZE nbytes)
207 return (Malloc_t)PerlMem_malloc(nbytes);
210 Malloc_t Perl_calloc (MEM_SIZE elements, MEM_SIZE size)
213 return (Malloc_t)PerlMem_calloc(elements, size);
216 Malloc_t Perl_realloc (Malloc_t where, MEM_SIZE nbytes)
219 return (Malloc_t)PerlMem_realloc(where, nbytes);
222 Free_t Perl_mfree (Malloc_t where)
230 /* copy a string up to some (non-backslashed) delimiter, if any */
233 Perl_delimcpy(pTHX_ register char *to, register const char *toend, register const char *from, register const char *fromend, register int delim, I32 *retlen)
236 for (tolen = 0; from < fromend; from++, tolen++) {
238 if (from[1] == delim)
247 else if (*from == delim)
258 /* return ptr to little string in big string, NULL if not found */
259 /* This routine was donated by Corey Satten. */
262 Perl_instr(pTHX_ register const char *big, register const char *little)
264 register const char *s, *x;
275 for (x=big,s=little; *s; /**/ ) {
284 return (char*)(big-1);
289 /* same as instr but allow embedded nulls */
292 Perl_ninstr(pTHX_ register const char *big, register const char *bigend, const char *little, const char *lend)
294 register const char *s, *x;
295 register const I32 first = *little;
296 register const char *littleend = lend;
298 if (!first && little >= littleend)
300 if (bigend - big < littleend - little)
302 bigend -= littleend - little++;
303 while (big <= bigend) {
306 for (x=big,s=little; s < littleend; /**/ ) {
313 return (char*)(big-1);
318 /* reverse of the above--find last substring */
321 Perl_rninstr(pTHX_ register const char *big, const char *bigend, const char *little, const char *lend)
323 register const char *bigbeg;
324 register const char *s, *x;
325 register const I32 first = *little;
326 register const char *littleend = lend;
328 if (!first && little >= littleend)
329 return (char*)bigend;
331 big = bigend - (littleend - little++);
332 while (big >= bigbeg) {
335 for (x=big+2,s=little; s < littleend; /**/ ) {
342 return (char*)(big+1);
347 #define FBM_TABLE_OFFSET 2 /* Number of bytes between EOS and table*/
349 /* As a space optimization, we do not compile tables for strings of length
350 0 and 1, and for strings of length 2 unless FBMcf_TAIL. These are
351 special-cased in fbm_instr().
353 If FBMcf_TAIL, the table is created as if the string has a trailing \n. */
356 =head1 Miscellaneous Functions
358 =for apidoc fbm_compile
360 Analyses the string in order to make fast searches on it using fbm_instr()
361 -- the Boyer-Moore algorithm.
367 Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
376 if (flags & FBMcf_TAIL) {
377 MAGIC *mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
378 sv_catpvn(sv, "\n", 1); /* Taken into account in fbm_instr() */
379 if (mg && mg->mg_len >= 0)
382 s = (U8*)SvPV_force(sv, len);
383 (void)SvUPGRADE(sv, SVt_PVBM);
384 if (len == 0) /* TAIL might be on a zero-length string. */
394 Sv_Grow(sv, len + 256 + FBM_TABLE_OFFSET);
395 table = (unsigned char*)(SvPVX(sv) + len + FBM_TABLE_OFFSET);
396 s = table - 1 - FBM_TABLE_OFFSET; /* last char */
397 memset((void*)table, mlen, 256);
398 table[-1] = (U8)flags;
400 sb = s - mlen + 1; /* first char (maybe) */
402 if (table[*s] == mlen)
407 sv_magic(sv, Nullsv, PERL_MAGIC_bm, Nullch, 0); /* deep magic */
410 s = (unsigned char*)(SvPVX(sv)); /* deeper magic */
411 for (i = 0; i < len; i++) {
412 if (PL_freq[s[i]] < frequency) {
414 frequency = PL_freq[s[i]];
417 BmRARE(sv) = s[rarest];
418 BmPREVIOUS(sv) = (U16)rarest;
419 BmUSEFUL(sv) = 100; /* Initial value */
420 if (flags & FBMcf_TAIL)
422 DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %d\n",
423 BmRARE(sv),BmPREVIOUS(sv)));
426 /* If SvTAIL(littlestr), it has a fake '\n' at end. */
427 /* If SvTAIL is actually due to \Z or \z, this gives false positives
431 =for apidoc fbm_instr
433 Returns the location of the SV in the string delimited by C<str> and
434 C<strend>. It returns C<Nullch> if the string can't be found. The C<sv>
435 does not have to be fbm_compiled, but the search will not be as fast
442 Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *littlestr, U32 flags)
444 register unsigned char *s;
446 register unsigned char *little = (unsigned char *)SvPV(littlestr,l);
447 register STRLEN littlelen = l;
448 register const I32 multiline = flags & FBMrf_MULTILINE;
450 if ((STRLEN)(bigend - big) < littlelen) {
451 if ( SvTAIL(littlestr)
452 && ((STRLEN)(bigend - big) == littlelen - 1)
454 || (*big == *little &&
455 memEQ((char *)big, (char *)little, littlelen - 1))))
460 if (littlelen <= 2) { /* Special-cased */
462 if (littlelen == 1) {
463 if (SvTAIL(littlestr) && !multiline) { /* Anchor only! */
464 /* Know that bigend != big. */
465 if (bigend[-1] == '\n')
466 return (char *)(bigend - 1);
467 return (char *) bigend;
475 if (SvTAIL(littlestr))
476 return (char *) bigend;
480 return (char*)big; /* Cannot be SvTAIL! */
483 if (SvTAIL(littlestr) && !multiline) {
484 if (bigend[-1] == '\n' && bigend[-2] == *little)
485 return (char*)bigend - 2;
486 if (bigend[-1] == *little)
487 return (char*)bigend - 1;
491 /* This should be better than FBM if c1 == c2, and almost
492 as good otherwise: maybe better since we do less indirection.
493 And we save a lot of memory by caching no table. */
494 register unsigned char c1 = little[0];
495 register unsigned char c2 = little[1];
500 while (s <= bigend) {
510 goto check_1char_anchor;
521 goto check_1char_anchor;
524 while (s <= bigend) {
529 goto check_1char_anchor;
538 check_1char_anchor: /* One char and anchor! */
539 if (SvTAIL(littlestr) && (*bigend == *little))
540 return (char *)bigend; /* bigend is already decremented. */
543 if (SvTAIL(littlestr) && !multiline) { /* tail anchored? */
544 s = bigend - littlelen;
545 if (s >= big && bigend[-1] == '\n' && *s == *little
546 /* Automatically of length > 2 */
547 && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
549 return (char*)s; /* how sweet it is */
552 && memEQ((char*)s + 2, (char*)little + 1, littlelen - 2))
554 return (char*)s + 1; /* how sweet it is */
558 if (SvTYPE(littlestr) != SVt_PVBM || !SvVALID(littlestr)) {
559 char *b = ninstr((char*)big,(char*)bigend,
560 (char*)little, (char*)little + littlelen);
562 if (!b && SvTAIL(littlestr)) { /* Automatically multiline! */
563 /* Chop \n from littlestr: */
564 s = bigend - littlelen + 1;
566 && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
575 { /* Do actual FBM. */
576 register const unsigned char *table = little + littlelen + FBM_TABLE_OFFSET;
577 register unsigned char *oldlittle;
579 if (littlelen > (STRLEN)(bigend - big))
581 --littlelen; /* Last char found by table lookup */
584 little += littlelen; /* last char */
591 if ((tmp = table[*s])) {
592 if ((s += tmp) < bigend)
596 else { /* less expensive than calling strncmp() */
597 register unsigned char *olds = s;
602 if (*--s == *--little)
604 s = olds + 1; /* here we pay the price for failure */
606 if (s < bigend) /* fake up continue to outer loop */
614 if ( s == bigend && (table[-1] & FBMcf_TAIL)
615 && memEQ((char *)(bigend - littlelen),
616 (char *)(oldlittle - littlelen), littlelen) )
617 return (char*)bigend - littlelen;
622 /* start_shift, end_shift are positive quantities which give offsets
623 of ends of some substring of bigstr.
624 If `last' we want the last occurrence.
625 old_posp is the way of communication between consequent calls if
626 the next call needs to find the .
627 The initial *old_posp should be -1.
629 Note that we take into account SvTAIL, so one can get extra
630 optimizations if _ALL flag is set.
633 /* If SvTAIL is actually due to \Z or \z, this gives false positives
634 if PL_multiline. In fact if !PL_multiline the authoritative answer
635 is not supported yet. */
638 Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last)
640 register unsigned char *s, *x;
641 register unsigned char *big;
643 register I32 previous;
645 register unsigned char *little;
646 register I32 stop_pos;
647 register unsigned char *littleend;
651 ? (pos = PL_screamfirst[BmRARE(littlestr)]) < 0
652 : (((pos = *old_posp), pos += PL_screamnext[pos]) == 0)) {
654 if ( BmRARE(littlestr) == '\n'
655 && BmPREVIOUS(littlestr) == SvCUR(littlestr) - 1) {
656 little = (unsigned char *)(SvPVX(littlestr));
657 littleend = little + SvCUR(littlestr);
664 little = (unsigned char *)(SvPVX(littlestr));
665 littleend = little + SvCUR(littlestr);
667 /* The value of pos we can start at: */
668 previous = BmPREVIOUS(littlestr);
669 big = (unsigned char *)(SvPVX(bigstr));
670 /* The value of pos we can stop at: */
671 stop_pos = SvCUR(bigstr) - end_shift - (SvCUR(littlestr) - 1 - previous);
672 if (previous + start_shift > stop_pos) {
674 stop_pos does not include SvTAIL in the count, so this check is incorrect
675 (I think) - see [ID 20010618.006] and t/op/study.t. HVDS 2001/06/19
678 if (previous + start_shift == stop_pos + 1) /* A fake '\n'? */
683 while (pos < previous + start_shift) {
684 if (!(pos += PL_screamnext[pos]))
689 if (pos >= stop_pos) break;
690 if (big[pos] != first)
692 for (x=big+pos+1,s=little; s < littleend; /**/ ) {
698 if (s == littleend) {
700 if (!last) return (char *)(big+pos);
703 } while ( pos += PL_screamnext[pos] );
705 return (char *)(big+(*old_posp));
707 if (!SvTAIL(littlestr) || (end_shift > 0))
709 /* Ignore the trailing "\n". This code is not microoptimized */
710 big = (unsigned char *)(SvPVX(bigstr) + SvCUR(bigstr));
711 stop_pos = littleend - little; /* Actual littlestr len */
716 && ((stop_pos == 1) ||
717 memEQ((char *)(big + 1), (char *)little, stop_pos - 1)))
723 Perl_ibcmp(pTHX_ const char *s1, const char *s2, register I32 len)
725 register const U8 *a = (const U8 *)s1;
726 register const U8 *b = (const U8 *)s2;
728 if (*a != *b && *a != PL_fold[*b])
736 Perl_ibcmp_locale(pTHX_ const char *s1, const char *s2, register I32 len)
739 register const U8 *a = (const U8 *)s1;
740 register const U8 *b = (const U8 *)s2;
742 if (*a != *b && *a != PL_fold_locale[*b])
749 /* copy a string to a safe spot */
752 =head1 Memory Management
756 Perl's version of C<strdup()>. Returns a pointer to a newly allocated
757 string which is a duplicate of C<pv>. The size of the string is
758 determined by C<strlen()>. The memory allocated for the new string can
759 be freed with the C<Safefree()> function.
765 Perl_savepv(pTHX_ const char *pv)
767 register char *newaddr;
768 #ifdef PERL_MALLOC_WRAP
774 #ifdef PERL_MALLOC_WRAP
775 pvlen = strlen(pv)+1;
776 New(902,newaddr,pvlen,char);
778 New(902,newaddr,strlen(pv)+1,char);
780 return strcpy(newaddr,pv);
783 /* same thing but with a known length */
788 Perl's version of what C<strndup()> would be if it existed. Returns a
789 pointer to a newly allocated string which is a duplicate of the first
790 C<len> bytes from C<pv>. The memory allocated for the new string can be
791 freed with the C<Safefree()> function.
797 Perl_savepvn(pTHX_ const char *pv, register I32 len)
799 register char *newaddr;
801 New(903,newaddr,len+1,char);
802 /* Give a meaning to NULL pointer mainly for the use in sv_magic() */
804 /* might not be null terminated */
806 return (char *) CopyD(pv,newaddr,len,char);
809 return (char *) ZeroD(newaddr,len+1,char);
814 =for apidoc savesharedpv
816 A version of C<savepv()> which allocates the duplicate string in memory
817 which is shared between threads.
822 Perl_savesharedpv(pTHX_ const char *pv)
824 register char *newaddr;
828 newaddr = (char*)PerlMemShared_malloc(strlen(pv)+1);
830 PerlLIO_write(PerlIO_fileno(Perl_error_log),
831 PL_no_mem, strlen(PL_no_mem));
834 return strcpy(newaddr,pv);
840 A version of C<savepv()>/C<savepvn()> which gets the string to duplicate from
841 the passed in SV using C<SvPV()>
847 Perl_savesvpv(pTHX_ SV *sv)
850 const char *pv = SvPV(sv, len);
851 register char *newaddr;
854 New(903,newaddr,len,char);
855 return (char *) CopyD(pv,newaddr,len,char);
859 /* the SV for Perl_form() and mess() is not kept in an arena */
868 return sv_2mortal(newSVpvn("",0));
873 /* Create as PVMG now, to avoid any upgrading later */
875 Newz(905, any, 1, XPVMG);
876 SvFLAGS(sv) = SVt_PVMG;
877 SvANY(sv) = (void*)any;
878 SvREFCNT(sv) = 1 << 30; /* practically infinite */
883 #if defined(PERL_IMPLICIT_CONTEXT)
885 Perl_form_nocontext(const char* pat, ...)
891 retval = vform(pat, &args);
895 #endif /* PERL_IMPLICIT_CONTEXT */
898 =head1 Miscellaneous Functions
901 Takes a sprintf-style format pattern and conventional
902 (non-SV) arguments and returns the formatted string.
904 (char *) Perl_form(pTHX_ const char* pat, ...)
906 can be used any place a string (char *) is required:
908 char * s = Perl_form("%d.%d",major,minor);
910 Uses a single private buffer so if you want to format several strings you
911 must explicitly copy the earlier strings away (and free the copies when you
918 Perl_form(pTHX_ const char* pat, ...)
923 retval = vform(pat, &args);
929 Perl_vform(pTHX_ const char *pat, va_list *args)
931 SV *sv = mess_alloc();
932 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
936 #if defined(PERL_IMPLICIT_CONTEXT)
938 Perl_mess_nocontext(const char *pat, ...)
944 retval = vmess(pat, &args);
948 #endif /* PERL_IMPLICIT_CONTEXT */
951 Perl_mess(pTHX_ const char *pat, ...)
956 retval = vmess(pat, &args);
962 S_closest_cop(pTHX_ COP *cop, OP *o)
964 /* Look for PL_op starting from o. cop is the last COP we've seen. */
966 if (!o || o == PL_op) return cop;
968 if (o->op_flags & OPf_KIDS) {
970 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
974 /* If the OP_NEXTSTATE has been optimised away we can still use it
975 * the get the file and line number. */
977 if (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE)
980 /* Keep searching, and return when we've found something. */
982 new_cop = closest_cop(cop, kid);
983 if (new_cop) return new_cop;
993 Perl_vmess(pTHX_ const char *pat, va_list *args)
995 SV *sv = mess_alloc();
996 static const char dgd[] = " during global destruction.\n";
998 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
999 if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
1002 * Try and find the file and line for PL_op. This will usually be
1003 * PL_curcop, but it might be a cop that has been optimised away. We
1004 * can try to find such a cop by searching through the optree starting
1005 * from the sibling of PL_curcop.
1008 const COP *cop = closest_cop(PL_curcop, PL_curcop->op_sibling);
1009 if (!cop) cop = PL_curcop;
1012 Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf,
1013 OutCopFILE(cop), (IV)CopLINE(cop));
1014 if (GvIO(PL_last_in_gv) && IoLINES(GvIOp(PL_last_in_gv))) {
1015 const bool line_mode = (RsSIMPLE(PL_rs) &&
1016 SvCUR(PL_rs) == 1 && *SvPVX_const(PL_rs) == '\n');
1017 Perl_sv_catpvf(aTHX_ sv, ", <%s> %s %"IVdf,
1018 PL_last_in_gv == PL_argvgv ?
1019 "" : GvNAME(PL_last_in_gv),
1020 line_mode ? "line" : "chunk",
1021 (IV)IoLINES(GvIOp(PL_last_in_gv)));
1023 sv_catpv(sv, PL_dirty ? dgd : ".\n");
1029 Perl_write_to_stderr(pTHX_ const char* message, int msglen)
1035 if (PL_stderrgv && SvREFCNT(PL_stderrgv)
1036 && (io = GvIO(PL_stderrgv))
1037 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
1044 SAVESPTR(PL_stderrgv);
1045 PL_stderrgv = Nullgv;
1047 PUSHSTACKi(PERLSI_MAGIC);
1051 PUSHs(SvTIED_obj((SV*)io, mg));
1052 PUSHs(sv_2mortal(newSVpvn(message, msglen)));
1054 call_method("PRINT", G_SCALAR);
1062 /* SFIO can really mess with your errno */
1065 PerlIO *serr = Perl_error_log;
1067 PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
1068 (void)PerlIO_flush(serr);
1075 /* Common code used by vcroak, vdie and vwarner */
1077 void S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8);
1080 S_vdie_croak_common(pTHX_ const char* pat, va_list* args, STRLEN* msglen,
1087 SV *msv = vmess(pat, args);
1088 if (PL_errors && SvCUR(PL_errors)) {
1089 sv_catsv(PL_errors, msv);
1090 message = SvPV(PL_errors, *msglen);
1091 SvCUR_set(PL_errors, 0);
1094 message = SvPV(msv,*msglen);
1095 *utf8 = SvUTF8(msv);
1101 DEBUG_S(PerlIO_printf(Perl_debug_log,
1102 "%p: die/croak: message = %s\ndiehook = %p\n",
1103 thr, message, PL_diehook));
1105 S_vdie_common(aTHX_ message, *msglen, *utf8);
1111 S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8)
1116 /* sv_2cv might call Perl_croak() */
1117 SV *olddiehook = PL_diehook;
1121 SAVESPTR(PL_diehook);
1122 PL_diehook = Nullsv;
1123 cv = sv_2cv(olddiehook, &stash, &gv, 0);
1125 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1132 msg = newSVpvn(message, msglen);
1133 SvFLAGS(msg) |= utf8;
1141 PUSHSTACKi(PERLSI_DIEHOOK);
1145 call_sv((SV*)cv, G_DISCARD);
1152 Perl_vdie(pTHX_ const char* pat, va_list *args)
1154 const char *message;
1155 const int was_in_eval = PL_in_eval;
1159 DEBUG_S(PerlIO_printf(Perl_debug_log,
1160 "%p: die: curstack = %p, mainstack = %p\n",
1161 thr, PL_curstack, PL_mainstack));
1163 message = S_vdie_croak_common(aTHX_ pat, args, &msglen, &utf8);
1165 PL_restartop = die_where(message, msglen);
1166 SvFLAGS(ERRSV) |= utf8;
1167 DEBUG_S(PerlIO_printf(Perl_debug_log,
1168 "%p: die: restartop = %p, was_in_eval = %d, top_env = %p\n",
1169 thr, PL_restartop, was_in_eval, PL_top_env));
1170 if ((!PL_restartop && was_in_eval) || PL_top_env->je_prev)
1172 return PL_restartop;
1175 #if defined(PERL_IMPLICIT_CONTEXT)
1177 Perl_die_nocontext(const char* pat, ...)
1182 va_start(args, pat);
1183 o = vdie(pat, &args);
1187 #endif /* PERL_IMPLICIT_CONTEXT */
1190 Perl_die(pTHX_ const char* pat, ...)
1194 va_start(args, pat);
1195 o = vdie(pat, &args);
1201 Perl_vcroak(pTHX_ const char* pat, va_list *args)
1203 const char *message;
1207 message = S_vdie_croak_common(aTHX_ pat, args, &msglen, &utf8);
1210 PL_restartop = die_where(message, msglen);
1211 SvFLAGS(ERRSV) |= utf8;
1215 message = SvPVx(ERRSV, msglen);
1217 write_to_stderr(message, msglen);
1221 #if defined(PERL_IMPLICIT_CONTEXT)
1223 Perl_croak_nocontext(const char *pat, ...)
1227 va_start(args, pat);
1232 #endif /* PERL_IMPLICIT_CONTEXT */
1235 =head1 Warning and Dieing
1239 This is the XSUB-writer's interface to Perl's C<die> function.
1240 Normally call this function the same way you call the C C<printf>
1241 function. Calling C<croak> returns control directly to Perl,
1242 sidestepping the normal C order of execution. See C<warn>.
1244 If you want to throw an exception object, assign the object to
1245 C<$@> and then pass C<Nullch> to croak():
1247 errsv = get_sv("@", TRUE);
1248 sv_setsv(errsv, exception_object);
1255 Perl_croak(pTHX_ const char *pat, ...)
1258 va_start(args, pat);
1265 Perl_vwarn(pTHX_ const char* pat, va_list *args)
1276 msv = vmess(pat, args);
1278 message = SvPV(msv, msglen);
1281 /* sv_2cv might call Perl_warn() */
1282 SV *oldwarnhook = PL_warnhook;
1284 SAVESPTR(PL_warnhook);
1285 PL_warnhook = Nullsv;
1286 cv = sv_2cv(oldwarnhook, &stash, &gv, 0);
1288 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1294 msg = newSVpvn(message, msglen);
1295 SvFLAGS(msg) |= utf8;
1299 PUSHSTACKi(PERLSI_WARNHOOK);
1303 call_sv((SV*)cv, G_DISCARD);
1310 write_to_stderr(message, msglen);
1313 #if defined(PERL_IMPLICIT_CONTEXT)
1315 Perl_warn_nocontext(const char *pat, ...)
1319 va_start(args, pat);
1323 #endif /* PERL_IMPLICIT_CONTEXT */
1328 This is the XSUB-writer's interface to Perl's C<warn> function. Call this
1329 function the same way you call the C C<printf> function. See C<croak>.
1335 Perl_warn(pTHX_ const char *pat, ...)
1338 va_start(args, pat);
1343 #if defined(PERL_IMPLICIT_CONTEXT)
1345 Perl_warner_nocontext(U32 err, const char *pat, ...)
1349 va_start(args, pat);
1350 vwarner(err, pat, &args);
1353 #endif /* PERL_IMPLICIT_CONTEXT */
1356 Perl_warner(pTHX_ U32 err, const char* pat,...)
1359 va_start(args, pat);
1360 vwarner(err, pat, &args);
1365 Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args)
1369 SV * const msv = vmess(pat, args);
1371 const char *message = SvPV(msv, msglen);
1372 const I32 utf8 = SvUTF8(msv);
1376 S_vdie_common(aTHX_ message, msglen, utf8);
1379 PL_restartop = die_where(message, msglen);
1380 SvFLAGS(ERRSV) |= utf8;
1383 write_to_stderr(message, msglen);
1387 Perl_vwarn(aTHX_ pat, args);
1391 /* since we've already done strlen() for both nam and val
1392 * we can use that info to make things faster than
1393 * sprintf(s, "%s=%s", nam, val)
1395 #define my_setenv_format(s, nam, nlen, val, vlen) \
1396 Copy(nam, s, nlen, char); \
1398 Copy(val, s+(nlen+1), vlen, char); \
1399 *(s+(nlen+1+vlen)) = '\0'
1401 #ifdef USE_ENVIRON_ARRAY
1402 /* VMS' my_setenv() is in vms.c */
1403 #if !defined(WIN32) && !defined(NETWARE)
1405 Perl_my_setenv(pTHX_ const char *nam, const char *val)
1409 /* only parent thread can modify process environment */
1410 if (PL_curinterp == aTHX)
1413 #ifndef PERL_USE_SAFE_PUTENV
1414 if (!PL_use_safe_putenv) {
1415 /* most putenv()s leak, so we manipulate environ directly */
1416 register I32 i=setenv_getix(nam); /* where does it go? */
1419 if (environ == PL_origenviron) { /* need we copy environment? */
1425 for (max = i; environ[max]; max++) ;
1426 tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*));
1427 for (j=0; j<max; j++) { /* copy environment */
1428 const int len = strlen(environ[j]);
1429 tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char));
1430 Copy(environ[j], tmpenv[j], len+1, char);
1432 tmpenv[max] = Nullch;
1433 environ = tmpenv; /* tell exec where it is now */
1436 safesysfree(environ[i]);
1437 while (environ[i]) {
1438 environ[i] = environ[i+1];
1443 if (!environ[i]) { /* does not exist yet */
1444 environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
1445 environ[i+1] = Nullch; /* make sure it's null terminated */
1448 safesysfree(environ[i]);
1452 environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char));
1453 /* all that work just for this */
1454 my_setenv_format(environ[i], nam, nlen, val, vlen);
1457 # if defined(__CYGWIN__) || defined(EPOC) || defined(SYMBIAN)
1458 setenv(nam, val, 1);
1461 int nlen = strlen(nam), vlen;
1466 new_env = (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
1467 /* all that work just for this */
1468 my_setenv_format(new_env, nam, nlen, val, vlen);
1469 (void)putenv(new_env);
1470 # endif /* __CYGWIN__ */
1471 #ifndef PERL_USE_SAFE_PUTENV
1477 #else /* WIN32 || NETWARE */
1480 Perl_my_setenv(pTHX_ const char *nam, const char *val)
1483 register char *envstr;
1484 const int nlen = strlen(nam);
1491 New(904, envstr, nlen+vlen+2, char);
1492 my_setenv_format(envstr, nam, nlen, val, vlen);
1493 (void)PerlEnv_putenv(envstr);
1497 #endif /* WIN32 || NETWARE */
1501 Perl_setenv_getix(pTHX_ const char *nam)
1503 register I32 i, len = strlen(nam);
1505 for (i = 0; environ[i]; i++) {
1508 strnicmp(environ[i],nam,len) == 0
1510 strnEQ(environ[i],nam,len)
1512 && environ[i][len] == '=')
1513 break; /* strnEQ must come first to avoid */
1514 } /* potential SEGV's */
1517 #endif /* !PERL_MICRO */
1519 #endif /* !VMS && !EPOC*/
1521 #ifdef UNLINK_ALL_VERSIONS
1523 Perl_unlnk(pTHX_ char *f) /* unlink all versions of a file */
1527 for (i = 0; PerlLIO_unlink(f) >= 0; i++) ;
1532 /* this is a drop-in replacement for bcopy() */
1533 #if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY))
1535 Perl_my_bcopy(register const char *from,register char *to,register I32 len)
1539 if (from - to >= 0) {
1547 *(--to) = *(--from);
1553 /* this is a drop-in replacement for memset() */
1556 Perl_my_memset(register char *loc, register I32 ch, register I32 len)
1566 /* this is a drop-in replacement for bzero() */
1567 #if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
1569 Perl_my_bzero(register char *loc, register I32 len)
1579 /* this is a drop-in replacement for memcmp() */
1580 #if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
1582 Perl_my_memcmp(const char *s1, const char *s2, register I32 len)
1584 register const U8 *a = (const U8 *)s1;
1585 register const U8 *b = (const U8 *)s2;
1589 if ((tmp = *a++ - *b++))
1594 #endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */
1598 #ifdef USE_CHAR_VSPRINTF
1603 vsprintf(char *dest, const char *pat, char *args)
1607 fakebuf._ptr = dest;
1608 fakebuf._cnt = 32767;
1612 fakebuf._flag = _IOWRT|_IOSTRG;
1613 _doprnt(pat, args, &fakebuf); /* what a kludge */
1614 (void)putc('\0', &fakebuf);
1615 #ifdef USE_CHAR_VSPRINTF
1618 return 0; /* perl doesn't use return value */
1622 #endif /* HAS_VPRINTF */
1625 #if BYTEORDER != 0x4321
1627 Perl_my_swap(pTHX_ short s)
1629 #if (BYTEORDER & 1) == 0
1632 result = ((s & 255) << 8) + ((s >> 8) & 255);
1640 Perl_my_htonl(pTHX_ long l)
1644 char c[sizeof(long)];
1647 #if BYTEORDER == 0x1234
1648 u.c[0] = (l >> 24) & 255;
1649 u.c[1] = (l >> 16) & 255;
1650 u.c[2] = (l >> 8) & 255;
1654 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
1655 Perl_croak(aTHX_ "Unknown BYTEORDER\n");
1660 for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
1661 u.c[o & 0xf] = (l >> s) & 255;
1669 Perl_my_ntohl(pTHX_ long l)
1673 char c[sizeof(long)];
1676 #if BYTEORDER == 0x1234
1677 u.c[0] = (l >> 24) & 255;
1678 u.c[1] = (l >> 16) & 255;
1679 u.c[2] = (l >> 8) & 255;
1683 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
1684 Perl_croak(aTHX_ "Unknown BYTEORDER\n");
1691 for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
1692 l |= (u.c[o & 0xf] & 255) << s;
1699 #endif /* BYTEORDER != 0x4321 */
1703 * Little-endian byte order functions - 'v' for 'VAX', or 'reVerse'.
1704 * If these functions are defined,
1705 * the BYTEORDER is neither 0x1234 nor 0x4321.
1706 * However, this is not assumed.
1710 #define HTOLE(name,type) \
1712 name (register type n) \
1716 char c[sizeof(type)]; \
1719 register I32 s = 0; \
1720 for (i = 0; i < sizeof(u.c); i++, s += 8) { \
1721 u.c[i] = (n >> s) & 0xFF; \
1726 #define LETOH(name,type) \
1728 name (register type n) \
1732 char c[sizeof(type)]; \
1735 register I32 s = 0; \
1738 for (i = 0; i < sizeof(u.c); i++, s += 8) { \
1739 n |= ((type)(u.c[i] & 0xFF)) << s; \
1745 * Big-endian byte order functions.
1748 #define HTOBE(name,type) \
1750 name (register type n) \
1754 char c[sizeof(type)]; \
1757 register I32 s = 8*(sizeof(u.c)-1); \
1758 for (i = 0; i < sizeof(u.c); i++, s -= 8) { \
1759 u.c[i] = (n >> s) & 0xFF; \
1764 #define BETOH(name,type) \
1766 name (register type n) \
1770 char c[sizeof(type)]; \
1773 register I32 s = 8*(sizeof(u.c)-1); \
1776 for (i = 0; i < sizeof(u.c); i++, s -= 8) { \
1777 n |= ((type)(u.c[i] & 0xFF)) << s; \
1783 * If we just can't do it...
1786 #define NOT_AVAIL(name,type) \
1788 name (register type n) \
1790 Perl_croak_nocontext(#name "() not available"); \
1791 return n; /* not reached */ \
1795 #if defined(HAS_HTOVS) && !defined(htovs)
1798 #if defined(HAS_HTOVL) && !defined(htovl)
1801 #if defined(HAS_VTOHS) && !defined(vtohs)
1804 #if defined(HAS_VTOHL) && !defined(vtohl)
1808 #ifdef PERL_NEED_MY_HTOLE16
1810 HTOLE(Perl_my_htole16,U16)
1812 NOT_AVAIL(Perl_my_htole16,U16)
1815 #ifdef PERL_NEED_MY_LETOH16
1817 LETOH(Perl_my_letoh16,U16)
1819 NOT_AVAIL(Perl_my_letoh16,U16)
1822 #ifdef PERL_NEED_MY_HTOBE16
1824 HTOBE(Perl_my_htobe16,U16)
1826 NOT_AVAIL(Perl_my_htobe16,U16)
1829 #ifdef PERL_NEED_MY_BETOH16
1831 BETOH(Perl_my_betoh16,U16)
1833 NOT_AVAIL(Perl_my_betoh16,U16)
1837 #ifdef PERL_NEED_MY_HTOLE32
1839 HTOLE(Perl_my_htole32,U32)
1841 NOT_AVAIL(Perl_my_htole32,U32)
1844 #ifdef PERL_NEED_MY_LETOH32
1846 LETOH(Perl_my_letoh32,U32)
1848 NOT_AVAIL(Perl_my_letoh32,U32)
1851 #ifdef PERL_NEED_MY_HTOBE32
1853 HTOBE(Perl_my_htobe32,U32)
1855 NOT_AVAIL(Perl_my_htobe32,U32)
1858 #ifdef PERL_NEED_MY_BETOH32
1860 BETOH(Perl_my_betoh32,U32)
1862 NOT_AVAIL(Perl_my_betoh32,U32)
1866 #ifdef PERL_NEED_MY_HTOLE64
1868 HTOLE(Perl_my_htole64,U64)
1870 NOT_AVAIL(Perl_my_htole64,U64)
1873 #ifdef PERL_NEED_MY_LETOH64
1875 LETOH(Perl_my_letoh64,U64)
1877 NOT_AVAIL(Perl_my_letoh64,U64)
1880 #ifdef PERL_NEED_MY_HTOBE64
1882 HTOBE(Perl_my_htobe64,U64)
1884 NOT_AVAIL(Perl_my_htobe64,U64)
1887 #ifdef PERL_NEED_MY_BETOH64
1889 BETOH(Perl_my_betoh64,U64)
1891 NOT_AVAIL(Perl_my_betoh64,U64)
1895 #ifdef PERL_NEED_MY_HTOLES
1896 HTOLE(Perl_my_htoles,short)
1898 #ifdef PERL_NEED_MY_LETOHS
1899 LETOH(Perl_my_letohs,short)
1901 #ifdef PERL_NEED_MY_HTOBES
1902 HTOBE(Perl_my_htobes,short)
1904 #ifdef PERL_NEED_MY_BETOHS
1905 BETOH(Perl_my_betohs,short)
1908 #ifdef PERL_NEED_MY_HTOLEI
1909 HTOLE(Perl_my_htolei,int)
1911 #ifdef PERL_NEED_MY_LETOHI
1912 LETOH(Perl_my_letohi,int)
1914 #ifdef PERL_NEED_MY_HTOBEI
1915 HTOBE(Perl_my_htobei,int)
1917 #ifdef PERL_NEED_MY_BETOHI
1918 BETOH(Perl_my_betohi,int)
1921 #ifdef PERL_NEED_MY_HTOLEL
1922 HTOLE(Perl_my_htolel,long)
1924 #ifdef PERL_NEED_MY_LETOHL
1925 LETOH(Perl_my_letohl,long)
1927 #ifdef PERL_NEED_MY_HTOBEL
1928 HTOBE(Perl_my_htobel,long)
1930 #ifdef PERL_NEED_MY_BETOHL
1931 BETOH(Perl_my_betohl,long)
1935 Perl_my_swabn(void *ptr, int n)
1937 register char *s = (char *)ptr;
1938 register char *e = s + (n-1);
1941 for (n /= 2; n > 0; s++, e--, n--) {
1949 Perl_my_popen_list(pTHX_ char *mode, int n, SV **args)
1951 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) && !defined(NETWARE)
1953 register I32 This, that;
1959 PERL_FLUSHALL_FOR_CHILD;
1960 This = (*mode == 'w');
1964 taint_proper("Insecure %s%s", "EXEC");
1966 if (PerlProc_pipe(p) < 0)
1968 /* Try for another pipe pair for error return */
1969 if (PerlProc_pipe(pp) >= 0)
1971 while ((pid = PerlProc_fork()) < 0) {
1972 if (errno != EAGAIN) {
1973 PerlLIO_close(p[This]);
1974 PerlLIO_close(p[that]);
1976 PerlLIO_close(pp[0]);
1977 PerlLIO_close(pp[1]);
1989 /* Close parent's end of error status pipe (if any) */
1991 PerlLIO_close(pp[0]);
1992 #if defined(HAS_FCNTL) && defined(F_SETFD)
1993 /* Close error pipe automatically if exec works */
1994 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
1997 /* Now dup our end of _the_ pipe to right position */
1998 if (p[THIS] != (*mode == 'r')) {
1999 PerlLIO_dup2(p[THIS], *mode == 'r');
2000 PerlLIO_close(p[THIS]);
2001 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2002 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
2005 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
2006 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2007 /* No automatic close - do it by hand */
2014 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) {
2020 do_aexec5(Nullsv, args-1, args-1+n, pp[1], did_pipes);
2026 do_execfree(); /* free any memory malloced by child on fork */
2028 PerlLIO_close(pp[1]);
2029 /* Keep the lower of the two fd numbers */
2030 if (p[that] < p[This]) {
2031 PerlLIO_dup2(p[This], p[that]);
2032 PerlLIO_close(p[This]);
2036 PerlLIO_close(p[that]); /* close child's end of pipe */
2039 sv = *av_fetch(PL_fdpid,p[This],TRUE);
2041 (void)SvUPGRADE(sv,SVt_IV);
2043 PL_forkprocess = pid;
2044 /* If we managed to get status pipe check for exec fail */
2045 if (did_pipes && pid > 0) {
2049 while (n < sizeof(int)) {
2050 n1 = PerlLIO_read(pp[0],
2051 (void*)(((char*)&errkid)+n),
2057 PerlLIO_close(pp[0]);
2059 if (n) { /* Error */
2061 PerlLIO_close(p[This]);
2062 if (n != sizeof(int))
2063 Perl_croak(aTHX_ "panic: kid popen errno read");
2065 pid2 = wait4pid(pid, &status, 0);
2066 } while (pid2 == -1 && errno == EINTR);
2067 errno = errkid; /* Propagate errno from kid */
2072 PerlLIO_close(pp[0]);
2073 return PerlIO_fdopen(p[This], mode);
2075 Perl_croak(aTHX_ "List form of piped open not implemented");
2076 return (PerlIO *) NULL;
2080 /* VMS' my_popen() is in VMS.c, same with OS/2. */
2081 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
2083 Perl_my_popen(pTHX_ char *cmd, char *mode)
2086 register I32 This, that;
2089 I32 doexec = !(*cmd == '-' && cmd[1] == '\0');
2093 PERL_FLUSHALL_FOR_CHILD;
2096 return my_syspopen(aTHX_ cmd,mode);
2099 This = (*mode == 'w');
2101 if (doexec && PL_tainting) {
2103 taint_proper("Insecure %s%s", "EXEC");
2105 if (PerlProc_pipe(p) < 0)
2107 if (doexec && PerlProc_pipe(pp) >= 0)
2109 while ((pid = PerlProc_fork()) < 0) {
2110 if (errno != EAGAIN) {
2111 PerlLIO_close(p[This]);
2112 PerlLIO_close(p[that]);
2114 PerlLIO_close(pp[0]);
2115 PerlLIO_close(pp[1]);
2118 Perl_croak(aTHX_ "Can't fork");
2131 PerlLIO_close(pp[0]);
2132 #if defined(HAS_FCNTL) && defined(F_SETFD)
2133 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2136 if (p[THIS] != (*mode == 'r')) {
2137 PerlLIO_dup2(p[THIS], *mode == 'r');
2138 PerlLIO_close(p[THIS]);
2139 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2140 PerlLIO_close(p[THAT]);
2143 PerlLIO_close(p[THAT]);
2146 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2153 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
2158 /* may or may not use the shell */
2159 do_exec3(cmd, pp[1], did_pipes);
2162 #endif /* defined OS2 */
2164 if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) {
2165 SvREADONLY_off(GvSV(tmpgv));
2166 sv_setiv(GvSV(tmpgv), PerlProc_getpid());
2167 SvREADONLY_on(GvSV(tmpgv));
2169 #ifdef THREADS_HAVE_PIDS
2170 PL_ppid = (IV)getppid();
2173 hv_clear(PL_pidstatus); /* we have no children */
2178 do_execfree(); /* free any memory malloced by child on vfork */
2180 PerlLIO_close(pp[1]);
2181 if (p[that] < p[This]) {
2182 PerlLIO_dup2(p[This], p[that]);
2183 PerlLIO_close(p[This]);
2187 PerlLIO_close(p[that]);
2190 sv = *av_fetch(PL_fdpid,p[This],TRUE);
2192 (void)SvUPGRADE(sv,SVt_IV);
2194 PL_forkprocess = pid;
2195 if (did_pipes && pid > 0) {
2199 while (n < sizeof(int)) {
2200 n1 = PerlLIO_read(pp[0],
2201 (void*)(((char*)&errkid)+n),
2207 PerlLIO_close(pp[0]);
2209 if (n) { /* Error */
2211 PerlLIO_close(p[This]);
2212 if (n != sizeof(int))
2213 Perl_croak(aTHX_ "panic: kid popen errno read");
2215 pid2 = wait4pid(pid, &status, 0);
2216 } while (pid2 == -1 && errno == EINTR);
2217 errno = errkid; /* Propagate errno from kid */
2222 PerlLIO_close(pp[0]);
2223 return PerlIO_fdopen(p[This], mode);
2226 #if defined(atarist) || defined(EPOC)
2229 Perl_my_popen(pTHX_ char *cmd, char *mode)
2231 PERL_FLUSHALL_FOR_CHILD;
2232 /* Call system's popen() to get a FILE *, then import it.
2233 used 0 for 2nd parameter to PerlIO_importFILE;
2236 return PerlIO_importFILE(popen(cmd, mode), 0);
2240 FILE *djgpp_popen();
2242 Perl_my_popen(pTHX_ char *cmd, char *mode)
2244 PERL_FLUSHALL_FOR_CHILD;
2245 /* Call system's popen() to get a FILE *, then import it.
2246 used 0 for 2nd parameter to PerlIO_importFILE;
2249 return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
2254 #endif /* !DOSISH */
2256 /* this is called in parent before the fork() */
2258 Perl_atfork_lock(void)
2261 #if defined(USE_ITHREADS)
2262 /* locks must be held in locking order (if any) */
2264 MUTEX_LOCK(&PL_malloc_mutex);
2270 /* this is called in both parent and child after the fork() */
2272 Perl_atfork_unlock(void)
2275 #if defined(USE_ITHREADS)
2276 /* locks must be released in same order as in atfork_lock() */
2278 MUTEX_UNLOCK(&PL_malloc_mutex);
2287 #if defined(HAS_FORK)
2289 #if defined(USE_ITHREADS) && !defined(HAS_PTHREAD_ATFORK)
2294 /* atfork_lock() and atfork_unlock() are installed as pthread_atfork()
2295 * handlers elsewhere in the code */
2300 /* this "canna happen" since nothing should be calling here if !HAS_FORK */
2301 Perl_croak_nocontext("fork() not available");
2303 #endif /* HAS_FORK */
2308 Perl_dump_fds(pTHX_ char *s)
2313 PerlIO_printf(Perl_debug_log,"%s", s);
2314 for (fd = 0; fd < 32; fd++) {
2315 if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0)
2316 PerlIO_printf(Perl_debug_log," %d",fd);
2318 PerlIO_printf(Perl_debug_log,"\n");
2321 #endif /* DUMP_FDS */
2325 dup2(int oldfd, int newfd)
2327 #if defined(HAS_FCNTL) && defined(F_DUPFD)
2330 PerlLIO_close(newfd);
2331 return fcntl(oldfd, F_DUPFD, newfd);
2333 #define DUP2_MAX_FDS 256
2334 int fdtmp[DUP2_MAX_FDS];
2340 PerlLIO_close(newfd);
2341 /* good enough for low fd's... */
2342 while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
2343 if (fdx >= DUP2_MAX_FDS) {
2351 PerlLIO_close(fdtmp[--fdx]);
2358 #ifdef HAS_SIGACTION
2360 #ifdef MACOS_TRADITIONAL
2361 /* We don't want restart behavior on MacOS */
2366 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2369 struct sigaction act, oact;
2372 /* only "parent" interpreter can diddle signals */
2373 if (PL_curinterp != aTHX)
2377 act.sa_handler = handler;
2378 sigemptyset(&act.sa_mask);
2381 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2382 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
2384 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2385 if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN)
2386 act.sa_flags |= SA_NOCLDWAIT;
2388 if (sigaction(signo, &act, &oact) == -1)
2391 return oact.sa_handler;
2395 Perl_rsignal_state(pTHX_ int signo)
2397 struct sigaction oact;
2399 if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
2402 return oact.sa_handler;
2406 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2409 struct sigaction act;
2412 /* only "parent" interpreter can diddle signals */
2413 if (PL_curinterp != aTHX)
2417 act.sa_handler = handler;
2418 sigemptyset(&act.sa_mask);
2421 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2422 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
2424 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2425 if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN)
2426 act.sa_flags |= SA_NOCLDWAIT;
2428 return sigaction(signo, &act, save);
2432 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2436 /* only "parent" interpreter can diddle signals */
2437 if (PL_curinterp != aTHX)
2441 return sigaction(signo, save, (struct sigaction *)NULL);
2444 #else /* !HAS_SIGACTION */
2447 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2449 #if defined(USE_ITHREADS) && !defined(WIN32)
2450 /* only "parent" interpreter can diddle signals */
2451 if (PL_curinterp != aTHX)
2455 return PerlProc_signal(signo, handler);
2467 Perl_rsignal_state(pTHX_ int signo)
2470 Sighandler_t oldsig;
2472 #if defined(USE_ITHREADS) && !defined(WIN32)
2473 /* only "parent" interpreter can diddle signals */
2474 if (PL_curinterp != aTHX)
2479 oldsig = PerlProc_signal(signo, sig_trap);
2480 PerlProc_signal(signo, oldsig);
2482 PerlProc_kill(PerlProc_getpid(), signo);
2487 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2489 #if defined(USE_ITHREADS) && !defined(WIN32)
2490 /* only "parent" interpreter can diddle signals */
2491 if (PL_curinterp != aTHX)
2494 *save = PerlProc_signal(signo, handler);
2495 return (*save == SIG_ERR) ? -1 : 0;
2499 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2501 #if defined(USE_ITHREADS) && !defined(WIN32)
2502 /* only "parent" interpreter can diddle signals */
2503 if (PL_curinterp != aTHX)
2506 return (PerlProc_signal(signo, *save) == SIG_ERR) ? -1 : 0;
2509 #endif /* !HAS_SIGACTION */
2510 #endif /* !PERL_MICRO */
2512 /* VMS' my_pclose() is in VMS.c; same with OS/2 */
2513 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
2515 Perl_my_pclose(pTHX_ PerlIO *ptr)
2517 Sigsave_t hstat, istat, qstat;
2523 int saved_errno = 0;
2525 int saved_vaxc_errno;
2528 int saved_win32_errno;
2532 svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE);
2534 pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
2536 *svp = &PL_sv_undef;
2538 if (pid == -1) { /* Opened by popen. */
2539 return my_syspclose(ptr);
2542 if ((close_failed = (PerlIO_close(ptr) == EOF))) {
2543 saved_errno = errno;
2545 saved_vaxc_errno = vaxc$errno;
2548 saved_win32_errno = GetLastError();
2552 if(PerlProc_kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */
2555 rsignal_save(SIGHUP, SIG_IGN, &hstat);
2556 rsignal_save(SIGINT, SIG_IGN, &istat);
2557 rsignal_save(SIGQUIT, SIG_IGN, &qstat);
2560 pid2 = wait4pid(pid, &status, 0);
2561 } while (pid2 == -1 && errno == EINTR);
2563 rsignal_restore(SIGHUP, &hstat);
2564 rsignal_restore(SIGINT, &istat);
2565 rsignal_restore(SIGQUIT, &qstat);
2568 SETERRNO(saved_errno, saved_vaxc_errno);
2571 return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status));
2573 #endif /* !DOSISH */
2575 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(MACOS_TRADITIONAL)
2577 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
2582 #if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME)
2584 char spid[TYPE_CHARS(IV)];
2588 sprintf(spid, "%"IVdf, (IV)pid);
2589 svp = hv_fetch(PL_pidstatus,spid,strlen(spid),FALSE);
2590 if (svp && *svp != &PL_sv_undef) {
2591 *statusp = SvIVX(*svp);
2592 (void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD);
2599 hv_iterinit(PL_pidstatus);
2600 if ((entry = hv_iternext(PL_pidstatus))) {
2601 SV *sv = hv_iterval(PL_pidstatus,entry);
2603 pid = atoi(hv_iterkey(entry,(I32*)statusp));
2604 *statusp = SvIVX(sv);
2605 sprintf(spid, "%"IVdf, (IV)pid);
2606 (void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD);
2613 # ifdef HAS_WAITPID_RUNTIME
2614 if (!HAS_WAITPID_RUNTIME)
2617 result = PerlProc_waitpid(pid,statusp,flags);
2620 #if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
2621 result = wait4((pid==-1)?0:pid,statusp,flags,Null(struct rusage *));
2624 #if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME)
2625 #if defined(HAS_WAITPID) && defined(HAS_WAITPID_RUNTIME)
2630 Perl_croak(aTHX_ "Can't do waitpid with flags");
2632 while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
2633 pidgone(result,*statusp);
2639 #if defined(HAS_WAITPID) || defined(HAS_WAIT4)
2642 if (result < 0 && errno == EINTR) {
2647 #endif /* !DOSISH || OS2 || WIN32 || NETWARE */
2651 Perl_pidgone(pTHX_ Pid_t pid, int status)
2654 char spid[TYPE_CHARS(IV)];
2656 sprintf(spid, "%"IVdf, (IV)pid);
2657 sv = *hv_fetch(PL_pidstatus,spid,strlen(spid),TRUE);
2658 (void)SvUPGRADE(sv,SVt_IV);
2659 SvIV_set(sv, status);
2663 #if defined(atarist) || defined(OS2) || defined(EPOC)
2666 int /* Cannot prototype with I32
2668 my_syspclose(PerlIO *ptr)
2671 Perl_my_pclose(pTHX_ PerlIO *ptr)
2674 /* Needs work for PerlIO ! */
2675 FILE *f = PerlIO_findFILE(ptr);
2676 I32 result = pclose(f);
2677 PerlIO_releaseFILE(ptr,f);
2685 Perl_my_pclose(pTHX_ PerlIO *ptr)
2687 /* Needs work for PerlIO ! */
2688 FILE *f = PerlIO_findFILE(ptr);
2689 I32 result = djgpp_pclose(f);
2690 result = (result << 8) & 0xff00;
2691 PerlIO_releaseFILE(ptr,f);
2697 Perl_repeatcpy(pTHX_ register char *to, register const char *from, I32 len, register I32 count)
2700 register const char *frombase = from;
2703 register const char c = *from;
2708 while (count-- > 0) {
2709 for (todo = len; todo > 0; todo--) {
2718 Perl_same_dirent(pTHX_ const char *a, const char *b)
2720 char *fa = strrchr(a,'/');
2721 char *fb = strrchr(b,'/');
2724 SV *tmpsv = sv_newmortal();
2737 sv_setpv(tmpsv, ".");
2739 sv_setpvn(tmpsv, a, fa - a);
2740 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0)
2743 sv_setpv(tmpsv, ".");
2745 sv_setpvn(tmpsv, b, fb - b);
2746 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0)
2748 return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
2749 tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
2751 #endif /* !HAS_RENAME */
2754 Perl_find_script(pTHX_ const char *scriptname, bool dosearch, const char **search_ext, I32 flags)
2756 const char *xfound = Nullch;
2757 char *xfailed = Nullch;
2758 char tmpbuf[MAXPATHLEN];
2762 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
2763 # define SEARCH_EXTS ".bat", ".cmd", NULL
2764 # define MAX_EXT_LEN 4
2767 # define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
2768 # define MAX_EXT_LEN 4
2771 # define SEARCH_EXTS ".pl", ".com", NULL
2772 # define MAX_EXT_LEN 4
2774 /* additional extensions to try in each dir if scriptname not found */
2776 const char *exts[] = { SEARCH_EXTS };
2777 const char **ext = search_ext ? search_ext : exts;
2778 int extidx = 0, i = 0;
2779 const char *curext = Nullch;
2782 # define MAX_EXT_LEN 0
2786 * If dosearch is true and if scriptname does not contain path
2787 * delimiters, search the PATH for scriptname.
2789 * If SEARCH_EXTS is also defined, will look for each
2790 * scriptname{SEARCH_EXTS} whenever scriptname is not found
2791 * while searching the PATH.
2793 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
2794 * proceeds as follows:
2795 * If DOSISH or VMSISH:
2796 * + look for ./scriptname{,.foo,.bar}
2797 * + search the PATH for scriptname{,.foo,.bar}
2800 * + look *only* in the PATH for scriptname{,.foo,.bar} (note
2801 * this will not look in '.' if it's not in the PATH)
2806 # ifdef ALWAYS_DEFTYPES
2807 len = strlen(scriptname);
2808 if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
2809 int hasdir, idx = 0, deftypes = 1;
2812 hasdir = !dosearch || (strpbrk(scriptname,":[</") != Nullch) ;
2815 int hasdir, idx = 0, deftypes = 1;
2818 hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
2820 /* The first time through, just add SEARCH_EXTS to whatever we
2821 * already have, so we can check for default file types. */
2823 (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
2829 if ((strlen(tmpbuf) + strlen(scriptname)
2830 + MAX_EXT_LEN) >= sizeof tmpbuf)
2831 continue; /* don't search dir with too-long name */
2832 strcat(tmpbuf, scriptname);
2836 if (strEQ(scriptname, "-"))
2838 if (dosearch) { /* Look in '.' first. */
2839 const char *cur = scriptname;
2841 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
2843 if (strEQ(ext[i++],curext)) {
2844 extidx = -1; /* already has an ext */
2849 DEBUG_p(PerlIO_printf(Perl_debug_log,
2850 "Looking for %s\n",cur));
2851 if (PerlLIO_stat(cur,&PL_statbuf) >= 0
2852 && !S_ISDIR(PL_statbuf.st_mode)) {
2860 if (cur == scriptname) {
2861 len = strlen(scriptname);
2862 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
2864 cur = strcpy(tmpbuf, scriptname);
2866 } while (extidx >= 0 && ext[extidx] /* try an extension? */
2867 && strcpy(tmpbuf+len, ext[extidx++]));
2872 #ifdef MACOS_TRADITIONAL
2873 if (dosearch && !strchr(scriptname, ':') &&
2874 (s = PerlEnv_getenv("Commands")))
2876 if (dosearch && !strchr(scriptname, '/')
2878 && !strchr(scriptname, '\\')
2880 && (s = PerlEnv_getenv("PATH")))
2885 PL_bufend = s + strlen(s);
2886 while (s < PL_bufend) {
2887 #ifdef MACOS_TRADITIONAL
2888 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
2892 #if defined(atarist) || defined(DOSISH)
2897 && *s != ';'; len++, s++) {
2898 if (len < sizeof tmpbuf)
2901 if (len < sizeof tmpbuf)
2903 #else /* ! (atarist || DOSISH) */
2904 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
2907 #endif /* ! (atarist || DOSISH) */
2908 #endif /* MACOS_TRADITIONAL */
2911 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
2912 continue; /* don't search dir with too-long name */
2913 #ifdef MACOS_TRADITIONAL
2914 if (len && tmpbuf[len - 1] != ':')
2915 tmpbuf[len++] = ':';
2918 #if defined(atarist) || defined(__MINT__) || defined(DOSISH)
2919 && tmpbuf[len - 1] != '/'
2920 && tmpbuf[len - 1] != '\\'
2923 tmpbuf[len++] = '/';
2924 if (len == 2 && tmpbuf[0] == '.')
2927 (void)strcpy(tmpbuf + len, scriptname);
2931 len = strlen(tmpbuf);
2932 if (extidx > 0) /* reset after previous loop */
2936 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
2937 retval = PerlLIO_stat(tmpbuf,&PL_statbuf);
2938 if (S_ISDIR(PL_statbuf.st_mode)) {
2942 } while ( retval < 0 /* not there */
2943 && extidx>=0 && ext[extidx] /* try an extension? */
2944 && strcpy(tmpbuf+len, ext[extidx++])
2949 if (S_ISREG(PL_statbuf.st_mode)
2950 && cando(S_IRUSR,TRUE,&PL_statbuf)
2951 #if !defined(DOSISH) && !defined(MACOS_TRADITIONAL)
2952 && cando(S_IXUSR,TRUE,&PL_statbuf)
2956 xfound = tmpbuf; /* bingo! */
2960 xfailed = savepv(tmpbuf);
2963 if (!xfound && !seen_dot && !xfailed &&
2964 (PerlLIO_stat(scriptname,&PL_statbuf) < 0
2965 || S_ISDIR(PL_statbuf.st_mode)))
2967 seen_dot = 1; /* Disable message. */
2969 if (flags & 1) { /* do or die? */
2970 Perl_croak(aTHX_ "Can't %s %s%s%s",
2971 (xfailed ? "execute" : "find"),
2972 (xfailed ? xfailed : scriptname),
2973 (xfailed ? "" : " on PATH"),
2974 (xfailed || seen_dot) ? "" : ", '.' not in PATH");
2976 scriptname = Nullch;
2980 scriptname = xfound;
2982 return (scriptname ? savepv(scriptname) : Nullch);
2985 #ifndef PERL_GET_CONTEXT_DEFINED
2988 Perl_get_context(void)
2991 #if defined(USE_ITHREADS)
2992 # ifdef OLD_PTHREADS_API
2994 if (pthread_getspecific(PL_thr_key, &t))
2995 Perl_croak_nocontext("panic: pthread_getspecific");
2998 # ifdef I_MACH_CTHREADS
2999 return (void*)cthread_data(cthread_self());
3001 return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
3010 Perl_set_context(void *t)
3013 #if defined(USE_ITHREADS)
3014 # ifdef I_MACH_CTHREADS
3015 cthread_set_data(cthread_self(), t);
3017 if (pthread_setspecific(PL_thr_key, t))
3018 Perl_croak_nocontext("panic: pthread_setspecific");
3023 #endif /* !PERL_GET_CONTEXT_DEFINED */
3025 #if defined(PERL_GLOBAL_STRUCT) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
3034 Perl_get_op_names(pTHX)
3036 return (char **)PL_op_name;
3040 Perl_get_op_descs(pTHX)
3042 return (char **)PL_op_desc;
3046 Perl_get_no_modify(pTHX)
3048 return PL_no_modify;
3052 Perl_get_opargs(pTHX)
3054 return (U32 *)PL_opargs;
3058 Perl_get_ppaddr(pTHX)
3061 return (PPADDR_t*)PL_ppaddr;
3064 #ifndef HAS_GETENV_LEN
3066 Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
3068 char *env_trans = PerlEnv_getenv(env_elem);
3070 *len = strlen(env_trans);
3077 Perl_get_vtbl(pTHX_ int vtbl_id)
3079 const MGVTBL* result = Null(MGVTBL*);
3083 result = &PL_vtbl_sv;
3086 result = &PL_vtbl_env;
3088 case want_vtbl_envelem:
3089 result = &PL_vtbl_envelem;
3092 result = &PL_vtbl_sig;
3094 case want_vtbl_sigelem:
3095 result = &PL_vtbl_sigelem;
3097 case want_vtbl_pack:
3098 result = &PL_vtbl_pack;
3100 case want_vtbl_packelem:
3101 result = &PL_vtbl_packelem;
3103 case want_vtbl_dbline:
3104 result = &PL_vtbl_dbline;
3107 result = &PL_vtbl_isa;
3109 case want_vtbl_isaelem:
3110 result = &PL_vtbl_isaelem;
3112 case want_vtbl_arylen:
3113 result = &PL_vtbl_arylen;
3115 case want_vtbl_glob:
3116 result = &PL_vtbl_glob;
3118 case want_vtbl_mglob:
3119 result = &PL_vtbl_mglob;
3121 case want_vtbl_nkeys:
3122 result = &PL_vtbl_nkeys;
3124 case want_vtbl_taint:
3125 result = &PL_vtbl_taint;
3127 case want_vtbl_substr:
3128 result = &PL_vtbl_substr;
3131 result = &PL_vtbl_vec;
3134 result = &PL_vtbl_pos;
3137 result = &PL_vtbl_bm;
3140 result = &PL_vtbl_fm;
3142 case want_vtbl_uvar:
3143 result = &PL_vtbl_uvar;
3145 case want_vtbl_defelem:
3146 result = &PL_vtbl_defelem;
3148 case want_vtbl_regexp:
3149 result = &PL_vtbl_regexp;
3151 case want_vtbl_regdata:
3152 result = &PL_vtbl_regdata;
3154 case want_vtbl_regdatum:
3155 result = &PL_vtbl_regdatum;
3157 #ifdef USE_LOCALE_COLLATE
3158 case want_vtbl_collxfrm:
3159 result = &PL_vtbl_collxfrm;
3162 case want_vtbl_amagic:
3163 result = &PL_vtbl_amagic;
3165 case want_vtbl_amagicelem:
3166 result = &PL_vtbl_amagicelem;
3168 case want_vtbl_backref:
3169 result = &PL_vtbl_backref;
3171 case want_vtbl_utf8:
3172 result = &PL_vtbl_utf8;
3175 return (MGVTBL*)result;
3179 Perl_my_fflush_all(pTHX)
3181 #if defined(USE_PERLIO) || defined(FFLUSH_NULL) || defined(USE_SFIO)
3182 return PerlIO_flush(NULL);
3184 # if defined(HAS__FWALK)
3185 extern int fflush(FILE *);
3186 /* undocumented, unprototyped, but very useful BSDism */
3187 extern void _fwalk(int (*)(FILE *));
3191 # if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
3193 # ifdef PERL_FFLUSH_ALL_FOPEN_MAX
3194 open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
3196 # if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
3197 open_max = sysconf(_SC_OPEN_MAX);
3200 open_max = FOPEN_MAX;
3203 open_max = OPEN_MAX;
3214 for (i = 0; i < open_max; i++)
3215 if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
3216 STDIO_STREAM_ARRAY[i]._file < open_max &&
3217 STDIO_STREAM_ARRAY[i]._flag)
3218 PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
3222 SETERRNO(EBADF,RMS_IFI);
3229 Perl_report_evil_fh(pTHX_ const GV *gv, const IO *io, I32 op)
3232 op == OP_READLINE ? "readline" : /* "<HANDLE>" not nice */
3233 op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */
3235 const char *pars = OP_IS_FILETEST(op) ? "" : "()";
3236 const char *type = OP_IS_SOCKET(op)
3237 || (gv && io && IoTYPE(io) == IoTYPE_SOCKET)
3238 ? "socket" : "filehandle";
3239 const char *name = NULL;
3241 if (gv && isGV(gv)) {
3245 if (op == OP_phoney_OUTPUT_ONLY || op == OP_phoney_INPUT_ONLY) {
3246 if (ckWARN(WARN_IO)) {
3247 const char *direction = (op == OP_phoney_INPUT_ONLY) ? "in" : "out";
3249 Perl_warner(aTHX_ packWARN(WARN_IO),
3250 "Filehandle %s opened only for %sput",
3253 Perl_warner(aTHX_ packWARN(WARN_IO),
3254 "Filehandle opened only for %sput", direction);
3261 if (gv && io && IoTYPE(io) == IoTYPE_CLOSED) {
3263 warn_type = WARN_CLOSED;
3267 warn_type = WARN_UNOPENED;
3270 if (ckWARN(warn_type)) {
3271 if (name && *name) {
3272 Perl_warner(aTHX_ packWARN(warn_type),
3273 "%s%s on %s %s %s", func, pars, vile, type, name);
3274 if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3276 aTHX_ packWARN(warn_type),
3277 "\t(Are you trying to call %s%s on dirhandle %s?)\n",
3282 Perl_warner(aTHX_ packWARN(warn_type),
3283 "%s%s on %s %s", func, pars, vile, type);
3284 if (gv && io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3286 aTHX_ packWARN(warn_type),
3287 "\t(Are you trying to call %s%s on dirhandle?)\n",
3296 /* in ASCII order, not that it matters */
3297 static const char controllablechars[] = "?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_";
3300 Perl_ebcdic_control(pTHX_ int ch)
3308 if ((ctlp = strchr(controllablechars, ch)) == 0) {
3309 Perl_die(aTHX_ "unrecognised control character '%c'\n", ch);
3312 if (ctlp == controllablechars)
3313 return('\177'); /* DEL */
3315 return((unsigned char)(ctlp - controllablechars - 1));
3316 } else { /* Want uncontrol */
3317 if (ch == '\177' || ch == -1)
3319 else if (ch == '\157')
3321 else if (ch == '\174')
3323 else if (ch == '^') /* '\137' in 1047, '\260' in 819 */
3325 else if (ch == '\155')
3327 else if (0 < ch && ch < (sizeof(controllablechars) - 1))
3328 return(controllablechars[ch+1]);
3330 Perl_die(aTHX_ "invalid control request: '\\%03o'\n", ch & 0xFF);
3335 /* To workaround core dumps from the uninitialised tm_zone we get the
3336 * system to give us a reasonable struct to copy. This fix means that
3337 * strftime uses the tm_zone and tm_gmtoff values returned by
3338 * localtime(time()). That should give the desired result most of the
3339 * time. But probably not always!
3341 * This does not address tzname aspects of NETaa14816.
3346 # ifndef STRUCT_TM_HASZONE
3347 # define STRUCT_TM_HASZONE
3351 #ifdef STRUCT_TM_HASZONE /* Backward compat */
3352 # ifndef HAS_TM_TM_ZONE
3353 # define HAS_TM_TM_ZONE
3358 Perl_init_tm(pTHX_ struct tm *ptm) /* see mktime, strftime and asctime */
3360 #ifdef HAS_TM_TM_ZONE
3364 my_tm = localtime(&now);
3366 Copy(my_tm, ptm, 1, struct tm);
3371 * mini_mktime - normalise struct tm values without the localtime()
3372 * semantics (and overhead) of mktime().
3375 Perl_mini_mktime(pTHX_ struct tm *ptm)
3379 int month, mday, year, jday;
3380 int odd_cent, odd_year;
3382 #define DAYS_PER_YEAR 365
3383 #define DAYS_PER_QYEAR (4*DAYS_PER_YEAR+1)
3384 #define DAYS_PER_CENT (25*DAYS_PER_QYEAR-1)
3385 #define DAYS_PER_QCENT (4*DAYS_PER_CENT+1)
3386 #define SECS_PER_HOUR (60*60)
3387 #define SECS_PER_DAY (24*SECS_PER_HOUR)
3388 /* parentheses deliberately absent on these two, otherwise they don't work */
3389 #define MONTH_TO_DAYS 153/5
3390 #define DAYS_TO_MONTH 5/153
3391 /* offset to bias by March (month 4) 1st between month/mday & year finding */
3392 #define YEAR_ADJUST (4*MONTH_TO_DAYS+1)
3393 /* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */
3394 #define WEEKDAY_BIAS 6 /* (1+6)%7 makes Sunday 0 again */
3397 * Year/day algorithm notes:
3399 * With a suitable offset for numeric value of the month, one can find
3400 * an offset into the year by considering months to have 30.6 (153/5) days,
3401 * using integer arithmetic (i.e., with truncation). To avoid too much
3402 * messing about with leap days, we consider January and February to be
3403 * the 13th and 14th month of the previous year. After that transformation,
3404 * we need the month index we use to be high by 1 from 'normal human' usage,
3405 * so the month index values we use run from 4 through 15.
3407 * Given that, and the rules for the Gregorian calendar (leap years are those
3408 * divisible by 4 unless also divisible by 100, when they must be divisible
3409 * by 400 instead), we can simply calculate the number of days since some
3410 * arbitrary 'beginning of time' by futzing with the (adjusted) year number,
3411 * the days we derive from our month index, and adding in the day of the
3412 * month. The value used here is not adjusted for the actual origin which
3413 * it normally would use (1 January A.D. 1), since we're not exposing it.
3414 * We're only building the value so we can turn around and get the
3415 * normalised values for the year, month, day-of-month, and day-of-year.
3417 * For going backward, we need to bias the value we're using so that we find
3418 * the right year value. (Basically, we don't want the contribution of
3419 * March 1st to the number to apply while deriving the year). Having done
3420 * that, we 'count up' the contribution to the year number by accounting for
3421 * full quadracenturies (400-year periods) with their extra leap days, plus
3422 * the contribution from full centuries (to avoid counting in the lost leap
3423 * days), plus the contribution from full quad-years (to count in the normal
3424 * leap days), plus the leftover contribution from any non-leap years.
3425 * At this point, if we were working with an actual leap day, we'll have 0
3426 * days left over. This is also true for March 1st, however. So, we have
3427 * to special-case that result, and (earlier) keep track of the 'odd'
3428 * century and year contributions. If we got 4 extra centuries in a qcent,
3429 * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb.
3430 * Otherwise, we add back in the earlier bias we removed (the 123 from
3431 * figuring in March 1st), find the month index (integer division by 30.6),
3432 * and the remainder is the day-of-month. We then have to convert back to
3433 * 'real' months (including fixing January and February from being 14/15 in
3434 * the previous year to being in the proper year). After that, to get
3435 * tm_yday, we work with the normalised year and get a new yearday value for
3436 * January 1st, which we subtract from the yearday value we had earlier,
3437 * representing the date we've re-built. This is done from January 1
3438 * because tm_yday is 0-origin.
3440 * Since POSIX time routines are only guaranteed to work for times since the
3441 * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm
3442 * applies Gregorian calendar rules even to dates before the 16th century
3443 * doesn't bother me. Besides, you'd need cultural context for a given
3444 * date to know whether it was Julian or Gregorian calendar, and that's
3445 * outside the scope for this routine. Since we convert back based on the
3446 * same rules we used to build the yearday, you'll only get strange results
3447 * for input which needed normalising, or for the 'odd' century years which
3448 * were leap years in the Julian calander but not in the Gregorian one.
3449 * I can live with that.
3451 * This algorithm also fails to handle years before A.D. 1 gracefully, but
3452 * that's still outside the scope for POSIX time manipulation, so I don't
3456 year = 1900 + ptm->tm_year;
3457 month = ptm->tm_mon;
3458 mday = ptm->tm_mday;
3459 /* allow given yday with no month & mday to dominate the result */
3460 if (ptm->tm_yday >= 0 && mday <= 0 && month <= 0) {
3463 jday = 1 + ptm->tm_yday;
3472 yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400;
3473 yearday += month*MONTH_TO_DAYS + mday + jday;
3475 * Note that we don't know when leap-seconds were or will be,
3476 * so we have to trust the user if we get something which looks
3477 * like a sensible leap-second. Wild values for seconds will
3478 * be rationalised, however.
3480 if ((unsigned) ptm->tm_sec <= 60) {
3487 secs += 60 * ptm->tm_min;
3488 secs += SECS_PER_HOUR * ptm->tm_hour;
3490 if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) {
3491 /* got negative remainder, but need positive time */
3492 /* back off an extra day to compensate */
3493 yearday += (secs/SECS_PER_DAY)-1;
3494 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1);
3497 yearday += (secs/SECS_PER_DAY);
3498 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY);
3501 else if (secs >= SECS_PER_DAY) {
3502 yearday += (secs/SECS_PER_DAY);
3503 secs %= SECS_PER_DAY;
3505 ptm->tm_hour = secs/SECS_PER_HOUR;
3506 secs %= SECS_PER_HOUR;
3507 ptm->tm_min = secs/60;
3509 ptm->tm_sec += secs;
3510 /* done with time of day effects */
3512 * The algorithm for yearday has (so far) left it high by 428.
3513 * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to
3514 * bias it by 123 while trying to figure out what year it
3515 * really represents. Even with this tweak, the reverse
3516 * translation fails for years before A.D. 0001.
3517 * It would still fail for Feb 29, but we catch that one below.
3519 jday = yearday; /* save for later fixup vis-a-vis Jan 1 */
3520 yearday -= YEAR_ADJUST;
3521 year = (yearday / DAYS_PER_QCENT) * 400;
3522 yearday %= DAYS_PER_QCENT;
3523 odd_cent = yearday / DAYS_PER_CENT;
3524 year += odd_cent * 100;
3525 yearday %= DAYS_PER_CENT;
3526 year += (yearday / DAYS_PER_QYEAR) * 4;
3527 yearday %= DAYS_PER_QYEAR;
3528 odd_year = yearday / DAYS_PER_YEAR;
3530 yearday %= DAYS_PER_YEAR;
3531 if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */
3536 yearday += YEAR_ADJUST; /* recover March 1st crock */
3537 month = yearday*DAYS_TO_MONTH;
3538 yearday -= month*MONTH_TO_DAYS;
3539 /* recover other leap-year adjustment */
3548 ptm->tm_year = year - 1900;
3550 ptm->tm_mday = yearday;
3551 ptm->tm_mon = month;
3555 ptm->tm_mon = month - 1;
3557 /* re-build yearday based on Jan 1 to get tm_yday */
3559 yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400;
3560 yearday += 14*MONTH_TO_DAYS + 1;
3561 ptm->tm_yday = jday - yearday;
3562 /* fix tm_wday if not overridden by caller */
3563 if ((unsigned)ptm->tm_wday > 6)
3564 ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
3568 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)
3576 init_tm(&mytm); /* XXX workaround - see init_tm() above */
3579 mytm.tm_hour = hour;
3580 mytm.tm_mday = mday;
3582 mytm.tm_year = year;
3583 mytm.tm_wday = wday;
3584 mytm.tm_yday = yday;
3585 mytm.tm_isdst = isdst;
3587 /* use libc to get the values for tm_gmtoff and tm_zone [perl #18238] */
3588 #if defined(HAS_MKTIME) && (defined(HAS_TM_TM_GMTOFF) || defined(HAS_TM_TM_ZONE))
3593 #ifdef HAS_TM_TM_GMTOFF
3594 mytm.tm_gmtoff = mytm2.tm_gmtoff;
3596 #ifdef HAS_TM_TM_ZONE
3597 mytm.tm_zone = mytm2.tm_zone;
3602 New(0, buf, buflen, char);
3603 len = strftime(buf, buflen, fmt, &mytm);
3605 ** The following is needed to handle to the situation where
3606 ** tmpbuf overflows. Basically we want to allocate a buffer
3607 ** and try repeatedly. The reason why it is so complicated
3608 ** is that getting a return value of 0 from strftime can indicate
3609 ** one of the following:
3610 ** 1. buffer overflowed,
3611 ** 2. illegal conversion specifier, or
3612 ** 3. the format string specifies nothing to be returned(not
3613 ** an error). This could be because format is an empty string
3614 ** or it specifies %p that yields an empty string in some locale.
3615 ** If there is a better way to make it portable, go ahead by
3618 if ((len > 0 && len < buflen) || (len == 0 && *fmt == '\0'))
3621 /* Possibly buf overflowed - try again with a bigger buf */
3622 const int fmtlen = strlen(fmt);
3623 const int bufsize = fmtlen + buflen;
3625 New(0, buf, bufsize, char);
3627 buflen = strftime(buf, bufsize, fmt, &mytm);
3628 if (buflen > 0 && buflen < bufsize)
3630 /* heuristic to prevent out-of-memory errors */
3631 if (bufsize > 100*fmtlen) {
3636 Renew(buf, bufsize*2, char);
3641 Perl_croak(aTHX_ "panic: no strftime");
3647 #define SV_CWD_RETURN_UNDEF \
3648 sv_setsv(sv, &PL_sv_undef); \
3651 #define SV_CWD_ISDOT(dp) \
3652 (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
3653 (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
3656 =head1 Miscellaneous Functions
3658 =for apidoc getcwd_sv
3660 Fill the sv with current working directory
3665 /* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars.
3666 * rewritten again by dougm, optimized for use with xs TARG, and to prefer
3667 * getcwd(3) if available
3668 * Comments from the orignal:
3669 * This is a faster version of getcwd. It's also more dangerous
3670 * because you might chdir out of a directory that you can't chdir
3674 Perl_getcwd_sv(pTHX_ register SV *sv)
3678 #ifndef INCOMPLETE_TAINTS
3684 char buf[MAXPATHLEN];
3686 /* Some getcwd()s automatically allocate a buffer of the given
3687 * size from the heap if they are given a NULL buffer pointer.
3688 * The problem is that this behaviour is not portable. */
3689 if (getcwd(buf, sizeof(buf) - 1)) {
3690 sv_setpvn(sv, buf, strlen(buf));
3694 sv_setsv(sv, &PL_sv_undef);
3702 int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
3706 (void)SvUPGRADE(sv, SVt_PV);
3708 if (PerlLIO_lstat(".", &statbuf) < 0) {
3709 SV_CWD_RETURN_UNDEF;
3712 orig_cdev = statbuf.st_dev;
3713 orig_cino = statbuf.st_ino;
3722 if (PerlDir_chdir("..") < 0) {
3723 SV_CWD_RETURN_UNDEF;
3725 if (PerlLIO_stat(".", &statbuf) < 0) {
3726 SV_CWD_RETURN_UNDEF;
3729 cdev = statbuf.st_dev;
3730 cino = statbuf.st_ino;
3732 if (odev == cdev && oino == cino) {
3735 if (!(dir = PerlDir_open("."))) {
3736 SV_CWD_RETURN_UNDEF;
3739 while ((dp = PerlDir_read(dir)) != NULL) {
3741 const int namelen = dp->d_namlen;
3743 const int namelen = strlen(dp->d_name);
3746 if (SV_CWD_ISDOT(dp)) {
3750 if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
3751 SV_CWD_RETURN_UNDEF;
3754 tdev = statbuf.st_dev;
3755 tino = statbuf.st_ino;
3756 if (tino == oino && tdev == odev) {
3762 SV_CWD_RETURN_UNDEF;
3765 if (pathlen + namelen + 1 >= MAXPATHLEN) {
3766 SV_CWD_RETURN_UNDEF;
3769 SvGROW(sv, pathlen + namelen + 1);
3773 Move(SvPVX_const(sv), SvPVX(sv) + namelen + 1, pathlen, char);
3776 /* prepend current directory to the front */
3778 Move(dp->d_name, SvPVX(sv)+1, namelen, char);
3779 pathlen += (namelen + 1);
3781 #ifdef VOID_CLOSEDIR
3784 if (PerlDir_close(dir) < 0) {
3785 SV_CWD_RETURN_UNDEF;
3791 SvCUR_set(sv, pathlen);
3795 if (PerlDir_chdir(SvPVX_const(sv)) < 0) {
3796 SV_CWD_RETURN_UNDEF;
3799 if (PerlLIO_stat(".", &statbuf) < 0) {
3800 SV_CWD_RETURN_UNDEF;
3803 cdev = statbuf.st_dev;
3804 cino = statbuf.st_ino;
3806 if (cdev != orig_cdev || cino != orig_cino) {
3807 Perl_croak(aTHX_ "Unstable directory path, "
3808 "current directory changed unexpectedly");
3820 =for apidoc scan_version
3822 Returns a pointer to the next character after the parsed
3823 version string, as well as upgrading the passed in SV to
3826 Function must be called with an already existing SV like
3829 s = scan_version(s,SV *sv, bool qv);
3831 Performs some preprocessing to the string to ensure that
3832 it has the correct characteristics of a version. Flags the
3833 object if it contains an underscore (which denotes this
3834 is a alpha version). The boolean qv denotes that the version
3835 should be interpreted as if it had multiple decimals, even if
3842 Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
3844 const char *start = s;
3845 const char *pos = s;
3848 SV* sv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
3849 (void)sv_upgrade(sv, SVt_PVAV); /* needs to be an AV type */
3852 /* pre-scan the imput string to check for decimals */
3853 while ( *pos == '.' || *pos == '_' || isDIGIT(*pos) )
3858 Perl_croak(aTHX_ "Invalid version format (underscores before decimal)");
3861 else if ( *pos == '_' )
3864 Perl_croak(aTHX_ "Invalid version format (multiple underscores)");
3872 pos++; /* get past 'v' */
3873 qv = 1; /* force quoted version processing */
3875 while (isDIGIT(*pos))
3877 if (!isALPHA(*pos)) {
3880 if (*s == 'v') s++; /* get past 'v' */
3885 /* this is atoi() that delimits on underscores */
3886 const char *end = pos;
3889 if ( s < pos && s > start && *(s-1) == '_' ) {
3890 mult *= -1; /* alpha version */
3892 /* the following if() will only be true after the decimal
3893 * point of a version originally created with a bare
3894 * floating point number, i.e. not quoted in any way
3896 if ( !qv && s > start+1 && saw_period == 1 ) {
3900 rev += (*s - '0') * mult;
3902 if ( PERL_ABS(orev) > PERL_ABS(rev) )
3903 Perl_croak(aTHX_ "Integer overflow in version");
3908 while (--end >= s) {
3910 rev += (*end - '0') * mult;
3912 if ( PERL_ABS(orev) > PERL_ABS(rev) )
3913 Perl_croak(aTHX_ "Integer overflow in version");
3918 /* Append revision */
3919 av_push((AV *)sv, newSViv(rev));
3920 if ( (*pos == '.' || *pos == '_') && isDIGIT(pos[1]))
3922 else if ( isDIGIT(*pos) )
3928 while ( isDIGIT(*pos) ) {
3929 if ( saw_period == 1 && pos-s == 3 )
3935 if ( qv ) { /* quoted versions always become full version objects */
3936 I32 len = av_len((AV *)sv);
3937 /* This for loop appears to trigger a compiler bug on OS X, as it
3938 loops infinitely. Yes, len is negative. No, it makes no sense.
3939 Compiler in question is:
3940 gcc version 3.3 20030304 (Apple Computer, Inc. build 1640)
3941 for ( len = 2 - len; len > 0; len-- )
3942 av_push((AV *)sv, newSViv(0));
3946 av_push((AV *)sv, newSViv(0));
3952 =for apidoc new_version
3954 Returns a new version object based on the passed in SV:
3956 SV *sv = new_version(SV *ver);
3958 Does not alter the passed in ver SV. See "upg_version" if you
3959 want to upgrade the SV.
3965 Perl_new_version(pTHX_ SV *ver)
3968 if ( sv_derived_from(ver,"version") ) /* can just copy directly */
3971 AV *av = (AV *)SvRV(ver);
3972 SV* sv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
3973 (void)sv_upgrade(sv, SVt_PVAV); /* needs to be an AV type */
3975 for ( key = 0; key <= av_len(av); key++ )
3977 const I32 rev = SvIV(*av_fetch(av, key, FALSE));
3978 av_push((AV *)sv, newSViv(rev));
3983 if ( SvVOK(ver) ) { /* already a v-string */
3985 MAGIC* mg = mg_find(ver,PERL_MAGIC_vstring);
3986 version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
3987 sv_setpv(rv,version);
3992 sv_setsv(rv,ver); /* make a duplicate */
4001 =for apidoc upg_version
4003 In-place upgrade of the supplied SV to a version object.
4005 SV *sv = upg_version(SV *sv);
4007 Returns a pointer to the upgraded SV.
4013 Perl_upg_version(pTHX_ SV *ver)
4018 if ( SvNOK(ver) ) /* may get too much accuracy */
4021 sprintf(tbuf,"%.9"NVgf, SvNVX(ver));
4022 version = savepv(tbuf);
4025 else if ( SvVOK(ver) ) { /* already a v-string */
4026 MAGIC* mg = mg_find(ver,PERL_MAGIC_vstring);
4027 version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
4031 else /* must be a string or something like a string */
4033 version = savesvpv(ver);
4035 (void)scan_version(version, ver, qv);
4044 Accepts a version object and returns the normalized floating
4045 point representation. Call like:
4049 NOTE: you can pass either the object directly or the SV
4050 contained within the RV.
4056 Perl_vnumify(pTHX_ SV *vs)
4062 len = av_len((AV *)vs);
4065 Perl_sv_catpv(aTHX_ sv,"0");
4068 digit = SvIVX(*av_fetch((AV *)vs, 0, 0));
4069 Perl_sv_setpvf(aTHX_ sv,"%d.", (int)PERL_ABS(digit));
4070 for ( i = 1 ; i < len ; i++ )
4072 digit = SvIVX(*av_fetch((AV *)vs, i, 0));
4073 Perl_sv_catpvf(aTHX_ sv,"%03d", (int)PERL_ABS(digit));
4078 digit = SvIVX(*av_fetch((AV *)vs, len, 0));
4079 if ( (int)PERL_ABS(digit) != 0 || len == 1 )
4081 if ( digit < 0 ) /* alpha version */
4082 Perl_sv_catpv(aTHX_ sv,"_");
4083 /* Don't display additional trailing zeros */
4084 Perl_sv_catpvf(aTHX_ sv,"%03d", (int)PERL_ABS(digit));
4089 Perl_sv_catpv(aTHX_ sv,"000");
4097 Accepts a version object and returns the normalized string
4098 representation. Call like:
4102 NOTE: you can pass either the object directly or the SV
4103 contained within the RV.
4109 Perl_vnormal(pTHX_ SV *vs)
4115 len = av_len((AV *)vs);
4118 Perl_sv_catpv(aTHX_ sv,"");
4121 digit = SvIVX(*av_fetch((AV *)vs, 0, 0));
4122 Perl_sv_setpvf(aTHX_ sv,"%"IVdf,(IV)digit);
4123 for ( i = 1 ; i <= len ; i++ )
4125 digit = SvIVX(*av_fetch((AV *)vs, i, 0));
4127 Perl_sv_catpvf(aTHX_ sv,"_%"IVdf,(IV)-digit);
4129 Perl_sv_catpvf(aTHX_ sv,".%"IVdf,(IV)digit);
4132 if ( len <= 2 ) { /* short version, must be at least three */
4133 for ( len = 2 - len; len != 0; len-- )
4134 Perl_sv_catpv(aTHX_ sv,".0");
4141 =for apidoc vstringify
4143 In order to maintain maximum compatibility with earlier versions
4144 of Perl, this function will return either the floating point
4145 notation or the multiple dotted notation, depending on whether
4146 the original version contained 1 or more dots, respectively
4152 Perl_vstringify(pTHX_ SV *vs)
4157 len = av_len((AV *)vs);
4158 digit = SvIVX(*av_fetch((AV *)vs, len, 0));
4160 if ( len < 2 || ( len == 2 && digit < 0 ) )
4169 Version object aware cmp. Both operands must already have been
4170 converted into version objects.
4176 Perl_vcmp(pTHX_ SV *lsv, SV *rsv)
4183 l = av_len((AV *)lsv);
4184 r = av_len((AV *)rsv);
4188 while ( i <= m && retval == 0 )
4190 I32 left = SvIV(*av_fetch((AV *)lsv,i,0));
4191 I32 right = SvIV(*av_fetch((AV *)rsv,i,0));
4192 bool lalpha = left < 0 ? 1 : 0;
4193 bool ralpha = right < 0 ? 1 : 0;
4196 if ( left < right || (left == right && lalpha && !ralpha) )
4198 if ( left > right || (left == right && ralpha && !lalpha) )
4203 if ( l != r && retval == 0 ) /* possible match except for trailing 0's */
4207 while ( i <= r && retval == 0 )
4209 if ( SvIV(*av_fetch((AV *)rsv,i,0)) != 0 )
4210 retval = -1; /* not a match after all */
4216 while ( i <= l && retval == 0 )
4218 if ( SvIV(*av_fetch((AV *)lsv,i,0)) != 0 )
4219 retval = +1; /* not a match after all */
4227 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT)
4228 # define EMULATE_SOCKETPAIR_UDP
4231 #ifdef EMULATE_SOCKETPAIR_UDP
4233 S_socketpair_udp (int fd[2]) {
4235 /* Fake a datagram socketpair using UDP to localhost. */
4236 int sockets[2] = {-1, -1};
4237 struct sockaddr_in addresses[2];
4239 Sock_size_t size = sizeof(struct sockaddr_in);
4240 unsigned short port;
4243 memset(&addresses, 0, sizeof(addresses));
4246 sockets[i] = PerlSock_socket(AF_INET, SOCK_DGRAM, PF_INET);
4247 if (sockets[i] == -1)
4248 goto tidy_up_and_fail;
4250 addresses[i].sin_family = AF_INET;
4251 addresses[i].sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4252 addresses[i].sin_port = 0; /* kernel choses port. */
4253 if (PerlSock_bind(sockets[i], (struct sockaddr *) &addresses[i],
4254 sizeof(struct sockaddr_in)) == -1)
4255 goto tidy_up_and_fail;
4258 /* Now have 2 UDP sockets. Find out which port each is connected to, and
4259 for each connect the other socket to it. */
4262 if (PerlSock_getsockname(sockets[i], (struct sockaddr *) &addresses[i],
4264 goto tidy_up_and_fail;
4265 if (size != sizeof(struct sockaddr_in))
4266 goto abort_tidy_up_and_fail;
4267 /* !1 is 0, !0 is 1 */
4268 if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i],
4269 sizeof(struct sockaddr_in)) == -1)
4270 goto tidy_up_and_fail;
4273 /* Now we have 2 sockets connected to each other. I don't trust some other
4274 process not to have already sent a packet to us (by random) so send
4275 a packet from each to the other. */
4278 /* I'm going to send my own port number. As a short.
4279 (Who knows if someone somewhere has sin_port as a bitfield and needs
4280 this routine. (I'm assuming crays have socketpair)) */
4281 port = addresses[i].sin_port;
4282 got = PerlLIO_write(sockets[i], &port, sizeof(port));
4283 if (got != sizeof(port)) {
4285 goto tidy_up_and_fail;
4286 goto abort_tidy_up_and_fail;
4290 /* Packets sent. I don't trust them to have arrived though.
4291 (As I understand it Solaris TCP stack is multithreaded. Non-blocking
4292 connect to localhost will use a second kernel thread. In 2.6 the
4293 first thread running the connect() returns before the second completes,
4294 so EINPROGRESS> In 2.7 the improved stack is faster and connect()
4295 returns 0. Poor programs have tripped up. One poor program's authors'
4296 had a 50-1 reverse stock split. Not sure how connected these were.)
4297 So I don't trust someone not to have an unpredictable UDP stack.
4301 struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */
4302 int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0];
4306 FD_SET(sockets[0], &rset);
4307 FD_SET(sockets[1], &rset);
4309 got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor);
4310 if (got != 2 || !FD_ISSET(sockets[0], &rset)
4311 || !FD_ISSET(sockets[1], &rset)) {
4312 /* I hope this is portable and appropriate. */
4314 goto tidy_up_and_fail;
4315 goto abort_tidy_up_and_fail;
4319 /* And the paranoia department even now doesn't trust it to have arrive
4320 (hence MSG_DONTWAIT). Or that what arrives was sent by us. */
4322 struct sockaddr_in readfrom;
4323 unsigned short buffer[2];
4328 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4329 sizeof(buffer), MSG_DONTWAIT,
4330 (struct sockaddr *) &readfrom, &size);
4332 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4334 (struct sockaddr *) &readfrom, &size);
4338 goto tidy_up_and_fail;
4339 if (got != sizeof(port)
4340 || size != sizeof(struct sockaddr_in)
4341 /* Check other socket sent us its port. */
4342 || buffer[0] != (unsigned short) addresses[!i].sin_port
4343 /* Check kernel says we got the datagram from that socket */
4344 || readfrom.sin_family != addresses[!i].sin_family
4345 || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr
4346 || readfrom.sin_port != addresses[!i].sin_port)
4347 goto abort_tidy_up_and_fail;
4350 /* My caller (my_socketpair) has validated that this is non-NULL */
4353 /* I hereby declare this connection open. May God bless all who cross
4357 abort_tidy_up_and_fail:
4358 errno = ECONNABORTED;
4361 const int save_errno = errno;
4362 if (sockets[0] != -1)
4363 PerlLIO_close(sockets[0]);
4364 if (sockets[1] != -1)
4365 PerlLIO_close(sockets[1]);
4370 #endif /* EMULATE_SOCKETPAIR_UDP */
4372 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET)
4374 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4375 /* Stevens says that family must be AF_LOCAL, protocol 0.
4376 I'm going to enforce that, then ignore it, and use TCP (or UDP). */
4381 struct sockaddr_in listen_addr;
4382 struct sockaddr_in connect_addr;
4387 || family != AF_UNIX
4390 errno = EAFNOSUPPORT;
4398 #ifdef EMULATE_SOCKETPAIR_UDP
4399 if (type == SOCK_DGRAM)
4400 return S_socketpair_udp(fd);
4403 listener = PerlSock_socket(AF_INET, type, 0);
4406 memset(&listen_addr, 0, sizeof(listen_addr));
4407 listen_addr.sin_family = AF_INET;
4408 listen_addr.sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4409 listen_addr.sin_port = 0; /* kernel choses port. */
4410 if (PerlSock_bind(listener, (struct sockaddr *) &listen_addr,
4411 sizeof(listen_addr)) == -1)
4412 goto tidy_up_and_fail;
4413 if (PerlSock_listen(listener, 1) == -1)
4414 goto tidy_up_and_fail;
4416 connector = PerlSock_socket(AF_INET, type, 0);
4417 if (connector == -1)
4418 goto tidy_up_and_fail;
4419 /* We want to find out the port number to connect to. */
4420 size = sizeof(connect_addr);
4421 if (PerlSock_getsockname(listener, (struct sockaddr *) &connect_addr,
4423 goto tidy_up_and_fail;
4424 if (size != sizeof(connect_addr))
4425 goto abort_tidy_up_and_fail;
4426 if (PerlSock_connect(connector, (struct sockaddr *) &connect_addr,
4427 sizeof(connect_addr)) == -1)
4428 goto tidy_up_and_fail;
4430 size = sizeof(listen_addr);
4431 acceptor = PerlSock_accept(listener, (struct sockaddr *) &listen_addr,
4434 goto tidy_up_and_fail;
4435 if (size != sizeof(listen_addr))
4436 goto abort_tidy_up_and_fail;
4437 PerlLIO_close(listener);
4438 /* Now check we are talking to ourself by matching port and host on the
4440 if (PerlSock_getsockname(connector, (struct sockaddr *) &connect_addr,
4442 goto tidy_up_and_fail;
4443 if (size != sizeof(connect_addr)
4444 || listen_addr.sin_family != connect_addr.sin_family
4445 || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr
4446 || listen_addr.sin_port != connect_addr.sin_port) {
4447 goto abort_tidy_up_and_fail;
4453 abort_tidy_up_and_fail:
4455 errno = ECONNABORTED; /* This would be the standard thing to do. */
4457 # ifdef ECONNREFUSED
4458 errno = ECONNREFUSED; /* E.g. Symbian does not have ECONNABORTED. */
4460 errno = ETIMEDOUT; /* Desperation time. */
4465 int save_errno = errno;
4467 PerlLIO_close(listener);
4468 if (connector != -1)
4469 PerlLIO_close(connector);
4471 PerlLIO_close(acceptor);
4477 /* In any case have a stub so that there's code corresponding
4478 * to the my_socketpair in global.sym. */
4480 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4481 #ifdef HAS_SOCKETPAIR
4482 return socketpair(family, type, protocol, fd);
4491 =for apidoc sv_nosharing
4493 Dummy routine which "shares" an SV when there is no sharing module present.
4494 Exists to avoid test for a NULL function pointer and because it could potentially warn under
4495 some level of strict-ness.
4501 Perl_sv_nosharing(pTHX_ SV *sv)
4507 =for apidoc sv_nolocking
4509 Dummy routine which "locks" an SV when there is no locking module present.
4510 Exists to avoid test for a NULL function pointer and because it could potentially warn under
4511 some level of strict-ness.
4517 Perl_sv_nolocking(pTHX_ SV *sv)
4524 =for apidoc sv_nounlocking
4526 Dummy routine which "unlocks" an SV when there is no locking module present.
4527 Exists to avoid test for a NULL function pointer and because it could potentially warn under
4528 some level of strict-ness.
4534 Perl_sv_nounlocking(pTHX_ SV *sv)
4540 Perl_parse_unicode_opts(pTHX_ const char **popt)
4542 const char *p = *popt;
4547 opt = (U32) atoi(p);
4548 while (isDIGIT(*p)) p++;
4549 if (*p && *p != '\n' && *p != '\r')
4550 Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
4555 case PERL_UNICODE_STDIN:
4556 opt |= PERL_UNICODE_STDIN_FLAG; break;
4557 case PERL_UNICODE_STDOUT:
4558 opt |= PERL_UNICODE_STDOUT_FLAG; break;
4559 case PERL_UNICODE_STDERR:
4560 opt |= PERL_UNICODE_STDERR_FLAG; break;
4561 case PERL_UNICODE_STD:
4562 opt |= PERL_UNICODE_STD_FLAG; break;
4563 case PERL_UNICODE_IN:
4564 opt |= PERL_UNICODE_IN_FLAG; break;
4565 case PERL_UNICODE_OUT:
4566 opt |= PERL_UNICODE_OUT_FLAG; break;
4567 case PERL_UNICODE_INOUT:
4568 opt |= PERL_UNICODE_INOUT_FLAG; break;
4569 case PERL_UNICODE_LOCALE:
4570 opt |= PERL_UNICODE_LOCALE_FLAG; break;
4571 case PERL_UNICODE_ARGV:
4572 opt |= PERL_UNICODE_ARGV_FLAG; break;
4574 if (*p != '\n' && *p != '\r')
4576 "Unknown Unicode option letter '%c'", *p);
4582 opt = PERL_UNICODE_DEFAULT_FLAGS;
4584 if (opt & ~PERL_UNICODE_ALL_FLAGS)
4585 Perl_croak(aTHX_ "Unknown Unicode option value %"UVuf,
4586 (UV) (opt & ~PERL_UNICODE_ALL_FLAGS));
4597 * This is really just a quick hack which grabs various garbage
4598 * values. It really should be a real hash algorithm which
4599 * spreads the effect of every input bit onto every output bit,
4600 * if someone who knows about such things would bother to write it.
4601 * Might be a good idea to add that function to CORE as well.
4602 * No numbers below come from careful analysis or anything here,
4603 * except they are primes and SEED_C1 > 1E6 to get a full-width
4604 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
4605 * probably be bigger too.
4608 # define SEED_C1 1000003
4609 #define SEED_C4 73819
4611 # define SEED_C1 25747
4612 #define SEED_C4 20639
4616 #define SEED_C5 26107
4618 #ifndef PERL_NO_DEV_RANDOM
4623 # include <starlet.h>
4624 /* when[] = (low 32 bits, high 32 bits) of time since epoch
4625 * in 100-ns units, typically incremented ever 10 ms. */
4626 unsigned int when[2];
4628 # ifdef HAS_GETTIMEOFDAY
4629 struct timeval when;
4635 /* This test is an escape hatch, this symbol isn't set by Configure. */
4636 #ifndef PERL_NO_DEV_RANDOM
4637 #ifndef PERL_RANDOM_DEVICE
4638 /* /dev/random isn't used by default because reads from it will block
4639 * if there isn't enough entropy available. You can compile with
4640 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
4641 * is enough real entropy to fill the seed. */
4642 # define PERL_RANDOM_DEVICE "/dev/urandom"
4644 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
4646 if (PerlLIO_read(fd, (void*)&u, sizeof u) != sizeof u)
4655 _ckvmssts(sys$gettim(when));
4656 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
4658 # ifdef HAS_GETTIMEOFDAY
4659 PerlProc_gettimeofday(&when,NULL);
4660 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
4663 u = (U32)SEED_C1 * when;
4666 u += SEED_C3 * (U32)PerlProc_getpid();
4667 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
4668 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
4669 u += SEED_C5 * (U32)PTR2UV(&when);
4675 Perl_get_hash_seed(pTHX)
4677 const char *s = PerlEnv_getenv("PERL_HASH_SEED");
4681 while (isSPACE(*s)) s++;
4682 if (s && isDIGIT(*s))
4683 myseed = (UV)Atoul(s);
4685 #ifdef USE_HASH_SEED_EXPLICIT
4689 /* Compute a random seed */
4690 (void)seedDrand01((Rand_seed_t)seed());
4691 myseed = (UV)(Drand01() * (NV)UV_MAX);
4692 #if RANDBITS < (UVSIZE * 8)
4693 /* Since there are not enough randbits to to reach all
4694 * the bits of a UV, the low bits might need extra
4695 * help. Sum in another random number that will
4696 * fill in the low bits. */
4698 (UV)(Drand01() * (NV)((1 << ((UVSIZE * 8 - RANDBITS))) - 1));
4699 #endif /* RANDBITS < (UVSIZE * 8) */
4700 if (myseed == 0) { /* Superparanoia. */
4701 myseed = (UV)(Drand01() * (NV)UV_MAX); /* One more chance. */
4703 Perl_croak(aTHX_ "Your random numbers are not that random");
4706 PL_rehash_seed_set = TRUE;
4711 #ifdef PERL_GLOBAL_STRUCT
4714 Perl_init_global_struct(pTHX)
4716 struct perl_vars *plvarsp = NULL;
4717 #ifdef PERL_GLOBAL_STRUCT
4718 # define PERL_GLOBAL_STRUCT_INIT
4719 # include "opcode.h" /* the ppaddr and check */
4720 IV nppaddr = sizeof(Gppaddr)/sizeof(Perl_ppaddr_t);
4721 IV ncheck = sizeof(Gcheck) /sizeof(Perl_check_t);
4722 # ifdef PERL_GLOBAL_STRUCT_PRIVATE
4723 /* PerlMem_malloc() because can't use even safesysmalloc() this early. */
4724 plvarsp = (struct perl_vars*)PerlMem_malloc(sizeof(struct perl_vars));
4728 plvarsp = PL_VarsPtr;
4729 # endif /* PERL_GLOBAL_STRUCT_PRIVATE */
4735 # define PERLVAR(var,type) /**/
4736 # define PERLVARA(var,n,type) /**/
4737 # define PERLVARI(var,type,init) plvarsp->var = init;
4738 # define PERLVARIC(var,type,init) plvarsp->var = init;
4739 # define PERLVARISC(var,init) Copy(init, plvarsp->var, sizeof(init), char);
4740 # include "perlvars.h"
4746 # ifdef PERL_GLOBAL_STRUCT
4747 plvarsp->Gppaddr = PerlMem_malloc(nppaddr * sizeof(Perl_ppaddr_t));
4748 if (!plvarsp->Gppaddr)
4750 plvarsp->Gcheck = PerlMem_malloc(ncheck * sizeof(Perl_check_t));
4751 if (!plvarsp->Gcheck)
4753 Copy(Gppaddr, plvarsp->Gppaddr, nppaddr, Perl_ppaddr_t);
4754 Copy(Gcheck, plvarsp->Gcheck, ncheck, Perl_check_t);
4756 # ifdef PERL_SET_VARS
4757 PERL_SET_VARS(plvarsp);
4759 # undef PERL_GLOBAL_STRUCT_INIT
4764 #endif /* PERL_GLOBAL_STRUCT */
4766 #ifdef PERL_GLOBAL_STRUCT
4769 Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp)
4771 #ifdef PERL_GLOBAL_STRUCT
4772 # ifdef PERL_UNSET_VARS
4773 PERL_UNSET_VARS(plvarsp);
4775 free(plvarsp->Gppaddr);
4776 free(plvarsp->Gcheck);
4777 # ifdef PERL_GLOBAL_STRUCT_PRIVATE
4783 #endif /* PERL_GLOBAL_STRUCT */
4787 * c-indentation-style: bsd
4789 * indent-tabs-mode: t
4792 * ex: set ts=8 sts=4 sw=4 noet: