3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * "Sam sat on the ground and put his head in his hands. 'I wish I had never
13 * come here, and I don't want to see no more magic,' he said, and fell silent."
17 =head1 Magical Functions
19 "Magic" is special data attached to SV structures in order to give them
20 "magical" properties. When any Perl code tries to read from, or assign to,
21 an SV marked as magical, it calls the 'get' or 'set' function associated
22 with that SV's magic. A get is called prior to reading an SV, in order to
23 give it a chance to update its internal value (get on $. writes the line
24 number of the last read filehandle into to the SV's IV slot), while
25 set is called after an SV has been written to, in order to allow it to make
26 use of its changed value (set on $/ copies the SV's new value to the
27 PL_rs global variable).
29 Magic is implemented as a linked list of MAGIC structures attached to the
30 SV. Each MAGIC struct holds the type of the magic, a pointer to an array
31 of functions that implement the get(), set(), length() etc functions,
32 plus space for some flags and pointers. For example, a tied variable has
33 a MAGIC structure that contains a pointer to the object associated with the
42 #if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS)
48 #if defined(HAS_SETGROUPS)
55 # include <sys/pstat.h>
58 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
59 Signal_t Perl_csighandler(int sig, ...);
61 Signal_t Perl_csighandler(int sig);
65 /* Missing protos on LynxOS */
66 void setruid(uid_t id);
67 void seteuid(uid_t id);
68 void setrgid(uid_t id);
69 void setegid(uid_t id);
73 * Use the "DESTRUCTOR" scope cleanup to reinstate magic.
81 /* MGS is typedef'ed to struct magic_state in perl.h */
84 S_save_magic(pTHX_ I32 mgs_ix, SV *sv)
88 assert(SvMAGICAL(sv));
89 /* Turning READONLY off for a copy-on-write scalar (including shared
90 hash keys) is a bad idea. */
92 sv_force_normal_flags(sv, 0);
94 SAVEDESTRUCTOR_X(S_restore_magic, INT2PTR(void*, (IV)mgs_ix));
96 mgs = SSPTR(mgs_ix, MGS*);
98 mgs->mgs_flags = SvMAGICAL(sv) | SvREADONLY(sv);
99 mgs->mgs_ss_ix = PL_savestack_ix; /* points after the saved destructor */
103 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
107 =for apidoc mg_magical
109 Turns on the magical status of an SV. See C<sv_magic>.
115 Perl_mg_magical(pTHX_ SV *sv)
119 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
120 const MGVTBL* const vtbl = mg->mg_virtual;
122 if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
126 if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)) || vtbl->svt_clear)
135 Do magic after a value is retrieved from the SV. See C<sv_magic>.
141 Perl_mg_get(pTHX_ SV *sv)
144 const I32 mgs_ix = SSNEW(sizeof(MGS));
145 const bool was_temp = (bool)SvTEMP(sv);
147 MAGIC *newmg, *head, *cur, *mg;
148 /* guard against sv having being freed midway by holding a private
151 /* sv_2mortal has this side effect of turning on the TEMP flag, which can
152 cause the SV's buffer to get stolen (and maybe other stuff).
155 sv_2mortal(SvREFCNT_inc_simple(sv));
160 save_magic(mgs_ix, sv);
162 /* We must call svt_get(sv, mg) for each valid entry in the linked
163 list of magic. svt_get() may delete the current entry, add new
164 magic to the head of the list, or upgrade the SV. AMS 20010810 */
166 newmg = cur = head = mg = SvMAGIC(sv);
168 const MGVTBL * const vtbl = mg->mg_virtual;
170 if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
171 CALL_FPTR(vtbl->svt_get)(aTHX_ sv, mg);
173 /* guard against magic having been deleted - eg FETCH calling
178 /* Don't restore the flags for this entry if it was deleted. */
179 if (mg->mg_flags & MGf_GSKIP)
180 (SSPTR(mgs_ix, MGS *))->mgs_flags = 0;
183 mg = mg->mg_moremagic;
186 /* Have we finished with the new entries we saw? Start again
187 where we left off (unless there are more new entries). */
195 /* Were any new entries added? */
196 if (!have_new && (newmg = SvMAGIC(sv)) != head) {
203 restore_magic(INT2PTR(void *, (IV)mgs_ix));
205 if (SvREFCNT(sv) == 1) {
206 /* We hold the last reference to this SV, which implies that the
207 SV was deleted as a side effect of the routines we called. */
216 Do magic after a value is assigned to the SV. See C<sv_magic>.
222 Perl_mg_set(pTHX_ SV *sv)
225 const I32 mgs_ix = SSNEW(sizeof(MGS));
229 save_magic(mgs_ix, sv);
231 for (mg = SvMAGIC(sv); mg; mg = nextmg) {
232 const MGVTBL* vtbl = mg->mg_virtual;
233 nextmg = mg->mg_moremagic; /* it may delete itself */
234 if (mg->mg_flags & MGf_GSKIP) {
235 mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */
236 (SSPTR(mgs_ix, MGS*))->mgs_flags = 0;
238 if (vtbl && vtbl->svt_set)
239 CALL_FPTR(vtbl->svt_set)(aTHX_ sv, mg);
242 restore_magic(INT2PTR(void*, (IV)mgs_ix));
247 =for apidoc mg_length
249 Report on the SV's length. See C<sv_magic>.
255 Perl_mg_length(pTHX_ SV *sv)
261 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
262 const MGVTBL * const vtbl = mg->mg_virtual;
263 if (vtbl && vtbl->svt_len) {
264 const I32 mgs_ix = SSNEW(sizeof(MGS));
265 save_magic(mgs_ix, sv);
266 /* omit MGf_GSKIP -- not changed here */
267 len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
268 restore_magic(INT2PTR(void*, (IV)mgs_ix));
274 const U8 *s = (U8*)SvPV_const(sv, len);
275 len = Perl_utf8_length(aTHX_ s, s + len);
278 (void)SvPV_const(sv, len);
283 Perl_mg_size(pTHX_ SV *sv)
287 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
288 const MGVTBL* const vtbl = mg->mg_virtual;
289 if (vtbl && vtbl->svt_len) {
290 const I32 mgs_ix = SSNEW(sizeof(MGS));
292 save_magic(mgs_ix, sv);
293 /* omit MGf_GSKIP -- not changed here */
294 len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
295 restore_magic(INT2PTR(void*, (IV)mgs_ix));
302 return AvFILLp((AV *) sv); /* Fallback to non-tied array */
306 Perl_croak(aTHX_ "Size magic not implemented");
315 Clear something magical that the SV represents. See C<sv_magic>.
321 Perl_mg_clear(pTHX_ SV *sv)
323 const I32 mgs_ix = SSNEW(sizeof(MGS));
326 save_magic(mgs_ix, sv);
328 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
329 const MGVTBL* const vtbl = mg->mg_virtual;
330 /* omit GSKIP -- never set here */
332 if (vtbl && vtbl->svt_clear)
333 CALL_FPTR(vtbl->svt_clear)(aTHX_ sv, mg);
336 restore_magic(INT2PTR(void*, (IV)mgs_ix));
343 Finds the magic pointer for type matching the SV. See C<sv_magic>.
349 Perl_mg_find(pTHX_ const SV *sv, int type)
354 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
355 if (mg->mg_type == type)
365 Copies the magic from one SV to another. See C<sv_magic>.
371 Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
375 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
376 const MGVTBL* const vtbl = mg->mg_virtual;
377 if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){
378 count += CALL_FPTR(vtbl->svt_copy)(aTHX_ sv, mg, nsv, key, klen);
381 const char type = mg->mg_type;
384 (type == PERL_MAGIC_tied)
386 : (type == PERL_MAGIC_regdata && mg->mg_obj)
389 toLOWER(type), key, klen);
398 =for apidoc mg_localize
400 Copy some of the magic from an existing SV to new localized version of
401 that SV. Container magic (eg %ENV, $1, tie) gets copied, value magic
402 doesn't (eg taint, pos).
408 Perl_mg_localize(pTHX_ SV *sv, SV *nsv)
412 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
413 MGVTBL* const vtbl = mg->mg_virtual;
414 switch (mg->mg_type) {
415 /* value magic types: don't copy */
418 case PERL_MAGIC_regex_global:
419 case PERL_MAGIC_nkeys:
420 #ifdef USE_LOCALE_COLLATE
421 case PERL_MAGIC_collxfrm:
424 case PERL_MAGIC_taint:
426 case PERL_MAGIC_vstring:
427 case PERL_MAGIC_utf8:
428 case PERL_MAGIC_substr:
429 case PERL_MAGIC_defelem:
430 case PERL_MAGIC_arylen:
432 case PERL_MAGIC_backref:
433 case PERL_MAGIC_arylen_p:
434 case PERL_MAGIC_rhash:
435 case PERL_MAGIC_symtab:
439 if ((mg->mg_flags & MGf_LOCAL) && vtbl->svt_local)
440 (void)CALL_FPTR(vtbl->svt_local)(aTHX_ nsv, mg);
442 sv_magicext(nsv, mg->mg_obj, mg->mg_type, vtbl,
443 mg->mg_ptr, mg->mg_len);
445 /* container types should remain read-only across localization */
446 SvFLAGS(nsv) |= SvREADONLY(sv);
449 if (SvTYPE(nsv) >= SVt_PVMG && SvMAGIC(nsv)) {
450 SvFLAGS(nsv) |= SvMAGICAL(sv);
460 Free any magic storage used by the SV. See C<sv_magic>.
466 Perl_mg_free(pTHX_ SV *sv)
470 for (mg = SvMAGIC(sv); mg; mg = moremagic) {
471 const MGVTBL* const vtbl = mg->mg_virtual;
472 moremagic = mg->mg_moremagic;
473 if (vtbl && vtbl->svt_free)
474 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
475 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
476 if (mg->mg_len > 0 || mg->mg_type == PERL_MAGIC_utf8)
477 Safefree(mg->mg_ptr);
478 else if (mg->mg_len == HEf_SVKEY)
479 SvREFCNT_dec((SV*)mg->mg_ptr);
481 if (mg->mg_flags & MGf_REFCOUNTED)
482 SvREFCNT_dec(mg->mg_obj);
485 SvMAGIC_set(sv, NULL);
492 Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
498 register const REGEXP * const rx = PM_GETRE(PL_curpm);
501 ? rx->nparens /* @+ */
502 : rx->lastparen; /* @- */
510 Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
514 register const REGEXP * const rx = PM_GETRE(PL_curpm);
516 register const I32 paren = mg->mg_len;
521 if (paren <= (I32)rx->nparens &&
522 (s = rx->startp[paren]) != -1 &&
523 (t = rx->endp[paren]) != -1)
526 if (mg->mg_obj) /* @+ */
531 if (i > 0 && RX_MATCH_UTF8(rx)) {
532 const char * const b = rx->subbeg;
534 i = Perl_utf8_length(aTHX_ (U8*)b, (U8*)(b+i));
545 Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
549 Perl_croak(aTHX_ PL_no_modify);
550 NORETURN_FUNCTION_END;
554 Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
559 register const REGEXP *rx;
562 switch (*mg->mg_ptr) {
563 case '1': case '2': case '3': case '4':
564 case '5': case '6': case '7': case '8': case '9': case '&':
565 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
567 paren = atoi(mg->mg_ptr); /* $& is in [0] */
569 if (paren <= (I32)rx->nparens &&
570 (s1 = rx->startp[paren]) != -1 &&
571 (t1 = rx->endp[paren]) != -1)
575 if (i > 0 && RX_MATCH_UTF8(rx)) {
576 const char * const s = rx->subbeg + s1;
581 if (is_utf8_string_loclen((U8*)s, i, &ep, &el))
585 Perl_croak(aTHX_ "panic: magic_len: %"IVdf, (IV)i);
589 if (ckWARN(WARN_UNINITIALIZED))
594 if (ckWARN(WARN_UNINITIALIZED))
599 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
600 paren = rx->lastparen;
605 case '\016': /* ^N */
606 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
607 paren = rx->lastcloseparen;
613 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
614 if (rx->startp[0] != -1) {
625 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
626 if (rx->endp[0] != -1) {
627 i = rx->sublen - rx->endp[0];
638 if (!SvPOK(sv) && SvNIOK(sv)) {
646 #define SvRTRIM(sv) STMT_START { \
648 STRLEN len = SvCUR(sv); \
649 char * const p = SvPVX(sv); \
650 while (len > 0 && isSPACE(p[len-1])) \
652 SvCUR_set(sv, len); \
658 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
662 register char *s = NULL;
665 const char * const remaining = mg->mg_ptr + 1;
666 const char nextchar = *remaining;
668 switch (*mg->mg_ptr) {
669 case '\001': /* ^A */
670 sv_setsv(sv, PL_bodytarget);
672 case '\003': /* ^C, ^CHILD_ERROR_NATIVE */
673 if (nextchar == '\0') {
674 sv_setiv(sv, (IV)PL_minus_c);
676 else if (strEQ(remaining, "HILD_ERROR_NATIVE")) {
677 sv_setiv(sv, (IV)STATUS_NATIVE);
681 case '\004': /* ^D */
682 sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
684 case '\005': /* ^E */
685 if (nextchar == '\0') {
686 #if defined(MACOS_TRADITIONAL)
690 sv_setnv(sv,(double)gMacPerl_OSErr);
691 sv_setpv(sv, gMacPerl_OSErr ? GetSysErrText(gMacPerl_OSErr, msg) : "");
695 # include <descrip.h>
696 # include <starlet.h>
698 $DESCRIPTOR(msgdsc,msg);
699 sv_setnv(sv,(NV) vaxc$errno);
700 if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
701 sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
706 if (!(_emx_env & 0x200)) { /* Under DOS */
707 sv_setnv(sv, (NV)errno);
708 sv_setpv(sv, errno ? Strerror(errno) : "");
710 if (errno != errno_isOS2) {
711 const int tmp = _syserrno();
712 if (tmp) /* 2nd call to _syserrno() makes it 0 */
715 sv_setnv(sv, (NV)Perl_rc);
716 sv_setpv(sv, os2error(Perl_rc));
720 const DWORD dwErr = GetLastError();
721 sv_setnv(sv, (NV)dwErr);
723 PerlProc_GetOSError(sv, dwErr);
726 sv_setpvn(sv, "", 0);
731 const int saveerrno = errno;
732 sv_setnv(sv, (NV)errno);
733 sv_setpv(sv, errno ? Strerror(errno) : "");
738 SvNOK_on(sv); /* what a wonderful hack! */
740 else if (strEQ(remaining, "NCODING"))
741 sv_setsv(sv, PL_encoding);
743 case '\006': /* ^F */
744 sv_setiv(sv, (IV)PL_maxsysfd);
746 case '\010': /* ^H */
747 sv_setiv(sv, (IV)PL_hints);
749 case '\011': /* ^I */ /* NOT \t in EBCDIC */
751 sv_setpv(sv, PL_inplace);
753 sv_setsv(sv, &PL_sv_undef);
755 case '\017': /* ^O & ^OPEN */
756 if (nextchar == '\0') {
757 sv_setpv(sv, PL_osname);
760 else if (strEQ(remaining, "PEN")) {
761 if (!PL_compiling.cop_io)
762 sv_setsv(sv, &PL_sv_undef);
764 sv_setsv(sv, PL_compiling.cop_io);
768 case '\020': /* ^P */
769 sv_setiv(sv, (IV)PL_perldb);
771 case '\023': /* ^S */
772 if (nextchar == '\0') {
773 if (PL_lex_state != LEX_NOTPARSING)
776 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
781 case '\024': /* ^T */
782 if (nextchar == '\0') {
784 sv_setnv(sv, PL_basetime);
786 sv_setiv(sv, (IV)PL_basetime);
789 else if (strEQ(remaining, "AINT"))
790 sv_setiv(sv, PL_tainting
791 ? (PL_taint_warn || PL_unsafe ? -1 : 1)
794 case '\025': /* $^UNICODE, $^UTF8LOCALE, $^UTF8CACHE */
795 if (strEQ(remaining, "NICODE"))
796 sv_setuv(sv, (UV) PL_unicode);
797 else if (strEQ(remaining, "TF8LOCALE"))
798 sv_setuv(sv, (UV) PL_utf8locale);
799 else if (strEQ(remaining, "TF8CACHE"))
800 sv_setiv(sv, (IV) PL_utf8cache);
802 case '\027': /* ^W & $^WARNING_BITS */
803 if (nextchar == '\0')
804 sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
805 else if (strEQ(remaining, "ARNING_BITS")) {
806 if (PL_compiling.cop_warnings == pWARN_NONE) {
807 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
809 else if (PL_compiling.cop_warnings == pWARN_STD) {
812 (PL_dowarn & G_WARN_ON) ? WARN_ALLstring : WARN_NONEstring,
816 else if (PL_compiling.cop_warnings == pWARN_ALL) {
817 /* Get the bit mask for $warnings::Bits{all}, because
818 * it could have been extended by warnings::register */
820 HV * const bits=get_hv("warnings::Bits", FALSE);
821 if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
822 sv_setsv(sv, *bits_all);
825 sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
829 sv_setpvn(sv, (char *) (PL_compiling.cop_warnings + 1),
830 *PL_compiling.cop_warnings);
835 case '1': case '2': case '3': case '4':
836 case '5': case '6': case '7': case '8': case '9': case '&':
837 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
841 * Pre-threads, this was paren = atoi(GvENAME((GV*)mg->mg_obj));
842 * XXX Does the new way break anything?
844 paren = atoi(mg->mg_ptr); /* $& is in [0] */
846 if (paren <= (I32)rx->nparens &&
847 (s1 = rx->startp[paren]) != -1 &&
848 (t1 = rx->endp[paren]) != -1)
856 const int oldtainted = PL_tainted;
859 PL_tainted = oldtainted;
860 if (RX_MATCH_UTF8(rx) && is_utf8_string((U8*)s, i))
865 if (RX_MATCH_TAINTED(rx)) {
866 MAGIC* const mg = SvMAGIC(sv);
869 SvMAGIC_set(sv, mg->mg_moremagic);
871 if ((mgt = SvMAGIC(sv))) {
872 mg->mg_moremagic = mgt;
882 sv_setsv(sv,&PL_sv_undef);
885 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
886 paren = rx->lastparen;
890 sv_setsv(sv,&PL_sv_undef);
892 case '\016': /* ^N */
893 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
894 paren = rx->lastcloseparen;
898 sv_setsv(sv,&PL_sv_undef);
901 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
902 if ((s = rx->subbeg) && rx->startp[0] != -1) {
907 sv_setsv(sv,&PL_sv_undef);
910 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
911 if (rx->subbeg && rx->endp[0] != -1) {
912 s = rx->subbeg + rx->endp[0];
913 i = rx->sublen - rx->endp[0];
917 sv_setsv(sv,&PL_sv_undef);
920 if (GvIO(PL_last_in_gv)) {
921 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
926 sv_setiv(sv, (IV)STATUS_CURRENT);
927 #ifdef COMPLEX_STATUS
928 LvTARGOFF(sv) = PL_statusvalue;
929 LvTARGLEN(sv) = PL_statusvalue_vms;
934 if (GvIOp(PL_defoutgv))
935 s = IoTOP_NAME(GvIOp(PL_defoutgv));
939 sv_setpv(sv,GvENAME(PL_defoutgv));
944 if (GvIOp(PL_defoutgv))
945 s = IoFMT_NAME(GvIOp(PL_defoutgv));
947 s = GvENAME(PL_defoutgv);
951 if (GvIOp(PL_defoutgv))
952 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
955 if (GvIOp(PL_defoutgv))
956 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
959 if (GvIOp(PL_defoutgv))
960 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
967 WITH_THR(sv_setiv(sv, (IV)CopARYBASE_get(PL_curcop)));
970 if (GvIOp(PL_defoutgv))
971 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
977 sv_copypv(sv, PL_ors_sv);
981 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
982 sv_setpv(sv, errno ? Strerror(errno) : "");
985 const int saveerrno = errno;
986 sv_setnv(sv, (NV)errno);
988 if (errno == errno_isOS2 || errno == errno_isOS2_set)
989 sv_setpv(sv, os2error(Perl_rc));
992 sv_setpv(sv, errno ? Strerror(errno) : "");
997 SvNOK_on(sv); /* what a wonderful hack! */
1000 sv_setiv(sv, (IV)PL_uid);
1003 sv_setiv(sv, (IV)PL_euid);
1006 sv_setiv(sv, (IV)PL_gid);
1009 sv_setiv(sv, (IV)PL_egid);
1011 #ifdef HAS_GETGROUPS
1013 Groups_t *gary = NULL;
1014 I32 i, num_groups = getgroups(0, gary);
1015 Newx(gary, num_groups, Groups_t);
1016 num_groups = getgroups(num_groups, gary);
1017 for (i = 0; i < num_groups; i++)
1018 Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]);
1021 (void)SvIOK_on(sv); /* what a wonderful hack! */
1024 #ifndef MACOS_TRADITIONAL
1033 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
1035 struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
1037 if (uf && uf->uf_val)
1038 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
1043 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
1046 STRLEN len = 0, klen;
1047 const char *s = SvOK(sv) ? SvPV_const(sv,len) : "";
1048 const char * const 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? */
1055 SV ** const valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE);
1057 s = SvOK(*valp) ? 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, ':')) != NULL)
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),NULL);
1128 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1131 PERL_UNUSED_ARG(mg);
1133 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1135 if (PL_localizing) {
1138 hv_iterinit((HV*)sv);
1139 while ((entry = hv_iternext((HV*)sv))) {
1141 my_setenv(hv_iterkey(entry, &keylen),
1142 SvPV_nolen_const(hv_iterval((HV*)sv, entry)));
1150 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1153 PERL_UNUSED_ARG(sv);
1154 PERL_UNUSED_ARG(mg);
1156 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1164 #ifdef HAS_SIGPROCMASK
1166 restore_sigmask(pTHX_ SV *save_sv)
1168 const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1169 (void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0);
1173 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1176 /* Are we fetching a signal entry? */
1177 const I32 i = whichsig(MgPV_nolen_const(mg));
1180 sv_setsv(sv,PL_psig_ptr[i]);
1182 Sighandler_t sigstate;
1183 sigstate = rsignal_state(i);
1184 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1185 if (PL_sig_handlers_initted && PL_sig_ignoring[i]) sigstate = SIG_IGN;
1187 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1188 if (PL_sig_handlers_initted && PL_sig_defaulting[i]) sigstate = SIG_DFL;
1190 /* cache state so we don't fetch it again */
1191 if(sigstate == (Sighandler_t) SIG_IGN)
1192 sv_setpv(sv,"IGNORE");
1194 sv_setsv(sv,&PL_sv_undef);
1195 PL_psig_ptr[i] = SvREFCNT_inc_simple(sv);
1202 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1204 /* XXX Some of this code was copied from Perl_magic_setsig. A little
1205 * refactoring might be in order.
1208 register const char * const s = MgPV_nolen_const(mg);
1209 PERL_UNUSED_ARG(sv);
1212 if (strEQ(s,"__DIE__"))
1214 else if (strEQ(s,"__WARN__"))
1217 Perl_croak(aTHX_ "No such hook: %s", s);
1219 SV * const to_dec = *svp;
1221 SvREFCNT_dec(to_dec);
1225 /* Are we clearing a signal entry? */
1226 const I32 i = whichsig(s);
1228 #ifdef HAS_SIGPROCMASK
1231 /* Avoid having the signal arrive at a bad time, if possible. */
1234 sigprocmask(SIG_BLOCK, &set, &save);
1236 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1237 SAVEFREESV(save_sv);
1238 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1241 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1242 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1244 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1245 PL_sig_defaulting[i] = 1;
1246 (void)rsignal(i, PL_csighandlerp);
1248 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1250 if(PL_psig_name[i]) {
1251 SvREFCNT_dec(PL_psig_name[i]);
1254 if(PL_psig_ptr[i]) {
1255 SV * const to_dec=PL_psig_ptr[i];
1258 SvREFCNT_dec(to_dec);
1268 S_raise_signal(pTHX_ int sig)
1271 /* Set a flag to say this signal is pending */
1272 PL_psig_pend[sig]++;
1273 /* And one to say _a_ signal is pending */
1278 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1279 Perl_csighandler(int sig, ...)
1281 Perl_csighandler(int sig)
1284 #ifdef PERL_GET_SIG_CONTEXT
1285 dTHXa(PERL_GET_SIG_CONTEXT);
1289 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1290 (void) rsignal(sig, PL_csighandlerp);
1291 if (PL_sig_ignoring[sig]) return;
1293 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1294 if (PL_sig_defaulting[sig])
1295 #ifdef KILL_BY_SIGPRC
1296 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1301 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
1302 /* Call the perl level handler now--
1303 * with risk we may be in malloc() etc. */
1304 (*PL_sighandlerp)(sig);
1306 S_raise_signal(aTHX_ sig);
1309 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1311 Perl_csighandler_init(void)
1314 if (PL_sig_handlers_initted) return;
1316 for (sig = 1; sig < SIG_SIZE; sig++) {
1317 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1319 PL_sig_defaulting[sig] = 1;
1320 (void) rsignal(sig, PL_csighandlerp);
1322 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1323 PL_sig_ignoring[sig] = 0;
1326 PL_sig_handlers_initted = 1;
1331 Perl_despatch_signals(pTHX)
1336 for (sig = 1; sig < SIG_SIZE; sig++) {
1337 if (PL_psig_pend[sig]) {
1338 PERL_BLOCKSIG_ADD(set, sig);
1339 PL_psig_pend[sig] = 0;
1340 PERL_BLOCKSIG_BLOCK(set);
1341 (*PL_sighandlerp)(sig);
1342 PERL_BLOCKSIG_UNBLOCK(set);
1348 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1353 /* Need to be careful with SvREFCNT_dec(), because that can have side
1354 * effects (due to closures). We must make sure that the new disposition
1355 * is in place before it is called.
1359 #ifdef HAS_SIGPROCMASK
1364 register const char *s = MgPV_const(mg,len);
1366 if (strEQ(s,"__DIE__"))
1368 else if (strEQ(s,"__WARN__"))
1371 Perl_croak(aTHX_ "No such hook: %s", s);
1379 i = whichsig(s); /* ...no, a brick */
1381 if (ckWARN(WARN_SIGNAL))
1382 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
1385 #ifdef HAS_SIGPROCMASK
1386 /* Avoid having the signal arrive at a bad time, if possible. */
1389 sigprocmask(SIG_BLOCK, &set, &save);
1391 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1392 SAVEFREESV(save_sv);
1393 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1396 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1397 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1399 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1400 PL_sig_ignoring[i] = 0;
1402 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1403 PL_sig_defaulting[i] = 0;
1405 SvREFCNT_dec(PL_psig_name[i]);
1406 to_dec = PL_psig_ptr[i];
1407 PL_psig_ptr[i] = SvREFCNT_inc_simple(sv);
1408 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1409 PL_psig_name[i] = newSVpvn(s, len);
1410 SvREADONLY_on(PL_psig_name[i]);
1412 if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
1414 (void)rsignal(i, PL_csighandlerp);
1415 #ifdef HAS_SIGPROCMASK
1420 *svp = SvREFCNT_inc_simple_NN(sv);
1422 SvREFCNT_dec(to_dec);
1425 s = SvPV_force(sv,len);
1426 if (strEQ(s,"IGNORE")) {
1428 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1429 PL_sig_ignoring[i] = 1;
1430 (void)rsignal(i, PL_csighandlerp);
1432 (void)rsignal(i, (Sighandler_t) SIG_IGN);
1436 else if (strEQ(s,"DEFAULT") || !*s) {
1438 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1440 PL_sig_defaulting[i] = 1;
1441 (void)rsignal(i, PL_csighandlerp);
1444 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1449 * We should warn if HINT_STRICT_REFS, but without
1450 * access to a known hint bit in a known OP, we can't
1451 * tell whether HINT_STRICT_REFS is in force or not.
1453 if (!strchr(s,':') && !strchr(s,'\''))
1454 Perl_sv_insert(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"));
1456 (void)rsignal(i, PL_csighandlerp);
1458 *svp = SvREFCNT_inc_simple(sv);
1460 #ifdef HAS_SIGPROCMASK
1465 SvREFCNT_dec(to_dec);
1468 #endif /* !PERL_MICRO */
1471 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1474 PERL_UNUSED_ARG(sv);
1475 PERL_UNUSED_ARG(mg);
1476 PL_sub_generation++;
1481 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
1484 PERL_UNUSED_ARG(sv);
1485 PERL_UNUSED_ARG(mg);
1486 /* HV_badAMAGIC_on(Sv_STASH(sv)); */
1487 PL_amagic_generation++;
1493 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1495 HV * const hv = (HV*)LvTARG(sv);
1497 PERL_UNUSED_ARG(mg);
1500 (void) hv_iterinit(hv);
1501 if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
1504 while (hv_iternext(hv))
1509 sv_setiv(sv, (IV)i);
1514 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1516 PERL_UNUSED_ARG(mg);
1518 hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
1523 /* caller is responsible for stack switching/cleanup */
1525 S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV *val)
1532 PUSHs(SvTIED_obj(sv, mg));
1535 if (mg->mg_len >= 0)
1536 PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len)));
1537 else if (mg->mg_len == HEf_SVKEY)
1538 PUSHs((SV*)mg->mg_ptr);
1540 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1541 PUSHs(sv_2mortal(newSViv(mg->mg_len)));
1549 return call_method(meth, flags);
1553 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
1559 PUSHSTACKi(PERLSI_MAGIC);
1561 if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
1562 sv_setsv(sv, *PL_stack_sp--);
1572 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1575 mg->mg_flags |= MGf_GSKIP;
1576 magic_methpack(sv,mg,"FETCH");
1581 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1585 PUSHSTACKi(PERLSI_MAGIC);
1586 magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
1593 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1595 return magic_methpack(sv,mg,"DELETE");
1600 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1607 PUSHSTACKi(PERLSI_MAGIC);
1608 if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
1609 sv = *PL_stack_sp--;
1610 retval = (U32) SvIV(sv)-1;
1619 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1624 PUSHSTACKi(PERLSI_MAGIC);
1626 XPUSHs(SvTIED_obj(sv, mg));
1628 call_method("CLEAR", G_SCALAR|G_DISCARD);
1636 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1639 const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
1643 PUSHSTACKi(PERLSI_MAGIC);
1646 PUSHs(SvTIED_obj(sv, mg));
1651 if (call_method(meth, G_SCALAR))
1652 sv_setsv(key, *PL_stack_sp--);
1661 Perl_magic_existspack(pTHX_ SV *sv, MAGIC *mg)
1663 return magic_methpack(sv,mg,"EXISTS");
1667 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1670 SV *retval = &PL_sv_undef;
1671 SV * const tied = SvTIED_obj((SV*)hv, mg);
1672 HV * const pkg = SvSTASH((SV*)SvRV(tied));
1674 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1676 if (HvEITER_get(hv))
1677 /* we are in an iteration so the hash cannot be empty */
1679 /* no xhv_eiter so now use FIRSTKEY */
1680 key = sv_newmortal();
1681 magic_nextpack((SV*)hv, mg, key);
1682 HvEITER_set(hv, NULL); /* need to reset iterator */
1683 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1686 /* there is a SCALAR method that we can call */
1688 PUSHSTACKi(PERLSI_MAGIC);
1694 if (call_method("SCALAR", G_SCALAR))
1695 retval = *PL_stack_sp--;
1702 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1705 GV * const gv = PL_DBline;
1706 const I32 i = SvTRUE(sv);
1707 SV ** const svp = av_fetch(GvAV(gv),
1708 atoi(MgPV_nolen_const(mg)), FALSE);
1709 if (svp && SvIOKp(*svp)) {
1710 OP * const o = INT2PTR(OP*,SvIVX(*svp));
1712 /* set or clear breakpoint in the relevant control op */
1714 o->op_flags |= OPf_SPECIAL;
1716 o->op_flags &= ~OPf_SPECIAL;
1723 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
1726 const AV * const obj = (AV*)mg->mg_obj;
1728 sv_setiv(sv, AvFILL(obj) + CopARYBASE_get(PL_curcop));
1736 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
1739 AV * const obj = (AV*)mg->mg_obj;
1741 av_fill(obj, SvIV(sv) - CopARYBASE_get(PL_curcop));
1743 if (ckWARN(WARN_MISC))
1744 Perl_warner(aTHX_ packWARN(WARN_MISC),
1745 "Attempt to set length of freed array");
1751 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
1754 PERL_UNUSED_ARG(sv);
1755 /* during global destruction, mg_obj may already have been freed */
1756 if (PL_in_clean_all)
1759 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
1762 /* arylen scalar holds a pointer back to the array, but doesn't own a
1763 reference. Hence the we (the array) are about to go away with it
1764 still pointing at us. Clear its pointer, else it would be pointing
1765 at free memory. See the comment in sv_magic about reference loops,
1766 and why it can't own a reference to us. */
1773 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
1776 SV* const lsv = LvTARG(sv);
1777 PERL_UNUSED_ARG(mg);
1779 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1780 MAGIC * const found = mg_find(lsv, PERL_MAGIC_regex_global);
1781 if (found && found->mg_len >= 0) {
1782 I32 i = found->mg_len;
1784 sv_pos_b2u(lsv, &i);
1785 sv_setiv(sv, i + CopARYBASE_get(PL_curcop));
1794 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
1797 SV* const lsv = LvTARG(sv);
1803 PERL_UNUSED_ARG(mg);
1805 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
1806 found = mg_find(lsv, PERL_MAGIC_regex_global);
1812 #ifdef PERL_OLD_COPY_ON_WRITE
1814 sv_force_normal_flags(lsv, 0);
1816 found = sv_magicext(lsv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
1819 else if (!SvOK(sv)) {
1823 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1825 pos = SvIV(sv) - CopARYBASE_get(PL_curcop);
1828 ulen = sv_len_utf8(lsv);
1838 else if (pos > (SSize_t)len)
1843 sv_pos_u2b(lsv, &p, 0);
1847 found->mg_len = pos;
1848 found->mg_flags &= ~MGf_MINMATCH;
1854 Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg)
1857 PERL_UNUSED_ARG(mg);
1861 if (SvFLAGS(sv) & SVp_SCREAM
1862 && (SvTYPE(sv) == SVt_PVGV || SvTYPE(sv) == SVt_PVGV)) {
1863 /* We're actually already a typeglob, so don't need the stuff below.
1867 gv = gv_fetchsv(sv, GV_ADD, SVt_PVGV);
1872 GvGP(sv) = gp_ref(GvGP(gv));
1877 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
1880 SV * const lsv = LvTARG(sv);
1881 const char * const tmps = SvPV_const(lsv,len);
1882 I32 offs = LvTARGOFF(sv);
1883 I32 rem = LvTARGLEN(sv);
1884 PERL_UNUSED_ARG(mg);
1887 sv_pos_u2b(lsv, &offs, &rem);
1888 if (offs > (I32)len)
1890 if (rem + offs > (I32)len)
1892 sv_setpvn(sv, tmps + offs, (STRLEN)rem);
1899 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
1903 const char *tmps = SvPV_const(sv, len);
1904 SV * const lsv = LvTARG(sv);
1905 I32 lvoff = LvTARGOFF(sv);
1906 I32 lvlen = LvTARGLEN(sv);
1907 PERL_UNUSED_ARG(mg);
1910 sv_utf8_upgrade(lsv);
1911 sv_pos_u2b(lsv, &lvoff, &lvlen);
1912 sv_insert(lsv, lvoff, lvlen, tmps, len);
1913 LvTARGLEN(sv) = sv_len_utf8(sv);
1916 else if (lsv && SvUTF8(lsv)) {
1917 sv_pos_u2b(lsv, &lvoff, &lvlen);
1918 LvTARGLEN(sv) = len;
1919 tmps = (char*)bytes_to_utf8((U8*)tmps, &len);
1920 sv_insert(lsv, lvoff, lvlen, tmps, len);
1924 sv_insert(lsv, lvoff, lvlen, tmps, len);
1925 LvTARGLEN(sv) = len;
1933 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
1936 PERL_UNUSED_ARG(sv);
1937 TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
1942 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
1945 PERL_UNUSED_ARG(sv);
1946 /* update taint status unless we're restoring at scope exit */
1947 if (PL_localizing != 2) {
1957 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
1959 SV * const lsv = LvTARG(sv);
1960 PERL_UNUSED_ARG(mg);
1963 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
1971 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
1973 PERL_UNUSED_ARG(mg);
1974 do_vecset(sv); /* XXX slurp this routine */
1979 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
1983 if (LvTARGLEN(sv)) {
1985 SV * const ahv = LvTARG(sv);
1986 HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
1991 AV* const av = (AV*)LvTARG(sv);
1992 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
1993 targ = AvARRAY(av)[LvTARGOFF(sv)];
1995 if (targ && targ != &PL_sv_undef) {
1996 /* somebody else defined it for us */
1997 SvREFCNT_dec(LvTARG(sv));
1998 LvTARG(sv) = SvREFCNT_inc_simple_NN(targ);
2000 SvREFCNT_dec(mg->mg_obj);
2002 mg->mg_flags &= ~MGf_REFCOUNTED;
2007 sv_setsv(sv, targ ? targ : &PL_sv_undef);
2012 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
2014 PERL_UNUSED_ARG(mg);
2018 sv_setsv(LvTARG(sv), sv);
2019 SvSETMAGIC(LvTARG(sv));
2025 Perl_vivify_defelem(pTHX_ SV *sv)
2031 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2034 SV * const ahv = LvTARG(sv);
2035 HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
2038 if (!value || value == &PL_sv_undef)
2039 Perl_croak(aTHX_ PL_no_helem_sv, mg->mg_obj);
2042 AV* const av = (AV*)LvTARG(sv);
2043 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
2044 LvTARG(sv) = NULL; /* array can't be extended */
2046 SV* const * const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
2047 if (!svp || (value = *svp) == &PL_sv_undef)
2048 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
2051 SvREFCNT_inc_simple_void(value);
2052 SvREFCNT_dec(LvTARG(sv));
2055 SvREFCNT_dec(mg->mg_obj);
2057 mg->mg_flags &= ~MGf_REFCOUNTED;
2061 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2063 return Perl_sv_kill_backrefs(aTHX_ sv, (AV*)mg->mg_obj);
2067 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2069 PERL_UNUSED_CONTEXT;
2076 Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
2078 PERL_UNUSED_ARG(mg);
2079 sv_unmagic(sv, PERL_MAGIC_bm);
2085 Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
2087 PERL_UNUSED_ARG(mg);
2088 sv_unmagic(sv, PERL_MAGIC_fm);
2094 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2096 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2098 if (uf && uf->uf_set)
2099 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2104 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2106 PERL_UNUSED_ARG(mg);
2107 sv_unmagic(sv, PERL_MAGIC_qr);
2112 Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
2115 regexp * const re = (regexp *)mg->mg_obj;
2116 PERL_UNUSED_ARG(sv);
2122 #ifdef USE_LOCALE_COLLATE
2124 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2127 * RenE<eacute> Descartes said "I think not."
2128 * and vanished with a faint plop.
2130 PERL_UNUSED_CONTEXT;
2131 PERL_UNUSED_ARG(sv);
2133 Safefree(mg->mg_ptr);
2139 #endif /* USE_LOCALE_COLLATE */
2141 /* Just clear the UTF-8 cache data. */
2143 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2145 PERL_UNUSED_CONTEXT;
2146 PERL_UNUSED_ARG(sv);
2147 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2149 mg->mg_len = -1; /* The mg_len holds the len cache. */
2154 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2157 register const char *s;
2160 switch (*mg->mg_ptr) {
2161 case '\001': /* ^A */
2162 sv_setsv(PL_bodytarget, sv);
2164 case '\003': /* ^C */
2165 PL_minus_c = (bool)SvIV(sv);
2168 case '\004': /* ^D */
2170 s = SvPV_nolen_const(sv);
2171 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2172 DEBUG_x(dump_all());
2174 PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG;
2177 case '\005': /* ^E */
2178 if (*(mg->mg_ptr+1) == '\0') {
2179 #ifdef MACOS_TRADITIONAL
2180 gMacPerl_OSErr = SvIV(sv);
2183 set_vaxc_errno(SvIV(sv));
2186 SetLastError( SvIV(sv) );
2189 os2_setsyserrno(SvIV(sv));
2191 /* will anyone ever use this? */
2192 SETERRNO(SvIV(sv), 4);
2198 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2200 SvREFCNT_dec(PL_encoding);
2201 if (SvOK(sv) || SvGMAGICAL(sv)) {
2202 PL_encoding = newSVsv(sv);
2209 case '\006': /* ^F */
2210 PL_maxsysfd = SvIV(sv);
2212 case '\010': /* ^H */
2213 PL_hints = SvIV(sv);
2215 case '\011': /* ^I */ /* NOT \t in EBCDIC */
2216 Safefree(PL_inplace);
2217 PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
2219 case '\017': /* ^O */
2220 if (*(mg->mg_ptr+1) == '\0') {
2221 Safefree(PL_osname);
2224 TAINT_PROPER("assigning to $^O");
2225 PL_osname = savesvpv(sv);
2228 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2229 if (!PL_compiling.cop_io)
2230 PL_compiling.cop_io = newSVsv(sv);
2232 sv_setsv(PL_compiling.cop_io,sv);
2235 case '\020': /* ^P */
2236 PL_perldb = SvIV(sv);
2237 if (PL_perldb && !PL_DBsingle)
2240 case '\024': /* ^T */
2242 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2244 PL_basetime = (Time_t)SvIV(sv);
2247 case '\025': /* ^UTF8CACHE */
2248 if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
2249 PL_utf8cache = (signed char) sv_2iv(sv);
2252 case '\027': /* ^W & $^WARNING_BITS */
2253 if (*(mg->mg_ptr+1) == '\0') {
2254 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2256 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2257 | (i ? G_WARN_ON : G_WARN_OFF) ;
2260 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2261 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2262 if (!SvPOK(sv) && PL_localizing) {
2263 sv_setpvn(sv, WARN_NONEstring, WARNsize);
2264 PL_compiling.cop_warnings = pWARN_NONE;
2269 int accumulate = 0 ;
2270 int any_fatals = 0 ;
2271 const char * const ptr = SvPV_const(sv, len) ;
2272 for (i = 0 ; i < len ; ++i) {
2273 accumulate |= ptr[i] ;
2274 any_fatals |= (ptr[i] & 0xAA) ;
2277 PL_compiling.cop_warnings = pWARN_NONE;
2278 /* Yuck. I can't see how to abstract this: */
2279 else if (isWARN_on(((STRLEN *)SvPV_nolen_const(sv)) - 1,
2280 WARN_ALL) && !any_fatals) {
2281 PL_compiling.cop_warnings = pWARN_ALL;
2282 PL_dowarn |= G_WARN_ONCE ;
2286 const char *const p = SvPV_const(sv, len);
2288 PL_compiling.cop_warnings
2289 = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
2292 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2293 PL_dowarn |= G_WARN_ONCE ;
2301 if (PL_localizing) {
2302 if (PL_localizing == 1)
2303 SAVESPTR(PL_last_in_gv);
2305 else if (SvOK(sv) && GvIO(PL_last_in_gv))
2306 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2309 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2310 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2311 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2314 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2315 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2316 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2319 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
2322 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
2323 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2324 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2327 IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
2331 IO * const io = GvIOp(PL_defoutgv);
2334 if ((SvIV(sv)) == 0)
2335 IoFLAGS(io) &= ~IOf_FLUSH;
2337 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2338 PerlIO *ofp = IoOFP(io);
2340 (void)PerlIO_flush(ofp);
2341 IoFLAGS(io) |= IOf_FLUSH;
2347 SvREFCNT_dec(PL_rs);
2348 PL_rs = newSVsv(sv);
2352 SvREFCNT_dec(PL_ors_sv);
2353 if (SvOK(sv) || SvGMAGICAL(sv)) {
2354 PL_ors_sv = newSVsv(sv);
2362 SvREFCNT_dec(PL_ofs_sv);
2363 if (SvOK(sv) || SvGMAGICAL(sv)) {
2364 PL_ofs_sv = newSVsv(sv);
2371 CopARYBASE_set(&PL_compiling, SvIV(sv));
2374 #ifdef COMPLEX_STATUS
2375 if (PL_localizing == 2) {
2376 PL_statusvalue = LvTARGOFF(sv);
2377 PL_statusvalue_vms = LvTARGLEN(sv);
2381 #ifdef VMSISH_STATUS
2383 STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2386 STATUS_UNIX_EXIT_SET(SvIV(sv));
2391 # define PERL_VMS_BANG vaxc$errno
2393 # define PERL_VMS_BANG 0
2395 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2396 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2401 if (PL_delaymagic) {
2402 PL_delaymagic |= DM_RUID;
2403 break; /* don't do magic till later */
2406 (void)setruid((Uid_t)PL_uid);
2409 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2411 #ifdef HAS_SETRESUID
2412 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2414 if (PL_uid == PL_euid) { /* special case $< = $> */
2416 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2417 if (PL_uid != 0 && PerlProc_getuid() == 0)
2418 (void)PerlProc_setuid(0);
2420 (void)PerlProc_setuid(PL_uid);
2422 PL_uid = PerlProc_getuid();
2423 Perl_croak(aTHX_ "setruid() not implemented");
2428 PL_uid = PerlProc_getuid();
2429 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2433 if (PL_delaymagic) {
2434 PL_delaymagic |= DM_EUID;
2435 break; /* don't do magic till later */
2438 (void)seteuid((Uid_t)PL_euid);
2441 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2443 #ifdef HAS_SETRESUID
2444 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2446 if (PL_euid == PL_uid) /* special case $> = $< */
2447 PerlProc_setuid(PL_euid);
2449 PL_euid = PerlProc_geteuid();
2450 Perl_croak(aTHX_ "seteuid() not implemented");
2455 PL_euid = PerlProc_geteuid();
2456 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2460 if (PL_delaymagic) {
2461 PL_delaymagic |= DM_RGID;
2462 break; /* don't do magic till later */
2465 (void)setrgid((Gid_t)PL_gid);
2468 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2470 #ifdef HAS_SETRESGID
2471 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2473 if (PL_gid == PL_egid) /* special case $( = $) */
2474 (void)PerlProc_setgid(PL_gid);
2476 PL_gid = PerlProc_getgid();
2477 Perl_croak(aTHX_ "setrgid() not implemented");
2482 PL_gid = PerlProc_getgid();
2483 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2486 #ifdef HAS_SETGROUPS
2488 const char *p = SvPV_const(sv, len);
2489 Groups_t *gary = NULL;
2494 for (i = 0; i < NGROUPS; ++i) {
2495 while (*p && !isSPACE(*p))
2502 Newx(gary, i + 1, Groups_t);
2504 Renew(gary, i + 1, Groups_t);
2508 (void)setgroups(i, gary);
2512 #else /* HAS_SETGROUPS */
2514 #endif /* HAS_SETGROUPS */
2515 if (PL_delaymagic) {
2516 PL_delaymagic |= DM_EGID;
2517 break; /* don't do magic till later */
2520 (void)setegid((Gid_t)PL_egid);
2523 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2525 #ifdef HAS_SETRESGID
2526 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2528 if (PL_egid == PL_gid) /* special case $) = $( */
2529 (void)PerlProc_setgid(PL_egid);
2531 PL_egid = PerlProc_getegid();
2532 Perl_croak(aTHX_ "setegid() not implemented");
2537 PL_egid = PerlProc_getegid();
2538 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2541 PL_chopset = SvPV_force(sv,len);
2543 #ifndef MACOS_TRADITIONAL
2545 LOCK_DOLLARZERO_MUTEX;
2546 #ifdef HAS_SETPROCTITLE
2547 /* The BSDs don't show the argv[] in ps(1) output, they
2548 * show a string from the process struct and provide
2549 * the setproctitle() routine to manipulate that. */
2550 if (PL_origalen != 1) {
2551 s = SvPV_const(sv, len);
2552 # if __FreeBSD_version > 410001
2553 /* The leading "-" removes the "perl: " prefix,
2554 * but not the "(perl) suffix from the ps(1)
2555 * output, because that's what ps(1) shows if the
2556 * argv[] is modified. */
2557 setproctitle("-%s", s);
2558 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2559 /* This doesn't really work if you assume that
2560 * $0 = 'foobar'; will wipe out 'perl' from the $0
2561 * because in ps(1) output the result will be like
2562 * sprintf("perl: %s (perl)", s)
2563 * I guess this is a security feature:
2564 * one (a user process) cannot get rid of the original name.
2566 setproctitle("%s", s);
2570 #if defined(__hpux) && defined(PSTAT_SETCMD)
2571 if (PL_origalen != 1) {
2573 s = SvPV_const(sv, len);
2574 un.pst_command = (char *)s;
2575 pstat(PSTAT_SETCMD, un, len, 0, 0);
2578 if (PL_origalen > 1) {
2579 /* PL_origalen is set in perl_parse(). */
2580 s = SvPV_force(sv,len);
2581 if (len >= (STRLEN)PL_origalen-1) {
2582 /* Longer than original, will be truncated. We assume that
2583 * PL_origalen bytes are available. */
2584 Copy(s, PL_origargv[0], PL_origalen-1, char);
2587 /* Shorter than original, will be padded. */
2588 Copy(s, PL_origargv[0], len, char);
2589 PL_origargv[0][len] = 0;
2590 memset(PL_origargv[0] + len + 1,
2591 /* Is the space counterintuitive? Yes.
2592 * (You were expecting \0?)
2593 * Does it work? Seems to. (In Linux 2.4.20 at least.)
2596 PL_origalen - len - 1);
2598 PL_origargv[0][PL_origalen-1] = 0;
2599 for (i = 1; i < PL_origargc; i++)
2602 UNLOCK_DOLLARZERO_MUTEX;
2610 Perl_whichsig(pTHX_ const char *sig)
2612 register char* const* sigv;
2613 PERL_UNUSED_CONTEXT;
2615 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
2616 if (strEQ(sig,*sigv))
2617 return PL_sig_num[sigv - (char* const*)PL_sig_name];
2619 if (strEQ(sig,"CHLD"))
2623 if (strEQ(sig,"CLD"))
2630 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2631 Perl_sighandler(int sig, ...)
2633 Perl_sighandler(int sig)
2636 #ifdef PERL_GET_SIG_CONTEXT
2637 dTHXa(PERL_GET_SIG_CONTEXT);
2644 SV * const tSv = PL_Sv;
2648 XPV * const tXpv = PL_Xpv;
2650 if (PL_savestack_ix + 15 <= PL_savestack_max)
2652 if (PL_markstack_ptr < PL_markstack_max - 2)
2654 if (PL_scopestack_ix < PL_scopestack_max - 3)
2657 if (!PL_psig_ptr[sig]) {
2658 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2663 /* Max number of items pushed there is 3*n or 4. We cannot fix
2664 infinity, so we fix 4 (in fact 5): */
2666 PL_savestack_ix += 5; /* Protect save in progress. */
2667 SAVEDESTRUCTOR_X(S_unwind_handler_stack, (void*)&flags);
2670 PL_markstack_ptr++; /* Protect mark. */
2672 PL_scopestack_ix += 1;
2673 /* sv_2cv is too complicated, try a simpler variant first: */
2674 if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
2675 || SvTYPE(cv) != SVt_PVCV) {
2677 cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
2680 if (!cv || !CvROOT(cv)) {
2681 if (ckWARN(WARN_SIGNAL))
2682 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2683 PL_sig_name[sig], (gv ? GvENAME(gv)
2690 if(PL_psig_name[sig]) {
2691 sv = SvREFCNT_inc_NN(PL_psig_name[sig]);
2693 #if !defined(PERL_IMPLICIT_CONTEXT)
2697 sv = sv_newmortal();
2698 sv_setpv(sv,PL_sig_name[sig]);
2701 PUSHSTACKi(PERLSI_SIGNAL);
2704 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2706 struct sigaction oact;
2708 if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
2712 va_start(args, sig);
2713 sip = (siginfo_t*)va_arg(args, siginfo_t*);
2716 SV *rv = newRV_noinc((SV*)sih);
2717 /* The siginfo fields signo, code, errno, pid, uid,
2718 * addr, status, and band are defined by POSIX/SUSv3. */
2719 hv_store(sih, "signo", 5, newSViv(sip->si_signo), 0);
2720 hv_store(sih, "code", 4, newSViv(sip->si_code), 0);
2721 #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. */
2722 hv_store(sih, "errno", 5, newSViv(sip->si_errno), 0);
2723 hv_store(sih, "status", 6, newSViv(sip->si_status), 0);
2724 hv_store(sih, "uid", 3, newSViv(sip->si_uid), 0);
2725 hv_store(sih, "pid", 3, newSViv(sip->si_pid), 0);
2726 hv_store(sih, "addr", 4, newSVuv(PTR2UV(sip->si_addr)), 0);
2727 hv_store(sih, "band", 4, newSViv(sip->si_band), 0);
2731 PUSHs(newSVpv((void*)sip, sizeof(*sip)));
2740 call_sv((SV*)cv, G_DISCARD|G_EVAL);
2743 if (SvTRUE(ERRSV)) {
2745 #ifdef HAS_SIGPROCMASK
2746 /* Handler "died", for example to get out of a restart-able read().
2747 * Before we re-do that on its behalf re-enable the signal which was
2748 * blocked by the system when we entered.
2752 sigaddset(&set,sig);
2753 sigprocmask(SIG_UNBLOCK, &set, NULL);
2755 /* Not clear if this will work */
2756 (void)rsignal(sig, SIG_IGN);
2757 (void)rsignal(sig, PL_csighandlerp);
2759 #endif /* !PERL_MICRO */
2760 Perl_die(aTHX_ NULL);
2764 PL_savestack_ix -= 8; /* Unprotect save in progress. */
2768 PL_scopestack_ix -= 1;
2771 PL_op = myop; /* Apparently not needed... */
2773 PL_Sv = tSv; /* Restore global temporaries. */
2780 S_restore_magic(pTHX_ const void *p)
2783 MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
2784 SV* const sv = mgs->mgs_sv;
2789 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2791 #ifdef PERL_OLD_COPY_ON_WRITE
2792 /* While magic was saved (and off) sv_setsv may well have seen
2793 this SV as a prime candidate for COW. */
2795 sv_force_normal_flags(sv, 0);
2799 SvFLAGS(sv) |= mgs->mgs_flags;
2802 if (SvGMAGICAL(sv)) {
2803 /* downgrade public flags to private,
2804 and discard any other private flags */
2806 U32 public = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
2808 SvFLAGS(sv) &= ~( public | SVp_IOK|SVp_NOK|SVp_POK );
2809 SvFLAGS(sv) |= ( public << PRIVSHIFT );
2814 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
2816 /* If we're still on top of the stack, pop us off. (That condition
2817 * will be satisfied if restore_magic was called explicitly, but *not*
2818 * if it's being called via leave_scope.)
2819 * The reason for doing this is that otherwise, things like sv_2cv()
2820 * may leave alloc gunk on the savestack, and some code
2821 * (e.g. sighandler) doesn't expect that...
2823 if (PL_savestack_ix == mgs->mgs_ss_ix)
2825 I32 popval = SSPOPINT;
2826 assert(popval == SAVEt_DESTRUCTOR_X);
2827 PL_savestack_ix -= 2;
2829 assert(popval == SAVEt_ALLOC);
2831 PL_savestack_ix -= popval;
2837 S_unwind_handler_stack(pTHX_ const void *p)
2840 const U32 flags = *(const U32*)p;
2843 PL_savestack_ix -= 5; /* Unprotect save in progress. */
2844 #if !defined(PERL_IMPLICIT_CONTEXT)
2846 SvREFCNT_dec(PL_sig_sv);
2851 =for apidoc magic_sethint
2853 Triggered by a store to %^H, records the key/value pair to
2854 C<PL_compiling.cop_hints>. It is assumed that hints aren't storing anything
2855 that would need a deep copy. Maybe we should warn if we find a reference.
2860 Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
2863 assert(mg->mg_len == HEf_SVKEY);
2865 /* mg->mg_obj isn't being used. If needed, it would be possible to store
2866 an alternative leaf in there, with PL_compiling.cop_hints being used if
2867 it's NULL. If needed for threads, the alternative could lock a mutex,
2868 or take other more complex action. */
2870 /* Something changed in %^H, so it will need to be restored on scope exit.
2871 Doing this here saves a lot of doing it manually in perl code (and
2872 forgetting to do it, and consequent subtle errors. */
2873 PL_hints |= HINT_LOCALIZE_HH;
2874 PL_compiling.cop_hints
2875 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints,
2876 (SV *)mg->mg_ptr, newSVsv(sv));
2881 =for apidoc magic_sethint
2883 Triggered by a delete from %^H, records the key to C<PL_compiling.cop_hints>.
2888 Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
2891 assert(mg->mg_len == HEf_SVKEY);
2893 PERL_UNUSED_ARG(sv);
2895 PL_hints |= HINT_LOCALIZE_HH;
2896 PL_compiling.cop_hints
2897 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints,
2898 (SV *)mg->mg_ptr, &PL_sv_placeholder);
2904 * c-indentation-style: bsd
2906 * indent-tabs-mode: t
2909 * ex: set ts=8 sts=4 sw=4 noet: