3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 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 * "Sam sat on the ground and put his head in his hands. 'I wish I had never
13 * come here, and I don't want to see no more magic,' he said, and fell silent."
17 =head1 Magical Functions
19 "Magic" is special data attached to SV structures in order to give them
20 "magical" properties. When any Perl code tries to read from, or assign to,
21 an SV marked as magical, it calls the 'get' or 'set' function associated
22 with that SV's magic. A get is called prior to reading an SV, in order to
23 give it a chance to update its internal value (get on $. writes the line
24 number of the last read filehandle into to the SV's IV slot), while
25 set is called after an SV has been written to, in order to allow it to make
26 use of its changed value (set on $/ copies the SV's new value to the
27 PL_rs global variable).
29 Magic is implemented as a linked list of MAGIC structures attached to the
30 SV. Each MAGIC struct holds the type of the magic, a pointer to an array
31 of functions that implement the get(), set(), length() etc functions,
32 plus space for some flags and pointers. For example, a tied variable has
33 a MAGIC structure that contains a pointer to the object associated with the
42 #if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS)
48 #if defined(HAS_SETGROUPS)
55 # include <sys/pstat.h>
58 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
59 Signal_t Perl_csighandler(int sig, ...);
61 Signal_t Perl_csighandler(int sig);
65 /* Missing protos on LynxOS */
66 void setruid(uid_t id);
67 void seteuid(uid_t id);
68 void setrgid(uid_t id);
69 void setegid(uid_t id);
73 * Use the "DESTRUCTOR" scope cleanup to reinstate magic.
81 /* MGS is typedef'ed to struct magic_state in perl.h */
84 S_save_magic(pTHX_ I32 mgs_ix, SV *sv)
88 assert(SvMAGICAL(sv));
89 /* Turning READONLY off for a copy-on-write scalar (including shared
90 hash keys) is a bad idea. */
92 sv_force_normal_flags(sv, 0);
94 SAVEDESTRUCTOR_X(S_restore_magic, INT2PTR(void*, (IV)mgs_ix));
96 mgs = SSPTR(mgs_ix, MGS*);
98 mgs->mgs_flags = SvMAGICAL(sv) | SvREADONLY(sv);
99 mgs->mgs_ss_ix = PL_savestack_ix; /* points after the saved destructor */
103 if (!(SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK))) {
104 /* No public flags are set, so promote any private flags to public. */
105 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
110 =for apidoc mg_magical
112 Turns on the magical status of an SV. See C<sv_magic>.
118 Perl_mg_magical(pTHX_ SV *sv)
122 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
123 const MGVTBL* const vtbl = mg->mg_virtual;
125 if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
129 if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)) || vtbl->svt_clear)
136 /* is this container magic (%ENV, $1 etc), or value magic (pos, taint etc)? */
139 S_is_container_magic(const MAGIC *mg)
141 switch (mg->mg_type) {
144 case PERL_MAGIC_regex_global:
145 case PERL_MAGIC_nkeys:
146 #ifdef USE_LOCALE_COLLATE
147 case PERL_MAGIC_collxfrm:
150 case PERL_MAGIC_taint:
152 case PERL_MAGIC_vstring:
153 case PERL_MAGIC_utf8:
154 case PERL_MAGIC_substr:
155 case PERL_MAGIC_defelem:
156 case PERL_MAGIC_arylen:
158 case PERL_MAGIC_backref:
159 case PERL_MAGIC_arylen_p:
160 case PERL_MAGIC_rhash:
161 case PERL_MAGIC_symtab:
171 Do magic after a value is retrieved from the SV. See C<sv_magic>.
177 Perl_mg_get(pTHX_ SV *sv)
180 const I32 mgs_ix = SSNEW(sizeof(MGS));
181 const bool was_temp = (bool)SvTEMP(sv);
183 MAGIC *newmg, *head, *cur, *mg;
184 /* guard against sv having being freed midway by holding a private
187 /* sv_2mortal has this side effect of turning on the TEMP flag, which can
188 cause the SV's buffer to get stolen (and maybe other stuff).
191 sv_2mortal(SvREFCNT_inc_simple_NN(sv));
196 save_magic(mgs_ix, sv);
198 /* We must call svt_get(sv, mg) for each valid entry in the linked
199 list of magic. svt_get() may delete the current entry, add new
200 magic to the head of the list, or upgrade the SV. AMS 20010810 */
202 newmg = cur = head = mg = SvMAGIC(sv);
204 const MGVTBL * const vtbl = mg->mg_virtual;
206 if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
207 CALL_FPTR(vtbl->svt_get)(aTHX_ sv, mg);
209 /* guard against magic having been deleted - eg FETCH calling
214 /* Don't restore the flags for this entry if it was deleted. */
215 if (mg->mg_flags & MGf_GSKIP)
216 (SSPTR(mgs_ix, MGS *))->mgs_flags = 0;
219 mg = mg->mg_moremagic;
222 /* Have we finished with the new entries we saw? Start again
223 where we left off (unless there are more new entries). */
231 /* Were any new entries added? */
232 if (!have_new && (newmg = SvMAGIC(sv)) != head) {
239 restore_magic(INT2PTR(void *, (IV)mgs_ix));
241 if (SvREFCNT(sv) == 1) {
242 /* We hold the last reference to this SV, which implies that the
243 SV was deleted as a side effect of the routines we called. */
252 Do magic after a value is assigned to the SV. See C<sv_magic>.
258 Perl_mg_set(pTHX_ SV *sv)
261 const I32 mgs_ix = SSNEW(sizeof(MGS));
265 save_magic(mgs_ix, sv);
267 for (mg = SvMAGIC(sv); mg; mg = nextmg) {
268 const MGVTBL* vtbl = mg->mg_virtual;
269 nextmg = mg->mg_moremagic; /* it may delete itself */
270 if (mg->mg_flags & MGf_GSKIP) {
271 mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */
272 (SSPTR(mgs_ix, MGS*))->mgs_flags = 0;
274 if (PL_localizing == 2 && !S_is_container_magic(mg))
276 if (vtbl && vtbl->svt_set)
277 CALL_FPTR(vtbl->svt_set)(aTHX_ sv, mg);
280 restore_magic(INT2PTR(void*, (IV)mgs_ix));
285 =for apidoc mg_length
287 Report on the SV's length. See C<sv_magic>.
293 Perl_mg_length(pTHX_ SV *sv)
299 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
300 const MGVTBL * const vtbl = mg->mg_virtual;
301 if (vtbl && vtbl->svt_len) {
302 const I32 mgs_ix = SSNEW(sizeof(MGS));
303 save_magic(mgs_ix, sv);
304 /* omit MGf_GSKIP -- not changed here */
305 len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
306 restore_magic(INT2PTR(void*, (IV)mgs_ix));
312 const U8 *s = (U8*)SvPV_const(sv, len);
313 len = utf8_length(s, s + len);
316 (void)SvPV_const(sv, len);
321 Perl_mg_size(pTHX_ SV *sv)
325 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
326 const MGVTBL* const vtbl = mg->mg_virtual;
327 if (vtbl && vtbl->svt_len) {
328 const I32 mgs_ix = SSNEW(sizeof(MGS));
330 save_magic(mgs_ix, sv);
331 /* omit MGf_GSKIP -- not changed here */
332 len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
333 restore_magic(INT2PTR(void*, (IV)mgs_ix));
340 return AvFILLp((AV *) sv); /* Fallback to non-tied array */
344 Perl_croak(aTHX_ "Size magic not implemented");
353 Clear something magical that the SV represents. See C<sv_magic>.
359 Perl_mg_clear(pTHX_ SV *sv)
361 const I32 mgs_ix = SSNEW(sizeof(MGS));
364 save_magic(mgs_ix, sv);
366 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
367 const MGVTBL* const vtbl = mg->mg_virtual;
368 /* omit GSKIP -- never set here */
370 if (vtbl && vtbl->svt_clear)
371 CALL_FPTR(vtbl->svt_clear)(aTHX_ sv, mg);
374 restore_magic(INT2PTR(void*, (IV)mgs_ix));
381 Finds the magic pointer for type matching the SV. See C<sv_magic>.
387 Perl_mg_find(pTHX_ const SV *sv, int type)
392 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
393 if (mg->mg_type == type)
403 Copies the magic from one SV to another. See C<sv_magic>.
409 Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
413 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
414 const MGVTBL* const vtbl = mg->mg_virtual;
415 if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){
416 count += CALL_FPTR(vtbl->svt_copy)(aTHX_ sv, mg, nsv, key, klen);
419 const char type = mg->mg_type;
420 if (isUPPER(type) && type != PERL_MAGIC_uvar) {
422 (type == PERL_MAGIC_tied)
424 : (type == PERL_MAGIC_regdata && mg->mg_obj)
427 toLOWER(type), key, klen);
436 =for apidoc mg_localize
438 Copy some of the magic from an existing SV to new localized version of
439 that SV. Container magic (eg %ENV, $1, tie) gets copied, value magic
440 doesn't (eg taint, pos).
446 Perl_mg_localize(pTHX_ SV *sv, SV *nsv)
450 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
451 const MGVTBL* const vtbl = mg->mg_virtual;
452 if (!S_is_container_magic(mg))
455 if ((mg->mg_flags & MGf_LOCAL) && vtbl->svt_local)
456 (void)CALL_FPTR(vtbl->svt_local)(aTHX_ nsv, mg);
458 sv_magicext(nsv, mg->mg_obj, mg->mg_type, vtbl,
459 mg->mg_ptr, mg->mg_len);
461 /* container types should remain read-only across localization */
462 SvFLAGS(nsv) |= SvREADONLY(sv);
465 if (SvTYPE(nsv) >= SVt_PVMG && SvMAGIC(nsv)) {
466 SvFLAGS(nsv) |= SvMAGICAL(sv);
476 Free any magic storage used by the SV. See C<sv_magic>.
482 Perl_mg_free(pTHX_ SV *sv)
486 for (mg = SvMAGIC(sv); mg; mg = moremagic) {
487 const MGVTBL* const vtbl = mg->mg_virtual;
488 moremagic = mg->mg_moremagic;
489 if (vtbl && vtbl->svt_free)
490 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
491 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
492 if (mg->mg_len > 0 || mg->mg_type == PERL_MAGIC_utf8)
493 Safefree(mg->mg_ptr);
494 else if (mg->mg_len == HEf_SVKEY)
495 SvREFCNT_dec((SV*)mg->mg_ptr);
497 if (mg->mg_flags & MGf_REFCOUNTED)
498 SvREFCNT_dec(mg->mg_obj);
501 SvMAGIC_set(sv, NULL);
508 Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
514 register const REGEXP * const rx = PM_GETRE(PL_curpm);
516 if (mg->mg_obj) { /* @+ */
517 /* return the number possible */
520 I32 paren = rx->lastparen;
522 /* return the last filled */
524 && (rx->offs[paren].start == -1
525 || rx->offs[paren].end == -1) )
536 Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
540 register const REGEXP * const rx = PM_GETRE(PL_curpm);
542 register const I32 paren = mg->mg_len;
547 if (paren <= (I32)rx->nparens &&
548 (s = rx->offs[paren].start) != -1 &&
549 (t = rx->offs[paren].end) != -1)
552 if (mg->mg_obj) /* @+ */
557 if (i > 0 && RX_MATCH_UTF8(rx)) {
558 const char * const b = rx->subbeg;
560 i = utf8_length((U8*)b, (U8*)(b+i));
571 Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
575 Perl_croak(aTHX_ PL_no_modify);
576 NORETURN_FUNCTION_END;
580 Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
585 register const REGEXP *rx;
588 switch (*mg->mg_ptr) {
589 case '1': case '2': case '3': case '4':
590 case '5': case '6': case '7': case '8': case '9': case '&':
591 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
593 paren = atoi(mg->mg_ptr); /* $& is in [0] */
595 if (paren <= (I32)rx->nparens &&
596 (s1 = rx->offs[paren].start) != -1 &&
597 (t1 = rx->offs[paren].end) != -1)
601 if (i > 0 && RX_MATCH_UTF8(rx)) {
602 const char * const s = rx->subbeg + s1;
607 if (is_utf8_string_loclen((U8*)s, i, &ep, &el))
611 Perl_croak(aTHX_ "panic: magic_len: %"IVdf, (IV)i);
615 if (ckWARN(WARN_UNINITIALIZED))
620 if (ckWARN(WARN_UNINITIALIZED))
625 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
626 paren = rx->lastparen;
631 case '\016': /* ^N */
632 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
633 paren = rx->lastcloseparen;
639 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
640 if (rx->offs[0].start != -1) {
641 i = rx->offs[0].start;
651 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
652 if (rx->offs[0].end != -1) {
653 i = rx->sublen - rx->offs[0].end;
655 s1 = rx->offs[0].end;
664 if (!SvPOK(sv) && SvNIOK(sv)) {
672 #define SvRTRIM(sv) STMT_START { \
674 STRLEN len = SvCUR(sv); \
675 char * const p = SvPVX(sv); \
676 while (len > 0 && isSPACE(p[len-1])) \
678 SvCUR_set(sv, len); \
684 Perl_emulate_cop_io(pTHX_ const COP *const c, SV *const sv)
686 if (!(CopHINTS_get(c) & (HINT_LEXICAL_IO_IN|HINT_LEXICAL_IO_OUT)))
687 sv_setsv(sv, &PL_sv_undef);
691 if ((CopHINTS_get(c) & HINT_LEXICAL_IO_IN)) {
692 SV *const value = Perl_refcounted_he_fetch(aTHX_
694 0, "open<", 5, 0, 0);
699 if ((CopHINTS_get(c) & HINT_LEXICAL_IO_OUT)) {
700 SV *const value = Perl_refcounted_he_fetch(aTHX_
702 0, "open>", 5, 0, 0);
710 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
714 register char *s = NULL;
716 const char * const remaining = mg->mg_ptr + 1;
717 const char nextchar = *remaining;
719 switch (*mg->mg_ptr) {
720 case '\001': /* ^A */
721 sv_setsv(sv, PL_bodytarget);
723 case '\003': /* ^C, ^CHILD_ERROR_NATIVE */
724 if (nextchar == '\0') {
725 sv_setiv(sv, (IV)PL_minus_c);
727 else if (strEQ(remaining, "HILD_ERROR_NATIVE")) {
728 sv_setiv(sv, (IV)STATUS_NATIVE);
732 case '\004': /* ^D */
733 sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
735 case '\005': /* ^E */
736 if (nextchar == '\0') {
737 #if defined(MACOS_TRADITIONAL)
741 sv_setnv(sv,(double)gMacPerl_OSErr);
742 sv_setpv(sv, gMacPerl_OSErr ? GetSysErrText(gMacPerl_OSErr, msg) : "");
746 # include <descrip.h>
747 # include <starlet.h>
749 $DESCRIPTOR(msgdsc,msg);
750 sv_setnv(sv,(NV) vaxc$errno);
751 if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
752 sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
757 if (!(_emx_env & 0x200)) { /* Under DOS */
758 sv_setnv(sv, (NV)errno);
759 sv_setpv(sv, errno ? Strerror(errno) : "");
761 if (errno != errno_isOS2) {
762 const int tmp = _syserrno();
763 if (tmp) /* 2nd call to _syserrno() makes it 0 */
766 sv_setnv(sv, (NV)Perl_rc);
767 sv_setpv(sv, os2error(Perl_rc));
771 const DWORD dwErr = GetLastError();
772 sv_setnv(sv, (NV)dwErr);
774 PerlProc_GetOSError(sv, dwErr);
777 sv_setpvn(sv, "", 0);
782 const int saveerrno = errno;
783 sv_setnv(sv, (NV)errno);
784 sv_setpv(sv, errno ? Strerror(errno) : "");
789 SvNOK_on(sv); /* what a wonderful hack! */
791 else if (strEQ(remaining, "NCODING"))
792 sv_setsv(sv, PL_encoding);
794 case '\006': /* ^F */
795 sv_setiv(sv, (IV)PL_maxsysfd);
797 case '\010': /* ^H */
798 sv_setiv(sv, (IV)PL_hints);
800 case '\011': /* ^I */ /* NOT \t in EBCDIC */
802 sv_setpv(sv, PL_inplace);
804 sv_setsv(sv, &PL_sv_undef);
806 case '\017': /* ^O & ^OPEN */
807 if (nextchar == '\0') {
808 sv_setpv(sv, PL_osname);
811 else if (strEQ(remaining, "PEN")) {
812 Perl_emulate_cop_io(aTHX_ &PL_compiling, sv);
816 if (nextchar == '\0') { /* ^P */
817 sv_setiv(sv, (IV)PL_perldb);
818 } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
819 goto do_prematch_fetch;
820 } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
821 goto do_postmatch_fetch;
824 case '\023': /* ^S */
825 if (nextchar == '\0') {
826 if (PL_lex_state != LEX_NOTPARSING)
829 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
834 case '\024': /* ^T */
835 if (nextchar == '\0') {
837 sv_setnv(sv, PL_basetime);
839 sv_setiv(sv, (IV)PL_basetime);
842 else if (strEQ(remaining, "AINT"))
843 sv_setiv(sv, PL_tainting
844 ? (PL_taint_warn || PL_unsafe ? -1 : 1)
847 case '\025': /* $^UNICODE, $^UTF8LOCALE, $^UTF8CACHE */
848 if (strEQ(remaining, "NICODE"))
849 sv_setuv(sv, (UV) PL_unicode);
850 else if (strEQ(remaining, "TF8LOCALE"))
851 sv_setuv(sv, (UV) PL_utf8locale);
852 else if (strEQ(remaining, "TF8CACHE"))
853 sv_setiv(sv, (IV) PL_utf8cache);
855 case '\027': /* ^W & $^WARNING_BITS */
856 if (nextchar == '\0')
857 sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
858 else if (strEQ(remaining, "ARNING_BITS")) {
859 if (PL_compiling.cop_warnings == pWARN_NONE) {
860 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
862 else if (PL_compiling.cop_warnings == pWARN_STD) {
865 (PL_dowarn & G_WARN_ON) ? WARN_ALLstring : WARN_NONEstring,
869 else if (PL_compiling.cop_warnings == pWARN_ALL) {
870 /* Get the bit mask for $warnings::Bits{all}, because
871 * it could have been extended by warnings::register */
872 HV * const bits=get_hv("warnings::Bits", FALSE);
874 SV ** const bits_all = hv_fetchs(bits, "all", FALSE);
876 sv_setsv(sv, *bits_all);
879 sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
883 sv_setpvn(sv, (char *) (PL_compiling.cop_warnings + 1),
884 *PL_compiling.cop_warnings);
889 case '\015': /* $^MATCH */
890 if (strEQ(remaining, "ATCH")) {
891 case '1': case '2': case '3': case '4':
892 case '5': case '6': case '7': case '8': case '9': case '&':
893 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
895 * Pre-threads, this was paren = atoi(GvENAME((GV*)mg->mg_obj));
896 * XXX Does the new way break anything?
898 paren = atoi(mg->mg_ptr); /* $& is in [0] */
899 CALLREG_NUMBUF(rx,paren,sv);
902 sv_setsv(sv,&PL_sv_undef);
906 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
908 CALLREG_NUMBUF(rx,rx->lastparen,sv);
912 sv_setsv(sv,&PL_sv_undef);
914 case '\016': /* ^N */
915 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
916 if (rx->lastcloseparen) {
917 CALLREG_NUMBUF(rx,rx->lastcloseparen,sv);
922 sv_setsv(sv,&PL_sv_undef);
926 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
927 CALLREG_NUMBUF(rx,-2,sv);
930 sv_setsv(sv,&PL_sv_undef);
934 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
935 CALLREG_NUMBUF(rx,-1,sv);
938 sv_setsv(sv,&PL_sv_undef);
941 if (GvIO(PL_last_in_gv)) {
942 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
947 sv_setiv(sv, (IV)STATUS_CURRENT);
948 #ifdef COMPLEX_STATUS
949 LvTARGOFF(sv) = PL_statusvalue;
950 LvTARGLEN(sv) = PL_statusvalue_vms;
955 if (GvIOp(PL_defoutgv))
956 s = IoTOP_NAME(GvIOp(PL_defoutgv));
960 sv_setpv(sv,GvENAME(PL_defoutgv));
965 if (GvIOp(PL_defoutgv))
966 s = IoFMT_NAME(GvIOp(PL_defoutgv));
968 s = GvENAME(PL_defoutgv);
972 if (GvIOp(PL_defoutgv))
973 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
976 if (GvIOp(PL_defoutgv))
977 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
980 if (GvIOp(PL_defoutgv))
981 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
988 sv_setiv(sv, (IV)CopARYBASE_get(PL_curcop));
991 if (GvIOp(PL_defoutgv))
992 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
998 sv_copypv(sv, PL_ors_sv);
1002 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
1003 sv_setpv(sv, errno ? Strerror(errno) : "");
1006 const int saveerrno = errno;
1007 sv_setnv(sv, (NV)errno);
1009 if (errno == errno_isOS2 || errno == errno_isOS2_set)
1010 sv_setpv(sv, os2error(Perl_rc));
1013 sv_setpv(sv, errno ? Strerror(errno) : "");
1018 SvNOK_on(sv); /* what a wonderful hack! */
1021 sv_setiv(sv, (IV)PL_uid);
1024 sv_setiv(sv, (IV)PL_euid);
1027 sv_setiv(sv, (IV)PL_gid);
1030 sv_setiv(sv, (IV)PL_egid);
1032 #ifdef HAS_GETGROUPS
1034 Groups_t *gary = NULL;
1035 I32 i, num_groups = getgroups(0, gary);
1036 Newx(gary, num_groups, Groups_t);
1037 num_groups = getgroups(num_groups, gary);
1038 for (i = 0; i < num_groups; i++)
1039 Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]);
1042 (void)SvIOK_on(sv); /* what a wonderful hack! */
1045 #ifndef MACOS_TRADITIONAL
1054 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
1056 struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
1058 if (uf && uf->uf_val)
1059 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
1064 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
1067 STRLEN len = 0, klen;
1068 const char *s = SvOK(sv) ? SvPV_const(sv,len) : "";
1069 const char * const ptr = MgPV_const(mg,klen);
1072 #ifdef DYNAMIC_ENV_FETCH
1073 /* We just undefd an environment var. Is a replacement */
1074 /* waiting in the wings? */
1076 SV ** const valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE);
1078 s = SvOK(*valp) ? SvPV_const(*valp, len) : "";
1082 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
1083 /* And you'll never guess what the dog had */
1084 /* in its mouth... */
1086 MgTAINTEDDIR_off(mg);
1088 if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
1089 char pathbuf[256], eltbuf[256], *cp, *elt;
1093 my_strlcpy(eltbuf, s, sizeof(eltbuf));
1095 do { /* DCL$PATH may be a search list */
1096 while (1) { /* as may dev portion of any element */
1097 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1098 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1099 cando_by_name(S_IWUSR,0,elt) ) {
1100 MgTAINTEDDIR_on(mg);
1104 if ((cp = strchr(elt, ':')) != NULL)
1106 if (my_trnlnm(elt, eltbuf, j++))
1112 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1115 if (s && klen == 4 && strEQ(ptr,"PATH")) {
1116 const char * const strend = s + len;
1118 while (s < strend) {
1122 #ifdef VMS /* Hmm. How do we get $Config{path_sep} from C? */
1123 const char path_sep = '|';
1125 const char path_sep = ':';
1127 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
1128 s, strend, path_sep, &i);
1130 if (i >= (I32)sizeof tmpbuf /* too long -- assume the worst */
1132 || !strchr(tmpbuf, ':') /* no colon thus no device name -- assume relative path */
1134 || *tmpbuf != '/' /* no starting slash -- assume relative path */
1136 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1137 MgTAINTEDDIR_on(mg);
1143 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1149 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1151 PERL_UNUSED_ARG(sv);
1152 my_setenv(MgPV_nolen_const(mg),NULL);
1157 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1160 PERL_UNUSED_ARG(mg);
1162 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1164 if (PL_localizing) {
1167 hv_iterinit((HV*)sv);
1168 while ((entry = hv_iternext((HV*)sv))) {
1170 my_setenv(hv_iterkey(entry, &keylen),
1171 SvPV_nolen_const(hv_iterval((HV*)sv, entry)));
1179 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1182 PERL_UNUSED_ARG(sv);
1183 PERL_UNUSED_ARG(mg);
1185 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1193 #ifdef HAS_SIGPROCMASK
1195 restore_sigmask(pTHX_ SV *save_sv)
1197 const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1198 (void)sigprocmask(SIG_SETMASK, ossetp, NULL);
1202 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1205 /* Are we fetching a signal entry? */
1206 const I32 i = whichsig(MgPV_nolen_const(mg));
1209 sv_setsv(sv,PL_psig_ptr[i]);
1211 Sighandler_t sigstate = rsignal_state(i);
1212 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1213 if (PL_sig_handlers_initted && PL_sig_ignoring[i])
1216 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1217 if (PL_sig_handlers_initted && PL_sig_defaulting[i])
1220 /* cache state so we don't fetch it again */
1221 if(sigstate == (Sighandler_t) SIG_IGN)
1222 sv_setpvs(sv,"IGNORE");
1224 sv_setsv(sv,&PL_sv_undef);
1225 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1232 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1234 /* XXX Some of this code was copied from Perl_magic_setsig. A little
1235 * refactoring might be in order.
1238 register const char * const s = MgPV_nolen_const(mg);
1239 PERL_UNUSED_ARG(sv);
1242 if (strEQ(s,"__DIE__"))
1244 else if (strEQ(s,"__WARN__") && PL_warnhook != PERL_WARNHOOK_FATAL)
1247 SV *const to_dec = *svp;
1249 SvREFCNT_dec(to_dec);
1253 /* Are we clearing a signal entry? */
1254 const I32 i = whichsig(s);
1256 #ifdef HAS_SIGPROCMASK
1259 /* Avoid having the signal arrive at a bad time, if possible. */
1262 sigprocmask(SIG_BLOCK, &set, &save);
1264 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1265 SAVEFREESV(save_sv);
1266 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1269 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1270 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1272 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1273 PL_sig_defaulting[i] = 1;
1274 (void)rsignal(i, PL_csighandlerp);
1276 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1278 if(PL_psig_name[i]) {
1279 SvREFCNT_dec(PL_psig_name[i]);
1282 if(PL_psig_ptr[i]) {
1283 SV * const to_dec=PL_psig_ptr[i];
1286 SvREFCNT_dec(to_dec);
1296 * The signal handling nomenclature has gotten a bit confusing since the advent of
1297 * safe signals. S_raise_signal only raises signals by analogy with what the
1298 * underlying system's signal mechanism does. It might be more proper to say that
1299 * it defers signals that have already been raised and caught.
1301 * PL_sig_pending and PL_psig_pend likewise do not track signals that are pending
1302 * in the sense of being on the system's signal queue in between raising and delivery.
1303 * They are only pending on Perl's deferral list, i.e., they track deferred signals
1304 * awaiting delivery after the current Perl opcode completes and say nothing about
1305 * signals raised but not yet caught in the underlying signal implementation.
1308 #ifndef SIG_PENDING_DIE_COUNT
1309 # define SIG_PENDING_DIE_COUNT 120
1313 S_raise_signal(pTHX_ int sig)
1316 /* Set a flag to say this signal is pending */
1317 PL_psig_pend[sig]++;
1318 /* And one to say _a_ signal is pending */
1319 if (++PL_sig_pending >= SIG_PENDING_DIE_COUNT)
1320 Perl_croak(aTHX_ "Maximal count of pending signals (%lu) exceeded",
1321 (unsigned long)SIG_PENDING_DIE_COUNT);
1325 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1326 Perl_csighandler(int sig, ...)
1328 Perl_csighandler(int sig)
1331 #ifdef PERL_GET_SIG_CONTEXT
1332 dTHXa(PERL_GET_SIG_CONTEXT);
1336 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1337 (void) rsignal(sig, PL_csighandlerp);
1338 if (PL_sig_ignoring[sig]) return;
1340 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1341 if (PL_sig_defaulting[sig])
1342 #ifdef KILL_BY_SIGPRC
1343 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1358 (PL_signals & PERL_SIGNALS_UNSAFE_FLAG))
1359 /* Call the perl level handler now--
1360 * with risk we may be in malloc() etc. */
1361 (*PL_sighandlerp)(sig);
1363 S_raise_signal(aTHX_ sig);
1366 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1368 Perl_csighandler_init(void)
1371 if (PL_sig_handlers_initted) return;
1373 for (sig = 1; sig < SIG_SIZE; sig++) {
1374 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1376 PL_sig_defaulting[sig] = 1;
1377 (void) rsignal(sig, PL_csighandlerp);
1379 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1380 PL_sig_ignoring[sig] = 0;
1383 PL_sig_handlers_initted = 1;
1388 Perl_despatch_signals(pTHX)
1393 for (sig = 1; sig < SIG_SIZE; sig++) {
1394 if (PL_psig_pend[sig]) {
1395 PERL_BLOCKSIG_ADD(set, sig);
1396 PL_psig_pend[sig] = 0;
1397 PERL_BLOCKSIG_BLOCK(set);
1398 (*PL_sighandlerp)(sig);
1399 PERL_BLOCKSIG_UNBLOCK(set);
1405 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1410 /* Need to be careful with SvREFCNT_dec(), because that can have side
1411 * effects (due to closures). We must make sure that the new disposition
1412 * is in place before it is called.
1416 #ifdef HAS_SIGPROCMASK
1421 register const char *s = MgPV_const(mg,len);
1423 if (strEQ(s,"__DIE__"))
1425 else if (strEQ(s,"__WARN__"))
1428 Perl_croak(aTHX_ "No such hook: %s", s);
1431 if (*svp != PERL_WARNHOOK_FATAL)
1437 i = whichsig(s); /* ...no, a brick */
1439 if (ckWARN(WARN_SIGNAL))
1440 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
1443 #ifdef HAS_SIGPROCMASK
1444 /* Avoid having the signal arrive at a bad time, if possible. */
1447 sigprocmask(SIG_BLOCK, &set, &save);
1449 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1450 SAVEFREESV(save_sv);
1451 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1454 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1455 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1457 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1458 PL_sig_ignoring[i] = 0;
1460 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1461 PL_sig_defaulting[i] = 0;
1463 SvREFCNT_dec(PL_psig_name[i]);
1464 to_dec = PL_psig_ptr[i];
1465 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1466 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1467 PL_psig_name[i] = newSVpvn(s, len);
1468 SvREADONLY_on(PL_psig_name[i]);
1470 if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
1472 (void)rsignal(i, PL_csighandlerp);
1473 #ifdef HAS_SIGPROCMASK
1478 *svp = SvREFCNT_inc_simple_NN(sv);
1480 SvREFCNT_dec(to_dec);
1483 s = SvOK(sv) ? SvPV_force(sv,len) : "DEFAULT";
1484 if (strEQ(s,"IGNORE")) {
1486 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1487 PL_sig_ignoring[i] = 1;
1488 (void)rsignal(i, PL_csighandlerp);
1490 (void)rsignal(i, (Sighandler_t) SIG_IGN);
1494 else if (strEQ(s,"DEFAULT") || !*s) {
1496 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1498 PL_sig_defaulting[i] = 1;
1499 (void)rsignal(i, PL_csighandlerp);
1502 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1507 * We should warn if HINT_STRICT_REFS, but without
1508 * access to a known hint bit in a known OP, we can't
1509 * tell whether HINT_STRICT_REFS is in force or not.
1511 if (!strchr(s,':') && !strchr(s,'\''))
1512 Perl_sv_insert(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"));
1514 (void)rsignal(i, PL_csighandlerp);
1516 *svp = SvREFCNT_inc_simple_NN(sv);
1518 #ifdef HAS_SIGPROCMASK
1523 SvREFCNT_dec(to_dec);
1526 #endif /* !PERL_MICRO */
1529 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1532 PERL_UNUSED_ARG(sv);
1534 /* The first case occurs via setisa,
1535 the second via setisa_elem, which
1536 calls this same magic */
1539 SvTYPE(mg->mg_obj) == SVt_PVGV
1541 : (GV*)SvMAGIC(mg->mg_obj)->mg_obj
1549 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
1552 PERL_UNUSED_ARG(sv);
1553 PERL_UNUSED_ARG(mg);
1554 PL_amagic_generation++;
1560 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1562 HV * const hv = (HV*)LvTARG(sv);
1564 PERL_UNUSED_ARG(mg);
1567 (void) hv_iterinit(hv);
1568 if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
1571 while (hv_iternext(hv))
1576 sv_setiv(sv, (IV)i);
1581 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1583 PERL_UNUSED_ARG(mg);
1585 hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
1590 /* caller is responsible for stack switching/cleanup */
1592 S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV *val)
1599 PUSHs(SvTIED_obj(sv, mg));
1602 if (mg->mg_len >= 0)
1603 PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len)));
1604 else if (mg->mg_len == HEf_SVKEY)
1605 PUSHs((SV*)mg->mg_ptr);
1607 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1608 PUSHs(sv_2mortal(newSViv(mg->mg_len)));
1616 return call_method(meth, flags);
1620 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
1626 PUSHSTACKi(PERLSI_MAGIC);
1628 if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
1629 sv_setsv(sv, *PL_stack_sp--);
1639 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1642 mg->mg_flags |= MGf_GSKIP;
1643 magic_methpack(sv,mg,"FETCH");
1648 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1652 PUSHSTACKi(PERLSI_MAGIC);
1653 magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
1660 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1662 return magic_methpack(sv,mg,"DELETE");
1667 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1674 PUSHSTACKi(PERLSI_MAGIC);
1675 if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
1676 sv = *PL_stack_sp--;
1677 retval = (U32) SvIV(sv)-1;
1686 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1691 PUSHSTACKi(PERLSI_MAGIC);
1693 XPUSHs(SvTIED_obj(sv, mg));
1695 call_method("CLEAR", G_SCALAR|G_DISCARD);
1703 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1706 const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
1710 PUSHSTACKi(PERLSI_MAGIC);
1713 PUSHs(SvTIED_obj(sv, mg));
1718 if (call_method(meth, G_SCALAR))
1719 sv_setsv(key, *PL_stack_sp--);
1728 Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg)
1730 return magic_methpack(sv,mg,"EXISTS");
1734 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1738 SV * const tied = SvTIED_obj((SV*)hv, mg);
1739 HV * const pkg = SvSTASH((SV*)SvRV(tied));
1741 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1743 if (HvEITER_get(hv))
1744 /* we are in an iteration so the hash cannot be empty */
1746 /* no xhv_eiter so now use FIRSTKEY */
1747 key = sv_newmortal();
1748 magic_nextpack((SV*)hv, mg, key);
1749 HvEITER_set(hv, NULL); /* need to reset iterator */
1750 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1753 /* there is a SCALAR method that we can call */
1755 PUSHSTACKi(PERLSI_MAGIC);
1761 if (call_method("SCALAR", G_SCALAR))
1762 retval = *PL_stack_sp--;
1764 retval = &PL_sv_undef;
1771 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1774 GV * const gv = PL_DBline;
1775 const I32 i = SvTRUE(sv);
1776 SV ** const svp = av_fetch(GvAV(gv),
1777 atoi(MgPV_nolen_const(mg)), FALSE);
1778 if (svp && SvIOKp(*svp)) {
1779 OP * const o = INT2PTR(OP*,SvIVX(*svp));
1781 /* set or clear breakpoint in the relevant control op */
1783 o->op_flags |= OPf_SPECIAL;
1785 o->op_flags &= ~OPf_SPECIAL;
1792 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
1795 const AV * const obj = (AV*)mg->mg_obj;
1797 sv_setiv(sv, AvFILL(obj) + CopARYBASE_get(PL_curcop));
1805 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
1808 AV * const obj = (AV*)mg->mg_obj;
1810 av_fill(obj, SvIV(sv) - CopARYBASE_get(PL_curcop));
1812 if (ckWARN(WARN_MISC))
1813 Perl_warner(aTHX_ packWARN(WARN_MISC),
1814 "Attempt to set length of freed array");
1820 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
1823 PERL_UNUSED_ARG(sv);
1824 /* during global destruction, mg_obj may already have been freed */
1825 if (PL_in_clean_all)
1828 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
1831 /* arylen scalar holds a pointer back to the array, but doesn't own a
1832 reference. Hence the we (the array) are about to go away with it
1833 still pointing at us. Clear its pointer, else it would be pointing
1834 at free memory. See the comment in sv_magic about reference loops,
1835 and why it can't own a reference to us. */
1842 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
1845 SV* const lsv = LvTARG(sv);
1846 PERL_UNUSED_ARG(mg);
1848 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1849 MAGIC * const found = mg_find(lsv, PERL_MAGIC_regex_global);
1850 if (found && found->mg_len >= 0) {
1851 I32 i = found->mg_len;
1853 sv_pos_b2u(lsv, &i);
1854 sv_setiv(sv, i + CopARYBASE_get(PL_curcop));
1863 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
1866 SV* const lsv = LvTARG(sv);
1872 PERL_UNUSED_ARG(mg);
1874 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
1875 found = mg_find(lsv, PERL_MAGIC_regex_global);
1881 #ifdef PERL_OLD_COPY_ON_WRITE
1883 sv_force_normal_flags(lsv, 0);
1885 found = sv_magicext(lsv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
1888 else if (!SvOK(sv)) {
1892 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1894 pos = SvIV(sv) - CopARYBASE_get(PL_curcop);
1897 ulen = sv_len_utf8(lsv);
1907 else if (pos > (SSize_t)len)
1912 sv_pos_u2b(lsv, &p, 0);
1916 found->mg_len = pos;
1917 found->mg_flags &= ~MGf_MINMATCH;
1923 Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg)
1926 PERL_UNUSED_ARG(mg);
1930 if (isGV_with_GP(sv)) {
1931 /* We're actually already a typeglob, so don't need the stuff below.
1935 gv = gv_fetchsv(sv, GV_ADD, SVt_PVGV);
1940 GvGP(sv) = gp_ref(GvGP(gv));
1945 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
1948 SV * const lsv = LvTARG(sv);
1949 const char * const tmps = SvPV_const(lsv,len);
1950 I32 offs = LvTARGOFF(sv);
1951 I32 rem = LvTARGLEN(sv);
1952 PERL_UNUSED_ARG(mg);
1955 sv_pos_u2b(lsv, &offs, &rem);
1956 if (offs > (I32)len)
1958 if (rem + offs > (I32)len)
1960 sv_setpvn(sv, tmps + offs, (STRLEN)rem);
1967 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
1971 const char * const tmps = SvPV_const(sv, len);
1972 SV * const lsv = LvTARG(sv);
1973 I32 lvoff = LvTARGOFF(sv);
1974 I32 lvlen = LvTARGLEN(sv);
1975 PERL_UNUSED_ARG(mg);
1978 sv_utf8_upgrade(lsv);
1979 sv_pos_u2b(lsv, &lvoff, &lvlen);
1980 sv_insert(lsv, lvoff, lvlen, tmps, len);
1981 LvTARGLEN(sv) = sv_len_utf8(sv);
1984 else if (lsv && SvUTF8(lsv)) {
1986 sv_pos_u2b(lsv, &lvoff, &lvlen);
1987 LvTARGLEN(sv) = len;
1988 utf8 = (char*)bytes_to_utf8((U8*)tmps, &len);
1989 sv_insert(lsv, lvoff, lvlen, utf8, len);
1993 sv_insert(lsv, lvoff, lvlen, tmps, len);
1994 LvTARGLEN(sv) = len;
2002 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
2005 PERL_UNUSED_ARG(sv);
2006 TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
2011 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
2014 PERL_UNUSED_ARG(sv);
2015 /* update taint status */
2024 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
2026 SV * const lsv = LvTARG(sv);
2027 PERL_UNUSED_ARG(mg);
2030 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
2038 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
2040 PERL_UNUSED_ARG(mg);
2041 do_vecset(sv); /* XXX slurp this routine */
2046 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
2050 if (LvTARGLEN(sv)) {
2052 SV * const ahv = LvTARG(sv);
2053 HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
2058 AV* const av = (AV*)LvTARG(sv);
2059 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
2060 targ = AvARRAY(av)[LvTARGOFF(sv)];
2062 if (targ && (targ != &PL_sv_undef)) {
2063 /* somebody else defined it for us */
2064 SvREFCNT_dec(LvTARG(sv));
2065 LvTARG(sv) = SvREFCNT_inc_simple_NN(targ);
2067 SvREFCNT_dec(mg->mg_obj);
2069 mg->mg_flags &= ~MGf_REFCOUNTED;
2074 sv_setsv(sv, targ ? targ : &PL_sv_undef);
2079 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
2081 PERL_UNUSED_ARG(mg);
2085 sv_setsv(LvTARG(sv), sv);
2086 SvSETMAGIC(LvTARG(sv));
2092 Perl_vivify_defelem(pTHX_ SV *sv)
2098 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2101 SV * const ahv = LvTARG(sv);
2102 HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
2105 if (!value || value == &PL_sv_undef)
2106 Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(mg->mg_obj));
2109 AV* const av = (AV*)LvTARG(sv);
2110 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
2111 LvTARG(sv) = NULL; /* array can't be extended */
2113 SV* const * const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
2114 if (!svp || (value = *svp) == &PL_sv_undef)
2115 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
2118 SvREFCNT_inc_simple_void(value);
2119 SvREFCNT_dec(LvTARG(sv));
2122 SvREFCNT_dec(mg->mg_obj);
2124 mg->mg_flags &= ~MGf_REFCOUNTED;
2128 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2130 return Perl_sv_kill_backrefs(aTHX_ sv, (AV*)mg->mg_obj);
2134 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2136 PERL_UNUSED_CONTEXT;
2143 Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
2145 PERL_UNUSED_ARG(mg);
2146 sv_unmagic(sv, PERL_MAGIC_bm);
2153 Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
2155 PERL_UNUSED_ARG(mg);
2156 sv_unmagic(sv, PERL_MAGIC_fm);
2162 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2164 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2166 if (uf && uf->uf_set)
2167 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2172 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2174 PERL_UNUSED_ARG(mg);
2175 sv_unmagic(sv, PERL_MAGIC_qr);
2180 Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
2183 regexp * const re = (regexp *)mg->mg_obj;
2184 PERL_UNUSED_ARG(sv);
2190 #ifdef USE_LOCALE_COLLATE
2192 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2195 * RenE<eacute> Descartes said "I think not."
2196 * and vanished with a faint plop.
2198 PERL_UNUSED_CONTEXT;
2199 PERL_UNUSED_ARG(sv);
2201 Safefree(mg->mg_ptr);
2207 #endif /* USE_LOCALE_COLLATE */
2209 /* Just clear the UTF-8 cache data. */
2211 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2213 PERL_UNUSED_CONTEXT;
2214 PERL_UNUSED_ARG(sv);
2215 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2217 mg->mg_len = -1; /* The mg_len holds the len cache. */
2222 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2225 register const char *s;
2228 switch (*mg->mg_ptr) {
2229 case '\001': /* ^A */
2230 sv_setsv(PL_bodytarget, sv);
2232 case '\003': /* ^C */
2233 PL_minus_c = (bool)SvIV(sv);
2236 case '\004': /* ^D */
2238 s = SvPV_nolen_const(sv);
2239 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2240 DEBUG_x(dump_all());
2242 PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG;
2245 case '\005': /* ^E */
2246 if (*(mg->mg_ptr+1) == '\0') {
2247 #ifdef MACOS_TRADITIONAL
2248 gMacPerl_OSErr = SvIV(sv);
2251 set_vaxc_errno(SvIV(sv));
2254 SetLastError( SvIV(sv) );
2257 os2_setsyserrno(SvIV(sv));
2259 /* will anyone ever use this? */
2260 SETERRNO(SvIV(sv), 4);
2266 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2268 SvREFCNT_dec(PL_encoding);
2269 if (SvOK(sv) || SvGMAGICAL(sv)) {
2270 PL_encoding = newSVsv(sv);
2277 case '\006': /* ^F */
2278 PL_maxsysfd = SvIV(sv);
2280 case '\010': /* ^H */
2281 PL_hints = SvIV(sv);
2283 case '\011': /* ^I */ /* NOT \t in EBCDIC */
2284 Safefree(PL_inplace);
2285 PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
2287 case '\017': /* ^O */
2288 if (*(mg->mg_ptr+1) == '\0') {
2289 Safefree(PL_osname);
2292 TAINT_PROPER("assigning to $^O");
2293 PL_osname = savesvpv(sv);
2296 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2298 const char *const start = SvPV(sv, len);
2299 const char *out = (const char*)memchr(start, '\0', len);
2301 struct refcounted_he *tmp_he;
2304 PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2306 |= HINT_LOCALIZE_HH | HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2308 /* Opening for input is more common than opening for output, so
2309 ensure that hints for input are sooner on linked list. */
2310 tmp = sv_2mortal(out ? newSVpvn(out + 1, start + len - out - 1)
2312 SvFLAGS(tmp) |= SvUTF8(sv);
2315 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
2316 sv_2mortal(newSVpvs("open>")), tmp);
2318 /* The UTF-8 setting is carried over */
2319 sv_setpvn(tmp, start, out ? (STRLEN)(out - start) : len);
2321 PL_compiling.cop_hints_hash
2322 = Perl_refcounted_he_new(aTHX_ tmp_he,
2323 sv_2mortal(newSVpvs("open<")), tmp);
2326 case '\020': /* ^P */
2327 PL_perldb = SvIV(sv);
2328 if (PL_perldb && !PL_DBsingle)
2331 case '\024': /* ^T */
2333 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2335 PL_basetime = (Time_t)SvIV(sv);
2338 case '\025': /* ^UTF8CACHE */
2339 if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
2340 PL_utf8cache = (signed char) sv_2iv(sv);
2343 case '\027': /* ^W & $^WARNING_BITS */
2344 if (*(mg->mg_ptr+1) == '\0') {
2345 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2347 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2348 | (i ? G_WARN_ON : G_WARN_OFF) ;
2351 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2352 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2353 if (!SvPOK(sv) && PL_localizing) {
2354 sv_setpvn(sv, WARN_NONEstring, WARNsize);
2355 PL_compiling.cop_warnings = pWARN_NONE;
2360 int accumulate = 0 ;
2361 int any_fatals = 0 ;
2362 const char * const ptr = SvPV_const(sv, len) ;
2363 for (i = 0 ; i < len ; ++i) {
2364 accumulate |= ptr[i] ;
2365 any_fatals |= (ptr[i] & 0xAA) ;
2368 if (!specialWARN(PL_compiling.cop_warnings))
2369 PerlMemShared_free(PL_compiling.cop_warnings);
2370 PL_compiling.cop_warnings = pWARN_NONE;
2372 /* Yuck. I can't see how to abstract this: */
2373 else if (isWARN_on(((STRLEN *)SvPV_nolen_const(sv)) - 1,
2374 WARN_ALL) && !any_fatals) {
2375 if (!specialWARN(PL_compiling.cop_warnings))
2376 PerlMemShared_free(PL_compiling.cop_warnings);
2377 PL_compiling.cop_warnings = pWARN_ALL;
2378 PL_dowarn |= G_WARN_ONCE ;
2382 const char *const p = SvPV_const(sv, len);
2384 PL_compiling.cop_warnings
2385 = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
2388 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2389 PL_dowarn |= G_WARN_ONCE ;
2397 if (PL_localizing) {
2398 if (PL_localizing == 1)
2399 SAVESPTR(PL_last_in_gv);
2401 else if (SvOK(sv) && GvIO(PL_last_in_gv))
2402 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2405 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2406 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2407 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2410 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2411 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2412 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2415 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
2418 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
2419 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2420 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2423 IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
2427 IO * const io = GvIOp(PL_defoutgv);
2430 if ((SvIV(sv)) == 0)
2431 IoFLAGS(io) &= ~IOf_FLUSH;
2433 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2434 PerlIO *ofp = IoOFP(io);
2436 (void)PerlIO_flush(ofp);
2437 IoFLAGS(io) |= IOf_FLUSH;
2443 SvREFCNT_dec(PL_rs);
2444 PL_rs = newSVsv(sv);
2448 SvREFCNT_dec(PL_ors_sv);
2449 if (SvOK(sv) || SvGMAGICAL(sv)) {
2450 PL_ors_sv = newSVsv(sv);
2458 SvREFCNT_dec(PL_ofs_sv);
2459 if (SvOK(sv) || SvGMAGICAL(sv)) {
2460 PL_ofs_sv = newSVsv(sv);
2467 CopARYBASE_set(&PL_compiling, SvIV(sv));
2470 #ifdef COMPLEX_STATUS
2471 if (PL_localizing == 2) {
2472 PL_statusvalue = LvTARGOFF(sv);
2473 PL_statusvalue_vms = LvTARGLEN(sv);
2477 #ifdef VMSISH_STATUS
2479 STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2482 STATUS_UNIX_EXIT_SET(SvIV(sv));
2487 # define PERL_VMS_BANG vaxc$errno
2489 # define PERL_VMS_BANG 0
2491 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2492 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2497 if (PL_delaymagic) {
2498 PL_delaymagic |= DM_RUID;
2499 break; /* don't do magic till later */
2502 (void)setruid((Uid_t)PL_uid);
2505 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2507 #ifdef HAS_SETRESUID
2508 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2510 if (PL_uid == PL_euid) { /* special case $< = $> */
2512 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2513 if (PL_uid != 0 && PerlProc_getuid() == 0)
2514 (void)PerlProc_setuid(0);
2516 (void)PerlProc_setuid(PL_uid);
2518 PL_uid = PerlProc_getuid();
2519 Perl_croak(aTHX_ "setruid() not implemented");
2524 PL_uid = PerlProc_getuid();
2525 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2529 if (PL_delaymagic) {
2530 PL_delaymagic |= DM_EUID;
2531 break; /* don't do magic till later */
2534 (void)seteuid((Uid_t)PL_euid);
2537 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2539 #ifdef HAS_SETRESUID
2540 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2542 if (PL_euid == PL_uid) /* special case $> = $< */
2543 PerlProc_setuid(PL_euid);
2545 PL_euid = PerlProc_geteuid();
2546 Perl_croak(aTHX_ "seteuid() not implemented");
2551 PL_euid = PerlProc_geteuid();
2552 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2556 if (PL_delaymagic) {
2557 PL_delaymagic |= DM_RGID;
2558 break; /* don't do magic till later */
2561 (void)setrgid((Gid_t)PL_gid);
2564 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2566 #ifdef HAS_SETRESGID
2567 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2569 if (PL_gid == PL_egid) /* special case $( = $) */
2570 (void)PerlProc_setgid(PL_gid);
2572 PL_gid = PerlProc_getgid();
2573 Perl_croak(aTHX_ "setrgid() not implemented");
2578 PL_gid = PerlProc_getgid();
2579 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2582 #ifdef HAS_SETGROUPS
2584 const char *p = SvPV_const(sv, len);
2585 Groups_t *gary = NULL;
2590 for (i = 0; i < NGROUPS; ++i) {
2591 while (*p && !isSPACE(*p))
2598 Newx(gary, i + 1, Groups_t);
2600 Renew(gary, i + 1, Groups_t);
2604 (void)setgroups(i, gary);
2607 #else /* HAS_SETGROUPS */
2609 #endif /* HAS_SETGROUPS */
2610 if (PL_delaymagic) {
2611 PL_delaymagic |= DM_EGID;
2612 break; /* don't do magic till later */
2615 (void)setegid((Gid_t)PL_egid);
2618 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2620 #ifdef HAS_SETRESGID
2621 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2623 if (PL_egid == PL_gid) /* special case $) = $( */
2624 (void)PerlProc_setgid(PL_egid);
2626 PL_egid = PerlProc_getegid();
2627 Perl_croak(aTHX_ "setegid() not implemented");
2632 PL_egid = PerlProc_getegid();
2633 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2636 PL_chopset = SvPV_force(sv,len);
2638 #ifndef MACOS_TRADITIONAL
2640 LOCK_DOLLARZERO_MUTEX;
2641 #ifdef HAS_SETPROCTITLE
2642 /* The BSDs don't show the argv[] in ps(1) output, they
2643 * show a string from the process struct and provide
2644 * the setproctitle() routine to manipulate that. */
2645 if (PL_origalen != 1) {
2646 s = SvPV_const(sv, len);
2647 # if __FreeBSD_version > 410001
2648 /* The leading "-" removes the "perl: " prefix,
2649 * but not the "(perl) suffix from the ps(1)
2650 * output, because that's what ps(1) shows if the
2651 * argv[] is modified. */
2652 setproctitle("-%s", s);
2653 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2654 /* This doesn't really work if you assume that
2655 * $0 = 'foobar'; will wipe out 'perl' from the $0
2656 * because in ps(1) output the result will be like
2657 * sprintf("perl: %s (perl)", s)
2658 * I guess this is a security feature:
2659 * one (a user process) cannot get rid of the original name.
2661 setproctitle("%s", s);
2664 #elif defined(__hpux) && defined(PSTAT_SETCMD)
2665 if (PL_origalen != 1) {
2667 s = SvPV_const(sv, len);
2668 un.pst_command = (char *)s;
2669 pstat(PSTAT_SETCMD, un, len, 0, 0);
2672 if (PL_origalen > 1) {
2673 /* PL_origalen is set in perl_parse(). */
2674 s = SvPV_force(sv,len);
2675 if (len >= (STRLEN)PL_origalen-1) {
2676 /* Longer than original, will be truncated. We assume that
2677 * PL_origalen bytes are available. */
2678 Copy(s, PL_origargv[0], PL_origalen-1, char);
2681 /* Shorter than original, will be padded. */
2683 /* Special case for Mac OS X: see [perl #38868] */
2686 /* Is the space counterintuitive? Yes.
2687 * (You were expecting \0?)
2688 * Does it work? Seems to. (In Linux 2.4.20 at least.)
2690 const int pad = ' ';
2692 Copy(s, PL_origargv[0], len, char);
2693 PL_origargv[0][len] = 0;
2694 memset(PL_origargv[0] + len + 1,
2695 pad, PL_origalen - len - 1);
2697 PL_origargv[0][PL_origalen-1] = 0;
2698 for (i = 1; i < PL_origargc; i++)
2702 UNLOCK_DOLLARZERO_MUTEX;
2710 Perl_whichsig(pTHX_ const char *sig)
2712 register char* const* sigv;
2713 PERL_UNUSED_CONTEXT;
2715 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
2716 if (strEQ(sig,*sigv))
2717 return PL_sig_num[sigv - (char* const*)PL_sig_name];
2719 if (strEQ(sig,"CHLD"))
2723 if (strEQ(sig,"CLD"))
2730 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2731 Perl_sighandler(int sig, ...)
2733 Perl_sighandler(int sig)
2736 #ifdef PERL_GET_SIG_CONTEXT
2737 dTHXa(PERL_GET_SIG_CONTEXT);
2744 SV * const tSv = PL_Sv;
2748 XPV * const tXpv = PL_Xpv;
2750 if (PL_savestack_ix + 15 <= PL_savestack_max)
2752 if (PL_markstack_ptr < PL_markstack_max - 2)
2754 if (PL_scopestack_ix < PL_scopestack_max - 3)
2757 if (!PL_psig_ptr[sig]) {
2758 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2763 /* Max number of items pushed there is 3*n or 4. We cannot fix
2764 infinity, so we fix 4 (in fact 5): */
2766 PL_savestack_ix += 5; /* Protect save in progress. */
2767 SAVEDESTRUCTOR_X(S_unwind_handler_stack, (void*)&flags);
2770 PL_markstack_ptr++; /* Protect mark. */
2772 PL_scopestack_ix += 1;
2773 /* sv_2cv is too complicated, try a simpler variant first: */
2774 if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
2775 || SvTYPE(cv) != SVt_PVCV) {
2777 cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
2780 if (!cv || !CvROOT(cv)) {
2781 if (ckWARN(WARN_SIGNAL))
2782 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2783 PL_sig_name[sig], (gv ? GvENAME(gv)
2790 if(PL_psig_name[sig]) {
2791 sv = SvREFCNT_inc_NN(PL_psig_name[sig]);
2793 #if !defined(PERL_IMPLICIT_CONTEXT)
2797 sv = sv_newmortal();
2798 sv_setpv(sv,PL_sig_name[sig]);
2801 PUSHSTACKi(PERLSI_SIGNAL);
2804 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2806 struct sigaction oact;
2808 if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
2812 va_start(args, sig);
2813 sip = (siginfo_t*)va_arg(args, siginfo_t*);
2816 SV *rv = newRV_noinc((SV*)sih);
2817 /* The siginfo fields signo, code, errno, pid, uid,
2818 * addr, status, and band are defined by POSIX/SUSv3. */
2819 hv_store(sih, "signo", 5, newSViv(sip->si_signo), 0);
2820 hv_store(sih, "code", 4, newSViv(sip->si_code), 0);
2821 #if 0 /* XXX TODO: Configure scan for the existence of these, but even that does not help if the SA_SIGINFO is not implemented according to the spec. */
2822 hv_store(sih, "errno", 5, newSViv(sip->si_errno), 0);
2823 hv_store(sih, "status", 6, newSViv(sip->si_status), 0);
2824 hv_store(sih, "uid", 3, newSViv(sip->si_uid), 0);
2825 hv_store(sih, "pid", 3, newSViv(sip->si_pid), 0);
2826 hv_store(sih, "addr", 4, newSVuv(PTR2UV(sip->si_addr)), 0);
2827 hv_store(sih, "band", 4, newSViv(sip->si_band), 0);
2831 PUSHs(newSVpv((char *)sip, sizeof(*sip)));
2840 call_sv((SV*)cv, G_DISCARD|G_EVAL);
2843 if (SvTRUE(ERRSV)) {
2845 #ifdef HAS_SIGPROCMASK
2846 /* Handler "died", for example to get out of a restart-able read().
2847 * Before we re-do that on its behalf re-enable the signal which was
2848 * blocked by the system when we entered.
2852 sigaddset(&set,sig);
2853 sigprocmask(SIG_UNBLOCK, &set, NULL);
2855 /* Not clear if this will work */
2856 (void)rsignal(sig, SIG_IGN);
2857 (void)rsignal(sig, PL_csighandlerp);
2859 #endif /* !PERL_MICRO */
2860 Perl_die(aTHX_ NULL);
2864 PL_savestack_ix -= 8; /* Unprotect save in progress. */
2868 PL_scopestack_ix -= 1;
2871 PL_op = myop; /* Apparently not needed... */
2873 PL_Sv = tSv; /* Restore global temporaries. */
2880 S_restore_magic(pTHX_ const void *p)
2883 MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
2884 SV* const sv = mgs->mgs_sv;
2889 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2891 #ifdef PERL_OLD_COPY_ON_WRITE
2892 /* While magic was saved (and off) sv_setsv may well have seen
2893 this SV as a prime candidate for COW. */
2895 sv_force_normal_flags(sv, 0);
2899 SvFLAGS(sv) |= mgs->mgs_flags;
2902 if (SvGMAGICAL(sv)) {
2903 /* downgrade public flags to private,
2904 and discard any other private flags */
2906 const U32 pubflags = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
2908 SvFLAGS(sv) &= ~( pubflags | (SVp_IOK|SVp_NOK|SVp_POK) );
2909 SvFLAGS(sv) |= ( pubflags << PRIVSHIFT );
2914 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
2916 /* If we're still on top of the stack, pop us off. (That condition
2917 * will be satisfied if restore_magic was called explicitly, but *not*
2918 * if it's being called via leave_scope.)
2919 * The reason for doing this is that otherwise, things like sv_2cv()
2920 * may leave alloc gunk on the savestack, and some code
2921 * (e.g. sighandler) doesn't expect that...
2923 if (PL_savestack_ix == mgs->mgs_ss_ix)
2925 I32 popval = SSPOPINT;
2926 assert(popval == SAVEt_DESTRUCTOR_X);
2927 PL_savestack_ix -= 2;
2929 assert(popval == SAVEt_ALLOC);
2931 PL_savestack_ix -= popval;
2937 S_unwind_handler_stack(pTHX_ const void *p)
2940 const U32 flags = *(const U32*)p;
2943 PL_savestack_ix -= 5; /* Unprotect save in progress. */
2944 #if !defined(PERL_IMPLICIT_CONTEXT)
2946 SvREFCNT_dec(PL_sig_sv);
2951 =for apidoc magic_sethint
2953 Triggered by a store to %^H, records the key/value pair to
2954 C<PL_compiling.cop_hints_hash>. It is assumed that hints aren't storing
2955 anything that would need a deep copy. Maybe we should warn if we find a
2961 Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
2964 assert(mg->mg_len == HEf_SVKEY);
2966 /* mg->mg_obj isn't being used. If needed, it would be possible to store
2967 an alternative leaf in there, with PL_compiling.cop_hints being used if
2968 it's NULL. If needed for threads, the alternative could lock a mutex,
2969 or take other more complex action. */
2971 /* Something changed in %^H, so it will need to be restored on scope exit.
2972 Doing this here saves a lot of doing it manually in perl code (and
2973 forgetting to do it, and consequent subtle errors. */
2974 PL_hints |= HINT_LOCALIZE_HH;
2975 PL_compiling.cop_hints_hash
2976 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
2977 (SV *)mg->mg_ptr, sv);
2982 =for apidoc magic_sethint
2984 Triggered by a delete from %^H, records the key to
2985 C<PL_compiling.cop_hints_hash>.
2990 Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
2993 PERL_UNUSED_ARG(sv);
2995 assert(mg->mg_len == HEf_SVKEY);
2997 PERL_UNUSED_ARG(sv);
2999 PL_hints |= HINT_LOCALIZE_HH;
3000 PL_compiling.cop_hints_hash
3001 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
3002 (SV *)mg->mg_ptr, &PL_sv_placeholder);
3008 * c-indentation-style: bsd
3010 * indent-tabs-mode: t
3013 * ex: set ts=8 sts=4 sw=4 noet: