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 = NULL;
1010 I32 num_groups = getgroups(0, gary);
1011 Newx(gary, num_groups, Groups_t);
1012 num_groups = getgroups(num_groups, gary);
1013 while (--num_groups >= 0)
1014 Perl_sv_catpvf(aTHX_ sv, " %"Gid_t_f,
1015 (long unsigned int)gary[num_groups]);
1019 (void)SvIOK_on(sv); /* what a wonderful hack! */
1021 #ifndef MACOS_TRADITIONAL
1030 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
1032 struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
1034 if (uf && uf->uf_val)
1035 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
1040 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
1047 s = SvPV_const(sv,len);
1048 ptr = MgPV_const(mg,klen);
1051 #ifdef DYNAMIC_ENV_FETCH
1052 /* We just undefd an environment var. Is a replacement */
1053 /* waiting in the wings? */
1056 if ((valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE)))
1057 s = SvPV_const(*valp, len);
1061 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
1062 /* And you'll never guess what the dog had */
1063 /* in its mouth... */
1065 MgTAINTEDDIR_off(mg);
1067 if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
1068 char pathbuf[256], eltbuf[256], *cp, *elt;
1072 strncpy(eltbuf, s, 255);
1075 do { /* DCL$PATH may be a search list */
1076 while (1) { /* as may dev portion of any element */
1077 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1078 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1079 cando_by_name(S_IWUSR,0,elt) ) {
1080 MgTAINTEDDIR_on(mg);
1084 if ((cp = strchr(elt, ':')) != Nullch)
1086 if (my_trnlnm(elt, eltbuf, j++))
1092 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1095 if (s && klen == 4 && strEQ(ptr,"PATH")) {
1096 const char * const strend = s + len;
1098 while (s < strend) {
1102 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
1103 s, strend, ':', &i);
1105 if (i >= sizeof tmpbuf /* too long -- assume the worst */
1107 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1108 MgTAINTEDDIR_on(mg);
1114 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1120 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1122 PERL_UNUSED_ARG(sv);
1123 my_setenv(MgPV_nolen_const(mg),Nullch);
1128 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1130 PERL_UNUSED_ARG(mg);
1132 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1134 if (PL_localizing) {
1137 hv_iterinit((HV*)sv);
1138 while ((entry = hv_iternext((HV*)sv))) {
1140 my_setenv(hv_iterkey(entry, &keylen),
1141 SvPV_nolen_const(hv_iterval((HV*)sv, entry)));
1149 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1152 PERL_UNUSED_ARG(sv);
1153 PERL_UNUSED_ARG(mg);
1155 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1163 #ifdef HAS_SIGPROCMASK
1165 restore_sigmask(pTHX_ SV *save_sv)
1167 const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1168 (void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0);
1172 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1174 /* Are we fetching a signal entry? */
1175 const I32 i = whichsig(MgPV_nolen_const(mg));
1178 sv_setsv(sv,PL_psig_ptr[i]);
1180 Sighandler_t sigstate;
1181 sigstate = rsignal_state(i);
1182 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1183 if (PL_sig_handlers_initted && PL_sig_ignoring[i]) sigstate = SIG_IGN;
1185 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1186 if (PL_sig_handlers_initted && PL_sig_defaulting[i]) sigstate = SIG_DFL;
1188 /* cache state so we don't fetch it again */
1189 if(sigstate == (Sighandler_t) SIG_IGN)
1190 sv_setpv(sv,"IGNORE");
1192 sv_setsv(sv,&PL_sv_undef);
1193 PL_psig_ptr[i] = SvREFCNT_inc(sv);
1200 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1202 /* XXX Some of this code was copied from Perl_magic_setsig. A little
1203 * refactoring might be in order.
1206 register const char * const s = MgPV_nolen_const(mg);
1207 PERL_UNUSED_ARG(sv);
1210 if (strEQ(s,"__DIE__"))
1212 else if (strEQ(s,"__WARN__"))
1215 Perl_croak(aTHX_ "No such hook: %s", s);
1217 SV * const to_dec = *svp;
1219 SvREFCNT_dec(to_dec);
1223 /* Are we clearing a signal entry? */
1224 const I32 i = whichsig(s);
1226 #ifdef HAS_SIGPROCMASK
1229 /* Avoid having the signal arrive at a bad time, if possible. */
1232 sigprocmask(SIG_BLOCK, &set, &save);
1234 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1235 SAVEFREESV(save_sv);
1236 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1239 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1240 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1242 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1243 PL_sig_defaulting[i] = 1;
1244 (void)rsignal(i, PL_csighandlerp);
1246 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1248 if(PL_psig_name[i]) {
1249 SvREFCNT_dec(PL_psig_name[i]);
1252 if(PL_psig_ptr[i]) {
1253 SV *to_dec=PL_psig_ptr[i];
1256 SvREFCNT_dec(to_dec);
1266 S_raise_signal(pTHX_ int sig)
1268 /* Set a flag to say this signal is pending */
1269 PL_psig_pend[sig]++;
1270 /* And one to say _a_ signal is pending */
1275 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1276 Perl_csighandler(int sig, ...)
1278 Perl_csighandler(int sig)
1281 #ifdef PERL_GET_SIG_CONTEXT
1282 dTHXa(PERL_GET_SIG_CONTEXT);
1286 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1287 (void) rsignal(sig, PL_csighandlerp);
1288 if (PL_sig_ignoring[sig]) return;
1290 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1291 if (PL_sig_defaulting[sig])
1292 #ifdef KILL_BY_SIGPRC
1293 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1298 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
1299 /* Call the perl level handler now--
1300 * with risk we may be in malloc() etc. */
1301 (*PL_sighandlerp)(sig);
1303 S_raise_signal(aTHX_ sig);
1306 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1308 Perl_csighandler_init(void)
1311 if (PL_sig_handlers_initted) return;
1313 for (sig = 1; sig < SIG_SIZE; sig++) {
1314 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1316 PL_sig_defaulting[sig] = 1;
1317 (void) rsignal(sig, PL_csighandlerp);
1319 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1320 PL_sig_ignoring[sig] = 0;
1323 PL_sig_handlers_initted = 1;
1328 Perl_despatch_signals(pTHX)
1332 for (sig = 1; sig < SIG_SIZE; sig++) {
1333 if (PL_psig_pend[sig]) {
1334 PERL_BLOCKSIG_ADD(set, sig);
1335 PL_psig_pend[sig] = 0;
1336 PERL_BLOCKSIG_BLOCK(set);
1337 (*PL_sighandlerp)(sig);
1338 PERL_BLOCKSIG_UNBLOCK(set);
1344 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1349 /* Need to be careful with SvREFCNT_dec(), because that can have side
1350 * effects (due to closures). We must make sure that the new disposition
1351 * is in place before it is called.
1355 #ifdef HAS_SIGPROCMASK
1360 register const char *s = MgPV_const(mg,len);
1362 if (strEQ(s,"__DIE__"))
1364 else if (strEQ(s,"__WARN__"))
1367 Perl_croak(aTHX_ "No such hook: %s", s);
1375 i = whichsig(s); /* ...no, a brick */
1377 if (ckWARN(WARN_SIGNAL))
1378 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
1381 #ifdef HAS_SIGPROCMASK
1382 /* Avoid having the signal arrive at a bad time, if possible. */
1385 sigprocmask(SIG_BLOCK, &set, &save);
1387 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1388 SAVEFREESV(save_sv);
1389 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1392 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1393 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1395 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1396 PL_sig_ignoring[i] = 0;
1398 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1399 PL_sig_defaulting[i] = 0;
1401 SvREFCNT_dec(PL_psig_name[i]);
1402 to_dec = PL_psig_ptr[i];
1403 PL_psig_ptr[i] = SvREFCNT_inc(sv);
1404 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1405 PL_psig_name[i] = newSVpvn(s, len);
1406 SvREADONLY_on(PL_psig_name[i]);
1408 if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
1410 (void)rsignal(i, PL_csighandlerp);
1411 #ifdef HAS_SIGPROCMASK
1416 *svp = SvREFCNT_inc(sv);
1418 SvREFCNT_dec(to_dec);
1421 s = SvPV_force(sv,len);
1422 if (strEQ(s,"IGNORE")) {
1424 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1425 PL_sig_ignoring[i] = 1;
1426 (void)rsignal(i, PL_csighandlerp);
1428 (void)rsignal(i, (Sighandler_t) SIG_IGN);
1432 else if (strEQ(s,"DEFAULT") || !*s) {
1434 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1436 PL_sig_defaulting[i] = 1;
1437 (void)rsignal(i, PL_csighandlerp);
1440 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1445 * We should warn if HINT_STRICT_REFS, but without
1446 * access to a known hint bit in a known OP, we can't
1447 * tell whether HINT_STRICT_REFS is in force or not.
1449 if (!strchr(s,':') && !strchr(s,'\''))
1450 sv_insert(sv, 0, 0, "main::", 6);
1452 (void)rsignal(i, PL_csighandlerp);
1454 *svp = SvREFCNT_inc(sv);
1456 #ifdef HAS_SIGPROCMASK
1461 SvREFCNT_dec(to_dec);
1464 #endif /* !PERL_MICRO */
1467 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1469 PERL_UNUSED_ARG(sv);
1470 PERL_UNUSED_ARG(mg);
1471 PL_sub_generation++;
1476 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
1478 PERL_UNUSED_ARG(sv);
1479 PERL_UNUSED_ARG(mg);
1480 /* HV_badAMAGIC_on(Sv_STASH(sv)); */
1481 PL_amagic_generation++;
1487 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1489 HV * const hv = (HV*)LvTARG(sv);
1491 PERL_UNUSED_ARG(mg);
1494 (void) hv_iterinit(hv);
1495 if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
1498 while (hv_iternext(hv))
1503 sv_setiv(sv, (IV)i);
1508 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1510 PERL_UNUSED_ARG(mg);
1512 hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
1517 /* caller is responsible for stack switching/cleanup */
1519 S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV *val)
1525 PUSHs(SvTIED_obj(sv, mg));
1528 if (mg->mg_len >= 0)
1529 PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len)));
1530 else if (mg->mg_len == HEf_SVKEY)
1531 PUSHs((SV*)mg->mg_ptr);
1533 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1534 PUSHs(sv_2mortal(newSViv(mg->mg_len)));
1542 return call_method(meth, flags);
1546 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
1552 PUSHSTACKi(PERLSI_MAGIC);
1554 if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
1555 sv_setsv(sv, *PL_stack_sp--);
1565 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1568 mg->mg_flags |= MGf_GSKIP;
1569 magic_methpack(sv,mg,"FETCH");
1574 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1578 PUSHSTACKi(PERLSI_MAGIC);
1579 magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
1586 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1588 return magic_methpack(sv,mg,"DELETE");
1593 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1600 PUSHSTACKi(PERLSI_MAGIC);
1601 if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
1602 sv = *PL_stack_sp--;
1603 retval = (U32) SvIV(sv)-1;
1612 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1617 PUSHSTACKi(PERLSI_MAGIC);
1619 XPUSHs(SvTIED_obj(sv, mg));
1621 call_method("CLEAR", G_SCALAR|G_DISCARD);
1629 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1632 const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
1636 PUSHSTACKi(PERLSI_MAGIC);
1639 PUSHs(SvTIED_obj(sv, mg));
1644 if (call_method(meth, G_SCALAR))
1645 sv_setsv(key, *PL_stack_sp--);
1654 Perl_magic_existspack(pTHX_ SV *sv, MAGIC *mg)
1656 return magic_methpack(sv,mg,"EXISTS");
1660 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1663 SV *retval = &PL_sv_undef;
1664 SV * const tied = SvTIED_obj((SV*)hv, mg);
1665 HV * const pkg = SvSTASH((SV*)SvRV(tied));
1667 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1669 if (HvEITER_get(hv))
1670 /* we are in an iteration so the hash cannot be empty */
1672 /* no xhv_eiter so now use FIRSTKEY */
1673 key = sv_newmortal();
1674 magic_nextpack((SV*)hv, mg, key);
1675 HvEITER_set(hv, NULL); /* need to reset iterator */
1676 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1679 /* there is a SCALAR method that we can call */
1681 PUSHSTACKi(PERLSI_MAGIC);
1687 if (call_method("SCALAR", G_SCALAR))
1688 retval = *PL_stack_sp--;
1695 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1697 GV * const gv = PL_DBline;
1698 const I32 i = SvTRUE(sv);
1699 SV ** const svp = av_fetch(GvAV(gv),
1700 atoi(MgPV_nolen_const(mg)), FALSE);
1701 if (svp && SvIOKp(*svp)) {
1702 OP * const o = INT2PTR(OP*,SvIVX(*svp));
1704 /* set or clear breakpoint in the relevant control op */
1706 o->op_flags |= OPf_SPECIAL;
1708 o->op_flags &= ~OPf_SPECIAL;
1715 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
1717 const AV * const obj = (AV*)mg->mg_obj;
1719 sv_setiv(sv, AvFILL(obj) + PL_curcop->cop_arybase);
1727 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
1729 AV * const obj = (AV*)mg->mg_obj;
1731 av_fill(obj, SvIV(sv) - PL_curcop->cop_arybase);
1733 if (ckWARN(WARN_MISC))
1734 Perl_warner(aTHX_ packWARN(WARN_MISC),
1735 "Attempt to set length of freed array");
1741 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
1743 PERL_UNUSED_ARG(sv);
1744 /* during global destruction, mg_obj may already have been freed */
1745 if (PL_in_clean_all)
1748 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
1751 /* arylen scalar holds a pointer back to the array, but doesn't own a
1752 reference. Hence the we (the array) are about to go away with it
1753 still pointing at us. Clear its pointer, else it would be pointing
1754 at free memory. See the comment in sv_magic about reference loops,
1755 and why it can't own a reference to us. */
1762 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
1764 SV* const lsv = LvTARG(sv);
1766 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1767 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1768 if (mg && mg->mg_len >= 0) {
1771 sv_pos_b2u(lsv, &i);
1772 sv_setiv(sv, i + PL_curcop->cop_arybase);
1781 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
1783 SV* const lsv = LvTARG(sv);
1790 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
1791 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1795 sv_magic(lsv, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1796 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1798 else if (!SvOK(sv)) {
1802 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1804 pos = SvIV(sv) - PL_curcop->cop_arybase;
1807 ulen = sv_len_utf8(lsv);
1817 else if (pos > (SSize_t)len)
1822 sv_pos_u2b(lsv, &p, 0);
1827 mg->mg_flags &= ~MGf_MINMATCH;
1833 Perl_magic_getglob(pTHX_ SV *sv, MAGIC *mg)
1835 PERL_UNUSED_ARG(mg);
1836 if (SvFAKE(sv)) { /* FAKE globs can get coerced */
1838 gv_efullname3(sv,((GV*)sv), "*");
1842 gv_efullname3(sv,((GV*)sv), "*"); /* a gv value, be nice */
1847 Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg)
1850 PERL_UNUSED_ARG(mg);
1854 gv = gv_fetchsv(sv, GV_ADD, SVt_PVGV);
1859 GvGP(sv) = gp_ref(GvGP(gv));
1864 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
1867 SV * const lsv = LvTARG(sv);
1868 const char * const tmps = SvPV_const(lsv,len);
1869 I32 offs = LvTARGOFF(sv);
1870 I32 rem = LvTARGLEN(sv);
1871 PERL_UNUSED_ARG(mg);
1874 sv_pos_u2b(lsv, &offs, &rem);
1875 if (offs > (I32)len)
1877 if (rem + offs > (I32)len)
1879 sv_setpvn(sv, tmps + offs, (STRLEN)rem);
1886 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
1889 const char *tmps = SvPV_const(sv, len);
1890 SV * const lsv = LvTARG(sv);
1891 I32 lvoff = LvTARGOFF(sv);
1892 I32 lvlen = LvTARGLEN(sv);
1893 PERL_UNUSED_ARG(mg);
1896 sv_utf8_upgrade(lsv);
1897 sv_pos_u2b(lsv, &lvoff, &lvlen);
1898 sv_insert(lsv, lvoff, lvlen, tmps, len);
1899 LvTARGLEN(sv) = sv_len_utf8(sv);
1902 else if (lsv && SvUTF8(lsv)) {
1903 sv_pos_u2b(lsv, &lvoff, &lvlen);
1904 LvTARGLEN(sv) = len;
1905 tmps = (char*)bytes_to_utf8((U8*)tmps, &len);
1906 sv_insert(lsv, lvoff, lvlen, tmps, len);
1910 sv_insert(lsv, lvoff, lvlen, tmps, len);
1911 LvTARGLEN(sv) = len;
1919 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
1921 PERL_UNUSED_ARG(sv);
1922 TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
1927 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
1929 PERL_UNUSED_ARG(sv);
1930 /* update taint status unless we're restoring at scope exit */
1931 if (PL_localizing != 2) {
1941 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
1943 SV * const lsv = LvTARG(sv);
1944 PERL_UNUSED_ARG(mg);
1951 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
1956 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
1958 PERL_UNUSED_ARG(mg);
1959 do_vecset(sv); /* XXX slurp this routine */
1964 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
1967 if (LvTARGLEN(sv)) {
1969 SV * const ahv = LvTARG(sv);
1970 HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
1975 AV* const av = (AV*)LvTARG(sv);
1976 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
1977 targ = AvARRAY(av)[LvTARGOFF(sv)];
1979 if (targ && targ != &PL_sv_undef) {
1980 /* somebody else defined it for us */
1981 SvREFCNT_dec(LvTARG(sv));
1982 LvTARG(sv) = SvREFCNT_inc(targ);
1984 SvREFCNT_dec(mg->mg_obj);
1985 mg->mg_obj = Nullsv;
1986 mg->mg_flags &= ~MGf_REFCOUNTED;
1991 sv_setsv(sv, targ ? targ : &PL_sv_undef);
1996 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
1998 PERL_UNUSED_ARG(mg);
2002 sv_setsv(LvTARG(sv), sv);
2003 SvSETMAGIC(LvTARG(sv));
2009 Perl_vivify_defelem(pTHX_ SV *sv)
2014 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2017 SV * const ahv = LvTARG(sv);
2018 HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
2021 if (!value || value == &PL_sv_undef)
2022 Perl_croak(aTHX_ PL_no_helem_sv, mg->mg_obj);
2025 AV* const av = (AV*)LvTARG(sv);
2026 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
2027 LvTARG(sv) = Nullsv; /* array can't be extended */
2029 SV** const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
2030 if (!svp || (value = *svp) == &PL_sv_undef)
2031 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
2034 (void)SvREFCNT_inc(value);
2035 SvREFCNT_dec(LvTARG(sv));
2038 SvREFCNT_dec(mg->mg_obj);
2039 mg->mg_obj = Nullsv;
2040 mg->mg_flags &= ~MGf_REFCOUNTED;
2044 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2046 AV *const av = (AV*)mg->mg_obj;
2047 SV **svp = AvARRAY(av);
2048 PERL_UNUSED_ARG(sv);
2050 /* Not sure why the av can get freed ahead of its sv, but somehow it does
2051 in ext/B/t/bytecode.t test 15 (involving print <DATA>) */
2052 if (svp && !SvIS_FREED(av)) {
2053 SV *const *const last = svp + AvFILLp(av);
2055 while (svp <= last) {
2057 SV *const referrer = *svp;
2058 if (SvWEAKREF(referrer)) {
2059 /* XXX Should we check that it hasn't changed? */
2060 SvRV_set(referrer, 0);
2062 SvWEAKREF_off(referrer);
2063 } else if (SvTYPE(referrer) == SVt_PVGV ||
2064 SvTYPE(referrer) == SVt_PVLV) {
2065 /* You lookin' at me? */
2066 assert(GvSTASH(referrer));
2067 assert(GvSTASH(referrer) == (HV*)sv);
2068 GvSTASH(referrer) = 0;
2071 "panic: magic_killbackrefs (flags=%"UVxf")",
2072 (UV)SvFLAGS(referrer));
2080 SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */
2085 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2093 Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
2095 PERL_UNUSED_ARG(mg);
2096 sv_unmagic(sv, PERL_MAGIC_bm);
2102 Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
2104 PERL_UNUSED_ARG(mg);
2105 sv_unmagic(sv, PERL_MAGIC_fm);
2111 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2113 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2115 if (uf && uf->uf_set)
2116 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2121 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2123 PERL_UNUSED_ARG(mg);
2124 sv_unmagic(sv, PERL_MAGIC_qr);
2129 Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
2131 regexp * const re = (regexp *)mg->mg_obj;
2132 PERL_UNUSED_ARG(sv);
2138 #ifdef USE_LOCALE_COLLATE
2140 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2143 * RenE<eacute> Descartes said "I think not."
2144 * and vanished with a faint plop.
2146 PERL_UNUSED_ARG(sv);
2148 Safefree(mg->mg_ptr);
2154 #endif /* USE_LOCALE_COLLATE */
2156 /* Just clear the UTF-8 cache data. */
2158 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2160 PERL_UNUSED_ARG(sv);
2161 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2163 mg->mg_len = -1; /* The mg_len holds the len cache. */
2168 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2170 register const char *s;
2173 switch (*mg->mg_ptr) {
2174 case '\001': /* ^A */
2175 sv_setsv(PL_bodytarget, sv);
2177 case '\003': /* ^C */
2178 PL_minus_c = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2181 case '\004': /* ^D */
2183 s = SvPV_nolen_const(sv);
2184 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2185 DEBUG_x(dump_all());
2187 PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | DEBUG_TOP_FLAG;
2190 case '\005': /* ^E */
2191 if (*(mg->mg_ptr+1) == '\0') {
2192 #ifdef MACOS_TRADITIONAL
2193 gMacPerl_OSErr = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2196 set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2199 SetLastError( SvIV(sv) );
2202 os2_setsyserrno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2204 /* will anyone ever use this? */
2205 SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4);
2211 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2213 SvREFCNT_dec(PL_encoding);
2214 if (SvOK(sv) || SvGMAGICAL(sv)) {
2215 PL_encoding = newSVsv(sv);
2218 PL_encoding = Nullsv;
2222 case '\006': /* ^F */
2223 PL_maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2225 case '\010': /* ^H */
2226 PL_hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2228 case '\011': /* ^I */ /* NOT \t in EBCDIC */
2229 Safefree(PL_inplace);
2230 PL_inplace = SvOK(sv) ? savesvpv(sv) : Nullch;
2232 case '\017': /* ^O */
2233 if (*(mg->mg_ptr+1) == '\0') {
2234 Safefree(PL_osname);
2237 TAINT_PROPER("assigning to $^O");
2238 PL_osname = savesvpv(sv);
2241 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2242 if (!PL_compiling.cop_io)
2243 PL_compiling.cop_io = newSVsv(sv);
2245 sv_setsv(PL_compiling.cop_io,sv);
2248 case '\020': /* ^P */
2249 PL_perldb = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2250 if (PL_perldb && !PL_DBsingle)
2253 case '\024': /* ^T */
2255 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2257 PL_basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2260 case '\027': /* ^W & $^WARNING_BITS */
2261 if (*(mg->mg_ptr+1) == '\0') {
2262 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2263 i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2264 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2265 | (i ? G_WARN_ON : G_WARN_OFF) ;
2268 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2269 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2270 if (!SvPOK(sv) && PL_localizing) {
2271 sv_setpvn(sv, WARN_NONEstring, WARNsize);
2272 PL_compiling.cop_warnings = pWARN_NONE;
2277 int accumulate = 0 ;
2278 int any_fatals = 0 ;
2279 const char * const ptr = SvPV_const(sv, len) ;
2280 for (i = 0 ; i < len ; ++i) {
2281 accumulate |= ptr[i] ;
2282 any_fatals |= (ptr[i] & 0xAA) ;
2285 PL_compiling.cop_warnings = pWARN_NONE;
2286 else if (isWARN_on(sv, WARN_ALL) && !any_fatals) {
2287 PL_compiling.cop_warnings = pWARN_ALL;
2288 PL_dowarn |= G_WARN_ONCE ;
2291 if (specialWARN(PL_compiling.cop_warnings))
2292 PL_compiling.cop_warnings = newSVsv(sv) ;
2294 sv_setsv(PL_compiling.cop_warnings, sv);
2295 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2296 PL_dowarn |= G_WARN_ONCE ;
2304 if (PL_localizing) {
2305 if (PL_localizing == 1)
2306 SAVESPTR(PL_last_in_gv);
2308 else if (SvOK(sv) && GvIO(PL_last_in_gv))
2309 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2312 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2313 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2314 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2317 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2318 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2319 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2322 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2325 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2326 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2327 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2330 IoPAGE(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2334 IO * const io = GvIOp(PL_defoutgv);
2337 if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) == 0)
2338 IoFLAGS(io) &= ~IOf_FLUSH;
2340 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2341 PerlIO *ofp = IoOFP(io);
2343 (void)PerlIO_flush(ofp);
2344 IoFLAGS(io) |= IOf_FLUSH;
2350 SvREFCNT_dec(PL_rs);
2351 PL_rs = newSVsv(sv);
2355 SvREFCNT_dec(PL_ors_sv);
2356 if (SvOK(sv) || SvGMAGICAL(sv)) {
2357 PL_ors_sv = newSVsv(sv);
2365 SvREFCNT_dec(PL_ofs_sv);
2366 if (SvOK(sv) || SvGMAGICAL(sv)) {
2367 PL_ofs_sv = newSVsv(sv);
2374 PL_compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2377 #ifdef COMPLEX_STATUS
2378 if (PL_localizing == 2) {
2379 PL_statusvalue = LvTARGOFF(sv);
2380 PL_statusvalue_vms = LvTARGLEN(sv);
2384 #ifdef VMSISH_STATUS
2386 STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2389 STATUS_UNIX_EXIT_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2394 # define PERL_VMS_BANG vaxc$errno
2396 # define PERL_VMS_BANG 0
2398 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2399 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2403 PL_uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2404 if (PL_delaymagic) {
2405 PL_delaymagic |= DM_RUID;
2406 break; /* don't do magic till later */
2409 (void)setruid((Uid_t)PL_uid);
2412 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2414 #ifdef HAS_SETRESUID
2415 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2417 if (PL_uid == PL_euid) { /* special case $< = $> */
2419 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2420 if (PL_uid != 0 && PerlProc_getuid() == 0)
2421 (void)PerlProc_setuid(0);
2423 (void)PerlProc_setuid(PL_uid);
2425 PL_uid = PerlProc_getuid();
2426 Perl_croak(aTHX_ "setruid() not implemented");
2431 PL_uid = PerlProc_getuid();
2432 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2435 PL_euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2436 if (PL_delaymagic) {
2437 PL_delaymagic |= DM_EUID;
2438 break; /* don't do magic till later */
2441 (void)seteuid((Uid_t)PL_euid);
2444 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2446 #ifdef HAS_SETRESUID
2447 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2449 if (PL_euid == PL_uid) /* special case $> = $< */
2450 PerlProc_setuid(PL_euid);
2452 PL_euid = PerlProc_geteuid();
2453 Perl_croak(aTHX_ "seteuid() not implemented");
2458 PL_euid = PerlProc_geteuid();
2459 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2462 PL_gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2463 if (PL_delaymagic) {
2464 PL_delaymagic |= DM_RGID;
2465 break; /* don't do magic till later */
2468 (void)setrgid((Gid_t)PL_gid);
2471 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2473 #ifdef HAS_SETRESGID
2474 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2476 if (PL_gid == PL_egid) /* special case $( = $) */
2477 (void)PerlProc_setgid(PL_gid);
2479 PL_gid = PerlProc_getgid();
2480 Perl_croak(aTHX_ "setrgid() not implemented");
2485 PL_gid = PerlProc_getgid();
2486 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2489 #ifdef HAS_SETGROUPS
2491 const char *p = SvPV_const(sv, len);
2492 Groups_t gary[NGROUPS];
2497 for (i = 0; i < NGROUPS; ++i) {
2498 while (*p && !isSPACE(*p))
2507 (void)setgroups(i, gary);
2509 #else /* HAS_SETGROUPS */
2510 PL_egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2511 #endif /* HAS_SETGROUPS */
2512 if (PL_delaymagic) {
2513 PL_delaymagic |= DM_EGID;
2514 break; /* don't do magic till later */
2517 (void)setegid((Gid_t)PL_egid);
2520 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2522 #ifdef HAS_SETRESGID
2523 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2525 if (PL_egid == PL_gid) /* special case $) = $( */
2526 (void)PerlProc_setgid(PL_egid);
2528 PL_egid = PerlProc_getegid();
2529 Perl_croak(aTHX_ "setegid() not implemented");
2534 PL_egid = PerlProc_getegid();
2535 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2538 PL_chopset = SvPV_force(sv,len);
2540 #ifndef MACOS_TRADITIONAL
2542 LOCK_DOLLARZERO_MUTEX;
2543 #ifdef HAS_SETPROCTITLE
2544 /* The BSDs don't show the argv[] in ps(1) output, they
2545 * show a string from the process struct and provide
2546 * the setproctitle() routine to manipulate that. */
2548 s = SvPV_const(sv, len);
2549 # if __FreeBSD_version > 410001
2550 /* The leading "-" removes the "perl: " prefix,
2551 * but not the "(perl) suffix from the ps(1)
2552 * output, because that's what ps(1) shows if the
2553 * argv[] is modified. */
2554 setproctitle("-%s", s);
2555 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2556 /* This doesn't really work if you assume that
2557 * $0 = 'foobar'; will wipe out 'perl' from the $0
2558 * because in ps(1) output the result will be like
2559 * sprintf("perl: %s (perl)", s)
2560 * I guess this is a security feature:
2561 * one (a user process) cannot get rid of the original name.
2563 setproctitle("%s", s);
2567 #if defined(__hpux) && defined(PSTAT_SETCMD)
2570 s = SvPV_const(sv, len);
2571 un.pst_command = (char *)s;
2572 pstat(PSTAT_SETCMD, un, len, 0, 0);
2575 /* PL_origalen is set in perl_parse(). */
2576 s = SvPV_force(sv,len);
2577 if (len >= (STRLEN)PL_origalen-1) {
2578 /* Longer than original, will be truncated. We assume that
2579 * PL_origalen bytes are available. */
2580 Copy(s, PL_origargv[0], PL_origalen-1, char);
2583 /* Shorter than original, will be padded. */
2584 Copy(s, PL_origargv[0], len, char);
2585 PL_origargv[0][len] = 0;
2586 memset(PL_origargv[0] + len + 1,
2587 /* Is the space counterintuitive? Yes.
2588 * (You were expecting \0?)
2589 * Does it work? Seems to. (In Linux 2.4.20 at least.)
2592 PL_origalen - len - 1);
2594 PL_origargv[0][PL_origalen-1] = 0;
2595 for (i = 1; i < PL_origargc; i++)
2597 UNLOCK_DOLLARZERO_MUTEX;
2605 Perl_whichsig(pTHX_ const char *sig)
2607 register char* const* sigv;
2609 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
2610 if (strEQ(sig,*sigv))
2611 return PL_sig_num[sigv - (char* const*)PL_sig_name];
2613 if (strEQ(sig,"CHLD"))
2617 if (strEQ(sig,"CLD"))
2624 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2625 Perl_sighandler(int sig, ...)
2627 Perl_sighandler(int sig)
2630 #ifdef PERL_GET_SIG_CONTEXT
2631 dTHXa(PERL_GET_SIG_CONTEXT);
2638 SV * const tSv = PL_Sv;
2642 XPV * const tXpv = PL_Xpv;
2644 if (PL_savestack_ix + 15 <= PL_savestack_max)
2646 if (PL_markstack_ptr < PL_markstack_max - 2)
2648 if (PL_scopestack_ix < PL_scopestack_max - 3)
2651 if (!PL_psig_ptr[sig]) {
2652 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2657 /* Max number of items pushed there is 3*n or 4. We cannot fix
2658 infinity, so we fix 4 (in fact 5): */
2660 PL_savestack_ix += 5; /* Protect save in progress. */
2661 SAVEDESTRUCTOR_X(S_unwind_handler_stack, (void*)&flags);
2664 PL_markstack_ptr++; /* Protect mark. */
2666 PL_scopestack_ix += 1;
2667 /* sv_2cv is too complicated, try a simpler variant first: */
2668 if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
2669 || SvTYPE(cv) != SVt_PVCV) {
2671 cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
2674 if (!cv || !CvROOT(cv)) {
2675 if (ckWARN(WARN_SIGNAL))
2676 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2677 PL_sig_name[sig], (gv ? GvENAME(gv)
2684 if(PL_psig_name[sig]) {
2685 sv = SvREFCNT_inc(PL_psig_name[sig]);
2687 #if !defined(PERL_IMPLICIT_CONTEXT)
2691 sv = sv_newmortal();
2692 sv_setpv(sv,PL_sig_name[sig]);
2695 PUSHSTACKi(PERLSI_SIGNAL);
2698 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2700 struct sigaction oact;
2702 if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
2706 va_start(args, sig);
2707 sip = (siginfo_t*)va_arg(args, siginfo_t*);
2710 SV *rv = newRV_noinc((SV*)sih);
2711 /* The siginfo fields signo, code, errno, pid, uid,
2712 * addr, status, and band are defined by POSIX/SUSv3. */
2713 hv_store(sih, "signo", 5, newSViv(sip->si_signo), 0);
2714 hv_store(sih, "code", 4, newSViv(sip->si_code), 0);
2715 #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. */
2716 hv_store(sih, "errno", 5, newSViv(sip->si_errno), 0);
2717 hv_store(sih, "status", 6, newSViv(sip->si_status), 0);
2718 hv_store(sih, "uid", 3, newSViv(sip->si_uid), 0);
2719 hv_store(sih, "pid", 3, newSViv(sip->si_pid), 0);
2720 hv_store(sih, "addr", 4, newSVuv(PTR2UV(sip->si_addr)), 0);
2721 hv_store(sih, "band", 4, newSViv(sip->si_band), 0);
2725 PUSHs(newSVpv((void*)sip, sizeof(*sip)));
2734 call_sv((SV*)cv, G_DISCARD|G_EVAL);
2737 if (SvTRUE(ERRSV)) {
2739 #ifdef HAS_SIGPROCMASK
2740 /* Handler "died", for example to get out of a restart-able read().
2741 * Before we re-do that on its behalf re-enable the signal which was
2742 * blocked by the system when we entered.
2746 sigaddset(&set,sig);
2747 sigprocmask(SIG_UNBLOCK, &set, NULL);
2749 /* Not clear if this will work */
2750 (void)rsignal(sig, SIG_IGN);
2751 (void)rsignal(sig, PL_csighandlerp);
2753 #endif /* !PERL_MICRO */
2754 Perl_die(aTHX_ Nullch);
2758 PL_savestack_ix -= 8; /* Unprotect save in progress. */
2762 PL_scopestack_ix -= 1;
2765 PL_op = myop; /* Apparently not needed... */
2767 PL_Sv = tSv; /* Restore global temporaries. */
2774 S_restore_magic(pTHX_ const void *p)
2776 MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
2777 SV* const sv = mgs->mgs_sv;
2782 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2784 #ifdef PERL_OLD_COPY_ON_WRITE
2785 /* While magic was saved (and off) sv_setsv may well have seen
2786 this SV as a prime candidate for COW. */
2788 sv_force_normal_flags(sv, 0);
2792 SvFLAGS(sv) |= mgs->mgs_flags;
2795 if (SvGMAGICAL(sv)) {
2796 /* downgrade public flags to private,
2797 and discard any other private flags */
2799 U32 public = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
2801 SvFLAGS(sv) &= ~( public | SVp_IOK|SVp_NOK|SVp_POK );
2802 SvFLAGS(sv) |= ( public << PRIVSHIFT );
2807 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
2809 /* If we're still on top of the stack, pop us off. (That condition
2810 * will be satisfied if restore_magic was called explicitly, but *not*
2811 * if it's being called via leave_scope.)
2812 * The reason for doing this is that otherwise, things like sv_2cv()
2813 * may leave alloc gunk on the savestack, and some code
2814 * (e.g. sighandler) doesn't expect that...
2816 if (PL_savestack_ix == mgs->mgs_ss_ix)
2818 I32 popval = SSPOPINT;
2819 assert(popval == SAVEt_DESTRUCTOR_X);
2820 PL_savestack_ix -= 2;
2822 assert(popval == SAVEt_ALLOC);
2824 PL_savestack_ix -= popval;
2830 S_unwind_handler_stack(pTHX_ const void *p)
2833 const U32 flags = *(const U32*)p;
2836 PL_savestack_ix -= 5; /* Unprotect save in progress. */
2837 /* cxstack_ix-- Not needed, die already unwound it. */
2838 #if !defined(PERL_IMPLICIT_CONTEXT)
2840 SvREFCNT_dec(PL_sig_sv);
2846 * c-indentation-style: bsd
2848 * indent-tabs-mode: t
2851 * ex: set ts=8 sts=4 sw=4 noet: