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_NN(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 (!(CopHINTS_get(&PL_compiling) & HINT_LEXICAL_IO))
762 sv_setsv(sv, &PL_sv_undef);
765 Perl_refcounted_he_fetch(aTHX_
766 PL_compiling.cop_hints_hash,
767 0, "open", 4, 0, 0));
771 case '\020': /* ^P */
772 sv_setiv(sv, (IV)PL_perldb);
774 case '\023': /* ^S */
775 if (nextchar == '\0') {
776 if (PL_lex_state != LEX_NOTPARSING)
779 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
784 case '\024': /* ^T */
785 if (nextchar == '\0') {
787 sv_setnv(sv, PL_basetime);
789 sv_setiv(sv, (IV)PL_basetime);
792 else if (strEQ(remaining, "AINT"))
793 sv_setiv(sv, PL_tainting
794 ? (PL_taint_warn || PL_unsafe ? -1 : 1)
797 case '\025': /* $^UNICODE, $^UTF8LOCALE, $^UTF8CACHE */
798 if (strEQ(remaining, "NICODE"))
799 sv_setuv(sv, (UV) PL_unicode);
800 else if (strEQ(remaining, "TF8LOCALE"))
801 sv_setuv(sv, (UV) PL_utf8locale);
802 else if (strEQ(remaining, "TF8CACHE"))
803 sv_setiv(sv, (IV) PL_utf8cache);
805 case '\027': /* ^W & $^WARNING_BITS */
806 if (nextchar == '\0')
807 sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
808 else if (strEQ(remaining, "ARNING_BITS")) {
809 if (PL_compiling.cop_warnings == pWARN_NONE) {
810 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
812 else if (PL_compiling.cop_warnings == pWARN_STD) {
815 (PL_dowarn & G_WARN_ON) ? WARN_ALLstring : WARN_NONEstring,
819 else if (PL_compiling.cop_warnings == pWARN_ALL) {
820 /* Get the bit mask for $warnings::Bits{all}, because
821 * it could have been extended by warnings::register */
823 HV * const bits=get_hv("warnings::Bits", FALSE);
824 if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
825 sv_setsv(sv, *bits_all);
828 sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
832 sv_setpvn(sv, (char *) (PL_compiling.cop_warnings + 1),
833 *PL_compiling.cop_warnings);
838 case '1': case '2': case '3': case '4':
839 case '5': case '6': case '7': case '8': case '9': case '&':
840 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
844 * Pre-threads, this was paren = atoi(GvENAME((GV*)mg->mg_obj));
845 * XXX Does the new way break anything?
847 paren = atoi(mg->mg_ptr); /* $& is in [0] */
849 if (paren <= (I32)rx->nparens &&
850 (s1 = rx->startp[paren]) != -1 &&
851 (t1 = rx->endp[paren]) != -1)
859 const int oldtainted = PL_tainted;
862 PL_tainted = oldtainted;
863 if (RX_MATCH_UTF8(rx) && is_utf8_string((U8*)s, i))
868 if (RX_MATCH_TAINTED(rx)) {
869 MAGIC* const mg = SvMAGIC(sv);
872 SvMAGIC_set(sv, mg->mg_moremagic);
874 if ((mgt = SvMAGIC(sv))) {
875 mg->mg_moremagic = mgt;
885 sv_setsv(sv,&PL_sv_undef);
888 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
889 paren = rx->lastparen;
893 sv_setsv(sv,&PL_sv_undef);
895 case '\016': /* ^N */
896 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
897 paren = rx->lastcloseparen;
901 sv_setsv(sv,&PL_sv_undef);
904 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
905 if ((s = rx->subbeg) && rx->startp[0] != -1) {
910 sv_setsv(sv,&PL_sv_undef);
913 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
914 if (rx->subbeg && rx->endp[0] != -1) {
915 s = rx->subbeg + rx->endp[0];
916 i = rx->sublen - rx->endp[0];
920 sv_setsv(sv,&PL_sv_undef);
923 if (GvIO(PL_last_in_gv)) {
924 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
929 sv_setiv(sv, (IV)STATUS_CURRENT);
930 #ifdef COMPLEX_STATUS
931 LvTARGOFF(sv) = PL_statusvalue;
932 LvTARGLEN(sv) = PL_statusvalue_vms;
937 if (GvIOp(PL_defoutgv))
938 s = IoTOP_NAME(GvIOp(PL_defoutgv));
942 sv_setpv(sv,GvENAME(PL_defoutgv));
947 if (GvIOp(PL_defoutgv))
948 s = IoFMT_NAME(GvIOp(PL_defoutgv));
950 s = GvENAME(PL_defoutgv);
954 if (GvIOp(PL_defoutgv))
955 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
958 if (GvIOp(PL_defoutgv))
959 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
962 if (GvIOp(PL_defoutgv))
963 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
970 WITH_THR(sv_setiv(sv, (IV)CopARYBASE_get(PL_curcop)));
973 if (GvIOp(PL_defoutgv))
974 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
980 sv_copypv(sv, PL_ors_sv);
984 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
985 sv_setpv(sv, errno ? Strerror(errno) : "");
988 const int saveerrno = errno;
989 sv_setnv(sv, (NV)errno);
991 if (errno == errno_isOS2 || errno == errno_isOS2_set)
992 sv_setpv(sv, os2error(Perl_rc));
995 sv_setpv(sv, errno ? Strerror(errno) : "");
1000 SvNOK_on(sv); /* what a wonderful hack! */
1003 sv_setiv(sv, (IV)PL_uid);
1006 sv_setiv(sv, (IV)PL_euid);
1009 sv_setiv(sv, (IV)PL_gid);
1012 sv_setiv(sv, (IV)PL_egid);
1014 #ifdef HAS_GETGROUPS
1016 Groups_t *gary = NULL;
1017 I32 i, num_groups = getgroups(0, gary);
1018 Newx(gary, num_groups, Groups_t);
1019 num_groups = getgroups(num_groups, gary);
1020 for (i = 0; i < num_groups; i++)
1021 Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]);
1024 (void)SvIOK_on(sv); /* what a wonderful hack! */
1027 #ifndef MACOS_TRADITIONAL
1036 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
1038 struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
1040 if (uf && uf->uf_val)
1041 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
1046 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
1049 STRLEN len = 0, klen;
1050 const char *s = SvOK(sv) ? SvPV_const(sv,len) : "";
1051 const char * const ptr = MgPV_const(mg,klen);
1054 #ifdef DYNAMIC_ENV_FETCH
1055 /* We just undefd an environment var. Is a replacement */
1056 /* waiting in the wings? */
1058 SV ** const valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE);
1060 s = SvOK(*valp) ? SvPV_const(*valp, len) : "";
1064 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
1065 /* And you'll never guess what the dog had */
1066 /* in its mouth... */
1068 MgTAINTEDDIR_off(mg);
1070 if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
1071 char pathbuf[256], eltbuf[256], *cp, *elt;
1075 strncpy(eltbuf, s, 255);
1078 do { /* DCL$PATH may be a search list */
1079 while (1) { /* as may dev portion of any element */
1080 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1081 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1082 cando_by_name(S_IWUSR,0,elt) ) {
1083 MgTAINTEDDIR_on(mg);
1087 if ((cp = strchr(elt, ':')) != NULL)
1089 if (my_trnlnm(elt, eltbuf, j++))
1095 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1098 if (s && klen == 4 && strEQ(ptr,"PATH")) {
1099 const char * const strend = s + len;
1101 while (s < strend) {
1105 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
1106 s, strend, ':', &i);
1108 if (i >= (I32)sizeof tmpbuf /* too long -- assume the worst */
1110 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1111 MgTAINTEDDIR_on(mg);
1117 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1123 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1125 PERL_UNUSED_ARG(sv);
1126 my_setenv(MgPV_nolen_const(mg),NULL);
1131 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1134 PERL_UNUSED_ARG(mg);
1136 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1138 if (PL_localizing) {
1141 hv_iterinit((HV*)sv);
1142 while ((entry = hv_iternext((HV*)sv))) {
1144 my_setenv(hv_iterkey(entry, &keylen),
1145 SvPV_nolen_const(hv_iterval((HV*)sv, entry)));
1153 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1156 PERL_UNUSED_ARG(sv);
1157 PERL_UNUSED_ARG(mg);
1159 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1167 #ifdef HAS_SIGPROCMASK
1169 restore_sigmask(pTHX_ SV *save_sv)
1171 const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1172 (void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0);
1176 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1179 /* Are we fetching a signal entry? */
1180 const I32 i = whichsig(MgPV_nolen_const(mg));
1183 sv_setsv(sv,PL_psig_ptr[i]);
1185 Sighandler_t sigstate = rsignal_state(i);
1186 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1187 if (PL_sig_handlers_initted && PL_sig_ignoring[i])
1190 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1191 if (PL_sig_handlers_initted && PL_sig_defaulting[i])
1194 /* cache state so we don't fetch it again */
1195 if(sigstate == (Sighandler_t) SIG_IGN)
1196 sv_setpv(sv,"IGNORE");
1198 sv_setsv(sv,&PL_sv_undef);
1199 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1206 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1208 /* XXX Some of this code was copied from Perl_magic_setsig. A little
1209 * refactoring might be in order.
1212 register const char * const s = MgPV_nolen_const(mg);
1213 PERL_UNUSED_ARG(sv);
1216 if (strEQ(s,"__DIE__"))
1218 else if (strEQ(s,"__WARN__"))
1221 Perl_croak(aTHX_ "No such hook: %s", s);
1223 SV * const to_dec = *svp;
1225 SvREFCNT_dec(to_dec);
1229 /* Are we clearing a signal entry? */
1230 const I32 i = whichsig(s);
1232 #ifdef HAS_SIGPROCMASK
1235 /* Avoid having the signal arrive at a bad time, if possible. */
1238 sigprocmask(SIG_BLOCK, &set, &save);
1240 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1241 SAVEFREESV(save_sv);
1242 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1245 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1246 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1248 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1249 PL_sig_defaulting[i] = 1;
1250 (void)rsignal(i, PL_csighandlerp);
1252 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1254 if(PL_psig_name[i]) {
1255 SvREFCNT_dec(PL_psig_name[i]);
1258 if(PL_psig_ptr[i]) {
1259 SV * const to_dec=PL_psig_ptr[i];
1262 SvREFCNT_dec(to_dec);
1272 S_raise_signal(pTHX_ int sig)
1275 /* Set a flag to say this signal is pending */
1276 PL_psig_pend[sig]++;
1277 /* And one to say _a_ signal is pending */
1282 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1283 Perl_csighandler(int sig, ...)
1285 Perl_csighandler(int sig)
1288 #ifdef PERL_GET_SIG_CONTEXT
1289 dTHXa(PERL_GET_SIG_CONTEXT);
1293 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1294 (void) rsignal(sig, PL_csighandlerp);
1295 if (PL_sig_ignoring[sig]) return;
1297 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1298 if (PL_sig_defaulting[sig])
1299 #ifdef KILL_BY_SIGPRC
1300 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1305 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
1306 /* Call the perl level handler now--
1307 * with risk we may be in malloc() etc. */
1308 (*PL_sighandlerp)(sig);
1310 S_raise_signal(aTHX_ sig);
1313 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1315 Perl_csighandler_init(void)
1318 if (PL_sig_handlers_initted) return;
1320 for (sig = 1; sig < SIG_SIZE; sig++) {
1321 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1323 PL_sig_defaulting[sig] = 1;
1324 (void) rsignal(sig, PL_csighandlerp);
1326 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1327 PL_sig_ignoring[sig] = 0;
1330 PL_sig_handlers_initted = 1;
1335 Perl_despatch_signals(pTHX)
1340 for (sig = 1; sig < SIG_SIZE; sig++) {
1341 if (PL_psig_pend[sig]) {
1342 PERL_BLOCKSIG_ADD(set, sig);
1343 PL_psig_pend[sig] = 0;
1344 PERL_BLOCKSIG_BLOCK(set);
1345 (*PL_sighandlerp)(sig);
1346 PERL_BLOCKSIG_UNBLOCK(set);
1352 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1357 /* Need to be careful with SvREFCNT_dec(), because that can have side
1358 * effects (due to closures). We must make sure that the new disposition
1359 * is in place before it is called.
1363 #ifdef HAS_SIGPROCMASK
1368 register const char *s = MgPV_const(mg,len);
1370 if (strEQ(s,"__DIE__"))
1372 else if (strEQ(s,"__WARN__"))
1375 Perl_croak(aTHX_ "No such hook: %s", s);
1383 i = whichsig(s); /* ...no, a brick */
1385 if (ckWARN(WARN_SIGNAL))
1386 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
1389 #ifdef HAS_SIGPROCMASK
1390 /* Avoid having the signal arrive at a bad time, if possible. */
1393 sigprocmask(SIG_BLOCK, &set, &save);
1395 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1396 SAVEFREESV(save_sv);
1397 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1400 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1401 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1403 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1404 PL_sig_ignoring[i] = 0;
1406 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1407 PL_sig_defaulting[i] = 0;
1409 SvREFCNT_dec(PL_psig_name[i]);
1410 to_dec = PL_psig_ptr[i];
1411 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1412 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1413 PL_psig_name[i] = newSVpvn(s, len);
1414 SvREADONLY_on(PL_psig_name[i]);
1416 if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
1418 (void)rsignal(i, PL_csighandlerp);
1419 #ifdef HAS_SIGPROCMASK
1424 *svp = SvREFCNT_inc_simple_NN(sv);
1426 SvREFCNT_dec(to_dec);
1429 s = SvPV_force(sv,len);
1430 if (strEQ(s,"IGNORE")) {
1432 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1433 PL_sig_ignoring[i] = 1;
1434 (void)rsignal(i, PL_csighandlerp);
1436 (void)rsignal(i, (Sighandler_t) SIG_IGN);
1440 else if (strEQ(s,"DEFAULT") || !*s) {
1442 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1444 PL_sig_defaulting[i] = 1;
1445 (void)rsignal(i, PL_csighandlerp);
1448 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1453 * We should warn if HINT_STRICT_REFS, but without
1454 * access to a known hint bit in a known OP, we can't
1455 * tell whether HINT_STRICT_REFS is in force or not.
1457 if (!strchr(s,':') && !strchr(s,'\''))
1458 Perl_sv_insert(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"));
1460 (void)rsignal(i, PL_csighandlerp);
1462 *svp = SvREFCNT_inc_simple_NN(sv);
1464 #ifdef HAS_SIGPROCMASK
1469 SvREFCNT_dec(to_dec);
1472 #endif /* !PERL_MICRO */
1475 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1478 PERL_UNUSED_ARG(sv);
1479 PERL_UNUSED_ARG(mg);
1480 PL_sub_generation++;
1485 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
1488 PERL_UNUSED_ARG(sv);
1489 PERL_UNUSED_ARG(mg);
1490 /* HV_badAMAGIC_on(Sv_STASH(sv)); */
1491 PL_amagic_generation++;
1497 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1499 HV * const hv = (HV*)LvTARG(sv);
1501 PERL_UNUSED_ARG(mg);
1504 (void) hv_iterinit(hv);
1505 if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
1508 while (hv_iternext(hv))
1513 sv_setiv(sv, (IV)i);
1518 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1520 PERL_UNUSED_ARG(mg);
1522 hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
1527 /* caller is responsible for stack switching/cleanup */
1529 S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV *val)
1536 PUSHs(SvTIED_obj(sv, mg));
1539 if (mg->mg_len >= 0)
1540 PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len)));
1541 else if (mg->mg_len == HEf_SVKEY)
1542 PUSHs((SV*)mg->mg_ptr);
1544 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1545 PUSHs(sv_2mortal(newSViv(mg->mg_len)));
1553 return call_method(meth, flags);
1557 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
1563 PUSHSTACKi(PERLSI_MAGIC);
1565 if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
1566 sv_setsv(sv, *PL_stack_sp--);
1576 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1579 mg->mg_flags |= MGf_GSKIP;
1580 magic_methpack(sv,mg,"FETCH");
1585 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1589 PUSHSTACKi(PERLSI_MAGIC);
1590 magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
1597 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1599 return magic_methpack(sv,mg,"DELETE");
1604 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1611 PUSHSTACKi(PERLSI_MAGIC);
1612 if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
1613 sv = *PL_stack_sp--;
1614 retval = (U32) SvIV(sv)-1;
1623 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1628 PUSHSTACKi(PERLSI_MAGIC);
1630 XPUSHs(SvTIED_obj(sv, mg));
1632 call_method("CLEAR", G_SCALAR|G_DISCARD);
1640 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1643 const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
1647 PUSHSTACKi(PERLSI_MAGIC);
1650 PUSHs(SvTIED_obj(sv, mg));
1655 if (call_method(meth, G_SCALAR))
1656 sv_setsv(key, *PL_stack_sp--);
1665 Perl_magic_existspack(pTHX_ SV *sv, MAGIC *mg)
1667 return magic_methpack(sv,mg,"EXISTS");
1671 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1675 SV * const tied = SvTIED_obj((SV*)hv, mg);
1676 HV * const pkg = SvSTASH((SV*)SvRV(tied));
1678 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1680 if (HvEITER_get(hv))
1681 /* we are in an iteration so the hash cannot be empty */
1683 /* no xhv_eiter so now use FIRSTKEY */
1684 key = sv_newmortal();
1685 magic_nextpack((SV*)hv, mg, key);
1686 HvEITER_set(hv, NULL); /* need to reset iterator */
1687 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1690 /* there is a SCALAR method that we can call */
1692 PUSHSTACKi(PERLSI_MAGIC);
1698 if (call_method("SCALAR", G_SCALAR))
1699 retval = *PL_stack_sp--;
1701 retval = &PL_sv_undef;
1708 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1711 GV * const gv = PL_DBline;
1712 const I32 i = SvTRUE(sv);
1713 SV ** const svp = av_fetch(GvAV(gv),
1714 atoi(MgPV_nolen_const(mg)), FALSE);
1715 if (svp && SvIOKp(*svp)) {
1716 OP * const o = INT2PTR(OP*,SvIVX(*svp));
1718 /* set or clear breakpoint in the relevant control op */
1720 o->op_flags |= OPf_SPECIAL;
1722 o->op_flags &= ~OPf_SPECIAL;
1729 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
1732 const AV * const obj = (AV*)mg->mg_obj;
1734 sv_setiv(sv, AvFILL(obj) + CopARYBASE_get(PL_curcop));
1742 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
1745 AV * const obj = (AV*)mg->mg_obj;
1747 av_fill(obj, SvIV(sv) - CopARYBASE_get(PL_curcop));
1749 if (ckWARN(WARN_MISC))
1750 Perl_warner(aTHX_ packWARN(WARN_MISC),
1751 "Attempt to set length of freed array");
1757 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
1760 PERL_UNUSED_ARG(sv);
1761 /* during global destruction, mg_obj may already have been freed */
1762 if (PL_in_clean_all)
1765 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
1768 /* arylen scalar holds a pointer back to the array, but doesn't own a
1769 reference. Hence the we (the array) are about to go away with it
1770 still pointing at us. Clear its pointer, else it would be pointing
1771 at free memory. See the comment in sv_magic about reference loops,
1772 and why it can't own a reference to us. */
1779 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
1782 SV* const lsv = LvTARG(sv);
1783 PERL_UNUSED_ARG(mg);
1785 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1786 MAGIC * const found = mg_find(lsv, PERL_MAGIC_regex_global);
1787 if (found && found->mg_len >= 0) {
1788 I32 i = found->mg_len;
1790 sv_pos_b2u(lsv, &i);
1791 sv_setiv(sv, i + CopARYBASE_get(PL_curcop));
1800 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
1803 SV* const lsv = LvTARG(sv);
1809 PERL_UNUSED_ARG(mg);
1811 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
1812 found = mg_find(lsv, PERL_MAGIC_regex_global);
1818 #ifdef PERL_OLD_COPY_ON_WRITE
1820 sv_force_normal_flags(lsv, 0);
1822 found = sv_magicext(lsv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
1825 else if (!SvOK(sv)) {
1829 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1831 pos = SvIV(sv) - CopARYBASE_get(PL_curcop);
1834 ulen = sv_len_utf8(lsv);
1844 else if (pos > (SSize_t)len)
1849 sv_pos_u2b(lsv, &p, 0);
1853 found->mg_len = pos;
1854 found->mg_flags &= ~MGf_MINMATCH;
1860 Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg)
1863 PERL_UNUSED_ARG(mg);
1867 if (SvFLAGS(sv) & SVp_SCREAM
1868 && (SvTYPE(sv) == SVt_PVGV || SvTYPE(sv) == SVt_PVGV)) {
1869 /* We're actually already a typeglob, so don't need the stuff below.
1873 gv = gv_fetchsv(sv, GV_ADD, SVt_PVGV);
1878 GvGP(sv) = gp_ref(GvGP(gv));
1883 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
1886 SV * const lsv = LvTARG(sv);
1887 const char * const tmps = SvPV_const(lsv,len);
1888 I32 offs = LvTARGOFF(sv);
1889 I32 rem = LvTARGLEN(sv);
1890 PERL_UNUSED_ARG(mg);
1893 sv_pos_u2b(lsv, &offs, &rem);
1894 if (offs > (I32)len)
1896 if (rem + offs > (I32)len)
1898 sv_setpvn(sv, tmps + offs, (STRLEN)rem);
1905 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
1909 const char * const tmps = SvPV_const(sv, len);
1910 SV * const lsv = LvTARG(sv);
1911 I32 lvoff = LvTARGOFF(sv);
1912 I32 lvlen = LvTARGLEN(sv);
1913 PERL_UNUSED_ARG(mg);
1916 sv_utf8_upgrade(lsv);
1917 sv_pos_u2b(lsv, &lvoff, &lvlen);
1918 sv_insert(lsv, lvoff, lvlen, tmps, len);
1919 LvTARGLEN(sv) = sv_len_utf8(sv);
1922 else if (lsv && SvUTF8(lsv)) {
1924 sv_pos_u2b(lsv, &lvoff, &lvlen);
1925 LvTARGLEN(sv) = len;
1926 utf8 = (char*)bytes_to_utf8((U8*)tmps, &len);
1927 sv_insert(lsv, lvoff, lvlen, utf8, len);
1931 sv_insert(lsv, lvoff, lvlen, tmps, len);
1932 LvTARGLEN(sv) = len;
1940 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
1943 PERL_UNUSED_ARG(sv);
1944 TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
1949 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
1952 PERL_UNUSED_ARG(sv);
1953 /* update taint status unless we're restoring at scope exit */
1954 if (PL_localizing != 2) {
1964 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
1966 SV * const lsv = LvTARG(sv);
1967 PERL_UNUSED_ARG(mg);
1970 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
1978 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
1980 PERL_UNUSED_ARG(mg);
1981 do_vecset(sv); /* XXX slurp this routine */
1986 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
1990 if (LvTARGLEN(sv)) {
1992 SV * const ahv = LvTARG(sv);
1993 HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
1998 AV* const av = (AV*)LvTARG(sv);
1999 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
2000 targ = AvARRAY(av)[LvTARGOFF(sv)];
2002 if (targ && (targ != &PL_sv_undef)) {
2003 /* somebody else defined it for us */
2004 SvREFCNT_dec(LvTARG(sv));
2005 LvTARG(sv) = SvREFCNT_inc_simple_NN(targ);
2007 SvREFCNT_dec(mg->mg_obj);
2009 mg->mg_flags &= ~MGf_REFCOUNTED;
2014 sv_setsv(sv, targ ? targ : &PL_sv_undef);
2019 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
2021 PERL_UNUSED_ARG(mg);
2025 sv_setsv(LvTARG(sv), sv);
2026 SvSETMAGIC(LvTARG(sv));
2032 Perl_vivify_defelem(pTHX_ SV *sv)
2038 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2041 SV * const ahv = LvTARG(sv);
2042 HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
2045 if (!value || value == &PL_sv_undef)
2046 Perl_croak(aTHX_ PL_no_helem_sv, mg->mg_obj);
2049 AV* const av = (AV*)LvTARG(sv);
2050 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
2051 LvTARG(sv) = NULL; /* array can't be extended */
2053 SV* const * const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
2054 if (!svp || (value = *svp) == &PL_sv_undef)
2055 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
2058 SvREFCNT_inc_simple_void(value);
2059 SvREFCNT_dec(LvTARG(sv));
2062 SvREFCNT_dec(mg->mg_obj);
2064 mg->mg_flags &= ~MGf_REFCOUNTED;
2068 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2070 return Perl_sv_kill_backrefs(aTHX_ sv, (AV*)mg->mg_obj);
2074 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2076 PERL_UNUSED_CONTEXT;
2083 Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
2085 PERL_UNUSED_ARG(mg);
2086 sv_unmagic(sv, PERL_MAGIC_bm);
2092 Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
2094 PERL_UNUSED_ARG(mg);
2095 sv_unmagic(sv, PERL_MAGIC_fm);
2101 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2103 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2105 if (uf && uf->uf_set)
2106 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2111 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2113 PERL_UNUSED_ARG(mg);
2114 sv_unmagic(sv, PERL_MAGIC_qr);
2119 Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
2122 regexp * const re = (regexp *)mg->mg_obj;
2123 PERL_UNUSED_ARG(sv);
2129 #ifdef USE_LOCALE_COLLATE
2131 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2134 * RenE<eacute> Descartes said "I think not."
2135 * and vanished with a faint plop.
2137 PERL_UNUSED_CONTEXT;
2138 PERL_UNUSED_ARG(sv);
2140 Safefree(mg->mg_ptr);
2146 #endif /* USE_LOCALE_COLLATE */
2148 /* Just clear the UTF-8 cache data. */
2150 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2152 PERL_UNUSED_CONTEXT;
2153 PERL_UNUSED_ARG(sv);
2154 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2156 mg->mg_len = -1; /* The mg_len holds the len cache. */
2161 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2164 register const char *s;
2167 switch (*mg->mg_ptr) {
2168 case '\001': /* ^A */
2169 sv_setsv(PL_bodytarget, sv);
2171 case '\003': /* ^C */
2172 PL_minus_c = (bool)SvIV(sv);
2175 case '\004': /* ^D */
2177 s = SvPV_nolen_const(sv);
2178 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2179 DEBUG_x(dump_all());
2181 PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG;
2184 case '\005': /* ^E */
2185 if (*(mg->mg_ptr+1) == '\0') {
2186 #ifdef MACOS_TRADITIONAL
2187 gMacPerl_OSErr = SvIV(sv);
2190 set_vaxc_errno(SvIV(sv));
2193 SetLastError( SvIV(sv) );
2196 os2_setsyserrno(SvIV(sv));
2198 /* will anyone ever use this? */
2199 SETERRNO(SvIV(sv), 4);
2205 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2207 SvREFCNT_dec(PL_encoding);
2208 if (SvOK(sv) || SvGMAGICAL(sv)) {
2209 PL_encoding = newSVsv(sv);
2216 case '\006': /* ^F */
2217 PL_maxsysfd = SvIV(sv);
2219 case '\010': /* ^H */
2220 PL_hints = SvIV(sv);
2222 case '\011': /* ^I */ /* NOT \t in EBCDIC */
2223 Safefree(PL_inplace);
2224 PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
2226 case '\017': /* ^O */
2227 if (*(mg->mg_ptr+1) == '\0') {
2228 Safefree(PL_osname);
2231 TAINT_PROPER("assigning to $^O");
2232 PL_osname = savesvpv(sv);
2235 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2236 PL_compiling.cop_hints |= HINT_LEXICAL_IO;
2237 PL_hints |= HINT_LOCALIZE_HH | HINT_LEXICAL_IO;
2238 PL_compiling.cop_hints_hash
2239 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
2240 sv_2mortal(newSVpvs("open")), sv);
2243 case '\020': /* ^P */
2244 PL_perldb = SvIV(sv);
2245 if (PL_perldb && !PL_DBsingle)
2248 case '\024': /* ^T */
2250 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2252 PL_basetime = (Time_t)SvIV(sv);
2255 case '\025': /* ^UTF8CACHE */
2256 if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
2257 PL_utf8cache = (signed char) sv_2iv(sv);
2260 case '\027': /* ^W & $^WARNING_BITS */
2261 if (*(mg->mg_ptr+1) == '\0') {
2262 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
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 /* Yuck. I can't see how to abstract this: */
2287 else if (isWARN_on(((STRLEN *)SvPV_nolen_const(sv)) - 1,
2288 WARN_ALL) && !any_fatals) {
2289 PL_compiling.cop_warnings = pWARN_ALL;
2290 PL_dowarn |= G_WARN_ONCE ;
2294 const char *const p = SvPV_const(sv, len);
2296 PL_compiling.cop_warnings
2297 = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
2300 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2301 PL_dowarn |= G_WARN_ONCE ;
2309 if (PL_localizing) {
2310 if (PL_localizing == 1)
2311 SAVESPTR(PL_last_in_gv);
2313 else if (SvOK(sv) && GvIO(PL_last_in_gv))
2314 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2317 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2318 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2319 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2322 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2323 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2324 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2327 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
2330 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
2331 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2332 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2335 IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
2339 IO * const io = GvIOp(PL_defoutgv);
2342 if ((SvIV(sv)) == 0)
2343 IoFLAGS(io) &= ~IOf_FLUSH;
2345 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2346 PerlIO *ofp = IoOFP(io);
2348 (void)PerlIO_flush(ofp);
2349 IoFLAGS(io) |= IOf_FLUSH;
2355 SvREFCNT_dec(PL_rs);
2356 PL_rs = newSVsv(sv);
2360 SvREFCNT_dec(PL_ors_sv);
2361 if (SvOK(sv) || SvGMAGICAL(sv)) {
2362 PL_ors_sv = newSVsv(sv);
2370 SvREFCNT_dec(PL_ofs_sv);
2371 if (SvOK(sv) || SvGMAGICAL(sv)) {
2372 PL_ofs_sv = newSVsv(sv);
2379 CopARYBASE_set(&PL_compiling, SvIV(sv));
2382 #ifdef COMPLEX_STATUS
2383 if (PL_localizing == 2) {
2384 PL_statusvalue = LvTARGOFF(sv);
2385 PL_statusvalue_vms = LvTARGLEN(sv);
2389 #ifdef VMSISH_STATUS
2391 STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2394 STATUS_UNIX_EXIT_SET(SvIV(sv));
2399 # define PERL_VMS_BANG vaxc$errno
2401 # define PERL_VMS_BANG 0
2403 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2404 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2409 if (PL_delaymagic) {
2410 PL_delaymagic |= DM_RUID;
2411 break; /* don't do magic till later */
2414 (void)setruid((Uid_t)PL_uid);
2417 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2419 #ifdef HAS_SETRESUID
2420 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2422 if (PL_uid == PL_euid) { /* special case $< = $> */
2424 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2425 if (PL_uid != 0 && PerlProc_getuid() == 0)
2426 (void)PerlProc_setuid(0);
2428 (void)PerlProc_setuid(PL_uid);
2430 PL_uid = PerlProc_getuid();
2431 Perl_croak(aTHX_ "setruid() not implemented");
2436 PL_uid = PerlProc_getuid();
2437 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2441 if (PL_delaymagic) {
2442 PL_delaymagic |= DM_EUID;
2443 break; /* don't do magic till later */
2446 (void)seteuid((Uid_t)PL_euid);
2449 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2451 #ifdef HAS_SETRESUID
2452 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2454 if (PL_euid == PL_uid) /* special case $> = $< */
2455 PerlProc_setuid(PL_euid);
2457 PL_euid = PerlProc_geteuid();
2458 Perl_croak(aTHX_ "seteuid() not implemented");
2463 PL_euid = PerlProc_geteuid();
2464 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2468 if (PL_delaymagic) {
2469 PL_delaymagic |= DM_RGID;
2470 break; /* don't do magic till later */
2473 (void)setrgid((Gid_t)PL_gid);
2476 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2478 #ifdef HAS_SETRESGID
2479 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2481 if (PL_gid == PL_egid) /* special case $( = $) */
2482 (void)PerlProc_setgid(PL_gid);
2484 PL_gid = PerlProc_getgid();
2485 Perl_croak(aTHX_ "setrgid() not implemented");
2490 PL_gid = PerlProc_getgid();
2491 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2494 #ifdef HAS_SETGROUPS
2496 const char *p = SvPV_const(sv, len);
2497 Groups_t *gary = NULL;
2502 for (i = 0; i < NGROUPS; ++i) {
2503 while (*p && !isSPACE(*p))
2510 Newx(gary, i + 1, Groups_t);
2512 Renew(gary, i + 1, Groups_t);
2516 (void)setgroups(i, gary);
2520 #else /* HAS_SETGROUPS */
2522 #endif /* HAS_SETGROUPS */
2523 if (PL_delaymagic) {
2524 PL_delaymagic |= DM_EGID;
2525 break; /* don't do magic till later */
2528 (void)setegid((Gid_t)PL_egid);
2531 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2533 #ifdef HAS_SETRESGID
2534 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2536 if (PL_egid == PL_gid) /* special case $) = $( */
2537 (void)PerlProc_setgid(PL_egid);
2539 PL_egid = PerlProc_getegid();
2540 Perl_croak(aTHX_ "setegid() not implemented");
2545 PL_egid = PerlProc_getegid();
2546 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2549 PL_chopset = SvPV_force(sv,len);
2551 #ifndef MACOS_TRADITIONAL
2553 LOCK_DOLLARZERO_MUTEX;
2554 #ifdef HAS_SETPROCTITLE
2555 /* The BSDs don't show the argv[] in ps(1) output, they
2556 * show a string from the process struct and provide
2557 * the setproctitle() routine to manipulate that. */
2558 if (PL_origalen != 1) {
2559 s = SvPV_const(sv, len);
2560 # if __FreeBSD_version > 410001
2561 /* The leading "-" removes the "perl: " prefix,
2562 * but not the "(perl) suffix from the ps(1)
2563 * output, because that's what ps(1) shows if the
2564 * argv[] is modified. */
2565 setproctitle("-%s", s);
2566 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2567 /* This doesn't really work if you assume that
2568 * $0 = 'foobar'; will wipe out 'perl' from the $0
2569 * because in ps(1) output the result will be like
2570 * sprintf("perl: %s (perl)", s)
2571 * I guess this is a security feature:
2572 * one (a user process) cannot get rid of the original name.
2574 setproctitle("%s", s);
2578 #if defined(__hpux) && defined(PSTAT_SETCMD)
2579 if (PL_origalen != 1) {
2581 s = SvPV_const(sv, len);
2582 un.pst_command = (char *)s;
2583 pstat(PSTAT_SETCMD, un, len, 0, 0);
2586 if (PL_origalen > 1) {
2587 /* PL_origalen is set in perl_parse(). */
2588 s = SvPV_force(sv,len);
2589 if (len >= (STRLEN)PL_origalen-1) {
2590 /* Longer than original, will be truncated. We assume that
2591 * PL_origalen bytes are available. */
2592 Copy(s, PL_origargv[0], PL_origalen-1, char);
2595 /* Shorter than original, will be padded. */
2596 Copy(s, PL_origargv[0], len, char);
2597 PL_origargv[0][len] = 0;
2598 memset(PL_origargv[0] + len + 1,
2599 /* Is the space counterintuitive? Yes.
2600 * (You were expecting \0?)
2601 * Does it work? Seems to. (In Linux 2.4.20 at least.)
2604 PL_origalen - len - 1);
2606 PL_origargv[0][PL_origalen-1] = 0;
2607 for (i = 1; i < PL_origargc; i++)
2610 UNLOCK_DOLLARZERO_MUTEX;
2618 Perl_whichsig(pTHX_ const char *sig)
2620 register char* const* sigv;
2621 PERL_UNUSED_CONTEXT;
2623 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
2624 if (strEQ(sig,*sigv))
2625 return PL_sig_num[sigv - (char* const*)PL_sig_name];
2627 if (strEQ(sig,"CHLD"))
2631 if (strEQ(sig,"CLD"))
2638 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2639 Perl_sighandler(int sig, ...)
2641 Perl_sighandler(int sig)
2644 #ifdef PERL_GET_SIG_CONTEXT
2645 dTHXa(PERL_GET_SIG_CONTEXT);
2652 SV * const tSv = PL_Sv;
2656 XPV * const tXpv = PL_Xpv;
2658 if (PL_savestack_ix + 15 <= PL_savestack_max)
2660 if (PL_markstack_ptr < PL_markstack_max - 2)
2662 if (PL_scopestack_ix < PL_scopestack_max - 3)
2665 if (!PL_psig_ptr[sig]) {
2666 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2671 /* Max number of items pushed there is 3*n or 4. We cannot fix
2672 infinity, so we fix 4 (in fact 5): */
2674 PL_savestack_ix += 5; /* Protect save in progress. */
2675 SAVEDESTRUCTOR_X(S_unwind_handler_stack, (void*)&flags);
2678 PL_markstack_ptr++; /* Protect mark. */
2680 PL_scopestack_ix += 1;
2681 /* sv_2cv is too complicated, try a simpler variant first: */
2682 if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
2683 || SvTYPE(cv) != SVt_PVCV) {
2685 cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
2688 if (!cv || !CvROOT(cv)) {
2689 if (ckWARN(WARN_SIGNAL))
2690 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2691 PL_sig_name[sig], (gv ? GvENAME(gv)
2698 if(PL_psig_name[sig]) {
2699 sv = SvREFCNT_inc_NN(PL_psig_name[sig]);
2701 #if !defined(PERL_IMPLICIT_CONTEXT)
2705 sv = sv_newmortal();
2706 sv_setpv(sv,PL_sig_name[sig]);
2709 PUSHSTACKi(PERLSI_SIGNAL);
2712 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2714 struct sigaction oact;
2716 if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
2720 va_start(args, sig);
2721 sip = (siginfo_t*)va_arg(args, siginfo_t*);
2724 SV *rv = newRV_noinc((SV*)sih);
2725 /* The siginfo fields signo, code, errno, pid, uid,
2726 * addr, status, and band are defined by POSIX/SUSv3. */
2727 hv_store(sih, "signo", 5, newSViv(sip->si_signo), 0);
2728 hv_store(sih, "code", 4, newSViv(sip->si_code), 0);
2729 #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. */
2730 hv_store(sih, "errno", 5, newSViv(sip->si_errno), 0);
2731 hv_store(sih, "status", 6, newSViv(sip->si_status), 0);
2732 hv_store(sih, "uid", 3, newSViv(sip->si_uid), 0);
2733 hv_store(sih, "pid", 3, newSViv(sip->si_pid), 0);
2734 hv_store(sih, "addr", 4, newSVuv(PTR2UV(sip->si_addr)), 0);
2735 hv_store(sih, "band", 4, newSViv(sip->si_band), 0);
2739 PUSHs(newSVpv((void*)sip, sizeof(*sip)));
2748 call_sv((SV*)cv, G_DISCARD|G_EVAL);
2751 if (SvTRUE(ERRSV)) {
2753 #ifdef HAS_SIGPROCMASK
2754 /* Handler "died", for example to get out of a restart-able read().
2755 * Before we re-do that on its behalf re-enable the signal which was
2756 * blocked by the system when we entered.
2760 sigaddset(&set,sig);
2761 sigprocmask(SIG_UNBLOCK, &set, NULL);
2763 /* Not clear if this will work */
2764 (void)rsignal(sig, SIG_IGN);
2765 (void)rsignal(sig, PL_csighandlerp);
2767 #endif /* !PERL_MICRO */
2768 Perl_die(aTHX_ NULL);
2772 PL_savestack_ix -= 8; /* Unprotect save in progress. */
2776 PL_scopestack_ix -= 1;
2779 PL_op = myop; /* Apparently not needed... */
2781 PL_Sv = tSv; /* Restore global temporaries. */
2788 S_restore_magic(pTHX_ const void *p)
2791 MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
2792 SV* const sv = mgs->mgs_sv;
2797 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2799 #ifdef PERL_OLD_COPY_ON_WRITE
2800 /* While magic was saved (and off) sv_setsv may well have seen
2801 this SV as a prime candidate for COW. */
2803 sv_force_normal_flags(sv, 0);
2807 SvFLAGS(sv) |= mgs->mgs_flags;
2810 if (SvGMAGICAL(sv)) {
2811 /* downgrade public flags to private,
2812 and discard any other private flags */
2814 U32 public = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
2816 SvFLAGS(sv) &= ~( public | SVp_IOK|SVp_NOK|SVp_POK );
2817 SvFLAGS(sv) |= ( public << PRIVSHIFT );
2822 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
2824 /* If we're still on top of the stack, pop us off. (That condition
2825 * will be satisfied if restore_magic was called explicitly, but *not*
2826 * if it's being called via leave_scope.)
2827 * The reason for doing this is that otherwise, things like sv_2cv()
2828 * may leave alloc gunk on the savestack, and some code
2829 * (e.g. sighandler) doesn't expect that...
2831 if (PL_savestack_ix == mgs->mgs_ss_ix)
2833 I32 popval = SSPOPINT;
2834 assert(popval == SAVEt_DESTRUCTOR_X);
2835 PL_savestack_ix -= 2;
2837 assert(popval == SAVEt_ALLOC);
2839 PL_savestack_ix -= popval;
2845 S_unwind_handler_stack(pTHX_ const void *p)
2848 const U32 flags = *(const U32*)p;
2851 PL_savestack_ix -= 5; /* Unprotect save in progress. */
2852 #if !defined(PERL_IMPLICIT_CONTEXT)
2854 SvREFCNT_dec(PL_sig_sv);
2859 =for apidoc magic_sethint
2861 Triggered by a store to %^H, records the key/value pair to
2862 C<PL_compiling.cop_hints_hash>. It is assumed that hints aren't storing
2863 anything that would need a deep copy. Maybe we should warn if we find a
2869 Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
2872 assert(mg->mg_len == HEf_SVKEY);
2874 /* mg->mg_obj isn't being used. If needed, it would be possible to store
2875 an alternative leaf in there, with PL_compiling.cop_hints being used if
2876 it's NULL. If needed for threads, the alternative could lock a mutex,
2877 or take other more complex action. */
2879 /* Something changed in %^H, so it will need to be restored on scope exit.
2880 Doing this here saves a lot of doing it manually in perl code (and
2881 forgetting to do it, and consequent subtle errors. */
2882 PL_hints |= HINT_LOCALIZE_HH;
2883 PL_compiling.cop_hints_hash
2884 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
2885 (SV *)mg->mg_ptr, sv);
2890 =for apidoc magic_sethint
2892 Triggered by a delete from %^H, records the key to
2893 C<PL_compiling.cop_hints_hash>.
2898 Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
2901 assert(mg->mg_len == HEf_SVKEY);
2903 PERL_UNUSED_ARG(sv);
2905 PL_hints |= HINT_LOCALIZE_HH;
2906 PL_compiling.cop_hints_hash
2907 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
2908 (SV *)mg->mg_ptr, &PL_sv_placeholder);
2914 * c-indentation-style: bsd
2916 * indent-tabs-mode: t
2919 * ex: set ts=8 sts=4 sw=4 noet: