3 * Copyright (C) 1991, 1992, 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 * "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)
52 # include <sys/pstat.h>
55 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
56 Signal_t Perl_csighandler(int sig, ...);
58 Signal_t Perl_csighandler(int sig);
62 /* Missing protos on LynxOS */
63 void setruid(uid_t id);
64 void seteuid(uid_t id);
65 void setrgid(uid_t id);
66 void setegid(uid_t id);
70 * Use the "DESTRUCTOR" scope cleanup to reinstate magic.
78 /* MGS is typedef'ed to struct magic_state in perl.h */
81 S_save_magic(pTHX_ I32 mgs_ix, SV *sv)
84 assert(SvMAGICAL(sv));
85 #ifdef PERL_OLD_COPY_ON_WRITE
86 /* Turning READONLY off for a copy-on-write scalar is a bad idea. */
88 sv_force_normal_flags(sv, 0);
91 SAVEDESTRUCTOR_X(S_restore_magic, INT2PTR(void*, (IV)mgs_ix));
93 mgs = SSPTR(mgs_ix, MGS*);
95 mgs->mgs_flags = SvMAGICAL(sv) | SvREADONLY(sv);
96 mgs->mgs_ss_ix = PL_savestack_ix; /* points after the saved destructor */
100 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
104 =for apidoc mg_magical
106 Turns on the magical status of an SV. See C<sv_magic>.
112 Perl_mg_magical(pTHX_ SV *sv)
115 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
116 const MGVTBL* const vtbl = mg->mg_virtual;
118 if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
122 if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)) || vtbl->svt_clear)
131 Do magic after a value is retrieved from the SV. See C<sv_magic>.
137 Perl_mg_get(pTHX_ SV *sv)
139 const I32 mgs_ix = SSNEW(sizeof(MGS));
140 const bool was_temp = (bool)SvTEMP(sv);
142 MAGIC *newmg, *head, *cur, *mg;
143 /* guard against sv having being freed midway by holding a private
146 /* sv_2mortal has this side effect of turning on the TEMP flag, which can
147 cause the SV's buffer to get stolen (and maybe other stuff).
150 sv_2mortal(SvREFCNT_inc(sv));
155 save_magic(mgs_ix, sv);
157 /* We must call svt_get(sv, mg) for each valid entry in the linked
158 list of magic. svt_get() may delete the current entry, add new
159 magic to the head of the list, or upgrade the SV. AMS 20010810 */
161 newmg = cur = head = mg = SvMAGIC(sv);
163 const MGVTBL * const vtbl = mg->mg_virtual;
165 if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
166 CALL_FPTR(vtbl->svt_get)(aTHX_ sv, mg);
168 /* guard against magic having been deleted - eg FETCH calling
173 /* Don't restore the flags for this entry if it was deleted. */
174 if (mg->mg_flags & MGf_GSKIP)
175 (SSPTR(mgs_ix, MGS *))->mgs_flags = 0;
178 mg = mg->mg_moremagic;
181 /* Have we finished with the new entries we saw? Start again
182 where we left off (unless there are more new entries). */
190 /* Were any new entries added? */
191 if (!have_new && (newmg = SvMAGIC(sv)) != head) {
198 restore_magic(INT2PTR(void *, (IV)mgs_ix));
200 if (SvREFCNT(sv) == 1) {
201 /* We hold the last reference to this SV, which implies that the
202 SV was deleted as a side effect of the routines we called. */
211 Do magic after a value is assigned to the SV. See C<sv_magic>.
217 Perl_mg_set(pTHX_ SV *sv)
219 const I32 mgs_ix = SSNEW(sizeof(MGS));
223 save_magic(mgs_ix, sv);
225 for (mg = SvMAGIC(sv); mg; mg = nextmg) {
226 const MGVTBL* vtbl = mg->mg_virtual;
227 nextmg = mg->mg_moremagic; /* it may delete itself */
228 if (mg->mg_flags & MGf_GSKIP) {
229 mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */
230 (SSPTR(mgs_ix, MGS*))->mgs_flags = 0;
232 if (vtbl && vtbl->svt_set)
233 CALL_FPTR(vtbl->svt_set)(aTHX_ sv, mg);
236 restore_magic(INT2PTR(void*, (IV)mgs_ix));
241 =for apidoc mg_length
243 Report on the SV's length. See C<sv_magic>.
249 Perl_mg_length(pTHX_ SV *sv)
254 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
255 const MGVTBL * const vtbl = mg->mg_virtual;
256 if (vtbl && vtbl->svt_len) {
257 const I32 mgs_ix = SSNEW(sizeof(MGS));
258 save_magic(mgs_ix, sv);
259 /* omit MGf_GSKIP -- not changed here */
260 len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
261 restore_magic(INT2PTR(void*, (IV)mgs_ix));
267 const U8 *s = (U8*)SvPV_const(sv, len);
268 len = Perl_utf8_length(aTHX_ s, s + len);
271 (void)SvPV_const(sv, len);
276 Perl_mg_size(pTHX_ SV *sv)
280 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
281 const MGVTBL* const vtbl = mg->mg_virtual;
282 if (vtbl && vtbl->svt_len) {
283 const I32 mgs_ix = SSNEW(sizeof(MGS));
285 save_magic(mgs_ix, sv);
286 /* omit MGf_GSKIP -- not changed here */
287 len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
288 restore_magic(INT2PTR(void*, (IV)mgs_ix));
295 return AvFILLp((AV *) sv); /* Fallback to non-tied array */
299 Perl_croak(aTHX_ "Size magic not implemented");
308 Clear something magical that the SV represents. See C<sv_magic>.
314 Perl_mg_clear(pTHX_ SV *sv)
316 const I32 mgs_ix = SSNEW(sizeof(MGS));
319 save_magic(mgs_ix, sv);
321 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
322 const MGVTBL* const vtbl = mg->mg_virtual;
323 /* omit GSKIP -- never set here */
325 if (vtbl && vtbl->svt_clear)
326 CALL_FPTR(vtbl->svt_clear)(aTHX_ sv, mg);
329 restore_magic(INT2PTR(void*, (IV)mgs_ix));
336 Finds the magic pointer for type matching the SV. See C<sv_magic>.
342 Perl_mg_find(pTHX_ const SV *sv, int type)
346 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
347 if (mg->mg_type == type)
357 Copies the magic from one SV to another. See C<sv_magic>.
363 Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
367 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
368 const MGVTBL* const vtbl = mg->mg_virtual;
369 if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){
370 count += CALL_FPTR(vtbl->svt_copy)(aTHX_ sv, mg, nsv, key, klen);
373 const char type = mg->mg_type;
376 (type == PERL_MAGIC_tied)
378 : (type == PERL_MAGIC_regdata && mg->mg_obj)
381 toLOWER(type), key, klen);
390 =for apidoc mg_localize
392 Copy some of the magic from an existing SV to new localized version of
393 that SV. Container magic (eg %ENV, $1, tie) gets copied, value magic
394 doesn't (eg taint, pos).
400 Perl_mg_localize(pTHX_ SV *sv, SV *nsv)
403 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
404 const MGVTBL* const vtbl = mg->mg_virtual;
405 switch (mg->mg_type) {
406 /* value magic types: don't copy */
409 case PERL_MAGIC_regex_global:
410 case PERL_MAGIC_nkeys:
411 #ifdef USE_LOCALE_COLLATE
412 case PERL_MAGIC_collxfrm:
415 case PERL_MAGIC_taint:
417 case PERL_MAGIC_vstring:
418 case PERL_MAGIC_utf8:
419 case PERL_MAGIC_substr:
420 case PERL_MAGIC_defelem:
421 case PERL_MAGIC_arylen:
423 case PERL_MAGIC_backref:
424 case PERL_MAGIC_arylen_p:
425 case PERL_MAGIC_rhash:
426 case PERL_MAGIC_symtab:
430 if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy) {
431 /* XXX calling the copy method is probably not correct. DAPM */
432 (void)CALL_FPTR(vtbl->svt_copy)(aTHX_ sv, mg, nsv,
433 mg->mg_ptr, mg->mg_len);
436 sv_magicext(nsv, mg->mg_obj, mg->mg_type, vtbl,
437 mg->mg_ptr, mg->mg_len);
439 /* container types should remain read-only across localization */
440 SvFLAGS(nsv) |= SvREADONLY(sv);
443 if (SvTYPE(nsv) >= SVt_PVMG && SvMAGIC(nsv)) {
444 SvFLAGS(nsv) |= SvMAGICAL(sv);
454 Free any magic storage used by the SV. See C<sv_magic>.
460 Perl_mg_free(pTHX_ SV *sv)
464 for (mg = SvMAGIC(sv); mg; mg = moremagic) {
465 const MGVTBL* const vtbl = mg->mg_virtual;
466 moremagic = mg->mg_moremagic;
467 if (vtbl && vtbl->svt_free)
468 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
469 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
470 if (mg->mg_len > 0 || mg->mg_type == PERL_MAGIC_utf8)
471 Safefree(mg->mg_ptr);
472 else if (mg->mg_len == HEf_SVKEY)
473 SvREFCNT_dec((SV*)mg->mg_ptr);
475 if (mg->mg_flags & MGf_REFCOUNTED)
476 SvREFCNT_dec(mg->mg_obj);
479 SvMAGIC_set(sv, NULL);
486 Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
491 register const REGEXP * const rx = PM_GETRE(PL_curpm);
494 ? rx->nparens /* @+ */
495 : rx->lastparen; /* @- */
503 Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
506 register const REGEXP * const rx = PM_GETRE(PL_curpm);
508 register const I32 paren = mg->mg_len;
513 if (paren <= (I32)rx->nparens &&
514 (s = rx->startp[paren]) != -1 &&
515 (t = rx->endp[paren]) != -1)
518 if (mg->mg_obj) /* @+ */
523 if (i > 0 && RX_MATCH_UTF8(rx)) {
524 const char * const b = rx->subbeg;
526 i = Perl_utf8_length(aTHX_ (U8*)b, (U8*)(b+i));
537 Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
539 PERL_UNUSED_ARG(sv); PERL_UNUSED_ARG(mg);
540 Perl_croak(aTHX_ PL_no_modify);
541 NORETURN_FUNCTION_END;
545 Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
549 register const REGEXP *rx;
552 switch (*mg->mg_ptr) {
553 case '1': case '2': case '3': case '4':
554 case '5': case '6': case '7': case '8': case '9': case '&':
555 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
557 paren = atoi(mg->mg_ptr); /* $& is in [0] */
559 if (paren <= (I32)rx->nparens &&
560 (s1 = rx->startp[paren]) != -1 &&
561 (t1 = rx->endp[paren]) != -1)
565 if (i > 0 && RX_MATCH_UTF8(rx)) {
566 const char * const s = rx->subbeg + s1;
571 if (is_utf8_string_loclen((U8*)s, i, &ep, &el))
575 Perl_croak(aTHX_ "panic: magic_len: %"IVdf, (IV)i);
579 if (ckWARN(WARN_UNINITIALIZED))
584 if (ckWARN(WARN_UNINITIALIZED))
589 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
590 paren = rx->lastparen;
595 case '\016': /* ^N */
596 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
597 paren = rx->lastcloseparen;
603 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
604 if (rx->startp[0] != -1) {
615 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
616 if (rx->endp[0] != -1) {
617 i = rx->sublen - rx->endp[0];
628 if (!SvPOK(sv) && SvNIOK(sv)) {
636 #define SvRTRIM(sv) STMT_START { \
637 STRLEN len = SvCUR(sv); \
638 while (len > 0 && isSPACE(SvPVX(sv)[len-1])) \
640 SvCUR_set(sv, len); \
644 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
648 register char *s = NULL;
651 const char * const remaining = mg->mg_ptr + 1;
652 const char nextchar = *remaining;
654 switch (*mg->mg_ptr) {
655 case '\001': /* ^A */
656 sv_setsv(sv, PL_bodytarget);
658 case '\003': /* ^C, ^CHILD_ERROR_NATIVE */
659 if (nextchar == '\0') {
660 sv_setiv(sv, (IV)PL_minus_c);
662 else if (strEQ(remaining, "HILD_ERROR_NATIVE")) {
663 sv_setiv(sv, (IV)STATUS_NATIVE);
667 case '\004': /* ^D */
668 sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
670 case '\005': /* ^E */
671 if (nextchar == '\0') {
672 #ifdef MACOS_TRADITIONAL
676 sv_setnv(sv,(double)gMacPerl_OSErr);
677 sv_setpv(sv, gMacPerl_OSErr ? GetSysErrText(gMacPerl_OSErr, msg) : "");
682 # include <descrip.h>
683 # include <starlet.h>
685 $DESCRIPTOR(msgdsc,msg);
686 sv_setnv(sv,(NV) vaxc$errno);
687 if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
688 sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
694 if (!(_emx_env & 0x200)) { /* Under DOS */
695 sv_setnv(sv, (NV)errno);
696 sv_setpv(sv, errno ? Strerror(errno) : "");
698 if (errno != errno_isOS2) {
699 const int tmp = _syserrno();
700 if (tmp) /* 2nd call to _syserrno() makes it 0 */
703 sv_setnv(sv, (NV)Perl_rc);
704 sv_setpv(sv, os2error(Perl_rc));
709 DWORD dwErr = GetLastError();
710 sv_setnv(sv, (NV)dwErr);
712 PerlProc_GetOSError(sv, dwErr);
715 sv_setpvn(sv, "", 0);
720 const int saveerrno = errno;
721 sv_setnv(sv, (NV)errno);
722 sv_setpv(sv, errno ? Strerror(errno) : "");
730 SvNOK_on(sv); /* what a wonderful hack! */
732 else if (strEQ(remaining, "NCODING"))
733 sv_setsv(sv, PL_encoding);
735 case '\006': /* ^F */
736 sv_setiv(sv, (IV)PL_maxsysfd);
738 case '\010': /* ^H */
739 sv_setiv(sv, (IV)PL_hints);
741 case '\011': /* ^I */ /* NOT \t in EBCDIC */
743 sv_setpv(sv, PL_inplace);
745 sv_setsv(sv, &PL_sv_undef);
747 case '\017': /* ^O & ^OPEN */
748 if (nextchar == '\0') {
749 sv_setpv(sv, PL_osname);
752 else if (strEQ(remaining, "PEN")) {
753 if (!PL_compiling.cop_io)
754 sv_setsv(sv, &PL_sv_undef);
756 sv_setsv(sv, PL_compiling.cop_io);
760 case '\020': /* ^P */
761 sv_setiv(sv, (IV)PL_perldb);
763 case '\023': /* ^S */
764 if (nextchar == '\0') {
765 if (PL_lex_state != LEX_NOTPARSING)
768 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
773 case '\024': /* ^T */
774 if (nextchar == '\0') {
776 sv_setnv(sv, PL_basetime);
778 sv_setiv(sv, (IV)PL_basetime);
781 else if (strEQ(remaining, "AINT"))
782 sv_setiv(sv, PL_tainting
783 ? (PL_taint_warn || PL_unsafe ? -1 : 1)
786 case '\025': /* $^UNICODE, $^UTF8LOCALE */
787 if (strEQ(remaining, "NICODE"))
788 sv_setuv(sv, (UV) PL_unicode);
789 else if (strEQ(remaining, "TF8LOCALE"))
790 sv_setuv(sv, (UV) PL_utf8locale);
792 case '\027': /* ^W & $^WARNING_BITS */
793 if (nextchar == '\0')
794 sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
795 else if (strEQ(remaining, "ARNING_BITS")) {
796 if (PL_compiling.cop_warnings == pWARN_NONE) {
797 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
799 else if (PL_compiling.cop_warnings == pWARN_STD) {
802 (PL_dowarn & G_WARN_ON) ? WARN_ALLstring : WARN_NONEstring,
806 else if (PL_compiling.cop_warnings == pWARN_ALL) {
807 /* Get the bit mask for $warnings::Bits{all}, because
808 * it could have been extended by warnings::register */
810 HV * const bits=get_hv("warnings::Bits", FALSE);
811 if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) {
812 sv_setsv(sv, *bits_all);
815 sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
819 sv_setsv(sv, PL_compiling.cop_warnings);
824 case '1': case '2': case '3': case '4':
825 case '5': case '6': case '7': case '8': case '9': case '&':
826 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
830 * Pre-threads, this was paren = atoi(GvENAME((GV*)mg->mg_obj));
831 * XXX Does the new way break anything?
833 paren = atoi(mg->mg_ptr); /* $& is in [0] */
835 if (paren <= (I32)rx->nparens &&
836 (s1 = rx->startp[paren]) != -1 &&
837 (t1 = rx->endp[paren]) != -1)
846 int oldtainted = PL_tainted;
849 PL_tainted = oldtainted;
850 if (RX_MATCH_UTF8(rx) && is_utf8_string((U8*)s, i))
855 if (RX_MATCH_TAINTED(rx)) {
856 MAGIC* const mg = SvMAGIC(sv);
859 SvMAGIC_set(sv, mg->mg_moremagic);
861 if ((mgt = SvMAGIC(sv))) {
862 mg->mg_moremagic = mgt;
872 sv_setsv(sv,&PL_sv_undef);
875 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
876 paren = rx->lastparen;
880 sv_setsv(sv,&PL_sv_undef);
882 case '\016': /* ^N */
883 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
884 paren = rx->lastcloseparen;
888 sv_setsv(sv,&PL_sv_undef);
891 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
892 if ((s = rx->subbeg) && rx->startp[0] != -1) {
897 sv_setsv(sv,&PL_sv_undef);
900 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
901 if (rx->subbeg && rx->endp[0] != -1) {
902 s = rx->subbeg + rx->endp[0];
903 i = rx->sublen - rx->endp[0];
907 sv_setsv(sv,&PL_sv_undef);
910 if (GvIO(PL_last_in_gv)) {
911 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
916 sv_setiv(sv, (IV)STATUS_CURRENT);
917 #ifdef COMPLEX_STATUS
918 LvTARGOFF(sv) = PL_statusvalue;
919 LvTARGLEN(sv) = PL_statusvalue_vms;
924 if (GvIOp(PL_defoutgv))
925 s = IoTOP_NAME(GvIOp(PL_defoutgv));
929 sv_setpv(sv,GvENAME(PL_defoutgv));
934 if (GvIOp(PL_defoutgv))
935 s = IoFMT_NAME(GvIOp(PL_defoutgv));
937 s = GvENAME(PL_defoutgv);
941 if (GvIOp(PL_defoutgv))
942 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
945 if (GvIOp(PL_defoutgv))
946 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
949 if (GvIOp(PL_defoutgv))
950 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
957 WITH_THR(sv_setiv(sv, (IV)PL_curcop->cop_arybase));
960 if (GvIOp(PL_defoutgv))
961 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
967 sv_copypv(sv, PL_ors_sv);
971 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
972 sv_setpv(sv, errno ? Strerror(errno) : "");
975 const int saveerrno = errno;
976 sv_setnv(sv, (NV)errno);
978 if (errno == errno_isOS2 || errno == errno_isOS2_set)
979 sv_setpv(sv, os2error(Perl_rc));
982 sv_setpv(sv, errno ? Strerror(errno) : "");
987 SvNOK_on(sv); /* what a wonderful hack! */
990 sv_setiv(sv, (IV)PL_uid);
993 sv_setiv(sv, (IV)PL_euid);
996 sv_setiv(sv, (IV)PL_gid);
998 Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, (long unsigned int)PL_gid);
1002 sv_setiv(sv, (IV)PL_egid);
1003 #ifdef HAS_GETGROUPS
1004 Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, (long unsigned int)PL_egid);
1007 #ifdef HAS_GETGROUPS
1009 Groups_t gary[NGROUPS];
1010 I32 j = getgroups(NGROUPS,gary);
1012 Perl_sv_catpvf(aTHX_ sv, " %"Gid_t_f, (long unsigned int)gary[j]);
1015 (void)SvIOK_on(sv); /* what a wonderful hack! */
1017 #ifndef MACOS_TRADITIONAL
1026 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
1028 struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
1030 if (uf && uf->uf_val)
1031 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
1036 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
1043 s = SvPV_const(sv,len);
1044 ptr = MgPV_const(mg,klen);
1047 #ifdef DYNAMIC_ENV_FETCH
1048 /* We just undefd an environment var. Is a replacement */
1049 /* waiting in the wings? */
1052 if ((valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE)))
1053 s = SvPV_const(*valp, len);
1057 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
1058 /* And you'll never guess what the dog had */
1059 /* in its mouth... */
1061 MgTAINTEDDIR_off(mg);
1063 if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
1064 char pathbuf[256], eltbuf[256], *cp, *elt;
1068 strncpy(eltbuf, s, 255);
1071 do { /* DCL$PATH may be a search list */
1072 while (1) { /* as may dev portion of any element */
1073 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1074 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1075 cando_by_name(S_IWUSR,0,elt) ) {
1076 MgTAINTEDDIR_on(mg);
1080 if ((cp = strchr(elt, ':')) != Nullch)
1082 if (my_trnlnm(elt, eltbuf, j++))
1088 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1091 if (s && klen == 4 && strEQ(ptr,"PATH")) {
1092 const char * const strend = s + len;
1094 while (s < strend) {
1098 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
1099 s, strend, ':', &i);
1101 if (i >= sizeof tmpbuf /* too long -- assume the worst */
1103 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1104 MgTAINTEDDIR_on(mg);
1110 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1116 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1118 PERL_UNUSED_ARG(sv);
1119 my_setenv(MgPV_nolen_const(mg),Nullch);
1124 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1126 PERL_UNUSED_ARG(mg);
1128 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1130 if (PL_localizing) {
1133 hv_iterinit((HV*)sv);
1134 while ((entry = hv_iternext((HV*)sv))) {
1136 my_setenv(hv_iterkey(entry, &keylen),
1137 SvPV_nolen_const(hv_iterval((HV*)sv, entry)));
1145 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1148 PERL_UNUSED_ARG(sv);
1149 PERL_UNUSED_ARG(mg);
1151 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1159 #ifdef HAS_SIGPROCMASK
1161 restore_sigmask(pTHX_ SV *save_sv)
1163 const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1164 (void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0);
1168 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1170 /* Are we fetching a signal entry? */
1171 const I32 i = whichsig(MgPV_nolen_const(mg));
1174 sv_setsv(sv,PL_psig_ptr[i]);
1176 Sighandler_t sigstate;
1177 sigstate = rsignal_state(i);
1178 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1179 if (PL_sig_handlers_initted && PL_sig_ignoring[i]) sigstate = SIG_IGN;
1181 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1182 if (PL_sig_handlers_initted && PL_sig_defaulting[i]) sigstate = SIG_DFL;
1184 /* cache state so we don't fetch it again */
1185 if(sigstate == (Sighandler_t) SIG_IGN)
1186 sv_setpv(sv,"IGNORE");
1188 sv_setsv(sv,&PL_sv_undef);
1189 PL_psig_ptr[i] = SvREFCNT_inc(sv);
1196 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1198 /* XXX Some of this code was copied from Perl_magic_setsig. A little
1199 * refactoring might be in order.
1202 register const char * const s = MgPV_nolen_const(mg);
1203 PERL_UNUSED_ARG(sv);
1206 if (strEQ(s,"__DIE__"))
1208 else if (strEQ(s,"__WARN__"))
1211 Perl_croak(aTHX_ "No such hook: %s", s);
1213 SV * const to_dec = *svp;
1215 SvREFCNT_dec(to_dec);
1219 /* Are we clearing a signal entry? */
1220 const I32 i = whichsig(s);
1222 #ifdef HAS_SIGPROCMASK
1225 /* Avoid having the signal arrive at a bad time, if possible. */
1228 sigprocmask(SIG_BLOCK, &set, &save);
1230 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1231 SAVEFREESV(save_sv);
1232 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1235 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1236 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1238 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1239 PL_sig_defaulting[i] = 1;
1240 (void)rsignal(i, PL_csighandlerp);
1242 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1244 if(PL_psig_name[i]) {
1245 SvREFCNT_dec(PL_psig_name[i]);
1248 if(PL_psig_ptr[i]) {
1249 SV *to_dec=PL_psig_ptr[i];
1252 SvREFCNT_dec(to_dec);
1262 S_raise_signal(pTHX_ int sig)
1264 /* Set a flag to say this signal is pending */
1265 PL_psig_pend[sig]++;
1266 /* And one to say _a_ signal is pending */
1271 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1272 Perl_csighandler(int sig, ...)
1274 Perl_csighandler(int sig)
1277 #ifdef PERL_GET_SIG_CONTEXT
1278 dTHXa(PERL_GET_SIG_CONTEXT);
1282 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1283 (void) rsignal(sig, PL_csighandlerp);
1284 if (PL_sig_ignoring[sig]) return;
1286 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1287 if (PL_sig_defaulting[sig])
1288 #ifdef KILL_BY_SIGPRC
1289 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1294 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
1295 /* Call the perl level handler now--
1296 * with risk we may be in malloc() etc. */
1297 (*PL_sighandlerp)(sig);
1299 S_raise_signal(aTHX_ sig);
1302 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1304 Perl_csighandler_init(void)
1307 if (PL_sig_handlers_initted) return;
1309 for (sig = 1; sig < SIG_SIZE; sig++) {
1310 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1312 PL_sig_defaulting[sig] = 1;
1313 (void) rsignal(sig, PL_csighandlerp);
1315 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1316 PL_sig_ignoring[sig] = 0;
1319 PL_sig_handlers_initted = 1;
1324 Perl_despatch_signals(pTHX)
1328 for (sig = 1; sig < SIG_SIZE; sig++) {
1329 if (PL_psig_pend[sig]) {
1330 PERL_BLOCKSIG_ADD(set, sig);
1331 PL_psig_pend[sig] = 0;
1332 PERL_BLOCKSIG_BLOCK(set);
1333 (*PL_sighandlerp)(sig);
1334 PERL_BLOCKSIG_UNBLOCK(set);
1340 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1345 /* Need to be careful with SvREFCNT_dec(), because that can have side
1346 * effects (due to closures). We must make sure that the new disposition
1347 * is in place before it is called.
1351 #ifdef HAS_SIGPROCMASK
1356 register const char *s = MgPV_const(mg,len);
1358 if (strEQ(s,"__DIE__"))
1360 else if (strEQ(s,"__WARN__"))
1363 Perl_croak(aTHX_ "No such hook: %s", s);
1371 i = whichsig(s); /* ...no, a brick */
1373 if (ckWARN(WARN_SIGNAL))
1374 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
1377 #ifdef HAS_SIGPROCMASK
1378 /* Avoid having the signal arrive at a bad time, if possible. */
1381 sigprocmask(SIG_BLOCK, &set, &save);
1383 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1384 SAVEFREESV(save_sv);
1385 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1388 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1389 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1391 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1392 PL_sig_ignoring[i] = 0;
1394 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1395 PL_sig_defaulting[i] = 0;
1397 SvREFCNT_dec(PL_psig_name[i]);
1398 to_dec = PL_psig_ptr[i];
1399 PL_psig_ptr[i] = SvREFCNT_inc(sv);
1400 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1401 PL_psig_name[i] = newSVpvn(s, len);
1402 SvREADONLY_on(PL_psig_name[i]);
1404 if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
1406 (void)rsignal(i, PL_csighandlerp);
1407 #ifdef HAS_SIGPROCMASK
1412 *svp = SvREFCNT_inc(sv);
1414 SvREFCNT_dec(to_dec);
1417 s = SvPV_force(sv,len);
1418 if (strEQ(s,"IGNORE")) {
1420 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1421 PL_sig_ignoring[i] = 1;
1422 (void)rsignal(i, PL_csighandlerp);
1424 (void)rsignal(i, (Sighandler_t) SIG_IGN);
1428 else if (strEQ(s,"DEFAULT") || !*s) {
1430 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1432 PL_sig_defaulting[i] = 1;
1433 (void)rsignal(i, PL_csighandlerp);
1436 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1441 * We should warn if HINT_STRICT_REFS, but without
1442 * access to a known hint bit in a known OP, we can't
1443 * tell whether HINT_STRICT_REFS is in force or not.
1445 if (!strchr(s,':') && !strchr(s,'\''))
1446 sv_insert(sv, 0, 0, "main::", 6);
1448 (void)rsignal(i, PL_csighandlerp);
1450 *svp = SvREFCNT_inc(sv);
1452 #ifdef HAS_SIGPROCMASK
1457 SvREFCNT_dec(to_dec);
1460 #endif /* !PERL_MICRO */
1463 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1465 PERL_UNUSED_ARG(sv);
1466 PERL_UNUSED_ARG(mg);
1467 PL_sub_generation++;
1472 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
1474 PERL_UNUSED_ARG(sv);
1475 PERL_UNUSED_ARG(mg);
1476 /* HV_badAMAGIC_on(Sv_STASH(sv)); */
1477 PL_amagic_generation++;
1483 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1485 HV * const hv = (HV*)LvTARG(sv);
1487 PERL_UNUSED_ARG(mg);
1490 (void) hv_iterinit(hv);
1491 if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
1494 while (hv_iternext(hv))
1499 sv_setiv(sv, (IV)i);
1504 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1506 PERL_UNUSED_ARG(mg);
1508 hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
1513 /* caller is responsible for stack switching/cleanup */
1515 S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV *val)
1521 PUSHs(SvTIED_obj(sv, mg));
1524 if (mg->mg_len >= 0)
1525 PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len)));
1526 else if (mg->mg_len == HEf_SVKEY)
1527 PUSHs((SV*)mg->mg_ptr);
1529 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1530 PUSHs(sv_2mortal(newSViv(mg->mg_len)));
1538 return call_method(meth, flags);
1542 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
1548 PUSHSTACKi(PERLSI_MAGIC);
1550 if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
1551 sv_setsv(sv, *PL_stack_sp--);
1561 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1564 mg->mg_flags |= MGf_GSKIP;
1565 magic_methpack(sv,mg,"FETCH");
1570 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1574 PUSHSTACKi(PERLSI_MAGIC);
1575 magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
1582 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1584 return magic_methpack(sv,mg,"DELETE");
1589 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1596 PUSHSTACKi(PERLSI_MAGIC);
1597 if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
1598 sv = *PL_stack_sp--;
1599 retval = (U32) SvIV(sv)-1;
1608 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1613 PUSHSTACKi(PERLSI_MAGIC);
1615 XPUSHs(SvTIED_obj(sv, mg));
1617 call_method("CLEAR", G_SCALAR|G_DISCARD);
1625 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1628 const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
1632 PUSHSTACKi(PERLSI_MAGIC);
1635 PUSHs(SvTIED_obj(sv, mg));
1640 if (call_method(meth, G_SCALAR))
1641 sv_setsv(key, *PL_stack_sp--);
1650 Perl_magic_existspack(pTHX_ SV *sv, MAGIC *mg)
1652 return magic_methpack(sv,mg,"EXISTS");
1656 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1659 SV *retval = &PL_sv_undef;
1660 SV * const tied = SvTIED_obj((SV*)hv, mg);
1661 HV * const pkg = SvSTASH((SV*)SvRV(tied));
1663 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1665 if (HvEITER_get(hv))
1666 /* we are in an iteration so the hash cannot be empty */
1668 /* no xhv_eiter so now use FIRSTKEY */
1669 key = sv_newmortal();
1670 magic_nextpack((SV*)hv, mg, key);
1671 HvEITER_set(hv, NULL); /* need to reset iterator */
1672 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1675 /* there is a SCALAR method that we can call */
1677 PUSHSTACKi(PERLSI_MAGIC);
1683 if (call_method("SCALAR", G_SCALAR))
1684 retval = *PL_stack_sp--;
1691 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1693 GV * const gv = PL_DBline;
1694 const I32 i = SvTRUE(sv);
1695 SV ** const svp = av_fetch(GvAV(gv),
1696 atoi(MgPV_nolen_const(mg)), FALSE);
1697 if (svp && SvIOKp(*svp)) {
1698 OP * const o = INT2PTR(OP*,SvIVX(*svp));
1700 /* set or clear breakpoint in the relevant control op */
1702 o->op_flags |= OPf_SPECIAL;
1704 o->op_flags &= ~OPf_SPECIAL;
1711 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
1713 const AV * const obj = (AV*)mg->mg_obj;
1715 sv_setiv(sv, AvFILL(obj) + PL_curcop->cop_arybase);
1723 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
1725 AV * const obj = (AV*)mg->mg_obj;
1727 av_fill(obj, SvIV(sv) - PL_curcop->cop_arybase);
1729 if (ckWARN(WARN_MISC))
1730 Perl_warner(aTHX_ packWARN(WARN_MISC),
1731 "Attempt to set length of freed array");
1737 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
1739 PERL_UNUSED_ARG(sv);
1740 /* during global destruction, mg_obj may already have been freed */
1741 if (PL_in_clean_all)
1744 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
1747 /* arylen scalar holds a pointer back to the array, but doesn't own a
1748 reference. Hence the we (the array) are about to go away with it
1749 still pointing at us. Clear its pointer, else it would be pointing
1750 at free memory. See the comment in sv_magic about reference loops,
1751 and why it can't own a reference to us. */
1758 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
1760 SV* const lsv = LvTARG(sv);
1762 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1763 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1764 if (mg && mg->mg_len >= 0) {
1767 sv_pos_b2u(lsv, &i);
1768 sv_setiv(sv, i + PL_curcop->cop_arybase);
1777 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
1779 SV* const lsv = LvTARG(sv);
1786 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
1787 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1791 sv_magic(lsv, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1792 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1794 else if (!SvOK(sv)) {
1798 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1800 pos = SvIV(sv) - PL_curcop->cop_arybase;
1803 ulen = sv_len_utf8(lsv);
1813 else if (pos > (SSize_t)len)
1818 sv_pos_u2b(lsv, &p, 0);
1823 mg->mg_flags &= ~MGf_MINMATCH;
1829 Perl_magic_getglob(pTHX_ SV *sv, MAGIC *mg)
1831 PERL_UNUSED_ARG(mg);
1832 if (SvFAKE(sv)) { /* FAKE globs can get coerced */
1834 gv_efullname3(sv,((GV*)sv), "*");
1838 gv_efullname3(sv,((GV*)sv), "*"); /* a gv value, be nice */
1843 Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg)
1846 PERL_UNUSED_ARG(mg);
1850 gv = gv_fetchsv(sv, GV_ADD, SVt_PVGV);
1855 GvGP(sv) = gp_ref(GvGP(gv));
1860 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
1863 SV * const lsv = LvTARG(sv);
1864 const char * const tmps = SvPV_const(lsv,len);
1865 I32 offs = LvTARGOFF(sv);
1866 I32 rem = LvTARGLEN(sv);
1867 PERL_UNUSED_ARG(mg);
1870 sv_pos_u2b(lsv, &offs, &rem);
1871 if (offs > (I32)len)
1873 if (rem + offs > (I32)len)
1875 sv_setpvn(sv, tmps + offs, (STRLEN)rem);
1882 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
1885 const char *tmps = SvPV_const(sv, len);
1886 SV * const lsv = LvTARG(sv);
1887 I32 lvoff = LvTARGOFF(sv);
1888 I32 lvlen = LvTARGLEN(sv);
1889 PERL_UNUSED_ARG(mg);
1892 sv_utf8_upgrade(lsv);
1893 sv_pos_u2b(lsv, &lvoff, &lvlen);
1894 sv_insert(lsv, lvoff, lvlen, tmps, len);
1895 LvTARGLEN(sv) = sv_len_utf8(sv);
1898 else if (lsv && SvUTF8(lsv)) {
1899 sv_pos_u2b(lsv, &lvoff, &lvlen);
1900 LvTARGLEN(sv) = len;
1901 tmps = (char*)bytes_to_utf8((U8*)tmps, &len);
1902 sv_insert(lsv, lvoff, lvlen, tmps, len);
1906 sv_insert(lsv, lvoff, lvlen, tmps, len);
1907 LvTARGLEN(sv) = len;
1915 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
1917 PERL_UNUSED_ARG(sv);
1918 TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
1923 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
1925 PERL_UNUSED_ARG(sv);
1926 /* update taint status unless we're restoring at scope exit */
1927 if (PL_localizing != 2) {
1937 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
1939 SV * const lsv = LvTARG(sv);
1940 PERL_UNUSED_ARG(mg);
1947 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
1952 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
1954 PERL_UNUSED_ARG(mg);
1955 do_vecset(sv); /* XXX slurp this routine */
1960 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
1963 if (LvTARGLEN(sv)) {
1965 SV * const ahv = LvTARG(sv);
1966 HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
1971 AV* const av = (AV*)LvTARG(sv);
1972 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
1973 targ = AvARRAY(av)[LvTARGOFF(sv)];
1975 if (targ && targ != &PL_sv_undef) {
1976 /* somebody else defined it for us */
1977 SvREFCNT_dec(LvTARG(sv));
1978 LvTARG(sv) = SvREFCNT_inc(targ);
1980 SvREFCNT_dec(mg->mg_obj);
1981 mg->mg_obj = Nullsv;
1982 mg->mg_flags &= ~MGf_REFCOUNTED;
1987 sv_setsv(sv, targ ? targ : &PL_sv_undef);
1992 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
1994 PERL_UNUSED_ARG(mg);
1998 sv_setsv(LvTARG(sv), sv);
1999 SvSETMAGIC(LvTARG(sv));
2005 Perl_vivify_defelem(pTHX_ SV *sv)
2010 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2013 SV * const ahv = LvTARG(sv);
2014 HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
2017 if (!value || value == &PL_sv_undef)
2018 Perl_croak(aTHX_ PL_no_helem_sv, mg->mg_obj);
2021 AV* const av = (AV*)LvTARG(sv);
2022 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
2023 LvTARG(sv) = Nullsv; /* array can't be extended */
2025 SV** const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
2026 if (!svp || (value = *svp) == &PL_sv_undef)
2027 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
2030 (void)SvREFCNT_inc(value);
2031 SvREFCNT_dec(LvTARG(sv));
2034 SvREFCNT_dec(mg->mg_obj);
2035 mg->mg_obj = Nullsv;
2036 mg->mg_flags &= ~MGf_REFCOUNTED;
2040 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2042 AV *const av = (AV*)mg->mg_obj;
2043 SV **svp = AvARRAY(av);
2044 PERL_UNUSED_ARG(sv);
2046 /* Not sure why the av can get freed ahead of its sv, but somehow it does
2047 in ext/B/t/bytecode.t test 15 (involving print <DATA>) */
2048 if (svp && !SvIS_FREED(av)) {
2049 SV *const *const last = svp + AvFILLp(av);
2051 while (svp <= last) {
2053 SV *const referrer = *svp;
2054 if (SvWEAKREF(referrer)) {
2055 /* XXX Should we check that it hasn't changed? */
2056 SvRV_set(referrer, 0);
2058 SvWEAKREF_off(referrer);
2059 } else if (SvTYPE(referrer) == SVt_PVGV ||
2060 SvTYPE(referrer) == SVt_PVLV) {
2061 /* You lookin' at me? */
2062 assert(GvSTASH(referrer));
2063 assert(GvSTASH(referrer) == (HV*)sv);
2064 GvSTASH(referrer) = 0;
2067 "panic: magic_killbackrefs (flags=%"UVxf")",
2068 (UV)SvFLAGS(referrer));
2076 SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */
2081 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2089 Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
2091 PERL_UNUSED_ARG(mg);
2092 sv_unmagic(sv, PERL_MAGIC_bm);
2098 Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
2100 PERL_UNUSED_ARG(mg);
2101 sv_unmagic(sv, PERL_MAGIC_fm);
2107 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2109 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2111 if (uf && uf->uf_set)
2112 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2117 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2119 PERL_UNUSED_ARG(mg);
2120 sv_unmagic(sv, PERL_MAGIC_qr);
2125 Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
2127 regexp * const re = (regexp *)mg->mg_obj;
2128 PERL_UNUSED_ARG(sv);
2134 #ifdef USE_LOCALE_COLLATE
2136 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2139 * RenE<eacute> Descartes said "I think not."
2140 * and vanished with a faint plop.
2142 PERL_UNUSED_ARG(sv);
2144 Safefree(mg->mg_ptr);
2150 #endif /* USE_LOCALE_COLLATE */
2152 /* Just clear the UTF-8 cache data. */
2154 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2156 PERL_UNUSED_ARG(sv);
2157 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2159 mg->mg_len = -1; /* The mg_len holds the len cache. */
2164 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2166 register const char *s;
2169 switch (*mg->mg_ptr) {
2170 case '\001': /* ^A */
2171 sv_setsv(PL_bodytarget, sv);
2173 case '\003': /* ^C */
2174 PL_minus_c = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2177 case '\004': /* ^D */
2179 s = SvPV_nolen_const(sv);
2180 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2181 DEBUG_x(dump_all());
2183 PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | DEBUG_TOP_FLAG;
2186 case '\005': /* ^E */
2187 if (*(mg->mg_ptr+1) == '\0') {
2188 #ifdef MACOS_TRADITIONAL
2189 gMacPerl_OSErr = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2192 set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2195 SetLastError( SvIV(sv) );
2198 os2_setsyserrno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2200 /* will anyone ever use this? */
2201 SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4);
2207 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2209 SvREFCNT_dec(PL_encoding);
2210 if (SvOK(sv) || SvGMAGICAL(sv)) {
2211 PL_encoding = newSVsv(sv);
2214 PL_encoding = Nullsv;
2218 case '\006': /* ^F */
2219 PL_maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2221 case '\010': /* ^H */
2222 PL_hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2224 case '\011': /* ^I */ /* NOT \t in EBCDIC */
2225 Safefree(PL_inplace);
2226 PL_inplace = SvOK(sv) ? savesvpv(sv) : Nullch;
2228 case '\017': /* ^O */
2229 if (*(mg->mg_ptr+1) == '\0') {
2230 Safefree(PL_osname);
2233 TAINT_PROPER("assigning to $^O");
2234 PL_osname = savesvpv(sv);
2237 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2238 if (!PL_compiling.cop_io)
2239 PL_compiling.cop_io = newSVsv(sv);
2241 sv_setsv(PL_compiling.cop_io,sv);
2244 case '\020': /* ^P */
2245 PL_perldb = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2246 if (PL_perldb && !PL_DBsingle)
2249 case '\024': /* ^T */
2251 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2253 PL_basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2256 case '\027': /* ^W & $^WARNING_BITS */
2257 if (*(mg->mg_ptr+1) == '\0') {
2258 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2259 i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2260 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2261 | (i ? G_WARN_ON : G_WARN_OFF) ;
2264 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2265 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2266 if (!SvPOK(sv) && PL_localizing) {
2267 sv_setpvn(sv, WARN_NONEstring, WARNsize);
2268 PL_compiling.cop_warnings = pWARN_NONE;
2273 int accumulate = 0 ;
2274 int any_fatals = 0 ;
2275 const char * const ptr = SvPV_const(sv, len) ;
2276 for (i = 0 ; i < len ; ++i) {
2277 accumulate |= ptr[i] ;
2278 any_fatals |= (ptr[i] & 0xAA) ;
2281 PL_compiling.cop_warnings = pWARN_NONE;
2282 else if (isWARN_on(sv, WARN_ALL) && !any_fatals) {
2283 PL_compiling.cop_warnings = pWARN_ALL;
2284 PL_dowarn |= G_WARN_ONCE ;
2287 if (specialWARN(PL_compiling.cop_warnings))
2288 PL_compiling.cop_warnings = newSVsv(sv) ;
2290 sv_setsv(PL_compiling.cop_warnings, sv);
2291 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2292 PL_dowarn |= G_WARN_ONCE ;
2300 if (PL_localizing) {
2301 if (PL_localizing == 1)
2302 SAVESPTR(PL_last_in_gv);
2304 else if (SvOK(sv) && GvIO(PL_last_in_gv))
2305 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2308 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2309 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2310 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2313 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2314 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2315 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2318 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2321 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2322 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2323 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2326 IoPAGE(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2330 IO * const io = GvIOp(PL_defoutgv);
2333 if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) == 0)
2334 IoFLAGS(io) &= ~IOf_FLUSH;
2336 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2337 PerlIO *ofp = IoOFP(io);
2339 (void)PerlIO_flush(ofp);
2340 IoFLAGS(io) |= IOf_FLUSH;
2346 SvREFCNT_dec(PL_rs);
2347 PL_rs = newSVsv(sv);
2351 SvREFCNT_dec(PL_ors_sv);
2352 if (SvOK(sv) || SvGMAGICAL(sv)) {
2353 PL_ors_sv = newSVsv(sv);
2361 SvREFCNT_dec(PL_ofs_sv);
2362 if (SvOK(sv) || SvGMAGICAL(sv)) {
2363 PL_ofs_sv = newSVsv(sv);
2370 PL_compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2373 #ifdef COMPLEX_STATUS
2374 if (PL_localizing == 2) {
2375 PL_statusvalue = LvTARGOFF(sv);
2376 PL_statusvalue_vms = LvTARGLEN(sv);
2380 #ifdef VMSISH_STATUS
2382 STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2385 STATUS_UNIX_EXIT_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2390 # define PERL_VMS_BANG vaxc$errno
2392 # define PERL_VMS_BANG 0
2394 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2395 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2399 PL_uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2400 if (PL_delaymagic) {
2401 PL_delaymagic |= DM_RUID;
2402 break; /* don't do magic till later */
2405 (void)setruid((Uid_t)PL_uid);
2408 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2410 #ifdef HAS_SETRESUID
2411 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2413 if (PL_uid == PL_euid) { /* special case $< = $> */
2415 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2416 if (PL_uid != 0 && PerlProc_getuid() == 0)
2417 (void)PerlProc_setuid(0);
2419 (void)PerlProc_setuid(PL_uid);
2421 PL_uid = PerlProc_getuid();
2422 Perl_croak(aTHX_ "setruid() not implemented");
2427 PL_uid = PerlProc_getuid();
2428 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2431 PL_euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2432 if (PL_delaymagic) {
2433 PL_delaymagic |= DM_EUID;
2434 break; /* don't do magic till later */
2437 (void)seteuid((Uid_t)PL_euid);
2440 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2442 #ifdef HAS_SETRESUID
2443 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2445 if (PL_euid == PL_uid) /* special case $> = $< */
2446 PerlProc_setuid(PL_euid);
2448 PL_euid = PerlProc_geteuid();
2449 Perl_croak(aTHX_ "seteuid() not implemented");
2454 PL_euid = PerlProc_geteuid();
2455 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2458 PL_gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2459 if (PL_delaymagic) {
2460 PL_delaymagic |= DM_RGID;
2461 break; /* don't do magic till later */
2464 (void)setrgid((Gid_t)PL_gid);
2467 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2469 #ifdef HAS_SETRESGID
2470 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2472 if (PL_gid == PL_egid) /* special case $( = $) */
2473 (void)PerlProc_setgid(PL_gid);
2475 PL_gid = PerlProc_getgid();
2476 Perl_croak(aTHX_ "setrgid() not implemented");
2481 PL_gid = PerlProc_getgid();
2482 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2485 #ifdef HAS_SETGROUPS
2487 const char *p = SvPV_const(sv, len);
2488 Groups_t gary[NGROUPS];
2493 for (i = 0; i < NGROUPS; ++i) {
2494 while (*p && !isSPACE(*p))
2503 (void)setgroups(i, gary);
2505 #else /* HAS_SETGROUPS */
2506 PL_egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2507 #endif /* HAS_SETGROUPS */
2508 if (PL_delaymagic) {
2509 PL_delaymagic |= DM_EGID;
2510 break; /* don't do magic till later */
2513 (void)setegid((Gid_t)PL_egid);
2516 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2518 #ifdef HAS_SETRESGID
2519 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2521 if (PL_egid == PL_gid) /* special case $) = $( */
2522 (void)PerlProc_setgid(PL_egid);
2524 PL_egid = PerlProc_getegid();
2525 Perl_croak(aTHX_ "setegid() not implemented");
2530 PL_egid = PerlProc_getegid();
2531 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2534 PL_chopset = SvPV_force(sv,len);
2536 #ifndef MACOS_TRADITIONAL
2538 LOCK_DOLLARZERO_MUTEX;
2539 #ifdef HAS_SETPROCTITLE
2540 /* The BSDs don't show the argv[] in ps(1) output, they
2541 * show a string from the process struct and provide
2542 * the setproctitle() routine to manipulate that. */
2544 s = SvPV_const(sv, len);
2545 # if __FreeBSD_version > 410001
2546 /* The leading "-" removes the "perl: " prefix,
2547 * but not the "(perl) suffix from the ps(1)
2548 * output, because that's what ps(1) shows if the
2549 * argv[] is modified. */
2550 setproctitle("-%s", s);
2551 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2552 /* This doesn't really work if you assume that
2553 * $0 = 'foobar'; will wipe out 'perl' from the $0
2554 * because in ps(1) output the result will be like
2555 * sprintf("perl: %s (perl)", s)
2556 * I guess this is a security feature:
2557 * one (a user process) cannot get rid of the original name.
2559 setproctitle("%s", s);
2563 #if defined(__hpux) && defined(PSTAT_SETCMD)
2566 s = SvPV_const(sv, len);
2567 un.pst_command = (char *)s;
2568 pstat(PSTAT_SETCMD, un, len, 0, 0);
2571 /* PL_origalen is set in perl_parse(). */
2572 s = SvPV_force(sv,len);
2573 if (len >= (STRLEN)PL_origalen-1) {
2574 /* Longer than original, will be truncated. We assume that
2575 * PL_origalen bytes are available. */
2576 Copy(s, PL_origargv[0], PL_origalen-1, char);
2579 /* Shorter than original, will be padded. */
2580 Copy(s, PL_origargv[0], len, char);
2581 PL_origargv[0][len] = 0;
2582 memset(PL_origargv[0] + len + 1,
2583 /* Is the space counterintuitive? Yes.
2584 * (You were expecting \0?)
2585 * Does it work? Seems to. (In Linux 2.4.20 at least.)
2588 PL_origalen - len - 1);
2590 PL_origargv[0][PL_origalen-1] = 0;
2591 for (i = 1; i < PL_origargc; i++)
2593 UNLOCK_DOLLARZERO_MUTEX;
2601 Perl_whichsig(pTHX_ const char *sig)
2603 register char* const* sigv;
2605 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
2606 if (strEQ(sig,*sigv))
2607 return PL_sig_num[sigv - (char* const*)PL_sig_name];
2609 if (strEQ(sig,"CHLD"))
2613 if (strEQ(sig,"CLD"))
2620 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2621 Perl_sighandler(int sig, ...)
2623 Perl_sighandler(int sig)
2626 #ifdef PERL_GET_SIG_CONTEXT
2627 dTHXa(PERL_GET_SIG_CONTEXT);
2634 SV * const tSv = PL_Sv;
2638 XPV * const tXpv = PL_Xpv;
2640 if (PL_savestack_ix + 15 <= PL_savestack_max)
2642 if (PL_markstack_ptr < PL_markstack_max - 2)
2644 if (PL_scopestack_ix < PL_scopestack_max - 3)
2647 if (!PL_psig_ptr[sig]) {
2648 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2653 /* Max number of items pushed there is 3*n or 4. We cannot fix
2654 infinity, so we fix 4 (in fact 5): */
2656 PL_savestack_ix += 5; /* Protect save in progress. */
2657 SAVEDESTRUCTOR_X(S_unwind_handler_stack, (void*)&flags);
2660 PL_markstack_ptr++; /* Protect mark. */
2662 PL_scopestack_ix += 1;
2663 /* sv_2cv is too complicated, try a simpler variant first: */
2664 if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
2665 || SvTYPE(cv) != SVt_PVCV) {
2667 cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
2670 if (!cv || !CvROOT(cv)) {
2671 if (ckWARN(WARN_SIGNAL))
2672 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2673 PL_sig_name[sig], (gv ? GvENAME(gv)
2680 if(PL_psig_name[sig]) {
2681 sv = SvREFCNT_inc(PL_psig_name[sig]);
2683 #if !defined(PERL_IMPLICIT_CONTEXT)
2687 sv = sv_newmortal();
2688 sv_setpv(sv,PL_sig_name[sig]);
2691 PUSHSTACKi(PERLSI_SIGNAL);
2694 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2696 struct sigaction oact;
2698 if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
2702 va_start(args, sig);
2703 sip = (siginfo_t*)va_arg(args, siginfo_t*);
2706 SV *rv = newRV_noinc((SV*)sih);
2707 /* The siginfo fields signo, code, errno, pid, uid,
2708 * addr, status, and band are defined by POSIX/SUSv3. */
2709 hv_store(sih, "signo", 5, newSViv(sip->si_signo), 0);
2710 hv_store(sih, "code", 4, newSViv(sip->si_code), 0);
2711 #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. */
2712 hv_store(sih, "errno", 5, newSViv(sip->si_errno), 0);
2713 hv_store(sih, "status", 6, newSViv(sip->si_status), 0);
2714 hv_store(sih, "uid", 3, newSViv(sip->si_uid), 0);
2715 hv_store(sih, "pid", 3, newSViv(sip->si_pid), 0);
2716 hv_store(sih, "addr", 4, newSVuv(PTR2UV(sip->si_addr)), 0);
2717 hv_store(sih, "band", 4, newSViv(sip->si_band), 0);
2721 PUSHs(newSVpv((void*)sip, sizeof(*sip)));
2730 call_sv((SV*)cv, G_DISCARD|G_EVAL);
2733 if (SvTRUE(ERRSV)) {
2735 #ifdef HAS_SIGPROCMASK
2736 /* Handler "died", for example to get out of a restart-able read().
2737 * Before we re-do that on its behalf re-enable the signal which was
2738 * blocked by the system when we entered.
2742 sigaddset(&set,sig);
2743 sigprocmask(SIG_UNBLOCK, &set, NULL);
2745 /* Not clear if this will work */
2746 (void)rsignal(sig, SIG_IGN);
2747 (void)rsignal(sig, PL_csighandlerp);
2749 #endif /* !PERL_MICRO */
2750 Perl_die(aTHX_ Nullch);
2754 PL_savestack_ix -= 8; /* Unprotect save in progress. */
2758 PL_scopestack_ix -= 1;
2761 PL_op = myop; /* Apparently not needed... */
2763 PL_Sv = tSv; /* Restore global temporaries. */
2770 S_restore_magic(pTHX_ const void *p)
2772 MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
2773 SV* const sv = mgs->mgs_sv;
2778 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2780 #ifdef PERL_OLD_COPY_ON_WRITE
2781 /* While magic was saved (and off) sv_setsv may well have seen
2782 this SV as a prime candidate for COW. */
2784 sv_force_normal_flags(sv, 0);
2788 SvFLAGS(sv) |= mgs->mgs_flags;
2791 if (SvGMAGICAL(sv)) {
2792 /* downgrade public flags to private,
2793 and discard any other private flags */
2795 U32 public = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
2797 SvFLAGS(sv) &= ~( public | SVp_IOK|SVp_NOK|SVp_POK );
2798 SvFLAGS(sv) |= ( public << PRIVSHIFT );
2803 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
2805 /* If we're still on top of the stack, pop us off. (That condition
2806 * will be satisfied if restore_magic was called explicitly, but *not*
2807 * if it's being called via leave_scope.)
2808 * The reason for doing this is that otherwise, things like sv_2cv()
2809 * may leave alloc gunk on the savestack, and some code
2810 * (e.g. sighandler) doesn't expect that...
2812 if (PL_savestack_ix == mgs->mgs_ss_ix)
2814 I32 popval = SSPOPINT;
2815 assert(popval == SAVEt_DESTRUCTOR_X);
2816 PL_savestack_ix -= 2;
2818 assert(popval == SAVEt_ALLOC);
2820 PL_savestack_ix -= popval;
2826 S_unwind_handler_stack(pTHX_ const void *p)
2829 const U32 flags = *(const U32*)p;
2832 PL_savestack_ix -= 5; /* Unprotect save in progress. */
2833 /* cxstack_ix-- Not needed, die already unwound it. */
2834 #if !defined(PERL_IMPLICIT_CONTEXT)
2836 SvREFCNT_dec(PL_sig_sv);
2842 * c-indentation-style: bsd
2844 * indent-tabs-mode: t
2847 * ex: set ts=8 sts=4 sw=4 noet: