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)
488 register const REGEXP *rx;
491 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
492 if (mg->mg_obj) /* @+ */
495 return rx->lastparen;
502 Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
506 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
507 register const I32 paren = mg->mg_len;
512 if (paren <= (I32)rx->nparens &&
513 (s = rx->startp[paren]) != -1 &&
514 (t = rx->endp[paren]) != -1)
517 if (mg->mg_obj) /* @+ */
522 if (i > 0 && RX_MATCH_UTF8(rx)) {
523 const char * const b = rx->subbeg;
525 i = Perl_utf8_length(aTHX_ (U8*)b, (U8*)(b+i));
535 Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
537 PERL_UNUSED_ARG(sv); PERL_UNUSED_ARG(mg);
538 Perl_croak(aTHX_ PL_no_modify);
539 NORETURN_FUNCTION_END;
543 Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
547 register const REGEXP *rx;
550 switch (*mg->mg_ptr) {
551 case '1': case '2': case '3': case '4':
552 case '5': case '6': case '7': case '8': case '9': case '&':
553 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
555 paren = atoi(mg->mg_ptr); /* $& is in [0] */
557 if (paren <= (I32)rx->nparens &&
558 (s1 = rx->startp[paren]) != -1 &&
559 (t1 = rx->endp[paren]) != -1)
563 if (i > 0 && RX_MATCH_UTF8(rx)) {
564 const char * const s = rx->subbeg + s1;
569 if (is_utf8_string_loclen((U8*)s, i, &ep, &el))
573 Perl_croak(aTHX_ "panic: magic_len: %"IVdf, (IV)i);
577 if (ckWARN(WARN_UNINITIALIZED))
582 if (ckWARN(WARN_UNINITIALIZED))
587 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
588 paren = rx->lastparen;
593 case '\016': /* ^N */
594 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
595 paren = rx->lastcloseparen;
601 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
602 if (rx->startp[0] != -1) {
613 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
614 if (rx->endp[0] != -1) {
615 i = rx->sublen - rx->endp[0];
626 if (!SvPOK(sv) && SvNIOK(sv)) {
634 #define SvRTRIM(sv) STMT_START { \
635 STRLEN len = SvCUR(sv); \
636 while (len > 0 && isSPACE(SvPVX(sv)[len-1])) \
638 SvCUR_set(sv, len); \
642 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
646 register char *s = NULL;
649 const char * const remaining = mg->mg_ptr + 1;
650 const char nextchar = *remaining;
652 switch (*mg->mg_ptr) {
653 case '\001': /* ^A */
654 sv_setsv(sv, PL_bodytarget);
656 case '\003': /* ^C, ^CHILD_ERROR_NATIVE */
657 if (nextchar == '\0') {
658 sv_setiv(sv, (IV)PL_minus_c);
660 else if (strEQ(remaining, "HILD_ERROR_NATIVE")) {
661 sv_setiv(sv, (IV)STATUS_NATIVE);
665 case '\004': /* ^D */
666 sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
668 case '\005': /* ^E */
669 if (nextchar == '\0') {
670 #ifdef MACOS_TRADITIONAL
674 sv_setnv(sv,(double)gMacPerl_OSErr);
675 sv_setpv(sv, gMacPerl_OSErr ? GetSysErrText(gMacPerl_OSErr, msg) : "");
680 # include <descrip.h>
681 # include <starlet.h>
683 $DESCRIPTOR(msgdsc,msg);
684 sv_setnv(sv,(NV) vaxc$errno);
685 if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
686 sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
692 if (!(_emx_env & 0x200)) { /* Under DOS */
693 sv_setnv(sv, (NV)errno);
694 sv_setpv(sv, errno ? Strerror(errno) : "");
696 if (errno != errno_isOS2) {
697 const int tmp = _syserrno();
698 if (tmp) /* 2nd call to _syserrno() makes it 0 */
701 sv_setnv(sv, (NV)Perl_rc);
702 sv_setpv(sv, os2error(Perl_rc));
707 DWORD dwErr = GetLastError();
708 sv_setnv(sv, (NV)dwErr);
710 PerlProc_GetOSError(sv, dwErr);
713 sv_setpvn(sv, "", 0);
718 const int saveerrno = errno;
719 sv_setnv(sv, (NV)errno);
720 sv_setpv(sv, errno ? Strerror(errno) : "");
728 SvNOK_on(sv); /* what a wonderful hack! */
730 else if (strEQ(remaining, "NCODING"))
731 sv_setsv(sv, PL_encoding);
733 case '\006': /* ^F */
734 sv_setiv(sv, (IV)PL_maxsysfd);
736 case '\010': /* ^H */
737 sv_setiv(sv, (IV)PL_hints);
739 case '\011': /* ^I */ /* NOT \t in EBCDIC */
741 sv_setpv(sv, PL_inplace);
743 sv_setsv(sv, &PL_sv_undef);
745 case '\017': /* ^O & ^OPEN */
746 if (nextchar == '\0') {
747 sv_setpv(sv, PL_osname);
750 else if (strEQ(remaining, "PEN")) {
751 if (!PL_compiling.cop_io)
752 sv_setsv(sv, &PL_sv_undef);
754 sv_setsv(sv, PL_compiling.cop_io);
758 case '\020': /* ^P */
759 sv_setiv(sv, (IV)PL_perldb);
761 case '\023': /* ^S */
762 if (nextchar == '\0') {
763 if (PL_lex_state != LEX_NOTPARSING)
766 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
771 case '\024': /* ^T */
772 if (nextchar == '\0') {
774 sv_setnv(sv, PL_basetime);
776 sv_setiv(sv, (IV)PL_basetime);
779 else if (strEQ(remaining, "AINT"))
780 sv_setiv(sv, PL_tainting
781 ? (PL_taint_warn || PL_unsafe ? -1 : 1)
784 case '\025': /* $^UNICODE, $^UTF8LOCALE */
785 if (strEQ(remaining, "NICODE"))
786 sv_setuv(sv, (UV) PL_unicode);
787 else if (strEQ(remaining, "TF8LOCALE"))
788 sv_setuv(sv, (UV) PL_utf8locale);
790 case '\027': /* ^W & $^WARNING_BITS */
791 if (nextchar == '\0')
792 sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
793 else if (strEQ(remaining, "ARNING_BITS")) {
794 if (PL_compiling.cop_warnings == pWARN_NONE) {
795 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
797 else if (PL_compiling.cop_warnings == pWARN_STD) {
800 (PL_dowarn & G_WARN_ON) ? WARN_ALLstring : WARN_NONEstring,
804 else if (PL_compiling.cop_warnings == pWARN_ALL) {
805 /* Get the bit mask for $warnings::Bits{all}, because
806 * it could have been extended by warnings::register */
808 HV * const bits=get_hv("warnings::Bits", FALSE);
809 if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) {
810 sv_setsv(sv, *bits_all);
813 sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
817 sv_setsv(sv, PL_compiling.cop_warnings);
822 case '1': case '2': case '3': case '4':
823 case '5': case '6': case '7': case '8': case '9': case '&':
824 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
828 * Pre-threads, this was paren = atoi(GvENAME((GV*)mg->mg_obj));
829 * XXX Does the new way break anything?
831 paren = atoi(mg->mg_ptr); /* $& is in [0] */
833 if (paren <= (I32)rx->nparens &&
834 (s1 = rx->startp[paren]) != -1 &&
835 (t1 = rx->endp[paren]) != -1)
844 int oldtainted = PL_tainted;
847 PL_tainted = oldtainted;
848 if (RX_MATCH_UTF8(rx) && is_utf8_string((U8*)s, i))
853 if (RX_MATCH_TAINTED(rx)) {
854 MAGIC* const mg = SvMAGIC(sv);
857 SvMAGIC_set(sv, mg->mg_moremagic);
859 if ((mgt = SvMAGIC(sv))) {
860 mg->mg_moremagic = mgt;
870 sv_setsv(sv,&PL_sv_undef);
873 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
874 paren = rx->lastparen;
878 sv_setsv(sv,&PL_sv_undef);
880 case '\016': /* ^N */
881 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
882 paren = rx->lastcloseparen;
886 sv_setsv(sv,&PL_sv_undef);
889 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
890 if ((s = rx->subbeg) && rx->startp[0] != -1) {
895 sv_setsv(sv,&PL_sv_undef);
898 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
899 if (rx->subbeg && rx->endp[0] != -1) {
900 s = rx->subbeg + rx->endp[0];
901 i = rx->sublen - rx->endp[0];
905 sv_setsv(sv,&PL_sv_undef);
908 if (GvIO(PL_last_in_gv)) {
909 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
914 sv_setiv(sv, (IV)STATUS_CURRENT);
915 #ifdef COMPLEX_STATUS
916 LvTARGOFF(sv) = PL_statusvalue;
917 LvTARGLEN(sv) = PL_statusvalue_vms;
922 if (GvIOp(PL_defoutgv))
923 s = IoTOP_NAME(GvIOp(PL_defoutgv));
927 sv_setpv(sv,GvENAME(PL_defoutgv));
932 if (GvIOp(PL_defoutgv))
933 s = IoFMT_NAME(GvIOp(PL_defoutgv));
935 s = GvENAME(PL_defoutgv);
939 if (GvIOp(PL_defoutgv))
940 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
943 if (GvIOp(PL_defoutgv))
944 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
947 if (GvIOp(PL_defoutgv))
948 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
955 WITH_THR(sv_setiv(sv, (IV)PL_curcop->cop_arybase));
958 if (GvIOp(PL_defoutgv))
959 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
965 sv_copypv(sv, PL_ors_sv);
969 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
970 sv_setpv(sv, errno ? Strerror(errno) : "");
973 const int saveerrno = errno;
974 sv_setnv(sv, (NV)errno);
976 if (errno == errno_isOS2 || errno == errno_isOS2_set)
977 sv_setpv(sv, os2error(Perl_rc));
980 sv_setpv(sv, errno ? Strerror(errno) : "");
985 SvNOK_on(sv); /* what a wonderful hack! */
988 sv_setiv(sv, (IV)PL_uid);
991 sv_setiv(sv, (IV)PL_euid);
994 sv_setiv(sv, (IV)PL_gid);
996 Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, (long unsigned int)PL_gid);
1000 sv_setiv(sv, (IV)PL_egid);
1001 #ifdef HAS_GETGROUPS
1002 Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, (long unsigned int)PL_egid);
1005 #ifdef HAS_GETGROUPS
1007 Groups_t gary[NGROUPS];
1008 I32 j = getgroups(NGROUPS,gary);
1010 Perl_sv_catpvf(aTHX_ sv, " %"Gid_t_f, (long unsigned int)gary[j]);
1013 (void)SvIOK_on(sv); /* what a wonderful hack! */
1015 #ifndef MACOS_TRADITIONAL
1024 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
1026 struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
1028 if (uf && uf->uf_val)
1029 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
1034 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
1041 s = SvPV_const(sv,len);
1042 ptr = MgPV_const(mg,klen);
1045 #ifdef DYNAMIC_ENV_FETCH
1046 /* We just undefd an environment var. Is a replacement */
1047 /* waiting in the wings? */
1050 if ((valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE)))
1051 s = SvPV_const(*valp, len);
1055 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
1056 /* And you'll never guess what the dog had */
1057 /* in its mouth... */
1059 MgTAINTEDDIR_off(mg);
1061 if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
1062 char pathbuf[256], eltbuf[256], *cp, *elt;
1066 strncpy(eltbuf, s, 255);
1069 do { /* DCL$PATH may be a search list */
1070 while (1) { /* as may dev portion of any element */
1071 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1072 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1073 cando_by_name(S_IWUSR,0,elt) ) {
1074 MgTAINTEDDIR_on(mg);
1078 if ((cp = strchr(elt, ':')) != Nullch)
1080 if (my_trnlnm(elt, eltbuf, j++))
1086 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1089 if (s && klen == 4 && strEQ(ptr,"PATH")) {
1090 const char * const strend = s + len;
1092 while (s < strend) {
1096 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
1097 s, strend, ':', &i);
1099 if (i >= sizeof tmpbuf /* too long -- assume the worst */
1101 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1102 MgTAINTEDDIR_on(mg);
1108 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1114 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1116 PERL_UNUSED_ARG(sv);
1117 my_setenv(MgPV_nolen_const(mg),Nullch);
1122 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1125 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1127 if (PL_localizing) {
1130 hv_iterinit((HV*)sv);
1131 while ((entry = hv_iternext((HV*)sv))) {
1133 my_setenv(hv_iterkey(entry, &keylen),
1134 SvPV_nolen_const(hv_iterval((HV*)sv, entry)));
1142 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1145 PERL_UNUSED_ARG(sv);
1146 PERL_UNUSED_ARG(mg);
1148 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1156 #ifdef HAS_SIGPROCMASK
1158 restore_sigmask(pTHX_ SV *save_sv)
1160 const sigset_t *ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1161 (void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0);
1165 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1167 /* Are we fetching a signal entry? */
1168 const I32 i = whichsig(MgPV_nolen_const(mg));
1171 sv_setsv(sv,PL_psig_ptr[i]);
1173 Sighandler_t sigstate;
1174 sigstate = rsignal_state(i);
1175 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1176 if (PL_sig_handlers_initted && PL_sig_ignoring[i]) sigstate = SIG_IGN;
1178 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1179 if (PL_sig_handlers_initted && PL_sig_defaulting[i]) sigstate = SIG_DFL;
1181 /* cache state so we don't fetch it again */
1182 if(sigstate == (Sighandler_t) SIG_IGN)
1183 sv_setpv(sv,"IGNORE");
1185 sv_setsv(sv,&PL_sv_undef);
1186 PL_psig_ptr[i] = SvREFCNT_inc(sv);
1193 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1195 /* XXX Some of this code was copied from Perl_magic_setsig. A little
1196 * refactoring might be in order.
1199 register const char * const s = MgPV_nolen_const(mg);
1200 PERL_UNUSED_ARG(sv);
1203 if (strEQ(s,"__DIE__"))
1205 else if (strEQ(s,"__WARN__"))
1208 Perl_croak(aTHX_ "No such hook: %s", s);
1210 SV * const to_dec = *svp;
1212 SvREFCNT_dec(to_dec);
1216 /* Are we clearing a signal entry? */
1217 const I32 i = whichsig(s);
1219 #ifdef HAS_SIGPROCMASK
1222 /* Avoid having the signal arrive at a bad time, if possible. */
1225 sigprocmask(SIG_BLOCK, &set, &save);
1227 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1228 SAVEFREESV(save_sv);
1229 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1232 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1233 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1235 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1236 PL_sig_defaulting[i] = 1;
1237 (void)rsignal(i, PL_csighandlerp);
1239 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1241 if(PL_psig_name[i]) {
1242 SvREFCNT_dec(PL_psig_name[i]);
1245 if(PL_psig_ptr[i]) {
1246 SV *to_dec=PL_psig_ptr[i];
1249 SvREFCNT_dec(to_dec);
1259 S_raise_signal(pTHX_ int sig)
1261 /* Set a flag to say this signal is pending */
1262 PL_psig_pend[sig]++;
1263 /* And one to say _a_ signal is pending */
1268 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1269 Perl_csighandler(int sig, ...)
1271 Perl_csighandler(int sig)
1274 #ifdef PERL_GET_SIG_CONTEXT
1275 dTHXa(PERL_GET_SIG_CONTEXT);
1279 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1280 (void) rsignal(sig, PL_csighandlerp);
1281 if (PL_sig_ignoring[sig]) return;
1283 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1284 if (PL_sig_defaulting[sig])
1285 #ifdef KILL_BY_SIGPRC
1286 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1291 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
1292 /* Call the perl level handler now--
1293 * with risk we may be in malloc() etc. */
1294 (*PL_sighandlerp)(sig);
1296 S_raise_signal(aTHX_ sig);
1299 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1301 Perl_csighandler_init(void)
1304 if (PL_sig_handlers_initted) return;
1306 for (sig = 1; sig < SIG_SIZE; sig++) {
1307 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1309 PL_sig_defaulting[sig] = 1;
1310 (void) rsignal(sig, PL_csighandlerp);
1312 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1313 PL_sig_ignoring[sig] = 0;
1316 PL_sig_handlers_initted = 1;
1321 Perl_despatch_signals(pTHX)
1325 for (sig = 1; sig < SIG_SIZE; sig++) {
1326 if (PL_psig_pend[sig]) {
1327 PERL_BLOCKSIG_ADD(set, sig);
1328 PL_psig_pend[sig] = 0;
1329 PERL_BLOCKSIG_BLOCK(set);
1330 (*PL_sighandlerp)(sig);
1331 PERL_BLOCKSIG_UNBLOCK(set);
1337 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1342 /* Need to be careful with SvREFCNT_dec(), because that can have side
1343 * effects (due to closures). We must make sure that the new disposition
1344 * is in place before it is called.
1348 #ifdef HAS_SIGPROCMASK
1353 register const char *s = MgPV_const(mg,len);
1355 if (strEQ(s,"__DIE__"))
1357 else if (strEQ(s,"__WARN__"))
1360 Perl_croak(aTHX_ "No such hook: %s", s);
1368 i = whichsig(s); /* ...no, a brick */
1370 if (ckWARN(WARN_SIGNAL))
1371 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
1374 #ifdef HAS_SIGPROCMASK
1375 /* Avoid having the signal arrive at a bad time, if possible. */
1378 sigprocmask(SIG_BLOCK, &set, &save);
1380 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1381 SAVEFREESV(save_sv);
1382 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1385 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1386 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1388 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1389 PL_sig_ignoring[i] = 0;
1391 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1392 PL_sig_defaulting[i] = 0;
1394 SvREFCNT_dec(PL_psig_name[i]);
1395 to_dec = PL_psig_ptr[i];
1396 PL_psig_ptr[i] = SvREFCNT_inc(sv);
1397 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1398 PL_psig_name[i] = newSVpvn(s, len);
1399 SvREADONLY_on(PL_psig_name[i]);
1401 if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
1403 (void)rsignal(i, PL_csighandlerp);
1404 #ifdef HAS_SIGPROCMASK
1409 *svp = SvREFCNT_inc(sv);
1411 SvREFCNT_dec(to_dec);
1414 s = SvPV_force(sv,len);
1415 if (strEQ(s,"IGNORE")) {
1417 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1418 PL_sig_ignoring[i] = 1;
1419 (void)rsignal(i, PL_csighandlerp);
1421 (void)rsignal(i, (Sighandler_t) SIG_IGN);
1425 else if (strEQ(s,"DEFAULT") || !*s) {
1427 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1429 PL_sig_defaulting[i] = 1;
1430 (void)rsignal(i, PL_csighandlerp);
1433 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1438 * We should warn if HINT_STRICT_REFS, but without
1439 * access to a known hint bit in a known OP, we can't
1440 * tell whether HINT_STRICT_REFS is in force or not.
1442 if (!strchr(s,':') && !strchr(s,'\''))
1443 sv_insert(sv, 0, 0, "main::", 6);
1445 (void)rsignal(i, PL_csighandlerp);
1447 *svp = SvREFCNT_inc(sv);
1449 #ifdef HAS_SIGPROCMASK
1454 SvREFCNT_dec(to_dec);
1457 #endif /* !PERL_MICRO */
1460 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1462 PERL_UNUSED_ARG(sv);
1463 PERL_UNUSED_ARG(mg);
1464 PL_sub_generation++;
1469 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
1471 PERL_UNUSED_ARG(sv);
1472 PERL_UNUSED_ARG(mg);
1473 /* HV_badAMAGIC_on(Sv_STASH(sv)); */
1474 PL_amagic_generation++;
1480 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1482 HV * const hv = (HV*)LvTARG(sv);
1484 PERL_UNUSED_ARG(mg);
1487 (void) hv_iterinit(hv);
1488 if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
1491 while (hv_iternext(hv))
1496 sv_setiv(sv, (IV)i);
1501 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1503 PERL_UNUSED_ARG(mg);
1505 hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
1510 /* caller is responsible for stack switching/cleanup */
1512 S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV *val)
1518 PUSHs(SvTIED_obj(sv, mg));
1521 if (mg->mg_len >= 0)
1522 PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len)));
1523 else if (mg->mg_len == HEf_SVKEY)
1524 PUSHs((SV*)mg->mg_ptr);
1526 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1527 PUSHs(sv_2mortal(newSViv(mg->mg_len)));
1535 return call_method(meth, flags);
1539 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
1545 PUSHSTACKi(PERLSI_MAGIC);
1547 if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
1548 sv_setsv(sv, *PL_stack_sp--);
1558 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1561 mg->mg_flags |= MGf_GSKIP;
1562 magic_methpack(sv,mg,"FETCH");
1567 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1571 PUSHSTACKi(PERLSI_MAGIC);
1572 magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
1579 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1581 return magic_methpack(sv,mg,"DELETE");
1586 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1593 PUSHSTACKi(PERLSI_MAGIC);
1594 if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
1595 sv = *PL_stack_sp--;
1596 retval = (U32) SvIV(sv)-1;
1605 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1610 PUSHSTACKi(PERLSI_MAGIC);
1612 XPUSHs(SvTIED_obj(sv, mg));
1614 call_method("CLEAR", G_SCALAR|G_DISCARD);
1622 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1625 const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
1629 PUSHSTACKi(PERLSI_MAGIC);
1632 PUSHs(SvTIED_obj(sv, mg));
1637 if (call_method(meth, G_SCALAR))
1638 sv_setsv(key, *PL_stack_sp--);
1647 Perl_magic_existspack(pTHX_ SV *sv, MAGIC *mg)
1649 return magic_methpack(sv,mg,"EXISTS");
1653 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1656 SV *retval = &PL_sv_undef;
1657 SV * const tied = SvTIED_obj((SV*)hv, mg);
1658 HV * const pkg = SvSTASH((SV*)SvRV(tied));
1660 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1662 if (HvEITER_get(hv))
1663 /* we are in an iteration so the hash cannot be empty */
1665 /* no xhv_eiter so now use FIRSTKEY */
1666 key = sv_newmortal();
1667 magic_nextpack((SV*)hv, mg, key);
1668 HvEITER_set(hv, NULL); /* need to reset iterator */
1669 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1672 /* there is a SCALAR method that we can call */
1674 PUSHSTACKi(PERLSI_MAGIC);
1680 if (call_method("SCALAR", G_SCALAR))
1681 retval = *PL_stack_sp--;
1688 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1690 GV * const gv = PL_DBline;
1691 const I32 i = SvTRUE(sv);
1692 SV ** const svp = av_fetch(GvAV(gv),
1693 atoi(MgPV_nolen_const(mg)), FALSE);
1694 if (svp && SvIOKp(*svp)) {
1695 OP * const o = INT2PTR(OP*,SvIVX(*svp));
1697 /* set or clear breakpoint in the relevant control op */
1699 o->op_flags |= OPf_SPECIAL;
1701 o->op_flags &= ~OPf_SPECIAL;
1708 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
1710 const AV * const obj = (AV*)mg->mg_obj;
1712 sv_setiv(sv, AvFILL(obj) + PL_curcop->cop_arybase);
1720 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
1722 AV * const obj = (AV*)mg->mg_obj;
1724 av_fill(obj, SvIV(sv) - PL_curcop->cop_arybase);
1726 if (ckWARN(WARN_MISC))
1727 Perl_warner(aTHX_ packWARN(WARN_MISC),
1728 "Attempt to set length of freed array");
1734 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
1736 PERL_UNUSED_ARG(sv);
1737 /* during global destruction, mg_obj may already have been freed */
1738 if (PL_in_clean_all)
1741 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
1744 /* arylen scalar holds a pointer back to the array, but doesn't own a
1745 reference. Hence the we (the array) are about to go away with it
1746 still pointing at us. Clear its pointer, else it would be pointing
1747 at free memory. See the comment in sv_magic about reference loops,
1748 and why it can't own a reference to us. */
1755 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
1757 SV* const lsv = LvTARG(sv);
1759 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1760 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1761 if (mg && mg->mg_len >= 0) {
1764 sv_pos_b2u(lsv, &i);
1765 sv_setiv(sv, i + PL_curcop->cop_arybase);
1774 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
1776 SV* const lsv = LvTARG(sv);
1783 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
1784 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1788 sv_magic(lsv, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1789 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1791 else if (!SvOK(sv)) {
1795 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1797 pos = SvIV(sv) - PL_curcop->cop_arybase;
1800 ulen = sv_len_utf8(lsv);
1810 else if (pos > (SSize_t)len)
1815 sv_pos_u2b(lsv, &p, 0);
1820 mg->mg_flags &= ~MGf_MINMATCH;
1826 Perl_magic_getglob(pTHX_ SV *sv, MAGIC *mg)
1828 PERL_UNUSED_ARG(mg);
1829 if (SvFAKE(sv)) { /* FAKE globs can get coerced */
1831 gv_efullname3(sv,((GV*)sv), "*");
1835 gv_efullname3(sv,((GV*)sv), "*"); /* a gv value, be nice */
1840 Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg)
1843 PERL_UNUSED_ARG(mg);
1847 gv = gv_fetchsv(sv,TRUE, SVt_PVGV);
1852 GvGP(sv) = gp_ref(GvGP(gv));
1857 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
1860 SV * const lsv = LvTARG(sv);
1861 const char * const tmps = SvPV_const(lsv,len);
1862 I32 offs = LvTARGOFF(sv);
1863 I32 rem = LvTARGLEN(sv);
1864 PERL_UNUSED_ARG(mg);
1867 sv_pos_u2b(lsv, &offs, &rem);
1868 if (offs > (I32)len)
1870 if (rem + offs > (I32)len)
1872 sv_setpvn(sv, tmps + offs, (STRLEN)rem);
1879 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
1882 const char *tmps = SvPV_const(sv, len);
1883 SV * const lsv = LvTARG(sv);
1884 I32 lvoff = LvTARGOFF(sv);
1885 I32 lvlen = LvTARGLEN(sv);
1886 PERL_UNUSED_ARG(mg);
1889 sv_utf8_upgrade(lsv);
1890 sv_pos_u2b(lsv, &lvoff, &lvlen);
1891 sv_insert(lsv, lvoff, lvlen, tmps, len);
1892 LvTARGLEN(sv) = sv_len_utf8(sv);
1895 else if (lsv && SvUTF8(lsv)) {
1896 sv_pos_u2b(lsv, &lvoff, &lvlen);
1897 LvTARGLEN(sv) = len;
1898 tmps = (char*)bytes_to_utf8((U8*)tmps, &len);
1899 sv_insert(lsv, lvoff, lvlen, tmps, len);
1903 sv_insert(lsv, lvoff, lvlen, tmps, len);
1904 LvTARGLEN(sv) = len;
1912 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
1914 PERL_UNUSED_ARG(sv);
1915 TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
1920 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
1922 PERL_UNUSED_ARG(sv);
1923 /* update taint status unless we're restoring at scope exit */
1924 if (PL_localizing != 2) {
1934 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
1936 SV * const lsv = LvTARG(sv);
1937 PERL_UNUSED_ARG(mg);
1944 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
1949 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
1951 PERL_UNUSED_ARG(mg);
1952 do_vecset(sv); /* XXX slurp this routine */
1957 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
1960 if (LvTARGLEN(sv)) {
1962 SV * const ahv = LvTARG(sv);
1963 HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
1968 AV* const av = (AV*)LvTARG(sv);
1969 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
1970 targ = AvARRAY(av)[LvTARGOFF(sv)];
1972 if (targ && targ != &PL_sv_undef) {
1973 /* somebody else defined it for us */
1974 SvREFCNT_dec(LvTARG(sv));
1975 LvTARG(sv) = SvREFCNT_inc(targ);
1977 SvREFCNT_dec(mg->mg_obj);
1978 mg->mg_obj = Nullsv;
1979 mg->mg_flags &= ~MGf_REFCOUNTED;
1984 sv_setsv(sv, targ ? targ : &PL_sv_undef);
1989 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
1991 PERL_UNUSED_ARG(mg);
1995 sv_setsv(LvTARG(sv), sv);
1996 SvSETMAGIC(LvTARG(sv));
2002 Perl_vivify_defelem(pTHX_ SV *sv)
2007 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2010 SV * const ahv = LvTARG(sv);
2011 HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
2014 if (!value || value == &PL_sv_undef)
2015 Perl_croak(aTHX_ PL_no_helem_sv, mg->mg_obj);
2018 AV* const av = (AV*)LvTARG(sv);
2019 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
2020 LvTARG(sv) = Nullsv; /* array can't be extended */
2022 SV** const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
2023 if (!svp || (value = *svp) == &PL_sv_undef)
2024 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
2027 (void)SvREFCNT_inc(value);
2028 SvREFCNT_dec(LvTARG(sv));
2031 SvREFCNT_dec(mg->mg_obj);
2032 mg->mg_obj = Nullsv;
2033 mg->mg_flags &= ~MGf_REFCOUNTED;
2037 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2039 AV *const av = (AV*)mg->mg_obj;
2040 SV **svp = AvARRAY(av);
2041 PERL_UNUSED_ARG(sv);
2043 /* Not sure why the av can get freed ahead of its sv, but somehow it does
2044 in ext/B/t/bytecode.t test 15 (involving print <DATA>) */
2045 if (svp && !SvIS_FREED(av)) {
2046 SV *const *const last = svp + AvFILLp(av);
2048 while (svp <= last) {
2050 SV *const referrer = *svp;
2051 if (SvWEAKREF(referrer)) {
2052 /* XXX Should we check that it hasn't changed? */
2053 SvRV_set(referrer, 0);
2055 SvWEAKREF_off(referrer);
2056 } else if (SvTYPE(referrer) == SVt_PVGV ||
2057 SvTYPE(referrer) == SVt_PVLV) {
2058 /* You lookin' at me? */
2059 assert(GvSTASH(referrer));
2060 assert(GvSTASH(referrer) == (HV*)sv);
2061 GvSTASH(referrer) = 0;
2064 "panic: magic_killbackrefs (flags=%"UVxf")",
2065 (UV)SvFLAGS(referrer));
2073 SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */
2078 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2086 Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
2088 PERL_UNUSED_ARG(mg);
2089 sv_unmagic(sv, PERL_MAGIC_bm);
2095 Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
2097 PERL_UNUSED_ARG(mg);
2098 sv_unmagic(sv, PERL_MAGIC_fm);
2104 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2106 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2108 if (uf && uf->uf_set)
2109 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2114 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2116 PERL_UNUSED_ARG(mg);
2117 sv_unmagic(sv, PERL_MAGIC_qr);
2122 Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
2124 regexp * const re = (regexp *)mg->mg_obj;
2125 PERL_UNUSED_ARG(sv);
2131 #ifdef USE_LOCALE_COLLATE
2133 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2136 * RenE<eacute> Descartes said "I think not."
2137 * and vanished with a faint plop.
2139 PERL_UNUSED_ARG(sv);
2141 Safefree(mg->mg_ptr);
2147 #endif /* USE_LOCALE_COLLATE */
2149 /* Just clear the UTF-8 cache data. */
2151 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2153 PERL_UNUSED_ARG(sv);
2154 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2156 mg->mg_len = -1; /* The mg_len holds the len cache. */
2161 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2163 register const char *s;
2166 switch (*mg->mg_ptr) {
2167 case '\001': /* ^A */
2168 sv_setsv(PL_bodytarget, sv);
2170 case '\003': /* ^C */
2171 PL_minus_c = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2174 case '\004': /* ^D */
2176 s = SvPV_nolen_const(sv);
2177 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2178 DEBUG_x(dump_all());
2180 PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | DEBUG_TOP_FLAG;
2183 case '\005': /* ^E */
2184 if (*(mg->mg_ptr+1) == '\0') {
2185 #ifdef MACOS_TRADITIONAL
2186 gMacPerl_OSErr = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2189 set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2192 SetLastError( SvIV(sv) );
2195 os2_setsyserrno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2197 /* will anyone ever use this? */
2198 SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4);
2204 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2206 SvREFCNT_dec(PL_encoding);
2207 if (SvOK(sv) || SvGMAGICAL(sv)) {
2208 PL_encoding = newSVsv(sv);
2211 PL_encoding = Nullsv;
2215 case '\006': /* ^F */
2216 PL_maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2218 case '\010': /* ^H */
2219 PL_hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2221 case '\011': /* ^I */ /* NOT \t in EBCDIC */
2222 Safefree(PL_inplace);
2223 PL_inplace = SvOK(sv) ? savesvpv(sv) : Nullch;
2225 case '\017': /* ^O */
2226 if (*(mg->mg_ptr+1) == '\0') {
2227 Safefree(PL_osname);
2230 TAINT_PROPER("assigning to $^O");
2231 PL_osname = savesvpv(sv);
2234 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2235 if (!PL_compiling.cop_io)
2236 PL_compiling.cop_io = newSVsv(sv);
2238 sv_setsv(PL_compiling.cop_io,sv);
2241 case '\020': /* ^P */
2242 PL_perldb = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2243 if (PL_perldb && !PL_DBsingle)
2246 case '\024': /* ^T */
2248 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2250 PL_basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2253 case '\027': /* ^W & $^WARNING_BITS */
2254 if (*(mg->mg_ptr+1) == '\0') {
2255 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2256 i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2257 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2258 | (i ? G_WARN_ON : G_WARN_OFF) ;
2261 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2262 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2263 if (!SvPOK(sv) && PL_localizing) {
2264 sv_setpvn(sv, WARN_NONEstring, WARNsize);
2265 PL_compiling.cop_warnings = pWARN_NONE;
2270 int accumulate = 0 ;
2271 int any_fatals = 0 ;
2272 const char * const ptr = SvPV_const(sv, len) ;
2273 for (i = 0 ; i < len ; ++i) {
2274 accumulate |= ptr[i] ;
2275 any_fatals |= (ptr[i] & 0xAA) ;
2278 PL_compiling.cop_warnings = pWARN_NONE;
2279 else if (isWARN_on(sv, WARN_ALL) && !any_fatals) {
2280 PL_compiling.cop_warnings = pWARN_ALL;
2281 PL_dowarn |= G_WARN_ONCE ;
2284 if (specialWARN(PL_compiling.cop_warnings))
2285 PL_compiling.cop_warnings = newSVsv(sv) ;
2287 sv_setsv(PL_compiling.cop_warnings, sv);
2288 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2289 PL_dowarn |= G_WARN_ONCE ;
2297 if (PL_localizing) {
2298 if (PL_localizing == 1)
2299 SAVESPTR(PL_last_in_gv);
2301 else if (SvOK(sv) && GvIO(PL_last_in_gv))
2302 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2305 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2306 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2307 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv,TRUE, SVt_PVIO);
2310 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2311 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2312 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv,TRUE, SVt_PVIO);
2315 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2318 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2319 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2320 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2323 IoPAGE(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2327 IO * const io = GvIOp(PL_defoutgv);
2330 if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) == 0)
2331 IoFLAGS(io) &= ~IOf_FLUSH;
2333 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2334 PerlIO *ofp = IoOFP(io);
2336 (void)PerlIO_flush(ofp);
2337 IoFLAGS(io) |= IOf_FLUSH;
2343 SvREFCNT_dec(PL_rs);
2344 PL_rs = newSVsv(sv);
2348 SvREFCNT_dec(PL_ors_sv);
2349 if (SvOK(sv) || SvGMAGICAL(sv)) {
2350 PL_ors_sv = newSVsv(sv);
2358 SvREFCNT_dec(PL_ofs_sv);
2359 if (SvOK(sv) || SvGMAGICAL(sv)) {
2360 PL_ofs_sv = newSVsv(sv);
2367 PL_compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2370 #ifdef COMPLEX_STATUS
2371 if (PL_localizing == 2) {
2372 PL_statusvalue = LvTARGOFF(sv);
2373 PL_statusvalue_vms = LvTARGLEN(sv);
2377 #ifdef VMSISH_STATUS
2379 STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2382 STATUS_UNIX_EXIT_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2387 # define PERL_VMS_BANG vaxc$errno
2389 # define PERL_VMS_BANG 0
2391 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2392 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2396 PL_uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2397 if (PL_delaymagic) {
2398 PL_delaymagic |= DM_RUID;
2399 break; /* don't do magic till later */
2402 (void)setruid((Uid_t)PL_uid);
2405 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2407 #ifdef HAS_SETRESUID
2408 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2410 if (PL_uid == PL_euid) { /* special case $< = $> */
2412 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2413 if (PL_uid != 0 && PerlProc_getuid() == 0)
2414 (void)PerlProc_setuid(0);
2416 (void)PerlProc_setuid(PL_uid);
2418 PL_uid = PerlProc_getuid();
2419 Perl_croak(aTHX_ "setruid() not implemented");
2424 PL_uid = PerlProc_getuid();
2425 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2428 PL_euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2429 if (PL_delaymagic) {
2430 PL_delaymagic |= DM_EUID;
2431 break; /* don't do magic till later */
2434 (void)seteuid((Uid_t)PL_euid);
2437 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2439 #ifdef HAS_SETRESUID
2440 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2442 if (PL_euid == PL_uid) /* special case $> = $< */
2443 PerlProc_setuid(PL_euid);
2445 PL_euid = PerlProc_geteuid();
2446 Perl_croak(aTHX_ "seteuid() not implemented");
2451 PL_euid = PerlProc_geteuid();
2452 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2455 PL_gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2456 if (PL_delaymagic) {
2457 PL_delaymagic |= DM_RGID;
2458 break; /* don't do magic till later */
2461 (void)setrgid((Gid_t)PL_gid);
2464 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2466 #ifdef HAS_SETRESGID
2467 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2469 if (PL_gid == PL_egid) /* special case $( = $) */
2470 (void)PerlProc_setgid(PL_gid);
2472 PL_gid = PerlProc_getgid();
2473 Perl_croak(aTHX_ "setrgid() not implemented");
2478 PL_gid = PerlProc_getgid();
2479 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2482 #ifdef HAS_SETGROUPS
2484 const char *p = SvPV_const(sv, len);
2485 Groups_t gary[NGROUPS];
2490 for (i = 0; i < NGROUPS; ++i) {
2491 while (*p && !isSPACE(*p))
2500 (void)setgroups(i, gary);
2502 #else /* HAS_SETGROUPS */
2503 PL_egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2504 #endif /* HAS_SETGROUPS */
2505 if (PL_delaymagic) {
2506 PL_delaymagic |= DM_EGID;
2507 break; /* don't do magic till later */
2510 (void)setegid((Gid_t)PL_egid);
2513 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2515 #ifdef HAS_SETRESGID
2516 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2518 if (PL_egid == PL_gid) /* special case $) = $( */
2519 (void)PerlProc_setgid(PL_egid);
2521 PL_egid = PerlProc_getegid();
2522 Perl_croak(aTHX_ "setegid() not implemented");
2527 PL_egid = PerlProc_getegid();
2528 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2531 PL_chopset = SvPV_force(sv,len);
2533 #ifndef MACOS_TRADITIONAL
2535 LOCK_DOLLARZERO_MUTEX;
2536 #ifdef HAS_SETPROCTITLE
2537 /* The BSDs don't show the argv[] in ps(1) output, they
2538 * show a string from the process struct and provide
2539 * the setproctitle() routine to manipulate that. */
2541 s = SvPV_const(sv, len);
2542 # if __FreeBSD_version > 410001
2543 /* The leading "-" removes the "perl: " prefix,
2544 * but not the "(perl) suffix from the ps(1)
2545 * output, because that's what ps(1) shows if the
2546 * argv[] is modified. */
2547 setproctitle("-%s", s);
2548 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2549 /* This doesn't really work if you assume that
2550 * $0 = 'foobar'; will wipe out 'perl' from the $0
2551 * because in ps(1) output the result will be like
2552 * sprintf("perl: %s (perl)", s)
2553 * I guess this is a security feature:
2554 * one (a user process) cannot get rid of the original name.
2556 setproctitle("%s", s);
2560 #if defined(__hpux) && defined(PSTAT_SETCMD)
2563 s = SvPV_const(sv, len);
2564 un.pst_command = (char *)s;
2565 pstat(PSTAT_SETCMD, un, len, 0, 0);
2568 /* PL_origalen is set in perl_parse(). */
2569 s = SvPV_force(sv,len);
2570 if (len >= (STRLEN)PL_origalen-1) {
2571 /* Longer than original, will be truncated. We assume that
2572 * PL_origalen bytes are available. */
2573 Copy(s, PL_origargv[0], PL_origalen-1, char);
2576 /* Shorter than original, will be padded. */
2577 Copy(s, PL_origargv[0], len, char);
2578 PL_origargv[0][len] = 0;
2579 memset(PL_origargv[0] + len + 1,
2580 /* Is the space counterintuitive? Yes.
2581 * (You were expecting \0?)
2582 * Does it work? Seems to. (In Linux 2.4.20 at least.)
2585 PL_origalen - len - 1);
2587 PL_origargv[0][PL_origalen-1] = 0;
2588 for (i = 1; i < PL_origargc; i++)
2590 UNLOCK_DOLLARZERO_MUTEX;
2598 Perl_whichsig(pTHX_ const char *sig)
2600 register char* const* sigv;
2602 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
2603 if (strEQ(sig,*sigv))
2604 return PL_sig_num[sigv - (char* const*)PL_sig_name];
2606 if (strEQ(sig,"CHLD"))
2610 if (strEQ(sig,"CLD"))
2617 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2618 Perl_sighandler(int sig, ...)
2620 Perl_sighandler(int sig)
2623 #ifdef PERL_GET_SIG_CONTEXT
2624 dTHXa(PERL_GET_SIG_CONTEXT);
2631 SV * const tSv = PL_Sv;
2635 XPV * const tXpv = PL_Xpv;
2637 if (PL_savestack_ix + 15 <= PL_savestack_max)
2639 if (PL_markstack_ptr < PL_markstack_max - 2)
2641 if (PL_scopestack_ix < PL_scopestack_max - 3)
2644 if (!PL_psig_ptr[sig]) {
2645 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2650 /* Max number of items pushed there is 3*n or 4. We cannot fix
2651 infinity, so we fix 4 (in fact 5): */
2653 PL_savestack_ix += 5; /* Protect save in progress. */
2654 SAVEDESTRUCTOR_X(S_unwind_handler_stack, (void*)&flags);
2657 PL_markstack_ptr++; /* Protect mark. */
2659 PL_scopestack_ix += 1;
2660 /* sv_2cv is too complicated, try a simpler variant first: */
2661 if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
2662 || SvTYPE(cv) != SVt_PVCV) {
2664 cv = sv_2cv(PL_psig_ptr[sig],&st,&gv,TRUE);
2667 if (!cv || !CvROOT(cv)) {
2668 if (ckWARN(WARN_SIGNAL))
2669 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2670 PL_sig_name[sig], (gv ? GvENAME(gv)
2677 if(PL_psig_name[sig]) {
2678 sv = SvREFCNT_inc(PL_psig_name[sig]);
2680 #if !defined(PERL_IMPLICIT_CONTEXT)
2684 sv = sv_newmortal();
2685 sv_setpv(sv,PL_sig_name[sig]);
2688 PUSHSTACKi(PERLSI_SIGNAL);
2691 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2693 struct sigaction oact;
2695 if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
2699 va_start(args, sig);
2700 sip = (siginfo_t*)va_arg(args, siginfo_t*);
2703 SV *rv = newRV_noinc((SV*)sih);
2704 /* The siginfo fields signo, code, errno, pid, uid,
2705 * addr, status, and band are defined by POSIX/SUSv3. */
2706 hv_store(sih, "signo", 5, newSViv(sip->si_signo), 0);
2707 hv_store(sih, "code", 4, newSViv(sip->si_code), 0);
2708 #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. */
2709 hv_store(sih, "errno", 5, newSViv(sip->si_errno), 0);
2710 hv_store(sih, "status", 6, newSViv(sip->si_status), 0);
2711 hv_store(sih, "uid", 3, newSViv(sip->si_uid), 0);
2712 hv_store(sih, "pid", 3, newSViv(sip->si_pid), 0);
2713 hv_store(sih, "addr", 4, newSVuv(PTR2UV(sip->si_addr)), 0);
2714 hv_store(sih, "band", 4, newSViv(sip->si_band), 0);
2718 PUSHs(newSVpv((void*)sip, sizeof(*sip)));
2727 call_sv((SV*)cv, G_DISCARD|G_EVAL);
2730 if (SvTRUE(ERRSV)) {
2732 #ifdef HAS_SIGPROCMASK
2733 /* Handler "died", for example to get out of a restart-able read().
2734 * Before we re-do that on its behalf re-enable the signal which was
2735 * blocked by the system when we entered.
2739 sigaddset(&set,sig);
2740 sigprocmask(SIG_UNBLOCK, &set, NULL);
2742 /* Not clear if this will work */
2743 (void)rsignal(sig, SIG_IGN);
2744 (void)rsignal(sig, PL_csighandlerp);
2746 #endif /* !PERL_MICRO */
2747 Perl_die(aTHX_ Nullch);
2751 PL_savestack_ix -= 8; /* Unprotect save in progress. */
2755 PL_scopestack_ix -= 1;
2758 PL_op = myop; /* Apparently not needed... */
2760 PL_Sv = tSv; /* Restore global temporaries. */
2767 S_restore_magic(pTHX_ const void *p)
2769 MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
2770 SV* const sv = mgs->mgs_sv;
2775 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2777 #ifdef PERL_OLD_COPY_ON_WRITE
2778 /* While magic was saved (and off) sv_setsv may well have seen
2779 this SV as a prime candidate for COW. */
2781 sv_force_normal_flags(sv, 0);
2785 SvFLAGS(sv) |= mgs->mgs_flags;
2788 if (SvGMAGICAL(sv)) {
2789 /* downgrade public flags to private,
2790 and discard any other private flags */
2792 U32 public = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
2794 SvFLAGS(sv) &= ~( public | SVp_IOK|SVp_NOK|SVp_POK );
2795 SvFLAGS(sv) |= ( public << PRIVSHIFT );
2800 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
2802 /* If we're still on top of the stack, pop us off. (That condition
2803 * will be satisfied if restore_magic was called explicitly, but *not*
2804 * if it's being called via leave_scope.)
2805 * The reason for doing this is that otherwise, things like sv_2cv()
2806 * may leave alloc gunk on the savestack, and some code
2807 * (e.g. sighandler) doesn't expect that...
2809 if (PL_savestack_ix == mgs->mgs_ss_ix)
2811 I32 popval = SSPOPINT;
2812 assert(popval == SAVEt_DESTRUCTOR_X);
2813 PL_savestack_ix -= 2;
2815 assert(popval == SAVEt_ALLOC);
2817 PL_savestack_ix -= popval;
2823 S_unwind_handler_stack(pTHX_ const void *p)
2826 const U32 flags = *(const U32*)p;
2829 PL_savestack_ix -= 5; /* Unprotect save in progress. */
2830 /* cxstack_ix-- Not needed, die already unwound it. */
2831 #if !defined(PERL_IMPLICIT_CONTEXT)
2833 SvREFCNT_dec(PL_sig_sv);
2839 * c-indentation-style: bsd
2841 * indent-tabs-mode: t
2844 * ex: set ts=8 sts=4 sw=4 noet: