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_setpv(tmpsv, ".");
2740 sv_setpvn(tmpsv, a, fa - a);
2741 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0)
2744 sv_setpv(tmpsv, ".");
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");
3024 #endif /* !PERL_GET_CONTEXT_DEFINED */
3026 #if defined(PERL_GLOBAL_STRUCT) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
3035 Perl_get_op_names(pTHX)
3037 return (char **)PL_op_name;
3041 Perl_get_op_descs(pTHX)
3043 return (char **)PL_op_desc;
3047 Perl_get_no_modify(pTHX)
3049 return PL_no_modify;
3053 Perl_get_opargs(pTHX)
3055 return (U32 *)PL_opargs;
3059 Perl_get_ppaddr(pTHX)
3062 return (PPADDR_t*)PL_ppaddr;
3065 #ifndef HAS_GETENV_LEN
3067 Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
3069 char *env_trans = PerlEnv_getenv(env_elem);
3071 *len = strlen(env_trans);
3078 Perl_get_vtbl(pTHX_ int vtbl_id)
3080 const MGVTBL* result = Null(MGVTBL*);
3084 result = &PL_vtbl_sv;
3087 result = &PL_vtbl_env;
3089 case want_vtbl_envelem:
3090 result = &PL_vtbl_envelem;
3093 result = &PL_vtbl_sig;
3095 case want_vtbl_sigelem:
3096 result = &PL_vtbl_sigelem;
3098 case want_vtbl_pack:
3099 result = &PL_vtbl_pack;
3101 case want_vtbl_packelem:
3102 result = &PL_vtbl_packelem;
3104 case want_vtbl_dbline:
3105 result = &PL_vtbl_dbline;
3108 result = &PL_vtbl_isa;
3110 case want_vtbl_isaelem:
3111 result = &PL_vtbl_isaelem;
3113 case want_vtbl_arylen:
3114 result = &PL_vtbl_arylen;
3116 case want_vtbl_glob:
3117 result = &PL_vtbl_glob;
3119 case want_vtbl_mglob:
3120 result = &PL_vtbl_mglob;
3122 case want_vtbl_nkeys:
3123 result = &PL_vtbl_nkeys;
3125 case want_vtbl_taint:
3126 result = &PL_vtbl_taint;
3128 case want_vtbl_substr:
3129 result = &PL_vtbl_substr;
3132 result = &PL_vtbl_vec;
3135 result = &PL_vtbl_pos;
3138 result = &PL_vtbl_bm;
3141 result = &PL_vtbl_fm;
3143 case want_vtbl_uvar:
3144 result = &PL_vtbl_uvar;
3146 case want_vtbl_defelem:
3147 result = &PL_vtbl_defelem;
3149 case want_vtbl_regexp:
3150 result = &PL_vtbl_regexp;
3152 case want_vtbl_regdata:
3153 result = &PL_vtbl_regdata;
3155 case want_vtbl_regdatum:
3156 result = &PL_vtbl_regdatum;
3158 #ifdef USE_LOCALE_COLLATE
3159 case want_vtbl_collxfrm:
3160 result = &PL_vtbl_collxfrm;
3163 case want_vtbl_amagic:
3164 result = &PL_vtbl_amagic;
3166 case want_vtbl_amagicelem:
3167 result = &PL_vtbl_amagicelem;
3169 case want_vtbl_backref:
3170 result = &PL_vtbl_backref;
3172 case want_vtbl_utf8:
3173 result = &PL_vtbl_utf8;
3176 return (MGVTBL*)result;
3180 Perl_my_fflush_all(pTHX)
3182 #if defined(USE_PERLIO) || defined(FFLUSH_NULL) || defined(USE_SFIO)
3183 return PerlIO_flush(NULL);
3185 # if defined(HAS__FWALK)
3186 extern int fflush(FILE *);
3187 /* undocumented, unprototyped, but very useful BSDism */
3188 extern void _fwalk(int (*)(FILE *));
3192 # if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
3194 # ifdef PERL_FFLUSH_ALL_FOPEN_MAX
3195 open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
3197 # if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
3198 open_max = sysconf(_SC_OPEN_MAX);
3201 open_max = FOPEN_MAX;
3204 open_max = OPEN_MAX;
3215 for (i = 0; i < open_max; i++)
3216 if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
3217 STDIO_STREAM_ARRAY[i]._file < open_max &&
3218 STDIO_STREAM_ARRAY[i]._flag)
3219 PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
3223 SETERRNO(EBADF,RMS_IFI);
3230 Perl_report_evil_fh(pTHX_ const GV *gv, const IO *io, I32 op)
3233 op == OP_READLINE ? "readline" : /* "<HANDLE>" not nice */
3234 op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */
3236 const char *pars = OP_IS_FILETEST(op) ? "" : "()";
3237 const char *type = OP_IS_SOCKET(op)
3238 || (gv && io && IoTYPE(io) == IoTYPE_SOCKET)
3239 ? "socket" : "filehandle";
3240 const char *name = NULL;
3242 if (gv && isGV(gv)) {
3246 if (op == OP_phoney_OUTPUT_ONLY || op == OP_phoney_INPUT_ONLY) {
3247 if (ckWARN(WARN_IO)) {
3248 const char *direction = (op == OP_phoney_INPUT_ONLY) ? "in" : "out";
3250 Perl_warner(aTHX_ packWARN(WARN_IO),
3251 "Filehandle %s opened only for %sput",
3254 Perl_warner(aTHX_ packWARN(WARN_IO),
3255 "Filehandle opened only for %sput", direction);
3262 if (gv && io && IoTYPE(io) == IoTYPE_CLOSED) {
3264 warn_type = WARN_CLOSED;
3268 warn_type = WARN_UNOPENED;
3271 if (ckWARN(warn_type)) {
3272 if (name && *name) {
3273 Perl_warner(aTHX_ packWARN(warn_type),
3274 "%s%s on %s %s %s", func, pars, vile, type, name);
3275 if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3277 aTHX_ packWARN(warn_type),
3278 "\t(Are you trying to call %s%s on dirhandle %s?)\n",
3283 Perl_warner(aTHX_ packWARN(warn_type),
3284 "%s%s on %s %s", func, pars, vile, type);
3285 if (gv && io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3287 aTHX_ packWARN(warn_type),
3288 "\t(Are you trying to call %s%s on dirhandle?)\n",
3297 /* in ASCII order, not that it matters */
3298 static const char controllablechars[] = "?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_";
3301 Perl_ebcdic_control(pTHX_ int ch)
3309 if ((ctlp = strchr(controllablechars, ch)) == 0) {
3310 Perl_die(aTHX_ "unrecognised control character '%c'\n", ch);
3313 if (ctlp == controllablechars)
3314 return('\177'); /* DEL */
3316 return((unsigned char)(ctlp - controllablechars - 1));
3317 } else { /* Want uncontrol */
3318 if (ch == '\177' || ch == -1)
3320 else if (ch == '\157')
3322 else if (ch == '\174')
3324 else if (ch == '^') /* '\137' in 1047, '\260' in 819 */
3326 else if (ch == '\155')
3328 else if (0 < ch && ch < (sizeof(controllablechars) - 1))
3329 return(controllablechars[ch+1]);
3331 Perl_die(aTHX_ "invalid control request: '\\%03o'\n", ch & 0xFF);
3336 /* To workaround core dumps from the uninitialised tm_zone we get the
3337 * system to give us a reasonable struct to copy. This fix means that
3338 * strftime uses the tm_zone and tm_gmtoff values returned by
3339 * localtime(time()). That should give the desired result most of the
3340 * time. But probably not always!
3342 * This does not address tzname aspects of NETaa14816.
3347 # ifndef STRUCT_TM_HASZONE
3348 # define STRUCT_TM_HASZONE
3352 #ifdef STRUCT_TM_HASZONE /* Backward compat */
3353 # ifndef HAS_TM_TM_ZONE
3354 # define HAS_TM_TM_ZONE
3359 Perl_init_tm(pTHX_ struct tm *ptm) /* see mktime, strftime and asctime */
3361 #ifdef HAS_TM_TM_ZONE
3365 my_tm = localtime(&now);
3367 Copy(my_tm, ptm, 1, struct tm);
3372 * mini_mktime - normalise struct tm values without the localtime()
3373 * semantics (and overhead) of mktime().
3376 Perl_mini_mktime(pTHX_ struct tm *ptm)
3380 int month, mday, year, jday;
3381 int odd_cent, odd_year;
3383 #define DAYS_PER_YEAR 365
3384 #define DAYS_PER_QYEAR (4*DAYS_PER_YEAR+1)
3385 #define DAYS_PER_CENT (25*DAYS_PER_QYEAR-1)
3386 #define DAYS_PER_QCENT (4*DAYS_PER_CENT+1)
3387 #define SECS_PER_HOUR (60*60)
3388 #define SECS_PER_DAY (24*SECS_PER_HOUR)
3389 /* parentheses deliberately absent on these two, otherwise they don't work */
3390 #define MONTH_TO_DAYS 153/5
3391 #define DAYS_TO_MONTH 5/153
3392 /* offset to bias by March (month 4) 1st between month/mday & year finding */
3393 #define YEAR_ADJUST (4*MONTH_TO_DAYS+1)
3394 /* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */
3395 #define WEEKDAY_BIAS 6 /* (1+6)%7 makes Sunday 0 again */
3398 * Year/day algorithm notes:
3400 * With a suitable offset for numeric value of the month, one can find
3401 * an offset into the year by considering months to have 30.6 (153/5) days,
3402 * using integer arithmetic (i.e., with truncation). To avoid too much
3403 * messing about with leap days, we consider January and February to be
3404 * the 13th and 14th month of the previous year. After that transformation,
3405 * we need the month index we use to be high by 1 from 'normal human' usage,
3406 * so the month index values we use run from 4 through 15.
3408 * Given that, and the rules for the Gregorian calendar (leap years are those
3409 * divisible by 4 unless also divisible by 100, when they must be divisible
3410 * by 400 instead), we can simply calculate the number of days since some
3411 * arbitrary 'beginning of time' by futzing with the (adjusted) year number,
3412 * the days we derive from our month index, and adding in the day of the
3413 * month. The value used here is not adjusted for the actual origin which
3414 * it normally would use (1 January A.D. 1), since we're not exposing it.
3415 * We're only building the value so we can turn around and get the
3416 * normalised values for the year, month, day-of-month, and day-of-year.
3418 * For going backward, we need to bias the value we're using so that we find
3419 * the right year value. (Basically, we don't want the contribution of
3420 * March 1st to the number to apply while deriving the year). Having done
3421 * that, we 'count up' the contribution to the year number by accounting for
3422 * full quadracenturies (400-year periods) with their extra leap days, plus
3423 * the contribution from full centuries (to avoid counting in the lost leap
3424 * days), plus the contribution from full quad-years (to count in the normal
3425 * leap days), plus the leftover contribution from any non-leap years.
3426 * At this point, if we were working with an actual leap day, we'll have 0
3427 * days left over. This is also true for March 1st, however. So, we have
3428 * to special-case that result, and (earlier) keep track of the 'odd'
3429 * century and year contributions. If we got 4 extra centuries in a qcent,
3430 * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb.
3431 * Otherwise, we add back in the earlier bias we removed (the 123 from
3432 * figuring in March 1st), find the month index (integer division by 30.6),
3433 * and the remainder is the day-of-month. We then have to convert back to
3434 * 'real' months (including fixing January and February from being 14/15 in
3435 * the previous year to being in the proper year). After that, to get
3436 * tm_yday, we work with the normalised year and get a new yearday value for
3437 * January 1st, which we subtract from the yearday value we had earlier,
3438 * representing the date we've re-built. This is done from January 1
3439 * because tm_yday is 0-origin.
3441 * Since POSIX time routines are only guaranteed to work for times since the
3442 * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm
3443 * applies Gregorian calendar rules even to dates before the 16th century
3444 * doesn't bother me. Besides, you'd need cultural context for a given
3445 * date to know whether it was Julian or Gregorian calendar, and that's
3446 * outside the scope for this routine. Since we convert back based on the
3447 * same rules we used to build the yearday, you'll only get strange results
3448 * for input which needed normalising, or for the 'odd' century years which
3449 * were leap years in the Julian calander but not in the Gregorian one.
3450 * I can live with that.
3452 * This algorithm also fails to handle years before A.D. 1 gracefully, but
3453 * that's still outside the scope for POSIX time manipulation, so I don't
3457 year = 1900 + ptm->tm_year;
3458 month = ptm->tm_mon;
3459 mday = ptm->tm_mday;
3460 /* allow given yday with no month & mday to dominate the result */
3461 if (ptm->tm_yday >= 0 && mday <= 0 && month <= 0) {
3464 jday = 1 + ptm->tm_yday;
3473 yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400;
3474 yearday += month*MONTH_TO_DAYS + mday + jday;
3476 * Note that we don't know when leap-seconds were or will be,
3477 * so we have to trust the user if we get something which looks
3478 * like a sensible leap-second. Wild values for seconds will
3479 * be rationalised, however.
3481 if ((unsigned) ptm->tm_sec <= 60) {
3488 secs += 60 * ptm->tm_min;
3489 secs += SECS_PER_HOUR * ptm->tm_hour;
3491 if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) {
3492 /* got negative remainder, but need positive time */
3493 /* back off an extra day to compensate */
3494 yearday += (secs/SECS_PER_DAY)-1;
3495 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1);
3498 yearday += (secs/SECS_PER_DAY);
3499 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY);
3502 else if (secs >= SECS_PER_DAY) {
3503 yearday += (secs/SECS_PER_DAY);
3504 secs %= SECS_PER_DAY;
3506 ptm->tm_hour = secs/SECS_PER_HOUR;
3507 secs %= SECS_PER_HOUR;
3508 ptm->tm_min = secs/60;
3510 ptm->tm_sec += secs;
3511 /* done with time of day effects */
3513 * The algorithm for yearday has (so far) left it high by 428.
3514 * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to
3515 * bias it by 123 while trying to figure out what year it
3516 * really represents. Even with this tweak, the reverse
3517 * translation fails for years before A.D. 0001.
3518 * It would still fail for Feb 29, but we catch that one below.
3520 jday = yearday; /* save for later fixup vis-a-vis Jan 1 */
3521 yearday -= YEAR_ADJUST;
3522 year = (yearday / DAYS_PER_QCENT) * 400;
3523 yearday %= DAYS_PER_QCENT;
3524 odd_cent = yearday / DAYS_PER_CENT;
3525 year += odd_cent * 100;
3526 yearday %= DAYS_PER_CENT;
3527 year += (yearday / DAYS_PER_QYEAR) * 4;
3528 yearday %= DAYS_PER_QYEAR;
3529 odd_year = yearday / DAYS_PER_YEAR;
3531 yearday %= DAYS_PER_YEAR;
3532 if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */
3537 yearday += YEAR_ADJUST; /* recover March 1st crock */
3538 month = yearday*DAYS_TO_MONTH;
3539 yearday -= month*MONTH_TO_DAYS;
3540 /* recover other leap-year adjustment */
3549 ptm->tm_year = year - 1900;
3551 ptm->tm_mday = yearday;
3552 ptm->tm_mon = month;
3556 ptm->tm_mon = month - 1;
3558 /* re-build yearday based on Jan 1 to get tm_yday */
3560 yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400;
3561 yearday += 14*MONTH_TO_DAYS + 1;
3562 ptm->tm_yday = jday - yearday;
3563 /* fix tm_wday if not overridden by caller */
3564 if ((unsigned)ptm->tm_wday > 6)
3565 ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
3569 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)
3577 init_tm(&mytm); /* XXX workaround - see init_tm() above */
3580 mytm.tm_hour = hour;
3581 mytm.tm_mday = mday;
3583 mytm.tm_year = year;
3584 mytm.tm_wday = wday;
3585 mytm.tm_yday = yday;
3586 mytm.tm_isdst = isdst;
3588 /* use libc to get the values for tm_gmtoff and tm_zone [perl #18238] */
3589 #if defined(HAS_MKTIME) && (defined(HAS_TM_TM_GMTOFF) || defined(HAS_TM_TM_ZONE))
3594 #ifdef HAS_TM_TM_GMTOFF
3595 mytm.tm_gmtoff = mytm2.tm_gmtoff;
3597 #ifdef HAS_TM_TM_ZONE
3598 mytm.tm_zone = mytm2.tm_zone;
3603 New(0, buf, buflen, char);
3604 len = strftime(buf, buflen, fmt, &mytm);
3606 ** The following is needed to handle to the situation where
3607 ** tmpbuf overflows. Basically we want to allocate a buffer
3608 ** and try repeatedly. The reason why it is so complicated
3609 ** is that getting a return value of 0 from strftime can indicate
3610 ** one of the following:
3611 ** 1. buffer overflowed,
3612 ** 2. illegal conversion specifier, or
3613 ** 3. the format string specifies nothing to be returned(not
3614 ** an error). This could be because format is an empty string
3615 ** or it specifies %p that yields an empty string in some locale.
3616 ** If there is a better way to make it portable, go ahead by
3619 if ((len > 0 && len < buflen) || (len == 0 && *fmt == '\0'))
3622 /* Possibly buf overflowed - try again with a bigger buf */
3623 const int fmtlen = strlen(fmt);
3624 const int bufsize = fmtlen + buflen;
3626 New(0, buf, bufsize, char);
3628 buflen = strftime(buf, bufsize, fmt, &mytm);
3629 if (buflen > 0 && buflen < bufsize)
3631 /* heuristic to prevent out-of-memory errors */
3632 if (bufsize > 100*fmtlen) {
3637 Renew(buf, bufsize*2, char);
3642 Perl_croak(aTHX_ "panic: no strftime");
3648 #define SV_CWD_RETURN_UNDEF \
3649 sv_setsv(sv, &PL_sv_undef); \
3652 #define SV_CWD_ISDOT(dp) \
3653 (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
3654 (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
3657 =head1 Miscellaneous Functions
3659 =for apidoc getcwd_sv
3661 Fill the sv with current working directory
3666 /* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars.
3667 * rewritten again by dougm, optimized for use with xs TARG, and to prefer
3668 * getcwd(3) if available
3669 * Comments from the orignal:
3670 * This is a faster version of getcwd. It's also more dangerous
3671 * because you might chdir out of a directory that you can't chdir
3675 Perl_getcwd_sv(pTHX_ register SV *sv)
3679 #ifndef INCOMPLETE_TAINTS
3685 char buf[MAXPATHLEN];
3687 /* Some getcwd()s automatically allocate a buffer of the given
3688 * size from the heap if they are given a NULL buffer pointer.
3689 * The problem is that this behaviour is not portable. */
3690 if (getcwd(buf, sizeof(buf) - 1)) {
3691 sv_setpvn(sv, buf, strlen(buf));
3695 sv_setsv(sv, &PL_sv_undef);
3703 int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
3707 (void)SvUPGRADE(sv, SVt_PV);
3709 if (PerlLIO_lstat(".", &statbuf) < 0) {
3710 SV_CWD_RETURN_UNDEF;
3713 orig_cdev = statbuf.st_dev;
3714 orig_cino = statbuf.st_ino;
3723 if (PerlDir_chdir("..") < 0) {
3724 SV_CWD_RETURN_UNDEF;
3726 if (PerlLIO_stat(".", &statbuf) < 0) {
3727 SV_CWD_RETURN_UNDEF;
3730 cdev = statbuf.st_dev;
3731 cino = statbuf.st_ino;
3733 if (odev == cdev && oino == cino) {
3736 if (!(dir = PerlDir_open("."))) {
3737 SV_CWD_RETURN_UNDEF;
3740 while ((dp = PerlDir_read(dir)) != NULL) {
3742 const int namelen = dp->d_namlen;
3744 const int namelen = strlen(dp->d_name);
3747 if (SV_CWD_ISDOT(dp)) {
3751 if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
3752 SV_CWD_RETURN_UNDEF;
3755 tdev = statbuf.st_dev;
3756 tino = statbuf.st_ino;
3757 if (tino == oino && tdev == odev) {
3763 SV_CWD_RETURN_UNDEF;
3766 if (pathlen + namelen + 1 >= MAXPATHLEN) {
3767 SV_CWD_RETURN_UNDEF;
3770 SvGROW(sv, pathlen + namelen + 1);
3774 Move(SvPVX_const(sv), SvPVX(sv) + namelen + 1, pathlen, char);
3777 /* prepend current directory to the front */
3779 Move(dp->d_name, SvPVX(sv)+1, namelen, char);
3780 pathlen += (namelen + 1);
3782 #ifdef VOID_CLOSEDIR
3785 if (PerlDir_close(dir) < 0) {
3786 SV_CWD_RETURN_UNDEF;
3792 SvCUR_set(sv, pathlen);
3796 if (PerlDir_chdir(SvPVX_const(sv)) < 0) {
3797 SV_CWD_RETURN_UNDEF;
3800 if (PerlLIO_stat(".", &statbuf) < 0) {
3801 SV_CWD_RETURN_UNDEF;
3804 cdev = statbuf.st_dev;
3805 cino = statbuf.st_ino;
3807 if (cdev != orig_cdev || cino != orig_cino) {
3808 Perl_croak(aTHX_ "Unstable directory path, "
3809 "current directory changed unexpectedly");
3821 =for apidoc scan_version
3823 Returns a pointer to the next character after the parsed
3824 version string, as well as upgrading the passed in SV to
3827 Function must be called with an already existing SV like
3830 s = scan_version(s,SV *sv, bool qv);
3832 Performs some preprocessing to the string to ensure that
3833 it has the correct characteristics of a version. Flags the
3834 object if it contains an underscore (which denotes this
3835 is a alpha version). The boolean qv denotes that the version
3836 should be interpreted as if it had multiple decimals, even if
3843 Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
3845 const char *start = s;
3846 const char *pos = s;
3849 SV* sv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
3850 (void)sv_upgrade(sv, SVt_PVAV); /* needs to be an AV type */
3853 /* pre-scan the imput string to check for decimals */
3854 while ( *pos == '.' || *pos == '_' || isDIGIT(*pos) )
3859 Perl_croak(aTHX_ "Invalid version format (underscores before decimal)");
3862 else if ( *pos == '_' )
3865 Perl_croak(aTHX_ "Invalid version format (multiple underscores)");
3873 pos++; /* get past 'v' */
3874 qv = 1; /* force quoted version processing */
3876 while (isDIGIT(*pos))
3878 if (!isALPHA(*pos)) {
3881 if (*s == 'v') s++; /* get past 'v' */
3886 /* this is atoi() that delimits on underscores */
3887 const char *end = pos;
3890 if ( s < pos && s > start && *(s-1) == '_' ) {
3891 mult *= -1; /* alpha version */
3893 /* the following if() will only be true after the decimal
3894 * point of a version originally created with a bare
3895 * floating point number, i.e. not quoted in any way
3897 if ( !qv && s > start+1 && saw_period == 1 ) {
3901 rev += (*s - '0') * mult;
3903 if ( PERL_ABS(orev) > PERL_ABS(rev) )
3904 Perl_croak(aTHX_ "Integer overflow in version");
3909 while (--end >= s) {
3911 rev += (*end - '0') * mult;
3913 if ( PERL_ABS(orev) > PERL_ABS(rev) )
3914 Perl_croak(aTHX_ "Integer overflow in version");
3919 /* Append revision */
3920 av_push((AV *)sv, newSViv(rev));
3921 if ( (*pos == '.' || *pos == '_') && isDIGIT(pos[1]))
3923 else if ( isDIGIT(*pos) )
3929 while ( isDIGIT(*pos) ) {
3930 if ( saw_period == 1 && pos-s == 3 )
3936 if ( qv ) { /* quoted versions always become full version objects */
3937 I32 len = av_len((AV *)sv);
3938 /* This for loop appears to trigger a compiler bug on OS X, as it
3939 loops infinitely. Yes, len is negative. No, it makes no sense.
3940 Compiler in question is:
3941 gcc version 3.3 20030304 (Apple Computer, Inc. build 1640)
3942 for ( len = 2 - len; len > 0; len-- )
3943 av_push((AV *)sv, newSViv(0));
3947 av_push((AV *)sv, newSViv(0));
3953 =for apidoc new_version
3955 Returns a new version object based on the passed in SV:
3957 SV *sv = new_version(SV *ver);
3959 Does not alter the passed in ver SV. See "upg_version" if you
3960 want to upgrade the SV.
3966 Perl_new_version(pTHX_ SV *ver)
3969 if ( sv_derived_from(ver,"version") ) /* can just copy directly */
3972 AV *av = (AV *)SvRV(ver);
3973 SV* sv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
3974 (void)sv_upgrade(sv, SVt_PVAV); /* needs to be an AV type */
3976 for ( key = 0; key <= av_len(av); key++ )
3978 const I32 rev = SvIV(*av_fetch(av, key, FALSE));
3979 av_push((AV *)sv, newSViv(rev));
3984 if ( SvVOK(ver) ) { /* already a v-string */
3986 MAGIC* mg = mg_find(ver,PERL_MAGIC_vstring);
3987 version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
3988 sv_setpv(rv,version);
3993 sv_setsv(rv,ver); /* make a duplicate */
4002 =for apidoc upg_version
4004 In-place upgrade of the supplied SV to a version object.
4006 SV *sv = upg_version(SV *sv);
4008 Returns a pointer to the upgraded SV.
4014 Perl_upg_version(pTHX_ SV *ver)
4019 if ( SvNOK(ver) ) /* may get too much accuracy */
4022 sprintf(tbuf,"%.9"NVgf, SvNVX(ver));
4023 version = savepv(tbuf);
4026 else if ( SvVOK(ver) ) { /* already a v-string */
4027 MAGIC* mg = mg_find(ver,PERL_MAGIC_vstring);
4028 version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
4032 else /* must be a string or something like a string */
4034 version = savesvpv(ver);
4036 (void)scan_version(version, ver, qv);
4045 Accepts a version object and returns the normalized floating
4046 point representation. Call like:
4050 NOTE: you can pass either the object directly or the SV
4051 contained within the RV.
4057 Perl_vnumify(pTHX_ SV *vs)
4063 len = av_len((AV *)vs);
4066 Perl_sv_catpv(aTHX_ sv,"0");
4069 digit = SvIVX(*av_fetch((AV *)vs, 0, 0));
4070 Perl_sv_setpvf(aTHX_ sv,"%d.", (int)PERL_ABS(digit));
4071 for ( i = 1 ; i < len ; i++ )
4073 digit = SvIVX(*av_fetch((AV *)vs, i, 0));
4074 Perl_sv_catpvf(aTHX_ sv,"%03d", (int)PERL_ABS(digit));
4079 digit = SvIVX(*av_fetch((AV *)vs, len, 0));
4080 if ( (int)PERL_ABS(digit) != 0 || len == 1 )
4082 if ( digit < 0 ) /* alpha version */
4083 Perl_sv_catpv(aTHX_ sv,"_");
4084 /* Don't display additional trailing zeros */
4085 Perl_sv_catpvf(aTHX_ sv,"%03d", (int)PERL_ABS(digit));
4090 Perl_sv_catpv(aTHX_ sv,"000");
4098 Accepts a version object and returns the normalized string
4099 representation. Call like:
4103 NOTE: you can pass either the object directly or the SV
4104 contained within the RV.
4110 Perl_vnormal(pTHX_ SV *vs)
4116 len = av_len((AV *)vs);
4119 Perl_sv_catpv(aTHX_ sv,"");
4122 digit = SvIVX(*av_fetch((AV *)vs, 0, 0));
4123 Perl_sv_setpvf(aTHX_ sv,"%"IVdf,(IV)digit);
4124 for ( i = 1 ; i <= len ; i++ )
4126 digit = SvIVX(*av_fetch((AV *)vs, i, 0));
4128 Perl_sv_catpvf(aTHX_ sv,"_%"IVdf,(IV)-digit);
4130 Perl_sv_catpvf(aTHX_ sv,".%"IVdf,(IV)digit);
4133 if ( len <= 2 ) { /* short version, must be at least three */
4134 for ( len = 2 - len; len != 0; len-- )
4135 Perl_sv_catpv(aTHX_ sv,".0");
4142 =for apidoc vstringify
4144 In order to maintain maximum compatibility with earlier versions
4145 of Perl, this function will return either the floating point
4146 notation or the multiple dotted notation, depending on whether
4147 the original version contained 1 or more dots, respectively
4153 Perl_vstringify(pTHX_ SV *vs)
4158 len = av_len((AV *)vs);
4159 digit = SvIVX(*av_fetch((AV *)vs, len, 0));
4161 if ( len < 2 || ( len == 2 && digit < 0 ) )
4170 Version object aware cmp. Both operands must already have been
4171 converted into version objects.
4177 Perl_vcmp(pTHX_ SV *lsv, SV *rsv)
4184 l = av_len((AV *)lsv);
4185 r = av_len((AV *)rsv);
4189 while ( i <= m && retval == 0 )
4191 I32 left = SvIV(*av_fetch((AV *)lsv,i,0));
4192 I32 right = SvIV(*av_fetch((AV *)rsv,i,0));
4193 bool lalpha = left < 0 ? 1 : 0;
4194 bool ralpha = right < 0 ? 1 : 0;
4197 if ( left < right || (left == right && lalpha && !ralpha) )
4199 if ( left > right || (left == right && ralpha && !lalpha) )
4204 if ( l != r && retval == 0 ) /* possible match except for trailing 0's */
4208 while ( i <= r && retval == 0 )
4210 if ( SvIV(*av_fetch((AV *)rsv,i,0)) != 0 )
4211 retval = -1; /* not a match after all */
4217 while ( i <= l && retval == 0 )
4219 if ( SvIV(*av_fetch((AV *)lsv,i,0)) != 0 )
4220 retval = +1; /* not a match after all */
4228 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT)
4229 # define EMULATE_SOCKETPAIR_UDP
4232 #ifdef EMULATE_SOCKETPAIR_UDP
4234 S_socketpair_udp (int fd[2]) {
4236 /* Fake a datagram socketpair using UDP to localhost. */
4237 int sockets[2] = {-1, -1};
4238 struct sockaddr_in addresses[2];
4240 Sock_size_t size = sizeof(struct sockaddr_in);
4241 unsigned short port;
4244 memset(&addresses, 0, sizeof(addresses));
4247 sockets[i] = PerlSock_socket(AF_INET, SOCK_DGRAM, PF_INET);
4248 if (sockets[i] == -1)
4249 goto tidy_up_and_fail;
4251 addresses[i].sin_family = AF_INET;
4252 addresses[i].sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4253 addresses[i].sin_port = 0; /* kernel choses port. */
4254 if (PerlSock_bind(sockets[i], (struct sockaddr *) &addresses[i],
4255 sizeof(struct sockaddr_in)) == -1)
4256 goto tidy_up_and_fail;
4259 /* Now have 2 UDP sockets. Find out which port each is connected to, and
4260 for each connect the other socket to it. */
4263 if (PerlSock_getsockname(sockets[i], (struct sockaddr *) &addresses[i],
4265 goto tidy_up_and_fail;
4266 if (size != sizeof(struct sockaddr_in))
4267 goto abort_tidy_up_and_fail;
4268 /* !1 is 0, !0 is 1 */
4269 if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i],
4270 sizeof(struct sockaddr_in)) == -1)
4271 goto tidy_up_and_fail;
4274 /* Now we have 2 sockets connected to each other. I don't trust some other
4275 process not to have already sent a packet to us (by random) so send
4276 a packet from each to the other. */
4279 /* I'm going to send my own port number. As a short.
4280 (Who knows if someone somewhere has sin_port as a bitfield and needs
4281 this routine. (I'm assuming crays have socketpair)) */
4282 port = addresses[i].sin_port;
4283 got = PerlLIO_write(sockets[i], &port, sizeof(port));
4284 if (got != sizeof(port)) {
4286 goto tidy_up_and_fail;
4287 goto abort_tidy_up_and_fail;
4291 /* Packets sent. I don't trust them to have arrived though.
4292 (As I understand it Solaris TCP stack is multithreaded. Non-blocking
4293 connect to localhost will use a second kernel thread. In 2.6 the
4294 first thread running the connect() returns before the second completes,
4295 so EINPROGRESS> In 2.7 the improved stack is faster and connect()
4296 returns 0. Poor programs have tripped up. One poor program's authors'
4297 had a 50-1 reverse stock split. Not sure how connected these were.)
4298 So I don't trust someone not to have an unpredictable UDP stack.
4302 struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */
4303 int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0];
4307 FD_SET(sockets[0], &rset);
4308 FD_SET(sockets[1], &rset);
4310 got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor);
4311 if (got != 2 || !FD_ISSET(sockets[0], &rset)
4312 || !FD_ISSET(sockets[1], &rset)) {
4313 /* I hope this is portable and appropriate. */
4315 goto tidy_up_and_fail;
4316 goto abort_tidy_up_and_fail;
4320 /* And the paranoia department even now doesn't trust it to have arrive
4321 (hence MSG_DONTWAIT). Or that what arrives was sent by us. */
4323 struct sockaddr_in readfrom;
4324 unsigned short buffer[2];
4329 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4330 sizeof(buffer), MSG_DONTWAIT,
4331 (struct sockaddr *) &readfrom, &size);
4333 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4335 (struct sockaddr *) &readfrom, &size);
4339 goto tidy_up_and_fail;
4340 if (got != sizeof(port)
4341 || size != sizeof(struct sockaddr_in)
4342 /* Check other socket sent us its port. */
4343 || buffer[0] != (unsigned short) addresses[!i].sin_port
4344 /* Check kernel says we got the datagram from that socket */
4345 || readfrom.sin_family != addresses[!i].sin_family
4346 || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr
4347 || readfrom.sin_port != addresses[!i].sin_port)
4348 goto abort_tidy_up_and_fail;
4351 /* My caller (my_socketpair) has validated that this is non-NULL */
4354 /* I hereby declare this connection open. May God bless all who cross
4358 abort_tidy_up_and_fail:
4359 errno = ECONNABORTED;
4362 const int save_errno = errno;
4363 if (sockets[0] != -1)
4364 PerlLIO_close(sockets[0]);
4365 if (sockets[1] != -1)
4366 PerlLIO_close(sockets[1]);
4371 #endif /* EMULATE_SOCKETPAIR_UDP */
4373 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET)
4375 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4376 /* Stevens says that family must be AF_LOCAL, protocol 0.
4377 I'm going to enforce that, then ignore it, and use TCP (or UDP). */
4382 struct sockaddr_in listen_addr;
4383 struct sockaddr_in connect_addr;
4388 || family != AF_UNIX
4391 errno = EAFNOSUPPORT;
4399 #ifdef EMULATE_SOCKETPAIR_UDP
4400 if (type == SOCK_DGRAM)
4401 return S_socketpair_udp(fd);
4404 listener = PerlSock_socket(AF_INET, type, 0);
4407 memset(&listen_addr, 0, sizeof(listen_addr));
4408 listen_addr.sin_family = AF_INET;
4409 listen_addr.sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4410 listen_addr.sin_port = 0; /* kernel choses port. */
4411 if (PerlSock_bind(listener, (struct sockaddr *) &listen_addr,
4412 sizeof(listen_addr)) == -1)
4413 goto tidy_up_and_fail;
4414 if (PerlSock_listen(listener, 1) == -1)
4415 goto tidy_up_and_fail;
4417 connector = PerlSock_socket(AF_INET, type, 0);
4418 if (connector == -1)
4419 goto tidy_up_and_fail;
4420 /* We want to find out the port number to connect to. */
4421 size = sizeof(connect_addr);
4422 if (PerlSock_getsockname(listener, (struct sockaddr *) &connect_addr,
4424 goto tidy_up_and_fail;
4425 if (size != sizeof(connect_addr))
4426 goto abort_tidy_up_and_fail;
4427 if (PerlSock_connect(connector, (struct sockaddr *) &connect_addr,
4428 sizeof(connect_addr)) == -1)
4429 goto tidy_up_and_fail;
4431 size = sizeof(listen_addr);
4432 acceptor = PerlSock_accept(listener, (struct sockaddr *) &listen_addr,
4435 goto tidy_up_and_fail;
4436 if (size != sizeof(listen_addr))
4437 goto abort_tidy_up_and_fail;
4438 PerlLIO_close(listener);
4439 /* Now check we are talking to ourself by matching port and host on the
4441 if (PerlSock_getsockname(connector, (struct sockaddr *) &connect_addr,
4443 goto tidy_up_and_fail;
4444 if (size != sizeof(connect_addr)
4445 || listen_addr.sin_family != connect_addr.sin_family
4446 || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr
4447 || listen_addr.sin_port != connect_addr.sin_port) {
4448 goto abort_tidy_up_and_fail;
4454 abort_tidy_up_and_fail:
4456 errno = ECONNABORTED; /* This would be the standard thing to do. */
4458 # ifdef ECONNREFUSED
4459 errno = ECONNREFUSED; /* E.g. Symbian does not have ECONNABORTED. */
4461 errno = ETIMEDOUT; /* Desperation time. */
4466 int save_errno = errno;
4468 PerlLIO_close(listener);
4469 if (connector != -1)
4470 PerlLIO_close(connector);
4472 PerlLIO_close(acceptor);
4478 /* In any case have a stub so that there's code corresponding
4479 * to the my_socketpair in global.sym. */
4481 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4482 #ifdef HAS_SOCKETPAIR
4483 return socketpair(family, type, protocol, fd);
4492 =for apidoc sv_nosharing
4494 Dummy routine which "shares" an SV when there is no sharing module present.
4495 Exists to avoid test for a NULL function pointer and because it could potentially warn under
4496 some level of strict-ness.
4502 Perl_sv_nosharing(pTHX_ SV *sv)
4508 =for apidoc sv_nolocking
4510 Dummy routine which "locks" an SV when there is no locking module present.
4511 Exists to avoid test for a NULL function pointer and because it could potentially warn under
4512 some level of strict-ness.
4518 Perl_sv_nolocking(pTHX_ SV *sv)
4525 =for apidoc sv_nounlocking
4527 Dummy routine which "unlocks" an SV when there is no locking module present.
4528 Exists to avoid test for a NULL function pointer and because it could potentially warn under
4529 some level of strict-ness.
4535 Perl_sv_nounlocking(pTHX_ SV *sv)
4541 Perl_parse_unicode_opts(pTHX_ const char **popt)
4543 const char *p = *popt;
4548 opt = (U32) atoi(p);
4549 while (isDIGIT(*p)) p++;
4550 if (*p && *p != '\n' && *p != '\r')
4551 Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
4556 case PERL_UNICODE_STDIN:
4557 opt |= PERL_UNICODE_STDIN_FLAG; break;
4558 case PERL_UNICODE_STDOUT:
4559 opt |= PERL_UNICODE_STDOUT_FLAG; break;
4560 case PERL_UNICODE_STDERR:
4561 opt |= PERL_UNICODE_STDERR_FLAG; break;
4562 case PERL_UNICODE_STD:
4563 opt |= PERL_UNICODE_STD_FLAG; break;
4564 case PERL_UNICODE_IN:
4565 opt |= PERL_UNICODE_IN_FLAG; break;
4566 case PERL_UNICODE_OUT:
4567 opt |= PERL_UNICODE_OUT_FLAG; break;
4568 case PERL_UNICODE_INOUT:
4569 opt |= PERL_UNICODE_INOUT_FLAG; break;
4570 case PERL_UNICODE_LOCALE:
4571 opt |= PERL_UNICODE_LOCALE_FLAG; break;
4572 case PERL_UNICODE_ARGV:
4573 opt |= PERL_UNICODE_ARGV_FLAG; break;
4575 if (*p != '\n' && *p != '\r')
4577 "Unknown Unicode option letter '%c'", *p);
4583 opt = PERL_UNICODE_DEFAULT_FLAGS;
4585 if (opt & ~PERL_UNICODE_ALL_FLAGS)
4586 Perl_croak(aTHX_ "Unknown Unicode option value %"UVuf,
4587 (UV) (opt & ~PERL_UNICODE_ALL_FLAGS));
4598 * This is really just a quick hack which grabs various garbage
4599 * values. It really should be a real hash algorithm which
4600 * spreads the effect of every input bit onto every output bit,
4601 * if someone who knows about such things would bother to write it.
4602 * Might be a good idea to add that function to CORE as well.
4603 * No numbers below come from careful analysis or anything here,
4604 * except they are primes and SEED_C1 > 1E6 to get a full-width
4605 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
4606 * probably be bigger too.
4609 # define SEED_C1 1000003
4610 #define SEED_C4 73819
4612 # define SEED_C1 25747
4613 #define SEED_C4 20639
4617 #define SEED_C5 26107
4619 #ifndef PERL_NO_DEV_RANDOM
4624 # include <starlet.h>
4625 /* when[] = (low 32 bits, high 32 bits) of time since epoch
4626 * in 100-ns units, typically incremented ever 10 ms. */
4627 unsigned int when[2];
4629 # ifdef HAS_GETTIMEOFDAY
4630 struct timeval when;
4636 /* This test is an escape hatch, this symbol isn't set by Configure. */
4637 #ifndef PERL_NO_DEV_RANDOM
4638 #ifndef PERL_RANDOM_DEVICE
4639 /* /dev/random isn't used by default because reads from it will block
4640 * if there isn't enough entropy available. You can compile with
4641 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
4642 * is enough real entropy to fill the seed. */
4643 # define PERL_RANDOM_DEVICE "/dev/urandom"
4645 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
4647 if (PerlLIO_read(fd, (void*)&u, sizeof u) != sizeof u)
4656 _ckvmssts(sys$gettim(when));
4657 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
4659 # ifdef HAS_GETTIMEOFDAY
4660 PerlProc_gettimeofday(&when,NULL);
4661 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
4664 u = (U32)SEED_C1 * when;
4667 u += SEED_C3 * (U32)PerlProc_getpid();
4668 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
4669 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
4670 u += SEED_C5 * (U32)PTR2UV(&when);
4676 Perl_get_hash_seed(pTHX)
4678 const char *s = PerlEnv_getenv("PERL_HASH_SEED");
4682 while (isSPACE(*s)) s++;
4683 if (s && isDIGIT(*s))
4684 myseed = (UV)Atoul(s);
4686 #ifdef USE_HASH_SEED_EXPLICIT
4690 /* Compute a random seed */
4691 (void)seedDrand01((Rand_seed_t)seed());
4692 myseed = (UV)(Drand01() * (NV)UV_MAX);
4693 #if RANDBITS < (UVSIZE * 8)
4694 /* Since there are not enough randbits to to reach all
4695 * the bits of a UV, the low bits might need extra
4696 * help. Sum in another random number that will
4697 * fill in the low bits. */
4699 (UV)(Drand01() * (NV)((1 << ((UVSIZE * 8 - RANDBITS))) - 1));
4700 #endif /* RANDBITS < (UVSIZE * 8) */
4701 if (myseed == 0) { /* Superparanoia. */
4702 myseed = (UV)(Drand01() * (NV)UV_MAX); /* One more chance. */
4704 Perl_croak(aTHX_ "Your random numbers are not that random");
4707 PL_rehash_seed_set = TRUE;
4712 #ifdef PERL_GLOBAL_STRUCT
4715 Perl_init_global_struct(pTHX)
4717 struct perl_vars *plvarsp = NULL;
4718 #ifdef PERL_GLOBAL_STRUCT
4719 # define PERL_GLOBAL_STRUCT_INIT
4720 # include "opcode.h" /* the ppaddr and check */
4721 IV nppaddr = sizeof(Gppaddr)/sizeof(Perl_ppaddr_t);
4722 IV ncheck = sizeof(Gcheck) /sizeof(Perl_check_t);
4723 # ifdef PERL_GLOBAL_STRUCT_PRIVATE
4724 /* PerlMem_malloc() because can't use even safesysmalloc() this early. */
4725 plvarsp = (struct perl_vars*)PerlMem_malloc(sizeof(struct perl_vars));
4729 plvarsp = PL_VarsPtr;
4730 # endif /* PERL_GLOBAL_STRUCT_PRIVATE */
4736 # define PERLVAR(var,type) /**/
4737 # define PERLVARA(var,n,type) /**/
4738 # define PERLVARI(var,type,init) plvarsp->var = init;
4739 # define PERLVARIC(var,type,init) plvarsp->var = init;
4740 # define PERLVARISC(var,init) Copy(init, plvarsp->var, sizeof(init), char);
4741 # include "perlvars.h"
4747 # ifdef PERL_GLOBAL_STRUCT
4748 plvarsp->Gppaddr = PerlMem_malloc(nppaddr * sizeof(Perl_ppaddr_t));
4749 if (!plvarsp->Gppaddr)
4751 plvarsp->Gcheck = PerlMem_malloc(ncheck * sizeof(Perl_check_t));
4752 if (!plvarsp->Gcheck)
4754 Copy(Gppaddr, plvarsp->Gppaddr, nppaddr, Perl_ppaddr_t);
4755 Copy(Gcheck, plvarsp->Gcheck, ncheck, Perl_check_t);
4757 # ifdef PERL_SET_VARS
4758 PERL_SET_VARS(plvarsp);
4760 # undef PERL_GLOBAL_STRUCT_INIT
4765 #endif /* PERL_GLOBAL_STRUCT */
4767 #ifdef PERL_GLOBAL_STRUCT
4770 Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp)
4772 #ifdef PERL_GLOBAL_STRUCT
4773 # ifdef PERL_UNSET_VARS
4774 PERL_UNSET_VARS(plvarsp);
4776 free(plvarsp->Gppaddr);
4777 free(plvarsp->Gcheck);
4778 # ifdef PERL_GLOBAL_STRUCT_PRIVATE
4784 #endif /* PERL_GLOBAL_STRUCT */
4788 * c-indentation-style: bsd
4790 * indent-tabs-mode: t
4793 * ex: set ts=8 sts=4 sw=4 noet: