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;
879 SvREFCNT(sv) = 1 << 30; /* practically infinite */
884 #if defined(PERL_IMPLICIT_CONTEXT)
886 Perl_form_nocontext(const char* pat, ...)
892 retval = vform(pat, &args);
896 #endif /* PERL_IMPLICIT_CONTEXT */
899 =head1 Miscellaneous Functions
902 Takes a sprintf-style format pattern and conventional
903 (non-SV) arguments and returns the formatted string.
905 (char *) Perl_form(pTHX_ const char* pat, ...)
907 can be used any place a string (char *) is required:
909 char * s = Perl_form("%d.%d",major,minor);
911 Uses a single private buffer so if you want to format several strings you
912 must explicitly copy the earlier strings away (and free the copies when you
919 Perl_form(pTHX_ const char* pat, ...)
924 retval = vform(pat, &args);
930 Perl_vform(pTHX_ const char *pat, va_list *args)
932 SV *sv = mess_alloc();
933 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
937 #if defined(PERL_IMPLICIT_CONTEXT)
939 Perl_mess_nocontext(const char *pat, ...)
945 retval = vmess(pat, &args);
949 #endif /* PERL_IMPLICIT_CONTEXT */
952 Perl_mess(pTHX_ const char *pat, ...)
957 retval = vmess(pat, &args);
963 S_closest_cop(pTHX_ COP *cop, OP *o)
965 /* Look for PL_op starting from o. cop is the last COP we've seen. */
967 if (!o || o == PL_op) return cop;
969 if (o->op_flags & OPf_KIDS) {
971 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
975 /* If the OP_NEXTSTATE has been optimised away we can still use it
976 * the get the file and line number. */
978 if (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE)
981 /* Keep searching, and return when we've found something. */
983 new_cop = closest_cop(cop, kid);
984 if (new_cop) return new_cop;
994 Perl_vmess(pTHX_ const char *pat, va_list *args)
996 SV *sv = mess_alloc();
997 static const char dgd[] = " during global destruction.\n";
999 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
1000 if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
1003 * Try and find the file and line for PL_op. This will usually be
1004 * PL_curcop, but it might be a cop that has been optimised away. We
1005 * can try to find such a cop by searching through the optree starting
1006 * from the sibling of PL_curcop.
1009 const COP *cop = closest_cop(PL_curcop, PL_curcop->op_sibling);
1010 if (!cop) cop = PL_curcop;
1013 Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf,
1014 OutCopFILE(cop), (IV)CopLINE(cop));
1015 if (GvIO(PL_last_in_gv) && IoLINES(GvIOp(PL_last_in_gv))) {
1016 const bool line_mode = (RsSIMPLE(PL_rs) &&
1017 SvCUR(PL_rs) == 1 && *SvPVX_const(PL_rs) == '\n');
1018 Perl_sv_catpvf(aTHX_ sv, ", <%s> %s %"IVdf,
1019 PL_last_in_gv == PL_argvgv ?
1020 "" : GvNAME(PL_last_in_gv),
1021 line_mode ? "line" : "chunk",
1022 (IV)IoLINES(GvIOp(PL_last_in_gv)));
1024 sv_catpv(sv, PL_dirty ? dgd : ".\n");
1030 Perl_write_to_stderr(pTHX_ const char* message, int msglen)
1036 if (PL_stderrgv && SvREFCNT(PL_stderrgv)
1037 && (io = GvIO(PL_stderrgv))
1038 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
1045 SAVESPTR(PL_stderrgv);
1046 PL_stderrgv = Nullgv;
1048 PUSHSTACKi(PERLSI_MAGIC);
1052 PUSHs(SvTIED_obj((SV*)io, mg));
1053 PUSHs(sv_2mortal(newSVpvn(message, msglen)));
1055 call_method("PRINT", G_SCALAR);
1063 /* SFIO can really mess with your errno */
1066 PerlIO *serr = Perl_error_log;
1068 PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
1069 (void)PerlIO_flush(serr);
1076 /* Common code used by vcroak, vdie and vwarner */
1078 void S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8);
1081 S_vdie_croak_common(pTHX_ const char* pat, va_list* args, STRLEN* msglen,
1088 SV *msv = vmess(pat, args);
1089 if (PL_errors && SvCUR(PL_errors)) {
1090 sv_catsv(PL_errors, msv);
1091 message = SvPV(PL_errors, *msglen);
1092 SvCUR_set(PL_errors, 0);
1095 message = SvPV(msv,*msglen);
1096 *utf8 = SvUTF8(msv);
1102 DEBUG_S(PerlIO_printf(Perl_debug_log,
1103 "%p: die/croak: message = %s\ndiehook = %p\n",
1104 thr, message, PL_diehook));
1106 S_vdie_common(aTHX_ message, *msglen, *utf8);
1112 S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8)
1117 /* sv_2cv might call Perl_croak() */
1118 SV *olddiehook = PL_diehook;
1122 SAVESPTR(PL_diehook);
1123 PL_diehook = Nullsv;
1124 cv = sv_2cv(olddiehook, &stash, &gv, 0);
1126 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1133 msg = newSVpvn(message, msglen);
1134 SvFLAGS(msg) |= utf8;
1142 PUSHSTACKi(PERLSI_DIEHOOK);
1146 call_sv((SV*)cv, G_DISCARD);
1153 Perl_vdie(pTHX_ const char* pat, va_list *args)
1155 const char *message;
1156 const int was_in_eval = PL_in_eval;
1160 DEBUG_S(PerlIO_printf(Perl_debug_log,
1161 "%p: die: curstack = %p, mainstack = %p\n",
1162 thr, PL_curstack, PL_mainstack));
1164 message = S_vdie_croak_common(aTHX_ pat, args, &msglen, &utf8);
1166 PL_restartop = die_where(message, msglen);
1167 SvFLAGS(ERRSV) |= utf8;
1168 DEBUG_S(PerlIO_printf(Perl_debug_log,
1169 "%p: die: restartop = %p, was_in_eval = %d, top_env = %p\n",
1170 thr, PL_restartop, was_in_eval, PL_top_env));
1171 if ((!PL_restartop && was_in_eval) || PL_top_env->je_prev)
1173 return PL_restartop;
1176 #if defined(PERL_IMPLICIT_CONTEXT)
1178 Perl_die_nocontext(const char* pat, ...)
1183 va_start(args, pat);
1184 o = vdie(pat, &args);
1188 #endif /* PERL_IMPLICIT_CONTEXT */
1191 Perl_die(pTHX_ const char* pat, ...)
1195 va_start(args, pat);
1196 o = vdie(pat, &args);
1202 Perl_vcroak(pTHX_ const char* pat, va_list *args)
1204 const char *message;
1208 message = S_vdie_croak_common(aTHX_ pat, args, &msglen, &utf8);
1211 PL_restartop = die_where(message, msglen);
1212 SvFLAGS(ERRSV) |= utf8;
1216 message = SvPVx(ERRSV, msglen);
1218 write_to_stderr(message, msglen);
1222 #if defined(PERL_IMPLICIT_CONTEXT)
1224 Perl_croak_nocontext(const char *pat, ...)
1228 va_start(args, pat);
1233 #endif /* PERL_IMPLICIT_CONTEXT */
1236 =head1 Warning and Dieing
1240 This is the XSUB-writer's interface to Perl's C<die> function.
1241 Normally call this function the same way you call the C C<printf>
1242 function. Calling C<croak> returns control directly to Perl,
1243 sidestepping the normal C order of execution. See C<warn>.
1245 If you want to throw an exception object, assign the object to
1246 C<$@> and then pass C<Nullch> to croak():
1248 errsv = get_sv("@", TRUE);
1249 sv_setsv(errsv, exception_object);
1256 Perl_croak(pTHX_ const char *pat, ...)
1259 va_start(args, pat);
1266 Perl_vwarn(pTHX_ const char* pat, va_list *args)
1277 msv = vmess(pat, args);
1279 message = SvPV(msv, msglen);
1282 /* sv_2cv might call Perl_warn() */
1283 SV *oldwarnhook = PL_warnhook;
1285 SAVESPTR(PL_warnhook);
1286 PL_warnhook = Nullsv;
1287 cv = sv_2cv(oldwarnhook, &stash, &gv, 0);
1289 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1295 msg = newSVpvn(message, msglen);
1296 SvFLAGS(msg) |= utf8;
1300 PUSHSTACKi(PERLSI_WARNHOOK);
1304 call_sv((SV*)cv, G_DISCARD);
1311 write_to_stderr(message, msglen);
1314 #if defined(PERL_IMPLICIT_CONTEXT)
1316 Perl_warn_nocontext(const char *pat, ...)
1320 va_start(args, pat);
1324 #endif /* PERL_IMPLICIT_CONTEXT */
1329 This is the XSUB-writer's interface to Perl's C<warn> function. Call this
1330 function the same way you call the C C<printf> function. See C<croak>.
1336 Perl_warn(pTHX_ const char *pat, ...)
1339 va_start(args, pat);
1344 #if defined(PERL_IMPLICIT_CONTEXT)
1346 Perl_warner_nocontext(U32 err, const char *pat, ...)
1350 va_start(args, pat);
1351 vwarner(err, pat, &args);
1354 #endif /* PERL_IMPLICIT_CONTEXT */
1357 Perl_warner(pTHX_ U32 err, const char* pat,...)
1360 va_start(args, pat);
1361 vwarner(err, pat, &args);
1366 Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args)
1370 SV * const msv = vmess(pat, args);
1372 const char *message = SvPV(msv, msglen);
1373 const I32 utf8 = SvUTF8(msv);
1377 S_vdie_common(aTHX_ message, msglen, utf8);
1380 PL_restartop = die_where(message, msglen);
1381 SvFLAGS(ERRSV) |= utf8;
1384 write_to_stderr(message, msglen);
1388 Perl_vwarn(aTHX_ pat, args);
1392 /* since we've already done strlen() for both nam and val
1393 * we can use that info to make things faster than
1394 * sprintf(s, "%s=%s", nam, val)
1396 #define my_setenv_format(s, nam, nlen, val, vlen) \
1397 Copy(nam, s, nlen, char); \
1399 Copy(val, s+(nlen+1), vlen, char); \
1400 *(s+(nlen+1+vlen)) = '\0'
1402 #ifdef USE_ENVIRON_ARRAY
1403 /* VMS' my_setenv() is in vms.c */
1404 #if !defined(WIN32) && !defined(NETWARE)
1406 Perl_my_setenv(pTHX_ const char *nam, const char *val)
1410 /* only parent thread can modify process environment */
1411 if (PL_curinterp == aTHX)
1414 #ifndef PERL_USE_SAFE_PUTENV
1415 if (!PL_use_safe_putenv) {
1416 /* most putenv()s leak, so we manipulate environ directly */
1417 register I32 i=setenv_getix(nam); /* where does it go? */
1420 if (environ == PL_origenviron) { /* need we copy environment? */
1426 for (max = i; environ[max]; max++) ;
1427 tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*));
1428 for (j=0; j<max; j++) { /* copy environment */
1429 const int len = strlen(environ[j]);
1430 tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char));
1431 Copy(environ[j], tmpenv[j], len+1, char);
1433 tmpenv[max] = Nullch;
1434 environ = tmpenv; /* tell exec where it is now */
1437 safesysfree(environ[i]);
1438 while (environ[i]) {
1439 environ[i] = environ[i+1];
1444 if (!environ[i]) { /* does not exist yet */
1445 environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
1446 environ[i+1] = Nullch; /* make sure it's null terminated */
1449 safesysfree(environ[i]);
1453 environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char));
1454 /* all that work just for this */
1455 my_setenv_format(environ[i], nam, nlen, val, vlen);
1458 # if defined(__CYGWIN__) || defined(EPOC) || defined(SYMBIAN)
1459 setenv(nam, val, 1);
1462 int nlen = strlen(nam), vlen;
1467 new_env = (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
1468 /* all that work just for this */
1469 my_setenv_format(new_env, nam, nlen, val, vlen);
1470 (void)putenv(new_env);
1471 # endif /* __CYGWIN__ */
1472 #ifndef PERL_USE_SAFE_PUTENV
1478 #else /* WIN32 || NETWARE */
1481 Perl_my_setenv(pTHX_ const char *nam, const char *val)
1484 register char *envstr;
1485 const int nlen = strlen(nam);
1492 New(904, envstr, nlen+vlen+2, char);
1493 my_setenv_format(envstr, nam, nlen, val, vlen);
1494 (void)PerlEnv_putenv(envstr);
1498 #endif /* WIN32 || NETWARE */
1502 Perl_setenv_getix(pTHX_ const char *nam)
1504 register I32 i, len = strlen(nam);
1506 for (i = 0; environ[i]; i++) {
1509 strnicmp(environ[i],nam,len) == 0
1511 strnEQ(environ[i],nam,len)
1513 && environ[i][len] == '=')
1514 break; /* strnEQ must come first to avoid */
1515 } /* potential SEGV's */
1518 #endif /* !PERL_MICRO */
1520 #endif /* !VMS && !EPOC*/
1522 #ifdef UNLINK_ALL_VERSIONS
1524 Perl_unlnk(pTHX_ char *f) /* unlink all versions of a file */
1528 for (i = 0; PerlLIO_unlink(f) >= 0; i++) ;
1533 /* this is a drop-in replacement for bcopy() */
1534 #if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY))
1536 Perl_my_bcopy(register const char *from,register char *to,register I32 len)
1540 if (from - to >= 0) {
1548 *(--to) = *(--from);
1554 /* this is a drop-in replacement for memset() */
1557 Perl_my_memset(register char *loc, register I32 ch, register I32 len)
1567 /* this is a drop-in replacement for bzero() */
1568 #if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
1570 Perl_my_bzero(register char *loc, register I32 len)
1580 /* this is a drop-in replacement for memcmp() */
1581 #if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
1583 Perl_my_memcmp(const char *s1, const char *s2, register I32 len)
1585 register const U8 *a = (const U8 *)s1;
1586 register const U8 *b = (const U8 *)s2;
1590 if ((tmp = *a++ - *b++))
1595 #endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */
1599 #ifdef USE_CHAR_VSPRINTF
1604 vsprintf(char *dest, const char *pat, char *args)
1608 fakebuf._ptr = dest;
1609 fakebuf._cnt = 32767;
1613 fakebuf._flag = _IOWRT|_IOSTRG;
1614 _doprnt(pat, args, &fakebuf); /* what a kludge */
1615 (void)putc('\0', &fakebuf);
1616 #ifdef USE_CHAR_VSPRINTF
1619 return 0; /* perl doesn't use return value */
1623 #endif /* HAS_VPRINTF */
1626 #if BYTEORDER != 0x4321
1628 Perl_my_swap(pTHX_ short s)
1630 #if (BYTEORDER & 1) == 0
1633 result = ((s & 255) << 8) + ((s >> 8) & 255);
1641 Perl_my_htonl(pTHX_ long l)
1645 char c[sizeof(long)];
1648 #if BYTEORDER == 0x1234
1649 u.c[0] = (l >> 24) & 255;
1650 u.c[1] = (l >> 16) & 255;
1651 u.c[2] = (l >> 8) & 255;
1655 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
1656 Perl_croak(aTHX_ "Unknown BYTEORDER\n");
1661 for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
1662 u.c[o & 0xf] = (l >> s) & 255;
1670 Perl_my_ntohl(pTHX_ long l)
1674 char c[sizeof(long)];
1677 #if BYTEORDER == 0x1234
1678 u.c[0] = (l >> 24) & 255;
1679 u.c[1] = (l >> 16) & 255;
1680 u.c[2] = (l >> 8) & 255;
1684 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
1685 Perl_croak(aTHX_ "Unknown BYTEORDER\n");
1692 for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
1693 l |= (u.c[o & 0xf] & 255) << s;
1700 #endif /* BYTEORDER != 0x4321 */
1704 * Little-endian byte order functions - 'v' for 'VAX', or 'reVerse'.
1705 * If these functions are defined,
1706 * the BYTEORDER is neither 0x1234 nor 0x4321.
1707 * However, this is not assumed.
1711 #define HTOLE(name,type) \
1713 name (register type n) \
1717 char c[sizeof(type)]; \
1720 register I32 s = 0; \
1721 for (i = 0; i < sizeof(u.c); i++, s += 8) { \
1722 u.c[i] = (n >> s) & 0xFF; \
1727 #define LETOH(name,type) \
1729 name (register type n) \
1733 char c[sizeof(type)]; \
1736 register I32 s = 0; \
1739 for (i = 0; i < sizeof(u.c); i++, s += 8) { \
1740 n |= ((type)(u.c[i] & 0xFF)) << s; \
1746 * Big-endian byte order functions.
1749 #define HTOBE(name,type) \
1751 name (register type n) \
1755 char c[sizeof(type)]; \
1758 register I32 s = 8*(sizeof(u.c)-1); \
1759 for (i = 0; i < sizeof(u.c); i++, s -= 8) { \
1760 u.c[i] = (n >> s) & 0xFF; \
1765 #define BETOH(name,type) \
1767 name (register type n) \
1771 char c[sizeof(type)]; \
1774 register I32 s = 8*(sizeof(u.c)-1); \
1777 for (i = 0; i < sizeof(u.c); i++, s -= 8) { \
1778 n |= ((type)(u.c[i] & 0xFF)) << s; \
1784 * If we just can't do it...
1787 #define NOT_AVAIL(name,type) \
1789 name (register type n) \
1791 Perl_croak_nocontext(#name "() not available"); \
1792 return n; /* not reached */ \
1796 #if defined(HAS_HTOVS) && !defined(htovs)
1799 #if defined(HAS_HTOVL) && !defined(htovl)
1802 #if defined(HAS_VTOHS) && !defined(vtohs)
1805 #if defined(HAS_VTOHL) && !defined(vtohl)
1809 #ifdef PERL_NEED_MY_HTOLE16
1811 HTOLE(Perl_my_htole16,U16)
1813 NOT_AVAIL(Perl_my_htole16,U16)
1816 #ifdef PERL_NEED_MY_LETOH16
1818 LETOH(Perl_my_letoh16,U16)
1820 NOT_AVAIL(Perl_my_letoh16,U16)
1823 #ifdef PERL_NEED_MY_HTOBE16
1825 HTOBE(Perl_my_htobe16,U16)
1827 NOT_AVAIL(Perl_my_htobe16,U16)
1830 #ifdef PERL_NEED_MY_BETOH16
1832 BETOH(Perl_my_betoh16,U16)
1834 NOT_AVAIL(Perl_my_betoh16,U16)
1838 #ifdef PERL_NEED_MY_HTOLE32
1840 HTOLE(Perl_my_htole32,U32)
1842 NOT_AVAIL(Perl_my_htole32,U32)
1845 #ifdef PERL_NEED_MY_LETOH32
1847 LETOH(Perl_my_letoh32,U32)
1849 NOT_AVAIL(Perl_my_letoh32,U32)
1852 #ifdef PERL_NEED_MY_HTOBE32
1854 HTOBE(Perl_my_htobe32,U32)
1856 NOT_AVAIL(Perl_my_htobe32,U32)
1859 #ifdef PERL_NEED_MY_BETOH32
1861 BETOH(Perl_my_betoh32,U32)
1863 NOT_AVAIL(Perl_my_betoh32,U32)
1867 #ifdef PERL_NEED_MY_HTOLE64
1869 HTOLE(Perl_my_htole64,U64)
1871 NOT_AVAIL(Perl_my_htole64,U64)
1874 #ifdef PERL_NEED_MY_LETOH64
1876 LETOH(Perl_my_letoh64,U64)
1878 NOT_AVAIL(Perl_my_letoh64,U64)
1881 #ifdef PERL_NEED_MY_HTOBE64
1883 HTOBE(Perl_my_htobe64,U64)
1885 NOT_AVAIL(Perl_my_htobe64,U64)
1888 #ifdef PERL_NEED_MY_BETOH64
1890 BETOH(Perl_my_betoh64,U64)
1892 NOT_AVAIL(Perl_my_betoh64,U64)
1896 #ifdef PERL_NEED_MY_HTOLES
1897 HTOLE(Perl_my_htoles,short)
1899 #ifdef PERL_NEED_MY_LETOHS
1900 LETOH(Perl_my_letohs,short)
1902 #ifdef PERL_NEED_MY_HTOBES
1903 HTOBE(Perl_my_htobes,short)
1905 #ifdef PERL_NEED_MY_BETOHS
1906 BETOH(Perl_my_betohs,short)
1909 #ifdef PERL_NEED_MY_HTOLEI
1910 HTOLE(Perl_my_htolei,int)
1912 #ifdef PERL_NEED_MY_LETOHI
1913 LETOH(Perl_my_letohi,int)
1915 #ifdef PERL_NEED_MY_HTOBEI
1916 HTOBE(Perl_my_htobei,int)
1918 #ifdef PERL_NEED_MY_BETOHI
1919 BETOH(Perl_my_betohi,int)
1922 #ifdef PERL_NEED_MY_HTOLEL
1923 HTOLE(Perl_my_htolel,long)
1925 #ifdef PERL_NEED_MY_LETOHL
1926 LETOH(Perl_my_letohl,long)
1928 #ifdef PERL_NEED_MY_HTOBEL
1929 HTOBE(Perl_my_htobel,long)
1931 #ifdef PERL_NEED_MY_BETOHL
1932 BETOH(Perl_my_betohl,long)
1936 Perl_my_swabn(void *ptr, int n)
1938 register char *s = (char *)ptr;
1939 register char *e = s + (n-1);
1942 for (n /= 2; n > 0; s++, e--, n--) {
1950 Perl_my_popen_list(pTHX_ char *mode, int n, SV **args)
1952 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) && !defined(NETWARE)
1954 register I32 This, that;
1960 PERL_FLUSHALL_FOR_CHILD;
1961 This = (*mode == 'w');
1965 taint_proper("Insecure %s%s", "EXEC");
1967 if (PerlProc_pipe(p) < 0)
1969 /* Try for another pipe pair for error return */
1970 if (PerlProc_pipe(pp) >= 0)
1972 while ((pid = PerlProc_fork()) < 0) {
1973 if (errno != EAGAIN) {
1974 PerlLIO_close(p[This]);
1975 PerlLIO_close(p[that]);
1977 PerlLIO_close(pp[0]);
1978 PerlLIO_close(pp[1]);
1990 /* Close parent's end of error status pipe (if any) */
1992 PerlLIO_close(pp[0]);
1993 #if defined(HAS_FCNTL) && defined(F_SETFD)
1994 /* Close error pipe automatically if exec works */
1995 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
1998 /* Now dup our end of _the_ pipe to right position */
1999 if (p[THIS] != (*mode == 'r')) {
2000 PerlLIO_dup2(p[THIS], *mode == 'r');
2001 PerlLIO_close(p[THIS]);
2002 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2003 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
2006 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
2007 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2008 /* No automatic close - do it by hand */
2015 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) {
2021 do_aexec5(Nullsv, args-1, args-1+n, pp[1], did_pipes);
2027 do_execfree(); /* free any memory malloced by child on fork */
2029 PerlLIO_close(pp[1]);
2030 /* Keep the lower of the two fd numbers */
2031 if (p[that] < p[This]) {
2032 PerlLIO_dup2(p[This], p[that]);
2033 PerlLIO_close(p[This]);
2037 PerlLIO_close(p[that]); /* close child's end of pipe */
2040 sv = *av_fetch(PL_fdpid,p[This],TRUE);
2042 (void)SvUPGRADE(sv,SVt_IV);
2044 PL_forkprocess = pid;
2045 /* If we managed to get status pipe check for exec fail */
2046 if (did_pipes && pid > 0) {
2050 while (n < sizeof(int)) {
2051 n1 = PerlLIO_read(pp[0],
2052 (void*)(((char*)&errkid)+n),
2058 PerlLIO_close(pp[0]);
2060 if (n) { /* Error */
2062 PerlLIO_close(p[This]);
2063 if (n != sizeof(int))
2064 Perl_croak(aTHX_ "panic: kid popen errno read");
2066 pid2 = wait4pid(pid, &status, 0);
2067 } while (pid2 == -1 && errno == EINTR);
2068 errno = errkid; /* Propagate errno from kid */
2073 PerlLIO_close(pp[0]);
2074 return PerlIO_fdopen(p[This], mode);
2076 Perl_croak(aTHX_ "List form of piped open not implemented");
2077 return (PerlIO *) NULL;
2081 /* VMS' my_popen() is in VMS.c, same with OS/2. */
2082 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
2084 Perl_my_popen(pTHX_ char *cmd, char *mode)
2087 register I32 This, that;
2090 I32 doexec = !(*cmd == '-' && cmd[1] == '\0');
2094 PERL_FLUSHALL_FOR_CHILD;
2097 return my_syspopen(aTHX_ cmd,mode);
2100 This = (*mode == 'w');
2102 if (doexec && PL_tainting) {
2104 taint_proper("Insecure %s%s", "EXEC");
2106 if (PerlProc_pipe(p) < 0)
2108 if (doexec && PerlProc_pipe(pp) >= 0)
2110 while ((pid = PerlProc_fork()) < 0) {
2111 if (errno != EAGAIN) {
2112 PerlLIO_close(p[This]);
2113 PerlLIO_close(p[that]);
2115 PerlLIO_close(pp[0]);
2116 PerlLIO_close(pp[1]);
2119 Perl_croak(aTHX_ "Can't fork");
2132 PerlLIO_close(pp[0]);
2133 #if defined(HAS_FCNTL) && defined(F_SETFD)
2134 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2137 if (p[THIS] != (*mode == 'r')) {
2138 PerlLIO_dup2(p[THIS], *mode == 'r');
2139 PerlLIO_close(p[THIS]);
2140 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2141 PerlLIO_close(p[THAT]);
2144 PerlLIO_close(p[THAT]);
2147 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2154 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
2159 /* may or may not use the shell */
2160 do_exec3(cmd, pp[1], did_pipes);
2163 #endif /* defined OS2 */
2165 if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) {
2166 SvREADONLY_off(GvSV(tmpgv));
2167 sv_setiv(GvSV(tmpgv), PerlProc_getpid());
2168 SvREADONLY_on(GvSV(tmpgv));
2170 #ifdef THREADS_HAVE_PIDS
2171 PL_ppid = (IV)getppid();
2174 hv_clear(PL_pidstatus); /* we have no children */
2179 do_execfree(); /* free any memory malloced by child on vfork */
2181 PerlLIO_close(pp[1]);
2182 if (p[that] < p[This]) {
2183 PerlLIO_dup2(p[This], p[that]);
2184 PerlLIO_close(p[This]);
2188 PerlLIO_close(p[that]);
2191 sv = *av_fetch(PL_fdpid,p[This],TRUE);
2193 (void)SvUPGRADE(sv,SVt_IV);
2195 PL_forkprocess = pid;
2196 if (did_pipes && pid > 0) {
2200 while (n < sizeof(int)) {
2201 n1 = PerlLIO_read(pp[0],
2202 (void*)(((char*)&errkid)+n),
2208 PerlLIO_close(pp[0]);
2210 if (n) { /* Error */
2212 PerlLIO_close(p[This]);
2213 if (n != sizeof(int))
2214 Perl_croak(aTHX_ "panic: kid popen errno read");
2216 pid2 = wait4pid(pid, &status, 0);
2217 } while (pid2 == -1 && errno == EINTR);
2218 errno = errkid; /* Propagate errno from kid */
2223 PerlLIO_close(pp[0]);
2224 return PerlIO_fdopen(p[This], mode);
2227 #if defined(atarist) || defined(EPOC)
2230 Perl_my_popen(pTHX_ char *cmd, char *mode)
2232 PERL_FLUSHALL_FOR_CHILD;
2233 /* Call system's popen() to get a FILE *, then import it.
2234 used 0 for 2nd parameter to PerlIO_importFILE;
2237 return PerlIO_importFILE(popen(cmd, mode), 0);
2241 FILE *djgpp_popen();
2243 Perl_my_popen(pTHX_ char *cmd, char *mode)
2245 PERL_FLUSHALL_FOR_CHILD;
2246 /* Call system's popen() to get a FILE *, then import it.
2247 used 0 for 2nd parameter to PerlIO_importFILE;
2250 return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
2255 #endif /* !DOSISH */
2257 /* this is called in parent before the fork() */
2259 Perl_atfork_lock(void)
2262 #if defined(USE_ITHREADS)
2263 /* locks must be held in locking order (if any) */
2265 MUTEX_LOCK(&PL_malloc_mutex);
2271 /* this is called in both parent and child after the fork() */
2273 Perl_atfork_unlock(void)
2276 #if defined(USE_ITHREADS)
2277 /* locks must be released in same order as in atfork_lock() */
2279 MUTEX_UNLOCK(&PL_malloc_mutex);
2288 #if defined(HAS_FORK)
2290 #if defined(USE_ITHREADS) && !defined(HAS_PTHREAD_ATFORK)
2295 /* atfork_lock() and atfork_unlock() are installed as pthread_atfork()
2296 * handlers elsewhere in the code */
2301 /* this "canna happen" since nothing should be calling here if !HAS_FORK */
2302 Perl_croak_nocontext("fork() not available");
2304 #endif /* HAS_FORK */
2309 Perl_dump_fds(pTHX_ char *s)
2314 PerlIO_printf(Perl_debug_log,"%s", s);
2315 for (fd = 0; fd < 32; fd++) {
2316 if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0)
2317 PerlIO_printf(Perl_debug_log," %d",fd);
2319 PerlIO_printf(Perl_debug_log,"\n");
2322 #endif /* DUMP_FDS */
2326 dup2(int oldfd, int newfd)
2328 #if defined(HAS_FCNTL) && defined(F_DUPFD)
2331 PerlLIO_close(newfd);
2332 return fcntl(oldfd, F_DUPFD, newfd);
2334 #define DUP2_MAX_FDS 256
2335 int fdtmp[DUP2_MAX_FDS];
2341 PerlLIO_close(newfd);
2342 /* good enough for low fd's... */
2343 while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
2344 if (fdx >= DUP2_MAX_FDS) {
2352 PerlLIO_close(fdtmp[--fdx]);
2359 #ifdef HAS_SIGACTION
2361 #ifdef MACOS_TRADITIONAL
2362 /* We don't want restart behavior on MacOS */
2367 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2370 struct sigaction act, oact;
2373 /* only "parent" interpreter can diddle signals */
2374 if (PL_curinterp != aTHX)
2378 act.sa_handler = handler;
2379 sigemptyset(&act.sa_mask);
2382 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2383 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
2385 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2386 if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN)
2387 act.sa_flags |= SA_NOCLDWAIT;
2389 if (sigaction(signo, &act, &oact) == -1)
2392 return oact.sa_handler;
2396 Perl_rsignal_state(pTHX_ int signo)
2398 struct sigaction oact;
2400 if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
2403 return oact.sa_handler;
2407 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2410 struct sigaction act;
2413 /* only "parent" interpreter can diddle signals */
2414 if (PL_curinterp != aTHX)
2418 act.sa_handler = handler;
2419 sigemptyset(&act.sa_mask);
2422 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2423 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
2425 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2426 if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN)
2427 act.sa_flags |= SA_NOCLDWAIT;
2429 return sigaction(signo, &act, save);
2433 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2437 /* only "parent" interpreter can diddle signals */
2438 if (PL_curinterp != aTHX)
2442 return sigaction(signo, save, (struct sigaction *)NULL);
2445 #else /* !HAS_SIGACTION */
2448 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2450 #if defined(USE_ITHREADS) && !defined(WIN32)
2451 /* only "parent" interpreter can diddle signals */
2452 if (PL_curinterp != aTHX)
2456 return PerlProc_signal(signo, handler);
2468 Perl_rsignal_state(pTHX_ int signo)
2471 Sighandler_t oldsig;
2473 #if defined(USE_ITHREADS) && !defined(WIN32)
2474 /* only "parent" interpreter can diddle signals */
2475 if (PL_curinterp != aTHX)
2480 oldsig = PerlProc_signal(signo, sig_trap);
2481 PerlProc_signal(signo, oldsig);
2483 PerlProc_kill(PerlProc_getpid(), signo);
2488 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2490 #if defined(USE_ITHREADS) && !defined(WIN32)
2491 /* only "parent" interpreter can diddle signals */
2492 if (PL_curinterp != aTHX)
2495 *save = PerlProc_signal(signo, handler);
2496 return (*save == SIG_ERR) ? -1 : 0;
2500 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2502 #if defined(USE_ITHREADS) && !defined(WIN32)
2503 /* only "parent" interpreter can diddle signals */
2504 if (PL_curinterp != aTHX)
2507 return (PerlProc_signal(signo, *save) == SIG_ERR) ? -1 : 0;
2510 #endif /* !HAS_SIGACTION */
2511 #endif /* !PERL_MICRO */
2513 /* VMS' my_pclose() is in VMS.c; same with OS/2 */
2514 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
2516 Perl_my_pclose(pTHX_ PerlIO *ptr)
2518 Sigsave_t hstat, istat, qstat;
2524 int saved_errno = 0;
2526 int saved_vaxc_errno;
2529 int saved_win32_errno;
2533 svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE);
2535 pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
2537 *svp = &PL_sv_undef;
2539 if (pid == -1) { /* Opened by popen. */
2540 return my_syspclose(ptr);
2543 if ((close_failed = (PerlIO_close(ptr) == EOF))) {
2544 saved_errno = errno;
2546 saved_vaxc_errno = vaxc$errno;
2549 saved_win32_errno = GetLastError();
2553 if(PerlProc_kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */
2556 rsignal_save(SIGHUP, SIG_IGN, &hstat);
2557 rsignal_save(SIGINT, SIG_IGN, &istat);
2558 rsignal_save(SIGQUIT, SIG_IGN, &qstat);
2561 pid2 = wait4pid(pid, &status, 0);
2562 } while (pid2 == -1 && errno == EINTR);
2564 rsignal_restore(SIGHUP, &hstat);
2565 rsignal_restore(SIGINT, &istat);
2566 rsignal_restore(SIGQUIT, &qstat);
2569 SETERRNO(saved_errno, saved_vaxc_errno);
2572 return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status));
2574 #endif /* !DOSISH */
2576 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(MACOS_TRADITIONAL)
2578 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
2583 #if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME)
2585 char spid[TYPE_CHARS(IV)];
2589 sprintf(spid, "%"IVdf, (IV)pid);
2590 svp = hv_fetch(PL_pidstatus,spid,strlen(spid),FALSE);
2591 if (svp && *svp != &PL_sv_undef) {
2592 *statusp = SvIVX(*svp);
2593 (void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD);
2600 hv_iterinit(PL_pidstatus);
2601 if ((entry = hv_iternext(PL_pidstatus))) {
2602 SV *sv = hv_iterval(PL_pidstatus,entry);
2604 pid = atoi(hv_iterkey(entry,(I32*)statusp));
2605 *statusp = SvIVX(sv);
2606 sprintf(spid, "%"IVdf, (IV)pid);
2607 (void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD);
2614 # ifdef HAS_WAITPID_RUNTIME
2615 if (!HAS_WAITPID_RUNTIME)
2618 result = PerlProc_waitpid(pid,statusp,flags);
2621 #if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
2622 result = wait4((pid==-1)?0:pid,statusp,flags,Null(struct rusage *));
2625 #if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME)
2626 #if defined(HAS_WAITPID) && defined(HAS_WAITPID_RUNTIME)
2631 Perl_croak(aTHX_ "Can't do waitpid with flags");
2633 while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
2634 pidgone(result,*statusp);
2640 #if defined(HAS_WAITPID) || defined(HAS_WAIT4)
2643 if (result < 0 && errno == EINTR) {
2648 #endif /* !DOSISH || OS2 || WIN32 || NETWARE */
2652 Perl_pidgone(pTHX_ Pid_t pid, int status)
2655 char spid[TYPE_CHARS(IV)];
2657 sprintf(spid, "%"IVdf, (IV)pid);
2658 sv = *hv_fetch(PL_pidstatus,spid,strlen(spid),TRUE);
2659 (void)SvUPGRADE(sv,SVt_IV);
2660 SvIV_set(sv, status);
2664 #if defined(atarist) || defined(OS2) || defined(EPOC)
2667 int /* Cannot prototype with I32
2669 my_syspclose(PerlIO *ptr)
2672 Perl_my_pclose(pTHX_ PerlIO *ptr)
2675 /* Needs work for PerlIO ! */
2676 FILE *f = PerlIO_findFILE(ptr);
2677 I32 result = pclose(f);
2678 PerlIO_releaseFILE(ptr,f);
2686 Perl_my_pclose(pTHX_ PerlIO *ptr)
2688 /* Needs work for PerlIO ! */
2689 FILE *f = PerlIO_findFILE(ptr);
2690 I32 result = djgpp_pclose(f);
2691 result = (result << 8) & 0xff00;
2692 PerlIO_releaseFILE(ptr,f);
2698 Perl_repeatcpy(pTHX_ register char *to, register const char *from, I32 len, register I32 count)
2701 register const char *frombase = from;
2704 register const char c = *from;
2709 while (count-- > 0) {
2710 for (todo = len; todo > 0; todo--) {
2719 Perl_same_dirent(pTHX_ const char *a, const char *b)
2721 char *fa = strrchr(a,'/');
2722 char *fb = strrchr(b,'/');
2725 SV *tmpsv = sv_newmortal();
2738 sv_setpvn(tmpsv, ".", 1);
2740 sv_setpvn(tmpsv, a, fa - a);
2741 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0)
2744 sv_setpvn(tmpsv, ".", 1);
2746 sv_setpvn(tmpsv, b, fb - b);
2747 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0)
2749 return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
2750 tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
2752 #endif /* !HAS_RENAME */
2755 Perl_find_script(pTHX_ const char *scriptname, bool dosearch, const char **search_ext, I32 flags)
2757 const char *xfound = Nullch;
2758 char *xfailed = Nullch;
2759 char tmpbuf[MAXPATHLEN];
2763 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
2764 # define SEARCH_EXTS ".bat", ".cmd", NULL
2765 # define MAX_EXT_LEN 4
2768 # define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
2769 # define MAX_EXT_LEN 4
2772 # define SEARCH_EXTS ".pl", ".com", NULL
2773 # define MAX_EXT_LEN 4
2775 /* additional extensions to try in each dir if scriptname not found */
2777 const char *exts[] = { SEARCH_EXTS };
2778 const char **ext = search_ext ? search_ext : exts;
2779 int extidx = 0, i = 0;
2780 const char *curext = Nullch;
2783 # define MAX_EXT_LEN 0
2787 * If dosearch is true and if scriptname does not contain path
2788 * delimiters, search the PATH for scriptname.
2790 * If SEARCH_EXTS is also defined, will look for each
2791 * scriptname{SEARCH_EXTS} whenever scriptname is not found
2792 * while searching the PATH.
2794 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
2795 * proceeds as follows:
2796 * If DOSISH or VMSISH:
2797 * + look for ./scriptname{,.foo,.bar}
2798 * + search the PATH for scriptname{,.foo,.bar}
2801 * + look *only* in the PATH for scriptname{,.foo,.bar} (note
2802 * this will not look in '.' if it's not in the PATH)
2807 # ifdef ALWAYS_DEFTYPES
2808 len = strlen(scriptname);
2809 if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
2810 int hasdir, idx = 0, deftypes = 1;
2813 hasdir = !dosearch || (strpbrk(scriptname,":[</") != Nullch) ;
2816 int hasdir, idx = 0, deftypes = 1;
2819 hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
2821 /* The first time through, just add SEARCH_EXTS to whatever we
2822 * already have, so we can check for default file types. */
2824 (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
2830 if ((strlen(tmpbuf) + strlen(scriptname)
2831 + MAX_EXT_LEN) >= sizeof tmpbuf)
2832 continue; /* don't search dir with too-long name */
2833 strcat(tmpbuf, scriptname);
2837 if (strEQ(scriptname, "-"))
2839 if (dosearch) { /* Look in '.' first. */
2840 const char *cur = scriptname;
2842 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
2844 if (strEQ(ext[i++],curext)) {
2845 extidx = -1; /* already has an ext */
2850 DEBUG_p(PerlIO_printf(Perl_debug_log,
2851 "Looking for %s\n",cur));
2852 if (PerlLIO_stat(cur,&PL_statbuf) >= 0
2853 && !S_ISDIR(PL_statbuf.st_mode)) {
2861 if (cur == scriptname) {
2862 len = strlen(scriptname);
2863 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
2865 cur = strcpy(tmpbuf, scriptname);
2867 } while (extidx >= 0 && ext[extidx] /* try an extension? */
2868 && strcpy(tmpbuf+len, ext[extidx++]));
2873 #ifdef MACOS_TRADITIONAL
2874 if (dosearch && !strchr(scriptname, ':') &&
2875 (s = PerlEnv_getenv("Commands")))
2877 if (dosearch && !strchr(scriptname, '/')
2879 && !strchr(scriptname, '\\')
2881 && (s = PerlEnv_getenv("PATH")))
2886 PL_bufend = s + strlen(s);
2887 while (s < PL_bufend) {
2888 #ifdef MACOS_TRADITIONAL
2889 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
2893 #if defined(atarist) || defined(DOSISH)
2898 && *s != ';'; len++, s++) {
2899 if (len < sizeof tmpbuf)
2902 if (len < sizeof tmpbuf)
2904 #else /* ! (atarist || DOSISH) */
2905 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
2908 #endif /* ! (atarist || DOSISH) */
2909 #endif /* MACOS_TRADITIONAL */
2912 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
2913 continue; /* don't search dir with too-long name */
2914 #ifdef MACOS_TRADITIONAL
2915 if (len && tmpbuf[len - 1] != ':')
2916 tmpbuf[len++] = ':';
2919 #if defined(atarist) || defined(__MINT__) || defined(DOSISH)
2920 && tmpbuf[len - 1] != '/'
2921 && tmpbuf[len - 1] != '\\'
2924 tmpbuf[len++] = '/';
2925 if (len == 2 && tmpbuf[0] == '.')
2928 (void)strcpy(tmpbuf + len, scriptname);
2932 len = strlen(tmpbuf);
2933 if (extidx > 0) /* reset after previous loop */
2937 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
2938 retval = PerlLIO_stat(tmpbuf,&PL_statbuf);
2939 if (S_ISDIR(PL_statbuf.st_mode)) {
2943 } while ( retval < 0 /* not there */
2944 && extidx>=0 && ext[extidx] /* try an extension? */
2945 && strcpy(tmpbuf+len, ext[extidx++])
2950 if (S_ISREG(PL_statbuf.st_mode)
2951 && cando(S_IRUSR,TRUE,&PL_statbuf)
2952 #if !defined(DOSISH) && !defined(MACOS_TRADITIONAL)
2953 && cando(S_IXUSR,TRUE,&PL_statbuf)
2957 xfound = tmpbuf; /* bingo! */
2961 xfailed = savepv(tmpbuf);
2964 if (!xfound && !seen_dot && !xfailed &&
2965 (PerlLIO_stat(scriptname,&PL_statbuf) < 0
2966 || S_ISDIR(PL_statbuf.st_mode)))
2968 seen_dot = 1; /* Disable message. */
2970 if (flags & 1) { /* do or die? */
2971 Perl_croak(aTHX_ "Can't %s %s%s%s",
2972 (xfailed ? "execute" : "find"),
2973 (xfailed ? xfailed : scriptname),
2974 (xfailed ? "" : " on PATH"),
2975 (xfailed || seen_dot) ? "" : ", '.' not in PATH");
2977 scriptname = Nullch;
2981 scriptname = xfound;
2983 return (scriptname ? savepv(scriptname) : Nullch);
2986 #ifndef PERL_GET_CONTEXT_DEFINED
2989 Perl_get_context(void)
2992 #if defined(USE_ITHREADS)
2993 # ifdef OLD_PTHREADS_API
2995 if (pthread_getspecific(PL_thr_key, &t))
2996 Perl_croak_nocontext("panic: pthread_getspecific");
2999 # ifdef I_MACH_CTHREADS
3000 return (void*)cthread_data(cthread_self());
3002 return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
3011 Perl_set_context(void *t)
3014 #if defined(USE_ITHREADS)
3015 # ifdef I_MACH_CTHREADS
3016 cthread_set_data(cthread_self(), t);
3018 if (pthread_setspecific(PL_thr_key, t))
3019 Perl_croak_nocontext("panic: pthread_setspecific");
3026 #endif /* !PERL_GET_CONTEXT_DEFINED */
3028 #if defined(PERL_GLOBAL_STRUCT) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
3037 Perl_get_op_names(pTHX)
3039 return (char **)PL_op_name;
3043 Perl_get_op_descs(pTHX)
3045 return (char **)PL_op_desc;
3049 Perl_get_no_modify(pTHX)
3051 return PL_no_modify;
3055 Perl_get_opargs(pTHX)
3057 return (U32 *)PL_opargs;
3061 Perl_get_ppaddr(pTHX)
3064 return (PPADDR_t*)PL_ppaddr;
3067 #ifndef HAS_GETENV_LEN
3069 Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
3071 char *env_trans = PerlEnv_getenv(env_elem);
3073 *len = strlen(env_trans);
3080 Perl_get_vtbl(pTHX_ int vtbl_id)
3082 const MGVTBL* result = Null(MGVTBL*);
3086 result = &PL_vtbl_sv;
3089 result = &PL_vtbl_env;
3091 case want_vtbl_envelem:
3092 result = &PL_vtbl_envelem;
3095 result = &PL_vtbl_sig;
3097 case want_vtbl_sigelem:
3098 result = &PL_vtbl_sigelem;
3100 case want_vtbl_pack:
3101 result = &PL_vtbl_pack;
3103 case want_vtbl_packelem:
3104 result = &PL_vtbl_packelem;
3106 case want_vtbl_dbline:
3107 result = &PL_vtbl_dbline;
3110 result = &PL_vtbl_isa;
3112 case want_vtbl_isaelem:
3113 result = &PL_vtbl_isaelem;
3115 case want_vtbl_arylen:
3116 result = &PL_vtbl_arylen;
3118 case want_vtbl_glob:
3119 result = &PL_vtbl_glob;
3121 case want_vtbl_mglob:
3122 result = &PL_vtbl_mglob;
3124 case want_vtbl_nkeys:
3125 result = &PL_vtbl_nkeys;
3127 case want_vtbl_taint:
3128 result = &PL_vtbl_taint;
3130 case want_vtbl_substr:
3131 result = &PL_vtbl_substr;
3134 result = &PL_vtbl_vec;
3137 result = &PL_vtbl_pos;
3140 result = &PL_vtbl_bm;
3143 result = &PL_vtbl_fm;
3145 case want_vtbl_uvar:
3146 result = &PL_vtbl_uvar;
3148 case want_vtbl_defelem:
3149 result = &PL_vtbl_defelem;
3151 case want_vtbl_regexp:
3152 result = &PL_vtbl_regexp;
3154 case want_vtbl_regdata:
3155 result = &PL_vtbl_regdata;
3157 case want_vtbl_regdatum:
3158 result = &PL_vtbl_regdatum;
3160 #ifdef USE_LOCALE_COLLATE
3161 case want_vtbl_collxfrm:
3162 result = &PL_vtbl_collxfrm;
3165 case want_vtbl_amagic:
3166 result = &PL_vtbl_amagic;
3168 case want_vtbl_amagicelem:
3169 result = &PL_vtbl_amagicelem;
3171 case want_vtbl_backref:
3172 result = &PL_vtbl_backref;
3174 case want_vtbl_utf8:
3175 result = &PL_vtbl_utf8;
3178 return (MGVTBL*)result;
3182 Perl_my_fflush_all(pTHX)
3184 #if defined(USE_PERLIO) || defined(FFLUSH_NULL) || defined(USE_SFIO)
3185 return PerlIO_flush(NULL);
3187 # if defined(HAS__FWALK)
3188 extern int fflush(FILE *);
3189 /* undocumented, unprototyped, but very useful BSDism */
3190 extern void _fwalk(int (*)(FILE *));
3194 # if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
3196 # ifdef PERL_FFLUSH_ALL_FOPEN_MAX
3197 open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
3199 # if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
3200 open_max = sysconf(_SC_OPEN_MAX);
3203 open_max = FOPEN_MAX;
3206 open_max = OPEN_MAX;
3217 for (i = 0; i < open_max; i++)
3218 if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
3219 STDIO_STREAM_ARRAY[i]._file < open_max &&
3220 STDIO_STREAM_ARRAY[i]._flag)
3221 PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
3225 SETERRNO(EBADF,RMS_IFI);
3232 Perl_report_evil_fh(pTHX_ const GV *gv, const IO *io, I32 op)
3235 op == OP_READLINE ? "readline" : /* "<HANDLE>" not nice */
3236 op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */
3238 const char *pars = OP_IS_FILETEST(op) ? "" : "()";
3239 const char *type = OP_IS_SOCKET(op)
3240 || (gv && io && IoTYPE(io) == IoTYPE_SOCKET)
3241 ? "socket" : "filehandle";
3242 const char *name = NULL;
3244 if (gv && isGV(gv)) {
3248 if (op == OP_phoney_OUTPUT_ONLY || op == OP_phoney_INPUT_ONLY) {
3249 if (ckWARN(WARN_IO)) {
3250 const char *direction = (op == OP_phoney_INPUT_ONLY) ? "in" : "out";
3252 Perl_warner(aTHX_ packWARN(WARN_IO),
3253 "Filehandle %s opened only for %sput",
3256 Perl_warner(aTHX_ packWARN(WARN_IO),
3257 "Filehandle opened only for %sput", direction);
3264 if (gv && io && IoTYPE(io) == IoTYPE_CLOSED) {
3266 warn_type = WARN_CLOSED;
3270 warn_type = WARN_UNOPENED;
3273 if (ckWARN(warn_type)) {
3274 if (name && *name) {
3275 Perl_warner(aTHX_ packWARN(warn_type),
3276 "%s%s on %s %s %s", func, pars, vile, type, name);
3277 if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3279 aTHX_ packWARN(warn_type),
3280 "\t(Are you trying to call %s%s on dirhandle %s?)\n",
3285 Perl_warner(aTHX_ packWARN(warn_type),
3286 "%s%s on %s %s", func, pars, vile, type);
3287 if (gv && io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3289 aTHX_ packWARN(warn_type),
3290 "\t(Are you trying to call %s%s on dirhandle?)\n",
3299 /* in ASCII order, not that it matters */
3300 static const char controllablechars[] = "?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_";
3303 Perl_ebcdic_control(pTHX_ int ch)
3311 if ((ctlp = strchr(controllablechars, ch)) == 0) {
3312 Perl_die(aTHX_ "unrecognised control character '%c'\n", ch);
3315 if (ctlp == controllablechars)
3316 return('\177'); /* DEL */
3318 return((unsigned char)(ctlp - controllablechars - 1));
3319 } else { /* Want uncontrol */
3320 if (ch == '\177' || ch == -1)
3322 else if (ch == '\157')
3324 else if (ch == '\174')
3326 else if (ch == '^') /* '\137' in 1047, '\260' in 819 */
3328 else if (ch == '\155')
3330 else if (0 < ch && ch < (sizeof(controllablechars) - 1))
3331 return(controllablechars[ch+1]);
3333 Perl_die(aTHX_ "invalid control request: '\\%03o'\n", ch & 0xFF);
3338 /* To workaround core dumps from the uninitialised tm_zone we get the
3339 * system to give us a reasonable struct to copy. This fix means that
3340 * strftime uses the tm_zone and tm_gmtoff values returned by
3341 * localtime(time()). That should give the desired result most of the
3342 * time. But probably not always!
3344 * This does not address tzname aspects of NETaa14816.
3349 # ifndef STRUCT_TM_HASZONE
3350 # define STRUCT_TM_HASZONE
3354 #ifdef STRUCT_TM_HASZONE /* Backward compat */
3355 # ifndef HAS_TM_TM_ZONE
3356 # define HAS_TM_TM_ZONE
3361 Perl_init_tm(pTHX_ struct tm *ptm) /* see mktime, strftime and asctime */
3363 #ifdef HAS_TM_TM_ZONE
3367 my_tm = localtime(&now);
3369 Copy(my_tm, ptm, 1, struct tm);
3374 * mini_mktime - normalise struct tm values without the localtime()
3375 * semantics (and overhead) of mktime().
3378 Perl_mini_mktime(pTHX_ struct tm *ptm)
3382 int month, mday, year, jday;
3383 int odd_cent, odd_year;
3385 #define DAYS_PER_YEAR 365
3386 #define DAYS_PER_QYEAR (4*DAYS_PER_YEAR+1)
3387 #define DAYS_PER_CENT (25*DAYS_PER_QYEAR-1)
3388 #define DAYS_PER_QCENT (4*DAYS_PER_CENT+1)
3389 #define SECS_PER_HOUR (60*60)
3390 #define SECS_PER_DAY (24*SECS_PER_HOUR)
3391 /* parentheses deliberately absent on these two, otherwise they don't work */
3392 #define MONTH_TO_DAYS 153/5
3393 #define DAYS_TO_MONTH 5/153
3394 /* offset to bias by March (month 4) 1st between month/mday & year finding */
3395 #define YEAR_ADJUST (4*MONTH_TO_DAYS+1)
3396 /* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */
3397 #define WEEKDAY_BIAS 6 /* (1+6)%7 makes Sunday 0 again */
3400 * Year/day algorithm notes:
3402 * With a suitable offset for numeric value of the month, one can find
3403 * an offset into the year by considering months to have 30.6 (153/5) days,
3404 * using integer arithmetic (i.e., with truncation). To avoid too much
3405 * messing about with leap days, we consider January and February to be
3406 * the 13th and 14th month of the previous year. After that transformation,
3407 * we need the month index we use to be high by 1 from 'normal human' usage,
3408 * so the month index values we use run from 4 through 15.
3410 * Given that, and the rules for the Gregorian calendar (leap years are those
3411 * divisible by 4 unless also divisible by 100, when they must be divisible
3412 * by 400 instead), we can simply calculate the number of days since some
3413 * arbitrary 'beginning of time' by futzing with the (adjusted) year number,
3414 * the days we derive from our month index, and adding in the day of the
3415 * month. The value used here is not adjusted for the actual origin which
3416 * it normally would use (1 January A.D. 1), since we're not exposing it.
3417 * We're only building the value so we can turn around and get the
3418 * normalised values for the year, month, day-of-month, and day-of-year.
3420 * For going backward, we need to bias the value we're using so that we find
3421 * the right year value. (Basically, we don't want the contribution of
3422 * March 1st to the number to apply while deriving the year). Having done
3423 * that, we 'count up' the contribution to the year number by accounting for
3424 * full quadracenturies (400-year periods) with their extra leap days, plus
3425 * the contribution from full centuries (to avoid counting in the lost leap
3426 * days), plus the contribution from full quad-years (to count in the normal
3427 * leap days), plus the leftover contribution from any non-leap years.
3428 * At this point, if we were working with an actual leap day, we'll have 0
3429 * days left over. This is also true for March 1st, however. So, we have
3430 * to special-case that result, and (earlier) keep track of the 'odd'
3431 * century and year contributions. If we got 4 extra centuries in a qcent,
3432 * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb.
3433 * Otherwise, we add back in the earlier bias we removed (the 123 from
3434 * figuring in March 1st), find the month index (integer division by 30.6),
3435 * and the remainder is the day-of-month. We then have to convert back to
3436 * 'real' months (including fixing January and February from being 14/15 in
3437 * the previous year to being in the proper year). After that, to get
3438 * tm_yday, we work with the normalised year and get a new yearday value for
3439 * January 1st, which we subtract from the yearday value we had earlier,
3440 * representing the date we've re-built. This is done from January 1
3441 * because tm_yday is 0-origin.
3443 * Since POSIX time routines are only guaranteed to work for times since the
3444 * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm
3445 * applies Gregorian calendar rules even to dates before the 16th century
3446 * doesn't bother me. Besides, you'd need cultural context for a given
3447 * date to know whether it was Julian or Gregorian calendar, and that's
3448 * outside the scope for this routine. Since we convert back based on the
3449 * same rules we used to build the yearday, you'll only get strange results
3450 * for input which needed normalising, or for the 'odd' century years which
3451 * were leap years in the Julian calander but not in the Gregorian one.
3452 * I can live with that.
3454 * This algorithm also fails to handle years before A.D. 1 gracefully, but
3455 * that's still outside the scope for POSIX time manipulation, so I don't
3459 year = 1900 + ptm->tm_year;
3460 month = ptm->tm_mon;
3461 mday = ptm->tm_mday;
3462 /* allow given yday with no month & mday to dominate the result */
3463 if (ptm->tm_yday >= 0 && mday <= 0 && month <= 0) {
3466 jday = 1 + ptm->tm_yday;
3475 yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400;
3476 yearday += month*MONTH_TO_DAYS + mday + jday;
3478 * Note that we don't know when leap-seconds were or will be,
3479 * so we have to trust the user if we get something which looks
3480 * like a sensible leap-second. Wild values for seconds will
3481 * be rationalised, however.
3483 if ((unsigned) ptm->tm_sec <= 60) {
3490 secs += 60 * ptm->tm_min;
3491 secs += SECS_PER_HOUR * ptm->tm_hour;
3493 if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) {
3494 /* got negative remainder, but need positive time */
3495 /* back off an extra day to compensate */
3496 yearday += (secs/SECS_PER_DAY)-1;
3497 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1);
3500 yearday += (secs/SECS_PER_DAY);
3501 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY);
3504 else if (secs >= SECS_PER_DAY) {
3505 yearday += (secs/SECS_PER_DAY);
3506 secs %= SECS_PER_DAY;
3508 ptm->tm_hour = secs/SECS_PER_HOUR;
3509 secs %= SECS_PER_HOUR;
3510 ptm->tm_min = secs/60;
3512 ptm->tm_sec += secs;
3513 /* done with time of day effects */
3515 * The algorithm for yearday has (so far) left it high by 428.
3516 * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to
3517 * bias it by 123 while trying to figure out what year it
3518 * really represents. Even with this tweak, the reverse
3519 * translation fails for years before A.D. 0001.
3520 * It would still fail for Feb 29, but we catch that one below.
3522 jday = yearday; /* save for later fixup vis-a-vis Jan 1 */
3523 yearday -= YEAR_ADJUST;
3524 year = (yearday / DAYS_PER_QCENT) * 400;
3525 yearday %= DAYS_PER_QCENT;
3526 odd_cent = yearday / DAYS_PER_CENT;
3527 year += odd_cent * 100;
3528 yearday %= DAYS_PER_CENT;
3529 year += (yearday / DAYS_PER_QYEAR) * 4;
3530 yearday %= DAYS_PER_QYEAR;
3531 odd_year = yearday / DAYS_PER_YEAR;
3533 yearday %= DAYS_PER_YEAR;
3534 if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */
3539 yearday += YEAR_ADJUST; /* recover March 1st crock */
3540 month = yearday*DAYS_TO_MONTH;
3541 yearday -= month*MONTH_TO_DAYS;
3542 /* recover other leap-year adjustment */
3551 ptm->tm_year = year - 1900;
3553 ptm->tm_mday = yearday;
3554 ptm->tm_mon = month;
3558 ptm->tm_mon = month - 1;
3560 /* re-build yearday based on Jan 1 to get tm_yday */
3562 yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400;
3563 yearday += 14*MONTH_TO_DAYS + 1;
3564 ptm->tm_yday = jday - yearday;
3565 /* fix tm_wday if not overridden by caller */
3566 if ((unsigned)ptm->tm_wday > 6)
3567 ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
3571 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)
3579 init_tm(&mytm); /* XXX workaround - see init_tm() above */
3582 mytm.tm_hour = hour;
3583 mytm.tm_mday = mday;
3585 mytm.tm_year = year;
3586 mytm.tm_wday = wday;
3587 mytm.tm_yday = yday;
3588 mytm.tm_isdst = isdst;
3590 /* use libc to get the values for tm_gmtoff and tm_zone [perl #18238] */
3591 #if defined(HAS_MKTIME) && (defined(HAS_TM_TM_GMTOFF) || defined(HAS_TM_TM_ZONE))
3596 #ifdef HAS_TM_TM_GMTOFF
3597 mytm.tm_gmtoff = mytm2.tm_gmtoff;
3599 #ifdef HAS_TM_TM_ZONE
3600 mytm.tm_zone = mytm2.tm_zone;
3605 New(0, buf, buflen, char);
3606 len = strftime(buf, buflen, fmt, &mytm);
3608 ** The following is needed to handle to the situation where
3609 ** tmpbuf overflows. Basically we want to allocate a buffer
3610 ** and try repeatedly. The reason why it is so complicated
3611 ** is that getting a return value of 0 from strftime can indicate
3612 ** one of the following:
3613 ** 1. buffer overflowed,
3614 ** 2. illegal conversion specifier, or
3615 ** 3. the format string specifies nothing to be returned(not
3616 ** an error). This could be because format is an empty string
3617 ** or it specifies %p that yields an empty string in some locale.
3618 ** If there is a better way to make it portable, go ahead by
3621 if ((len > 0 && len < buflen) || (len == 0 && *fmt == '\0'))
3624 /* Possibly buf overflowed - try again with a bigger buf */
3625 const int fmtlen = strlen(fmt);
3626 const int bufsize = fmtlen + buflen;
3628 New(0, buf, bufsize, char);
3630 buflen = strftime(buf, bufsize, fmt, &mytm);
3631 if (buflen > 0 && buflen < bufsize)
3633 /* heuristic to prevent out-of-memory errors */
3634 if (bufsize > 100*fmtlen) {
3639 Renew(buf, bufsize*2, char);
3644 Perl_croak(aTHX_ "panic: no strftime");
3650 #define SV_CWD_RETURN_UNDEF \
3651 sv_setsv(sv, &PL_sv_undef); \
3654 #define SV_CWD_ISDOT(dp) \
3655 (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
3656 (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
3659 =head1 Miscellaneous Functions
3661 =for apidoc getcwd_sv
3663 Fill the sv with current working directory
3668 /* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars.
3669 * rewritten again by dougm, optimized for use with xs TARG, and to prefer
3670 * getcwd(3) if available
3671 * Comments from the orignal:
3672 * This is a faster version of getcwd. It's also more dangerous
3673 * because you might chdir out of a directory that you can't chdir
3677 Perl_getcwd_sv(pTHX_ register SV *sv)
3681 #ifndef INCOMPLETE_TAINTS
3687 char buf[MAXPATHLEN];
3689 /* Some getcwd()s automatically allocate a buffer of the given
3690 * size from the heap if they are given a NULL buffer pointer.
3691 * The problem is that this behaviour is not portable. */
3692 if (getcwd(buf, sizeof(buf) - 1)) {
3693 sv_setpvn(sv, buf, strlen(buf));
3697 sv_setsv(sv, &PL_sv_undef);
3705 int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
3709 (void)SvUPGRADE(sv, SVt_PV);
3711 if (PerlLIO_lstat(".", &statbuf) < 0) {
3712 SV_CWD_RETURN_UNDEF;
3715 orig_cdev = statbuf.st_dev;
3716 orig_cino = statbuf.st_ino;
3725 if (PerlDir_chdir("..") < 0) {
3726 SV_CWD_RETURN_UNDEF;
3728 if (PerlLIO_stat(".", &statbuf) < 0) {
3729 SV_CWD_RETURN_UNDEF;
3732 cdev = statbuf.st_dev;
3733 cino = statbuf.st_ino;
3735 if (odev == cdev && oino == cino) {
3738 if (!(dir = PerlDir_open("."))) {
3739 SV_CWD_RETURN_UNDEF;
3742 while ((dp = PerlDir_read(dir)) != NULL) {
3744 const int namelen = dp->d_namlen;
3746 const int namelen = strlen(dp->d_name);
3749 if (SV_CWD_ISDOT(dp)) {
3753 if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
3754 SV_CWD_RETURN_UNDEF;
3757 tdev = statbuf.st_dev;
3758 tino = statbuf.st_ino;
3759 if (tino == oino && tdev == odev) {
3765 SV_CWD_RETURN_UNDEF;
3768 if (pathlen + namelen + 1 >= MAXPATHLEN) {
3769 SV_CWD_RETURN_UNDEF;
3772 SvGROW(sv, pathlen + namelen + 1);
3776 Move(SvPVX_const(sv), SvPVX(sv) + namelen + 1, pathlen, char);
3779 /* prepend current directory to the front */
3781 Move(dp->d_name, SvPVX(sv)+1, namelen, char);
3782 pathlen += (namelen + 1);
3784 #ifdef VOID_CLOSEDIR
3787 if (PerlDir_close(dir) < 0) {
3788 SV_CWD_RETURN_UNDEF;
3794 SvCUR_set(sv, pathlen);
3798 if (PerlDir_chdir(SvPVX_const(sv)) < 0) {
3799 SV_CWD_RETURN_UNDEF;
3802 if (PerlLIO_stat(".", &statbuf) < 0) {
3803 SV_CWD_RETURN_UNDEF;
3806 cdev = statbuf.st_dev;
3807 cino = statbuf.st_ino;
3809 if (cdev != orig_cdev || cino != orig_cino) {
3810 Perl_croak(aTHX_ "Unstable directory path, "
3811 "current directory changed unexpectedly");
3823 =for apidoc scan_version
3825 Returns a pointer to the next character after the parsed
3826 version string, as well as upgrading the passed in SV to
3829 Function must be called with an already existing SV like
3832 s = scan_version(s,SV *sv, bool qv);
3834 Performs some preprocessing to the string to ensure that
3835 it has the correct characteristics of a version. Flags the
3836 object if it contains an underscore (which denotes this
3837 is a alpha version). The boolean qv denotes that the version
3838 should be interpreted as if it had multiple decimals, even if
3845 Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
3847 const char *start = s;
3848 const char *pos = s;
3851 SV* sv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
3852 (void)sv_upgrade(sv, SVt_PVAV); /* needs to be an AV type */
3855 /* pre-scan the imput string to check for decimals */
3856 while ( *pos == '.' || *pos == '_' || isDIGIT(*pos) )
3861 Perl_croak(aTHX_ "Invalid version format (underscores before decimal)");
3864 else if ( *pos == '_' )
3867 Perl_croak(aTHX_ "Invalid version format (multiple underscores)");
3875 pos++; /* get past 'v' */
3876 qv = 1; /* force quoted version processing */
3878 while (isDIGIT(*pos))
3880 if (!isALPHA(*pos)) {
3883 if (*s == 'v') s++; /* get past 'v' */
3888 /* this is atoi() that delimits on underscores */
3889 const char *end = pos;
3892 if ( s < pos && s > start && *(s-1) == '_' ) {
3893 mult *= -1; /* alpha version */
3895 /* the following if() will only be true after the decimal
3896 * point of a version originally created with a bare
3897 * floating point number, i.e. not quoted in any way
3899 if ( !qv && s > start+1 && saw_period == 1 ) {
3903 rev += (*s - '0') * mult;
3905 if ( PERL_ABS(orev) > PERL_ABS(rev) )
3906 Perl_croak(aTHX_ "Integer overflow in version");
3911 while (--end >= s) {
3913 rev += (*end - '0') * mult;
3915 if ( PERL_ABS(orev) > PERL_ABS(rev) )
3916 Perl_croak(aTHX_ "Integer overflow in version");
3921 /* Append revision */
3922 av_push((AV *)sv, newSViv(rev));
3923 if ( (*pos == '.' || *pos == '_') && isDIGIT(pos[1]))
3925 else if ( isDIGIT(*pos) )
3931 while ( isDIGIT(*pos) ) {
3932 if ( saw_period == 1 && pos-s == 3 )
3938 if ( qv ) { /* quoted versions always become full version objects */
3939 I32 len = av_len((AV *)sv);
3940 /* This for loop appears to trigger a compiler bug on OS X, as it
3941 loops infinitely. Yes, len is negative. No, it makes no sense.
3942 Compiler in question is:
3943 gcc version 3.3 20030304 (Apple Computer, Inc. build 1640)
3944 for ( len = 2 - len; len > 0; len-- )
3945 av_push((AV *)sv, newSViv(0));
3949 av_push((AV *)sv, newSViv(0));
3955 =for apidoc new_version
3957 Returns a new version object based on the passed in SV:
3959 SV *sv = new_version(SV *ver);
3961 Does not alter the passed in ver SV. See "upg_version" if you
3962 want to upgrade the SV.
3968 Perl_new_version(pTHX_ SV *ver)
3971 if ( sv_derived_from(ver,"version") ) /* can just copy directly */
3974 AV *av = (AV *)SvRV(ver);
3975 SV* sv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
3976 (void)sv_upgrade(sv, SVt_PVAV); /* needs to be an AV type */
3978 for ( key = 0; key <= av_len(av); key++ )
3980 const I32 rev = SvIV(*av_fetch(av, key, FALSE));
3981 av_push((AV *)sv, newSViv(rev));
3986 if ( SvVOK(ver) ) { /* already a v-string */
3988 MAGIC* mg = mg_find(ver,PERL_MAGIC_vstring);
3989 version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
3990 sv_setpv(rv,version);
3995 sv_setsv(rv,ver); /* make a duplicate */
4004 =for apidoc upg_version
4006 In-place upgrade of the supplied SV to a version object.
4008 SV *sv = upg_version(SV *sv);
4010 Returns a pointer to the upgraded SV.
4016 Perl_upg_version(pTHX_ SV *ver)
4021 if ( SvNOK(ver) ) /* may get too much accuracy */
4024 sprintf(tbuf,"%.9"NVgf, SvNVX(ver));
4025 version = savepv(tbuf);
4028 else if ( SvVOK(ver) ) { /* already a v-string */
4029 MAGIC* mg = mg_find(ver,PERL_MAGIC_vstring);
4030 version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
4034 else /* must be a string or something like a string */
4036 version = savesvpv(ver);
4038 (void)scan_version(version, ver, qv);
4047 Accepts a version object and returns the normalized floating
4048 point representation. Call like:
4052 NOTE: you can pass either the object directly or the SV
4053 contained within the RV.
4059 Perl_vnumify(pTHX_ SV *vs)
4065 len = av_len((AV *)vs);
4068 Perl_sv_catpv(aTHX_ sv,"0");
4071 digit = SvIVX(*av_fetch((AV *)vs, 0, 0));
4072 Perl_sv_setpvf(aTHX_ sv,"%d.", (int)PERL_ABS(digit));
4073 for ( i = 1 ; i < len ; i++ )
4075 digit = SvIVX(*av_fetch((AV *)vs, i, 0));
4076 Perl_sv_catpvf(aTHX_ sv,"%03d", (int)PERL_ABS(digit));
4081 digit = SvIVX(*av_fetch((AV *)vs, len, 0));
4082 if ( (int)PERL_ABS(digit) != 0 || len == 1 )
4084 if ( digit < 0 ) /* alpha version */
4085 Perl_sv_catpv(aTHX_ sv,"_");
4086 /* Don't display additional trailing zeros */
4087 Perl_sv_catpvf(aTHX_ sv,"%03d", (int)PERL_ABS(digit));
4092 Perl_sv_catpv(aTHX_ sv,"000");
4100 Accepts a version object and returns the normalized string
4101 representation. Call like:
4105 NOTE: you can pass either the object directly or the SV
4106 contained within the RV.
4112 Perl_vnormal(pTHX_ SV *vs)
4118 len = av_len((AV *)vs);
4121 Perl_sv_catpv(aTHX_ sv,"");
4124 digit = SvIVX(*av_fetch((AV *)vs, 0, 0));
4125 Perl_sv_setpvf(aTHX_ sv,"%"IVdf,(IV)digit);
4126 for ( i = 1 ; i <= len ; i++ )
4128 digit = SvIVX(*av_fetch((AV *)vs, i, 0));
4130 Perl_sv_catpvf(aTHX_ sv,"_%"IVdf,(IV)-digit);
4132 Perl_sv_catpvf(aTHX_ sv,".%"IVdf,(IV)digit);
4135 if ( len <= 2 ) { /* short version, must be at least three */
4136 for ( len = 2 - len; len != 0; len-- )
4137 Perl_sv_catpv(aTHX_ sv,".0");
4144 =for apidoc vstringify
4146 In order to maintain maximum compatibility with earlier versions
4147 of Perl, this function will return either the floating point
4148 notation or the multiple dotted notation, depending on whether
4149 the original version contained 1 or more dots, respectively
4155 Perl_vstringify(pTHX_ SV *vs)
4160 len = av_len((AV *)vs);
4161 digit = SvIVX(*av_fetch((AV *)vs, len, 0));
4163 if ( len < 2 || ( len == 2 && digit < 0 ) )
4172 Version object aware cmp. Both operands must already have been
4173 converted into version objects.
4179 Perl_vcmp(pTHX_ SV *lsv, SV *rsv)
4186 l = av_len((AV *)lsv);
4187 r = av_len((AV *)rsv);
4191 while ( i <= m && retval == 0 )
4193 I32 left = SvIV(*av_fetch((AV *)lsv,i,0));
4194 I32 right = SvIV(*av_fetch((AV *)rsv,i,0));
4195 bool lalpha = left < 0 ? 1 : 0;
4196 bool ralpha = right < 0 ? 1 : 0;
4199 if ( left < right || (left == right && lalpha && !ralpha) )
4201 if ( left > right || (left == right && ralpha && !lalpha) )
4206 if ( l != r && retval == 0 ) /* possible match except for trailing 0's */
4210 while ( i <= r && retval == 0 )
4212 if ( SvIV(*av_fetch((AV *)rsv,i,0)) != 0 )
4213 retval = -1; /* not a match after all */
4219 while ( i <= l && retval == 0 )
4221 if ( SvIV(*av_fetch((AV *)lsv,i,0)) != 0 )
4222 retval = +1; /* not a match after all */
4230 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT)
4231 # define EMULATE_SOCKETPAIR_UDP
4234 #ifdef EMULATE_SOCKETPAIR_UDP
4236 S_socketpair_udp (int fd[2]) {
4238 /* Fake a datagram socketpair using UDP to localhost. */
4239 int sockets[2] = {-1, -1};
4240 struct sockaddr_in addresses[2];
4242 Sock_size_t size = sizeof(struct sockaddr_in);
4243 unsigned short port;
4246 memset(&addresses, 0, sizeof(addresses));
4249 sockets[i] = PerlSock_socket(AF_INET, SOCK_DGRAM, PF_INET);
4250 if (sockets[i] == -1)
4251 goto tidy_up_and_fail;
4253 addresses[i].sin_family = AF_INET;
4254 addresses[i].sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4255 addresses[i].sin_port = 0; /* kernel choses port. */
4256 if (PerlSock_bind(sockets[i], (struct sockaddr *) &addresses[i],
4257 sizeof(struct sockaddr_in)) == -1)
4258 goto tidy_up_and_fail;
4261 /* Now have 2 UDP sockets. Find out which port each is connected to, and
4262 for each connect the other socket to it. */
4265 if (PerlSock_getsockname(sockets[i], (struct sockaddr *) &addresses[i],
4267 goto tidy_up_and_fail;
4268 if (size != sizeof(struct sockaddr_in))
4269 goto abort_tidy_up_and_fail;
4270 /* !1 is 0, !0 is 1 */
4271 if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i],
4272 sizeof(struct sockaddr_in)) == -1)
4273 goto tidy_up_and_fail;
4276 /* Now we have 2 sockets connected to each other. I don't trust some other
4277 process not to have already sent a packet to us (by random) so send
4278 a packet from each to the other. */
4281 /* I'm going to send my own port number. As a short.
4282 (Who knows if someone somewhere has sin_port as a bitfield and needs
4283 this routine. (I'm assuming crays have socketpair)) */
4284 port = addresses[i].sin_port;
4285 got = PerlLIO_write(sockets[i], &port, sizeof(port));
4286 if (got != sizeof(port)) {
4288 goto tidy_up_and_fail;
4289 goto abort_tidy_up_and_fail;
4293 /* Packets sent. I don't trust them to have arrived though.
4294 (As I understand it Solaris TCP stack is multithreaded. Non-blocking
4295 connect to localhost will use a second kernel thread. In 2.6 the
4296 first thread running the connect() returns before the second completes,
4297 so EINPROGRESS> In 2.7 the improved stack is faster and connect()
4298 returns 0. Poor programs have tripped up. One poor program's authors'
4299 had a 50-1 reverse stock split. Not sure how connected these were.)
4300 So I don't trust someone not to have an unpredictable UDP stack.
4304 struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */
4305 int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0];
4309 FD_SET(sockets[0], &rset);
4310 FD_SET(sockets[1], &rset);
4312 got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor);
4313 if (got != 2 || !FD_ISSET(sockets[0], &rset)
4314 || !FD_ISSET(sockets[1], &rset)) {
4315 /* I hope this is portable and appropriate. */
4317 goto tidy_up_and_fail;
4318 goto abort_tidy_up_and_fail;
4322 /* And the paranoia department even now doesn't trust it to have arrive
4323 (hence MSG_DONTWAIT). Or that what arrives was sent by us. */
4325 struct sockaddr_in readfrom;
4326 unsigned short buffer[2];
4331 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4332 sizeof(buffer), MSG_DONTWAIT,
4333 (struct sockaddr *) &readfrom, &size);
4335 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4337 (struct sockaddr *) &readfrom, &size);
4341 goto tidy_up_and_fail;
4342 if (got != sizeof(port)
4343 || size != sizeof(struct sockaddr_in)
4344 /* Check other socket sent us its port. */
4345 || buffer[0] != (unsigned short) addresses[!i].sin_port
4346 /* Check kernel says we got the datagram from that socket */
4347 || readfrom.sin_family != addresses[!i].sin_family
4348 || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr
4349 || readfrom.sin_port != addresses[!i].sin_port)
4350 goto abort_tidy_up_and_fail;
4353 /* My caller (my_socketpair) has validated that this is non-NULL */
4356 /* I hereby declare this connection open. May God bless all who cross
4360 abort_tidy_up_and_fail:
4361 errno = ECONNABORTED;
4364 const int save_errno = errno;
4365 if (sockets[0] != -1)
4366 PerlLIO_close(sockets[0]);
4367 if (sockets[1] != -1)
4368 PerlLIO_close(sockets[1]);
4373 #endif /* EMULATE_SOCKETPAIR_UDP */
4375 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET)
4377 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4378 /* Stevens says that family must be AF_LOCAL, protocol 0.
4379 I'm going to enforce that, then ignore it, and use TCP (or UDP). */
4384 struct sockaddr_in listen_addr;
4385 struct sockaddr_in connect_addr;
4390 || family != AF_UNIX
4393 errno = EAFNOSUPPORT;
4401 #ifdef EMULATE_SOCKETPAIR_UDP
4402 if (type == SOCK_DGRAM)
4403 return S_socketpair_udp(fd);
4406 listener = PerlSock_socket(AF_INET, type, 0);
4409 memset(&listen_addr, 0, sizeof(listen_addr));
4410 listen_addr.sin_family = AF_INET;
4411 listen_addr.sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4412 listen_addr.sin_port = 0; /* kernel choses port. */
4413 if (PerlSock_bind(listener, (struct sockaddr *) &listen_addr,
4414 sizeof(listen_addr)) == -1)
4415 goto tidy_up_and_fail;
4416 if (PerlSock_listen(listener, 1) == -1)
4417 goto tidy_up_and_fail;
4419 connector = PerlSock_socket(AF_INET, type, 0);
4420 if (connector == -1)
4421 goto tidy_up_and_fail;
4422 /* We want to find out the port number to connect to. */
4423 size = sizeof(connect_addr);
4424 if (PerlSock_getsockname(listener, (struct sockaddr *) &connect_addr,
4426 goto tidy_up_and_fail;
4427 if (size != sizeof(connect_addr))
4428 goto abort_tidy_up_and_fail;
4429 if (PerlSock_connect(connector, (struct sockaddr *) &connect_addr,
4430 sizeof(connect_addr)) == -1)
4431 goto tidy_up_and_fail;
4433 size = sizeof(listen_addr);
4434 acceptor = PerlSock_accept(listener, (struct sockaddr *) &listen_addr,
4437 goto tidy_up_and_fail;
4438 if (size != sizeof(listen_addr))
4439 goto abort_tidy_up_and_fail;
4440 PerlLIO_close(listener);
4441 /* Now check we are talking to ourself by matching port and host on the
4443 if (PerlSock_getsockname(connector, (struct sockaddr *) &connect_addr,
4445 goto tidy_up_and_fail;
4446 if (size != sizeof(connect_addr)
4447 || listen_addr.sin_family != connect_addr.sin_family
4448 || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr
4449 || listen_addr.sin_port != connect_addr.sin_port) {
4450 goto abort_tidy_up_and_fail;
4456 abort_tidy_up_and_fail:
4458 errno = ECONNABORTED; /* This would be the standard thing to do. */
4460 # ifdef ECONNREFUSED
4461 errno = ECONNREFUSED; /* E.g. Symbian does not have ECONNABORTED. */
4463 errno = ETIMEDOUT; /* Desperation time. */
4468 int save_errno = errno;
4470 PerlLIO_close(listener);
4471 if (connector != -1)
4472 PerlLIO_close(connector);
4474 PerlLIO_close(acceptor);
4480 /* In any case have a stub so that there's code corresponding
4481 * to the my_socketpair in global.sym. */
4483 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4484 #ifdef HAS_SOCKETPAIR
4485 return socketpair(family, type, protocol, fd);
4494 =for apidoc sv_nosharing
4496 Dummy routine which "shares" an SV when there is no sharing module present.
4497 Exists to avoid test for a NULL function pointer and because it could potentially warn under
4498 some level of strict-ness.
4504 Perl_sv_nosharing(pTHX_ SV *sv)
4510 =for apidoc sv_nolocking
4512 Dummy routine which "locks" an SV when there is no locking module present.
4513 Exists to avoid test for a NULL function pointer and because it could potentially warn under
4514 some level of strict-ness.
4520 Perl_sv_nolocking(pTHX_ SV *sv)
4527 =for apidoc sv_nounlocking
4529 Dummy routine which "unlocks" an SV when there is no locking module present.
4530 Exists to avoid test for a NULL function pointer and because it could potentially warn under
4531 some level of strict-ness.
4537 Perl_sv_nounlocking(pTHX_ SV *sv)
4543 Perl_parse_unicode_opts(pTHX_ const char **popt)
4545 const char *p = *popt;
4550 opt = (U32) atoi(p);
4551 while (isDIGIT(*p)) p++;
4552 if (*p && *p != '\n' && *p != '\r')
4553 Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
4558 case PERL_UNICODE_STDIN:
4559 opt |= PERL_UNICODE_STDIN_FLAG; break;
4560 case PERL_UNICODE_STDOUT:
4561 opt |= PERL_UNICODE_STDOUT_FLAG; break;
4562 case PERL_UNICODE_STDERR:
4563 opt |= PERL_UNICODE_STDERR_FLAG; break;
4564 case PERL_UNICODE_STD:
4565 opt |= PERL_UNICODE_STD_FLAG; break;
4566 case PERL_UNICODE_IN:
4567 opt |= PERL_UNICODE_IN_FLAG; break;
4568 case PERL_UNICODE_OUT:
4569 opt |= PERL_UNICODE_OUT_FLAG; break;
4570 case PERL_UNICODE_INOUT:
4571 opt |= PERL_UNICODE_INOUT_FLAG; break;
4572 case PERL_UNICODE_LOCALE:
4573 opt |= PERL_UNICODE_LOCALE_FLAG; break;
4574 case PERL_UNICODE_ARGV:
4575 opt |= PERL_UNICODE_ARGV_FLAG; break;
4577 if (*p != '\n' && *p != '\r')
4579 "Unknown Unicode option letter '%c'", *p);
4585 opt = PERL_UNICODE_DEFAULT_FLAGS;
4587 if (opt & ~PERL_UNICODE_ALL_FLAGS)
4588 Perl_croak(aTHX_ "Unknown Unicode option value %"UVuf,
4589 (UV) (opt & ~PERL_UNICODE_ALL_FLAGS));
4600 * This is really just a quick hack which grabs various garbage
4601 * values. It really should be a real hash algorithm which
4602 * spreads the effect of every input bit onto every output bit,
4603 * if someone who knows about such things would bother to write it.
4604 * Might be a good idea to add that function to CORE as well.
4605 * No numbers below come from careful analysis or anything here,
4606 * except they are primes and SEED_C1 > 1E6 to get a full-width
4607 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
4608 * probably be bigger too.
4611 # define SEED_C1 1000003
4612 #define SEED_C4 73819
4614 # define SEED_C1 25747
4615 #define SEED_C4 20639
4619 #define SEED_C5 26107
4621 #ifndef PERL_NO_DEV_RANDOM
4626 # include <starlet.h>
4627 /* when[] = (low 32 bits, high 32 bits) of time since epoch
4628 * in 100-ns units, typically incremented ever 10 ms. */
4629 unsigned int when[2];
4631 # ifdef HAS_GETTIMEOFDAY
4632 struct timeval when;
4638 /* This test is an escape hatch, this symbol isn't set by Configure. */
4639 #ifndef PERL_NO_DEV_RANDOM
4640 #ifndef PERL_RANDOM_DEVICE
4641 /* /dev/random isn't used by default because reads from it will block
4642 * if there isn't enough entropy available. You can compile with
4643 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
4644 * is enough real entropy to fill the seed. */
4645 # define PERL_RANDOM_DEVICE "/dev/urandom"
4647 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
4649 if (PerlLIO_read(fd, (void*)&u, sizeof u) != sizeof u)
4658 _ckvmssts(sys$gettim(when));
4659 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
4661 # ifdef HAS_GETTIMEOFDAY
4662 PerlProc_gettimeofday(&when,NULL);
4663 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
4666 u = (U32)SEED_C1 * when;
4669 u += SEED_C3 * (U32)PerlProc_getpid();
4670 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
4671 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
4672 u += SEED_C5 * (U32)PTR2UV(&when);
4678 Perl_get_hash_seed(pTHX)
4680 const char *s = PerlEnv_getenv("PERL_HASH_SEED");
4684 while (isSPACE(*s)) s++;
4685 if (s && isDIGIT(*s))
4686 myseed = (UV)Atoul(s);
4688 #ifdef USE_HASH_SEED_EXPLICIT
4692 /* Compute a random seed */
4693 (void)seedDrand01((Rand_seed_t)seed());
4694 myseed = (UV)(Drand01() * (NV)UV_MAX);
4695 #if RANDBITS < (UVSIZE * 8)
4696 /* Since there are not enough randbits to to reach all
4697 * the bits of a UV, the low bits might need extra
4698 * help. Sum in another random number that will
4699 * fill in the low bits. */
4701 (UV)(Drand01() * (NV)((1 << ((UVSIZE * 8 - RANDBITS))) - 1));
4702 #endif /* RANDBITS < (UVSIZE * 8) */
4703 if (myseed == 0) { /* Superparanoia. */
4704 myseed = (UV)(Drand01() * (NV)UV_MAX); /* One more chance. */
4706 Perl_croak(aTHX_ "Your random numbers are not that random");
4709 PL_rehash_seed_set = TRUE;
4714 #ifdef PERL_GLOBAL_STRUCT
4717 Perl_init_global_struct(pTHX)
4719 struct perl_vars *plvarsp = NULL;
4720 #ifdef PERL_GLOBAL_STRUCT
4721 # define PERL_GLOBAL_STRUCT_INIT
4722 # include "opcode.h" /* the ppaddr and check */
4723 IV nppaddr = sizeof(Gppaddr)/sizeof(Perl_ppaddr_t);
4724 IV ncheck = sizeof(Gcheck) /sizeof(Perl_check_t);
4725 # ifdef PERL_GLOBAL_STRUCT_PRIVATE
4726 /* PerlMem_malloc() because can't use even safesysmalloc() this early. */
4727 plvarsp = (struct perl_vars*)PerlMem_malloc(sizeof(struct perl_vars));
4731 plvarsp = PL_VarsPtr;
4732 # endif /* PERL_GLOBAL_STRUCT_PRIVATE */
4738 # define PERLVAR(var,type) /**/
4739 # define PERLVARA(var,n,type) /**/
4740 # define PERLVARI(var,type,init) plvarsp->var = init;
4741 # define PERLVARIC(var,type,init) plvarsp->var = init;
4742 # define PERLVARISC(var,init) Copy(init, plvarsp->var, sizeof(init), char);
4743 # include "perlvars.h"
4749 # ifdef PERL_GLOBAL_STRUCT
4750 plvarsp->Gppaddr = PerlMem_malloc(nppaddr * sizeof(Perl_ppaddr_t));
4751 if (!plvarsp->Gppaddr)
4753 plvarsp->Gcheck = PerlMem_malloc(ncheck * sizeof(Perl_check_t));
4754 if (!plvarsp->Gcheck)
4756 Copy(Gppaddr, plvarsp->Gppaddr, nppaddr, Perl_ppaddr_t);
4757 Copy(Gcheck, plvarsp->Gcheck, ncheck, Perl_check_t);
4759 # ifdef PERL_SET_VARS
4760 PERL_SET_VARS(plvarsp);
4762 # undef PERL_GLOBAL_STRUCT_INIT
4767 #endif /* PERL_GLOBAL_STRUCT */
4769 #ifdef PERL_GLOBAL_STRUCT
4772 Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp)
4774 #ifdef PERL_GLOBAL_STRUCT
4775 # ifdef PERL_UNSET_VARS
4776 PERL_UNSET_VARS(plvarsp);
4778 free(plvarsp->Gppaddr);
4779 free(plvarsp->Gcheck);
4780 # ifdef PERL_GLOBAL_STRUCT_PRIVATE
4786 #endif /* PERL_GLOBAL_STRUCT */
4790 * c-indentation-style: bsd
4792 * indent-tabs-mode: t
4795 * ex: set ts=8 sts=4 sw=4 noet: