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 = utf8_length(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;
382 if (isUPPER(type) && type != PERL_MAGIC_uvar) {
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 = utf8_length((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 */
822 HV * const bits=get_hv("warnings::Bits", FALSE);
824 SV ** const bits_all = hv_fetchs(bits, "all", FALSE);
826 sv_setsv(sv, *bits_all);
829 sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
833 sv_setpvn(sv, (char *) (PL_compiling.cop_warnings + 1),
834 *PL_compiling.cop_warnings);
839 case '1': case '2': case '3': case '4':
840 case '5': case '6': case '7': case '8': case '9': case '&':
841 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
845 * Pre-threads, this was paren = atoi(GvENAME((GV*)mg->mg_obj));
846 * XXX Does the new way break anything?
848 paren = atoi(mg->mg_ptr); /* $& is in [0] */
850 if (paren <= (I32)rx->nparens &&
851 (s1 = rx->startp[paren]) != -1 &&
852 (t1 = rx->endp[paren]) != -1)
860 const int oldtainted = PL_tainted;
863 PL_tainted = oldtainted;
864 if (RX_MATCH_UTF8(rx) && is_utf8_string((U8*)s, i))
869 if (RX_MATCH_TAINTED(rx)) {
870 MAGIC* const mg = SvMAGIC(sv);
873 SvMAGIC_set(sv, mg->mg_moremagic);
875 if ((mgt = SvMAGIC(sv))) {
876 mg->mg_moremagic = mgt;
886 sv_setsv(sv,&PL_sv_undef);
889 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
890 paren = rx->lastparen;
894 sv_setsv(sv,&PL_sv_undef);
896 case '\016': /* ^N */
897 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
898 paren = rx->lastcloseparen;
902 sv_setsv(sv,&PL_sv_undef);
905 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
906 if ((s = rx->subbeg) && rx->startp[0] != -1) {
911 sv_setsv(sv,&PL_sv_undef);
914 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
915 if (rx->subbeg && rx->endp[0] != -1) {
916 s = rx->subbeg + rx->endp[0];
917 i = rx->sublen - rx->endp[0];
921 sv_setsv(sv,&PL_sv_undef);
924 if (GvIO(PL_last_in_gv)) {
925 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
930 sv_setiv(sv, (IV)STATUS_CURRENT);
931 #ifdef COMPLEX_STATUS
932 LvTARGOFF(sv) = PL_statusvalue;
933 LvTARGLEN(sv) = PL_statusvalue_vms;
938 if (GvIOp(PL_defoutgv))
939 s = IoTOP_NAME(GvIOp(PL_defoutgv));
943 sv_setpv(sv,GvENAME(PL_defoutgv));
948 if (GvIOp(PL_defoutgv))
949 s = IoFMT_NAME(GvIOp(PL_defoutgv));
951 s = GvENAME(PL_defoutgv);
955 if (GvIOp(PL_defoutgv))
956 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
959 if (GvIOp(PL_defoutgv))
960 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
963 if (GvIOp(PL_defoutgv))
964 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
971 sv_setiv(sv, (IV)CopARYBASE_get(PL_curcop));
974 if (GvIOp(PL_defoutgv))
975 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
981 sv_copypv(sv, PL_ors_sv);
985 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
986 sv_setpv(sv, errno ? Strerror(errno) : "");
989 const int saveerrno = errno;
990 sv_setnv(sv, (NV)errno);
992 if (errno == errno_isOS2 || errno == errno_isOS2_set)
993 sv_setpv(sv, os2error(Perl_rc));
996 sv_setpv(sv, errno ? Strerror(errno) : "");
1001 SvNOK_on(sv); /* what a wonderful hack! */
1004 sv_setiv(sv, (IV)PL_uid);
1007 sv_setiv(sv, (IV)PL_euid);
1010 sv_setiv(sv, (IV)PL_gid);
1013 sv_setiv(sv, (IV)PL_egid);
1015 #ifdef HAS_GETGROUPS
1017 Groups_t *gary = NULL;
1018 I32 i, num_groups = getgroups(0, gary);
1019 Newx(gary, num_groups, Groups_t);
1020 num_groups = getgroups(num_groups, gary);
1021 for (i = 0; i < num_groups; i++)
1022 Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]);
1025 (void)SvIOK_on(sv); /* what a wonderful hack! */
1028 #ifndef MACOS_TRADITIONAL
1037 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
1039 struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
1041 if (uf && uf->uf_val)
1042 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
1047 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
1050 STRLEN len = 0, klen;
1051 const char *s = SvOK(sv) ? SvPV_const(sv,len) : "";
1052 const char * const ptr = MgPV_const(mg,klen);
1055 #ifdef DYNAMIC_ENV_FETCH
1056 /* We just undefd an environment var. Is a replacement */
1057 /* waiting in the wings? */
1059 SV ** const valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE);
1061 s = SvOK(*valp) ? SvPV_const(*valp, len) : "";
1065 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
1066 /* And you'll never guess what the dog had */
1067 /* in its mouth... */
1069 MgTAINTEDDIR_off(mg);
1071 if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
1072 char pathbuf[256], eltbuf[256], *cp, *elt;
1076 my_strlcpy(eltbuf, s, sizeof(eltbuf));
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 #ifdef VMS /* Hmm. How do we get $Config{path_sep} from C? */
1106 const char path_sep = '|';
1108 const char path_sep = ':';
1110 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
1111 s, strend, path_sep, &i);
1113 if (i >= (I32)sizeof tmpbuf /* too long -- assume the worst */
1115 || !strchr(tmpbuf, ':') /* no colon thus no device name -- assume relative path */
1117 || *tmpbuf != '/' /* no starting slash -- assume relative path */
1119 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1120 MgTAINTEDDIR_on(mg);
1126 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1132 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1134 PERL_UNUSED_ARG(sv);
1135 my_setenv(MgPV_nolen_const(mg),NULL);
1140 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1143 PERL_UNUSED_ARG(mg);
1145 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1147 if (PL_localizing) {
1150 hv_iterinit((HV*)sv);
1151 while ((entry = hv_iternext((HV*)sv))) {
1153 my_setenv(hv_iterkey(entry, &keylen),
1154 SvPV_nolen_const(hv_iterval((HV*)sv, entry)));
1162 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1165 PERL_UNUSED_ARG(sv);
1166 PERL_UNUSED_ARG(mg);
1168 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1176 #ifdef HAS_SIGPROCMASK
1178 restore_sigmask(pTHX_ SV *save_sv)
1180 const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1181 (void)sigprocmask(SIG_SETMASK, ossetp, NULL);
1185 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1188 /* Are we fetching a signal entry? */
1189 const I32 i = whichsig(MgPV_nolen_const(mg));
1192 sv_setsv(sv,PL_psig_ptr[i]);
1194 Sighandler_t sigstate = rsignal_state(i);
1195 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1196 if (PL_sig_handlers_initted && PL_sig_ignoring[i])
1199 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1200 if (PL_sig_handlers_initted && PL_sig_defaulting[i])
1203 /* cache state so we don't fetch it again */
1204 if(sigstate == (Sighandler_t) SIG_IGN)
1205 sv_setpv(sv,"IGNORE");
1207 sv_setsv(sv,&PL_sv_undef);
1208 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1215 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1217 /* XXX Some of this code was copied from Perl_magic_setsig. A little
1218 * refactoring might be in order.
1221 register const char * const s = MgPV_nolen_const(mg);
1222 PERL_UNUSED_ARG(sv);
1225 if (strEQ(s,"__DIE__"))
1227 else if (strEQ(s,"__WARN__") && PL_warnhook != PERL_WARNHOOK_FATAL)
1230 SV *const to_dec = *svp;
1232 SvREFCNT_dec(to_dec);
1236 /* Are we clearing a signal entry? */
1237 const I32 i = whichsig(s);
1239 #ifdef HAS_SIGPROCMASK
1242 /* Avoid having the signal arrive at a bad time, if possible. */
1245 sigprocmask(SIG_BLOCK, &set, &save);
1247 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1248 SAVEFREESV(save_sv);
1249 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1252 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1253 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1255 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1256 PL_sig_defaulting[i] = 1;
1257 (void)rsignal(i, PL_csighandlerp);
1259 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1261 if(PL_psig_name[i]) {
1262 SvREFCNT_dec(PL_psig_name[i]);
1265 if(PL_psig_ptr[i]) {
1266 SV * const to_dec=PL_psig_ptr[i];
1269 SvREFCNT_dec(to_dec);
1279 S_raise_signal(pTHX_ int sig)
1282 /* Set a flag to say this signal is pending */
1283 PL_psig_pend[sig]++;
1284 /* And one to say _a_ signal is pending */
1289 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1290 Perl_csighandler(int sig, ...)
1292 Perl_csighandler(int sig)
1295 #ifdef PERL_GET_SIG_CONTEXT
1296 dTHXa(PERL_GET_SIG_CONTEXT);
1300 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1301 (void) rsignal(sig, PL_csighandlerp);
1302 if (PL_sig_ignoring[sig]) return;
1304 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1305 if (PL_sig_defaulting[sig])
1306 #ifdef KILL_BY_SIGPRC
1307 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1322 (PL_signals & PERL_SIGNALS_UNSAFE_FLAG))
1323 /* Call the perl level handler now--
1324 * with risk we may be in malloc() etc. */
1325 (*PL_sighandlerp)(sig);
1327 S_raise_signal(aTHX_ sig);
1330 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1332 Perl_csighandler_init(void)
1335 if (PL_sig_handlers_initted) return;
1337 for (sig = 1; sig < SIG_SIZE; sig++) {
1338 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1340 PL_sig_defaulting[sig] = 1;
1341 (void) rsignal(sig, PL_csighandlerp);
1343 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1344 PL_sig_ignoring[sig] = 0;
1347 PL_sig_handlers_initted = 1;
1352 Perl_despatch_signals(pTHX)
1357 for (sig = 1; sig < SIG_SIZE; sig++) {
1358 if (PL_psig_pend[sig]) {
1359 PERL_BLOCKSIG_ADD(set, sig);
1360 PL_psig_pend[sig] = 0;
1361 PERL_BLOCKSIG_BLOCK(set);
1362 (*PL_sighandlerp)(sig);
1363 PERL_BLOCKSIG_UNBLOCK(set);
1369 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1374 /* Need to be careful with SvREFCNT_dec(), because that can have side
1375 * effects (due to closures). We must make sure that the new disposition
1376 * is in place before it is called.
1380 #ifdef HAS_SIGPROCMASK
1385 register const char *s = MgPV_const(mg,len);
1387 if (strEQ(s,"__DIE__"))
1389 else if (strEQ(s,"__WARN__"))
1392 Perl_croak(aTHX_ "No such hook: %s", s);
1395 if (*svp != PERL_WARNHOOK_FATAL)
1401 i = whichsig(s); /* ...no, a brick */
1403 if (ckWARN(WARN_SIGNAL))
1404 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
1407 #ifdef HAS_SIGPROCMASK
1408 /* Avoid having the signal arrive at a bad time, if possible. */
1411 sigprocmask(SIG_BLOCK, &set, &save);
1413 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1414 SAVEFREESV(save_sv);
1415 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1418 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1419 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1421 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1422 PL_sig_ignoring[i] = 0;
1424 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1425 PL_sig_defaulting[i] = 0;
1427 SvREFCNT_dec(PL_psig_name[i]);
1428 to_dec = PL_psig_ptr[i];
1429 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1430 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1431 PL_psig_name[i] = newSVpvn(s, len);
1432 SvREADONLY_on(PL_psig_name[i]);
1434 if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
1436 (void)rsignal(i, PL_csighandlerp);
1437 #ifdef HAS_SIGPROCMASK
1442 *svp = SvREFCNT_inc_simple_NN(sv);
1444 SvREFCNT_dec(to_dec);
1447 s = SvPV_force(sv,len);
1448 if (strEQ(s,"IGNORE")) {
1450 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1451 PL_sig_ignoring[i] = 1;
1452 (void)rsignal(i, PL_csighandlerp);
1454 (void)rsignal(i, (Sighandler_t) SIG_IGN);
1458 else if (strEQ(s,"DEFAULT") || !*s) {
1460 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1462 PL_sig_defaulting[i] = 1;
1463 (void)rsignal(i, PL_csighandlerp);
1466 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1471 * We should warn if HINT_STRICT_REFS, but without
1472 * access to a known hint bit in a known OP, we can't
1473 * tell whether HINT_STRICT_REFS is in force or not.
1475 if (!strchr(s,':') && !strchr(s,'\''))
1476 Perl_sv_insert(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"));
1478 (void)rsignal(i, PL_csighandlerp);
1480 *svp = SvREFCNT_inc_simple_NN(sv);
1482 #ifdef HAS_SIGPROCMASK
1487 SvREFCNT_dec(to_dec);
1490 #endif /* !PERL_MICRO */
1493 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1496 PERL_UNUSED_ARG(sv);
1497 PERL_UNUSED_ARG(mg);
1498 PL_sub_generation++;
1503 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
1506 PERL_UNUSED_ARG(sv);
1507 PERL_UNUSED_ARG(mg);
1508 /* HV_badAMAGIC_on(Sv_STASH(sv)); */
1509 PL_amagic_generation++;
1515 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1517 HV * const hv = (HV*)LvTARG(sv);
1519 PERL_UNUSED_ARG(mg);
1522 (void) hv_iterinit(hv);
1523 if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
1526 while (hv_iternext(hv))
1531 sv_setiv(sv, (IV)i);
1536 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1538 PERL_UNUSED_ARG(mg);
1540 hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
1545 /* caller is responsible for stack switching/cleanup */
1547 S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV *val)
1554 PUSHs(SvTIED_obj(sv, mg));
1557 if (mg->mg_len >= 0)
1558 PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len)));
1559 else if (mg->mg_len == HEf_SVKEY)
1560 PUSHs((SV*)mg->mg_ptr);
1562 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1563 PUSHs(sv_2mortal(newSViv(mg->mg_len)));
1571 return call_method(meth, flags);
1575 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
1581 PUSHSTACKi(PERLSI_MAGIC);
1583 if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
1584 sv_setsv(sv, *PL_stack_sp--);
1594 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1597 mg->mg_flags |= MGf_GSKIP;
1598 magic_methpack(sv,mg,"FETCH");
1603 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1607 PUSHSTACKi(PERLSI_MAGIC);
1608 magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
1615 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1617 return magic_methpack(sv,mg,"DELETE");
1622 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1629 PUSHSTACKi(PERLSI_MAGIC);
1630 if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
1631 sv = *PL_stack_sp--;
1632 retval = (U32) SvIV(sv)-1;
1641 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1646 PUSHSTACKi(PERLSI_MAGIC);
1648 XPUSHs(SvTIED_obj(sv, mg));
1650 call_method("CLEAR", G_SCALAR|G_DISCARD);
1658 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1661 const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
1665 PUSHSTACKi(PERLSI_MAGIC);
1668 PUSHs(SvTIED_obj(sv, mg));
1673 if (call_method(meth, G_SCALAR))
1674 sv_setsv(key, *PL_stack_sp--);
1683 Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg)
1685 return magic_methpack(sv,mg,"EXISTS");
1689 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1693 SV * const tied = SvTIED_obj((SV*)hv, mg);
1694 HV * const pkg = SvSTASH((SV*)SvRV(tied));
1696 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1698 if (HvEITER_get(hv))
1699 /* we are in an iteration so the hash cannot be empty */
1701 /* no xhv_eiter so now use FIRSTKEY */
1702 key = sv_newmortal();
1703 magic_nextpack((SV*)hv, mg, key);
1704 HvEITER_set(hv, NULL); /* need to reset iterator */
1705 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1708 /* there is a SCALAR method that we can call */
1710 PUSHSTACKi(PERLSI_MAGIC);
1716 if (call_method("SCALAR", G_SCALAR))
1717 retval = *PL_stack_sp--;
1719 retval = &PL_sv_undef;
1726 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1729 GV * const gv = PL_DBline;
1730 const I32 i = SvTRUE(sv);
1731 SV ** const svp = av_fetch(GvAV(gv),
1732 atoi(MgPV_nolen_const(mg)), FALSE);
1733 if (svp && SvIOKp(*svp)) {
1734 OP * const o = INT2PTR(OP*,SvIVX(*svp));
1736 /* set or clear breakpoint in the relevant control op */
1738 o->op_flags |= OPf_SPECIAL;
1740 o->op_flags &= ~OPf_SPECIAL;
1747 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
1750 const AV * const obj = (AV*)mg->mg_obj;
1752 sv_setiv(sv, AvFILL(obj) + CopARYBASE_get(PL_curcop));
1760 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
1763 AV * const obj = (AV*)mg->mg_obj;
1765 av_fill(obj, SvIV(sv) - CopARYBASE_get(PL_curcop));
1767 if (ckWARN(WARN_MISC))
1768 Perl_warner(aTHX_ packWARN(WARN_MISC),
1769 "Attempt to set length of freed array");
1775 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
1778 PERL_UNUSED_ARG(sv);
1779 /* during global destruction, mg_obj may already have been freed */
1780 if (PL_in_clean_all)
1783 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
1786 /* arylen scalar holds a pointer back to the array, but doesn't own a
1787 reference. Hence the we (the array) are about to go away with it
1788 still pointing at us. Clear its pointer, else it would be pointing
1789 at free memory. See the comment in sv_magic about reference loops,
1790 and why it can't own a reference to us. */
1797 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
1800 SV* const lsv = LvTARG(sv);
1801 PERL_UNUSED_ARG(mg);
1803 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1804 MAGIC * const found = mg_find(lsv, PERL_MAGIC_regex_global);
1805 if (found && found->mg_len >= 0) {
1806 I32 i = found->mg_len;
1808 sv_pos_b2u(lsv, &i);
1809 sv_setiv(sv, i + CopARYBASE_get(PL_curcop));
1818 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
1821 SV* const lsv = LvTARG(sv);
1827 PERL_UNUSED_ARG(mg);
1829 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
1830 found = mg_find(lsv, PERL_MAGIC_regex_global);
1836 #ifdef PERL_OLD_COPY_ON_WRITE
1838 sv_force_normal_flags(lsv, 0);
1840 found = sv_magicext(lsv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
1843 else if (!SvOK(sv)) {
1847 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1849 pos = SvIV(sv) - CopARYBASE_get(PL_curcop);
1852 ulen = sv_len_utf8(lsv);
1862 else if (pos > (SSize_t)len)
1867 sv_pos_u2b(lsv, &p, 0);
1871 found->mg_len = pos;
1872 found->mg_flags &= ~MGf_MINMATCH;
1878 Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg)
1881 PERL_UNUSED_ARG(mg);
1885 if (SvFLAGS(sv) & SVp_SCREAM
1886 && (SvTYPE(sv) == SVt_PVGV || SvTYPE(sv) == SVt_PVGV)) {
1887 /* We're actually already a typeglob, so don't need the stuff below.
1891 gv = gv_fetchsv(sv, GV_ADD, SVt_PVGV);
1896 GvGP(sv) = gp_ref(GvGP(gv));
1901 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
1904 SV * const lsv = LvTARG(sv);
1905 const char * const tmps = SvPV_const(lsv,len);
1906 I32 offs = LvTARGOFF(sv);
1907 I32 rem = LvTARGLEN(sv);
1908 PERL_UNUSED_ARG(mg);
1911 sv_pos_u2b(lsv, &offs, &rem);
1912 if (offs > (I32)len)
1914 if (rem + offs > (I32)len)
1916 sv_setpvn(sv, tmps + offs, (STRLEN)rem);
1923 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
1927 const char * const tmps = SvPV_const(sv, len);
1928 SV * const lsv = LvTARG(sv);
1929 I32 lvoff = LvTARGOFF(sv);
1930 I32 lvlen = LvTARGLEN(sv);
1931 PERL_UNUSED_ARG(mg);
1934 sv_utf8_upgrade(lsv);
1935 sv_pos_u2b(lsv, &lvoff, &lvlen);
1936 sv_insert(lsv, lvoff, lvlen, tmps, len);
1937 LvTARGLEN(sv) = sv_len_utf8(sv);
1940 else if (lsv && SvUTF8(lsv)) {
1942 sv_pos_u2b(lsv, &lvoff, &lvlen);
1943 LvTARGLEN(sv) = len;
1944 utf8 = (char*)bytes_to_utf8((U8*)tmps, &len);
1945 sv_insert(lsv, lvoff, lvlen, utf8, len);
1949 sv_insert(lsv, lvoff, lvlen, tmps, len);
1950 LvTARGLEN(sv) = len;
1958 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
1961 PERL_UNUSED_ARG(sv);
1962 TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
1967 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
1970 PERL_UNUSED_ARG(sv);
1971 /* update taint status unless we're restoring at scope exit */
1972 if (PL_localizing != 2) {
1982 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
1984 SV * const lsv = LvTARG(sv);
1985 PERL_UNUSED_ARG(mg);
1988 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
1996 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
1998 PERL_UNUSED_ARG(mg);
1999 do_vecset(sv); /* XXX slurp this routine */
2004 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
2008 if (LvTARGLEN(sv)) {
2010 SV * const ahv = LvTARG(sv);
2011 HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
2016 AV* const av = (AV*)LvTARG(sv);
2017 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
2018 targ = AvARRAY(av)[LvTARGOFF(sv)];
2020 if (targ && (targ != &PL_sv_undef)) {
2021 /* somebody else defined it for us */
2022 SvREFCNT_dec(LvTARG(sv));
2023 LvTARG(sv) = SvREFCNT_inc_simple_NN(targ);
2025 SvREFCNT_dec(mg->mg_obj);
2027 mg->mg_flags &= ~MGf_REFCOUNTED;
2032 sv_setsv(sv, targ ? targ : &PL_sv_undef);
2037 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
2039 PERL_UNUSED_ARG(mg);
2043 sv_setsv(LvTARG(sv), sv);
2044 SvSETMAGIC(LvTARG(sv));
2050 Perl_vivify_defelem(pTHX_ SV *sv)
2056 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2059 SV * const ahv = LvTARG(sv);
2060 HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
2063 if (!value || value == &PL_sv_undef)
2064 Perl_croak(aTHX_ PL_no_helem_sv, mg->mg_obj);
2067 AV* const av = (AV*)LvTARG(sv);
2068 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
2069 LvTARG(sv) = NULL; /* array can't be extended */
2071 SV* const * const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
2072 if (!svp || (value = *svp) == &PL_sv_undef)
2073 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
2076 SvREFCNT_inc_simple_void(value);
2077 SvREFCNT_dec(LvTARG(sv));
2080 SvREFCNT_dec(mg->mg_obj);
2082 mg->mg_flags &= ~MGf_REFCOUNTED;
2086 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2088 return Perl_sv_kill_backrefs(aTHX_ sv, (AV*)mg->mg_obj);
2092 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2094 PERL_UNUSED_CONTEXT;
2101 Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
2103 PERL_UNUSED_ARG(mg);
2104 sv_unmagic(sv, PERL_MAGIC_bm);
2110 Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
2112 PERL_UNUSED_ARG(mg);
2113 sv_unmagic(sv, PERL_MAGIC_fm);
2119 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2121 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2123 if (uf && uf->uf_set)
2124 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2129 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2131 PERL_UNUSED_ARG(mg);
2132 sv_unmagic(sv, PERL_MAGIC_qr);
2137 Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
2140 regexp * const re = (regexp *)mg->mg_obj;
2141 PERL_UNUSED_ARG(sv);
2147 #ifdef USE_LOCALE_COLLATE
2149 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2152 * RenE<eacute> Descartes said "I think not."
2153 * and vanished with a faint plop.
2155 PERL_UNUSED_CONTEXT;
2156 PERL_UNUSED_ARG(sv);
2158 Safefree(mg->mg_ptr);
2164 #endif /* USE_LOCALE_COLLATE */
2166 /* Just clear the UTF-8 cache data. */
2168 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2170 PERL_UNUSED_CONTEXT;
2171 PERL_UNUSED_ARG(sv);
2172 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2174 mg->mg_len = -1; /* The mg_len holds the len cache. */
2179 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2182 register const char *s;
2185 switch (*mg->mg_ptr) {
2186 case '\001': /* ^A */
2187 sv_setsv(PL_bodytarget, sv);
2189 case '\003': /* ^C */
2190 PL_minus_c = (bool)SvIV(sv);
2193 case '\004': /* ^D */
2195 s = SvPV_nolen_const(sv);
2196 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2197 DEBUG_x(dump_all());
2199 PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG;
2202 case '\005': /* ^E */
2203 if (*(mg->mg_ptr+1) == '\0') {
2204 #ifdef MACOS_TRADITIONAL
2205 gMacPerl_OSErr = SvIV(sv);
2208 set_vaxc_errno(SvIV(sv));
2211 SetLastError( SvIV(sv) );
2214 os2_setsyserrno(SvIV(sv));
2216 /* will anyone ever use this? */
2217 SETERRNO(SvIV(sv), 4);
2223 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2225 SvREFCNT_dec(PL_encoding);
2226 if (SvOK(sv) || SvGMAGICAL(sv)) {
2227 PL_encoding = newSVsv(sv);
2234 case '\006': /* ^F */
2235 PL_maxsysfd = SvIV(sv);
2237 case '\010': /* ^H */
2238 PL_hints = SvIV(sv);
2240 case '\011': /* ^I */ /* NOT \t in EBCDIC */
2241 Safefree(PL_inplace);
2242 PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
2244 case '\017': /* ^O */
2245 if (*(mg->mg_ptr+1) == '\0') {
2246 Safefree(PL_osname);
2249 TAINT_PROPER("assigning to $^O");
2250 PL_osname = savesvpv(sv);
2253 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2254 PL_compiling.cop_hints |= HINT_LEXICAL_IO;
2255 PL_hints |= HINT_LOCALIZE_HH | HINT_LEXICAL_IO;
2256 PL_compiling.cop_hints_hash
2257 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
2258 sv_2mortal(newSVpvs("open")), sv);
2261 case '\020': /* ^P */
2262 PL_perldb = SvIV(sv);
2263 if (PL_perldb && !PL_DBsingle)
2266 case '\024': /* ^T */
2268 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2270 PL_basetime = (Time_t)SvIV(sv);
2273 case '\025': /* ^UTF8CACHE */
2274 if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
2275 PL_utf8cache = (signed char) sv_2iv(sv);
2278 case '\027': /* ^W & $^WARNING_BITS */
2279 if (*(mg->mg_ptr+1) == '\0') {
2280 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2282 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2283 | (i ? G_WARN_ON : G_WARN_OFF) ;
2286 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2287 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2288 if (!SvPOK(sv) && PL_localizing) {
2289 sv_setpvn(sv, WARN_NONEstring, WARNsize);
2290 PL_compiling.cop_warnings = pWARN_NONE;
2295 int accumulate = 0 ;
2296 int any_fatals = 0 ;
2297 const char * const ptr = SvPV_const(sv, len) ;
2298 for (i = 0 ; i < len ; ++i) {
2299 accumulate |= ptr[i] ;
2300 any_fatals |= (ptr[i] & 0xAA) ;
2303 PL_compiling.cop_warnings = pWARN_NONE;
2304 /* Yuck. I can't see how to abstract this: */
2305 else if (isWARN_on(((STRLEN *)SvPV_nolen_const(sv)) - 1,
2306 WARN_ALL) && !any_fatals) {
2307 PL_compiling.cop_warnings = pWARN_ALL;
2308 PL_dowarn |= G_WARN_ONCE ;
2312 const char *const p = SvPV_const(sv, len);
2314 PL_compiling.cop_warnings
2315 = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
2318 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2319 PL_dowarn |= G_WARN_ONCE ;
2327 if (PL_localizing) {
2328 if (PL_localizing == 1)
2329 SAVESPTR(PL_last_in_gv);
2331 else if (SvOK(sv) && GvIO(PL_last_in_gv))
2332 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2335 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2336 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2337 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2340 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2341 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2342 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2345 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
2348 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
2349 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2350 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2353 IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
2357 IO * const io = GvIOp(PL_defoutgv);
2360 if ((SvIV(sv)) == 0)
2361 IoFLAGS(io) &= ~IOf_FLUSH;
2363 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2364 PerlIO *ofp = IoOFP(io);
2366 (void)PerlIO_flush(ofp);
2367 IoFLAGS(io) |= IOf_FLUSH;
2373 SvREFCNT_dec(PL_rs);
2374 PL_rs = newSVsv(sv);
2378 SvREFCNT_dec(PL_ors_sv);
2379 if (SvOK(sv) || SvGMAGICAL(sv)) {
2380 PL_ors_sv = newSVsv(sv);
2388 SvREFCNT_dec(PL_ofs_sv);
2389 if (SvOK(sv) || SvGMAGICAL(sv)) {
2390 PL_ofs_sv = newSVsv(sv);
2397 CopARYBASE_set(&PL_compiling, SvIV(sv));
2400 #ifdef COMPLEX_STATUS
2401 if (PL_localizing == 2) {
2402 PL_statusvalue = LvTARGOFF(sv);
2403 PL_statusvalue_vms = LvTARGLEN(sv);
2407 #ifdef VMSISH_STATUS
2409 STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2412 STATUS_UNIX_EXIT_SET(SvIV(sv));
2417 # define PERL_VMS_BANG vaxc$errno
2419 # define PERL_VMS_BANG 0
2421 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2422 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2427 if (PL_delaymagic) {
2428 PL_delaymagic |= DM_RUID;
2429 break; /* don't do magic till later */
2432 (void)setruid((Uid_t)PL_uid);
2435 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2437 #ifdef HAS_SETRESUID
2438 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2440 if (PL_uid == PL_euid) { /* special case $< = $> */
2442 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2443 if (PL_uid != 0 && PerlProc_getuid() == 0)
2444 (void)PerlProc_setuid(0);
2446 (void)PerlProc_setuid(PL_uid);
2448 PL_uid = PerlProc_getuid();
2449 Perl_croak(aTHX_ "setruid() not implemented");
2454 PL_uid = PerlProc_getuid();
2455 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2459 if (PL_delaymagic) {
2460 PL_delaymagic |= DM_EUID;
2461 break; /* don't do magic till later */
2464 (void)seteuid((Uid_t)PL_euid);
2467 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2469 #ifdef HAS_SETRESUID
2470 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2472 if (PL_euid == PL_uid) /* special case $> = $< */
2473 PerlProc_setuid(PL_euid);
2475 PL_euid = PerlProc_geteuid();
2476 Perl_croak(aTHX_ "seteuid() not implemented");
2481 PL_euid = PerlProc_geteuid();
2482 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2486 if (PL_delaymagic) {
2487 PL_delaymagic |= DM_RGID;
2488 break; /* don't do magic till later */
2491 (void)setrgid((Gid_t)PL_gid);
2494 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2496 #ifdef HAS_SETRESGID
2497 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2499 if (PL_gid == PL_egid) /* special case $( = $) */
2500 (void)PerlProc_setgid(PL_gid);
2502 PL_gid = PerlProc_getgid();
2503 Perl_croak(aTHX_ "setrgid() not implemented");
2508 PL_gid = PerlProc_getgid();
2509 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2512 #ifdef HAS_SETGROUPS
2514 const char *p = SvPV_const(sv, len);
2515 Groups_t *gary = NULL;
2520 for (i = 0; i < NGROUPS; ++i) {
2521 while (*p && !isSPACE(*p))
2528 Newx(gary, i + 1, Groups_t);
2530 Renew(gary, i + 1, Groups_t);
2534 (void)setgroups(i, gary);
2537 #else /* HAS_SETGROUPS */
2539 #endif /* HAS_SETGROUPS */
2540 if (PL_delaymagic) {
2541 PL_delaymagic |= DM_EGID;
2542 break; /* don't do magic till later */
2545 (void)setegid((Gid_t)PL_egid);
2548 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2550 #ifdef HAS_SETRESGID
2551 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2553 if (PL_egid == PL_gid) /* special case $) = $( */
2554 (void)PerlProc_setgid(PL_egid);
2556 PL_egid = PerlProc_getegid();
2557 Perl_croak(aTHX_ "setegid() not implemented");
2562 PL_egid = PerlProc_getegid();
2563 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2566 PL_chopset = SvPV_force(sv,len);
2568 #ifndef MACOS_TRADITIONAL
2570 LOCK_DOLLARZERO_MUTEX;
2571 #ifdef HAS_SETPROCTITLE
2572 /* The BSDs don't show the argv[] in ps(1) output, they
2573 * show a string from the process struct and provide
2574 * the setproctitle() routine to manipulate that. */
2575 if (PL_origalen != 1) {
2576 s = SvPV_const(sv, len);
2577 # if __FreeBSD_version > 410001
2578 /* The leading "-" removes the "perl: " prefix,
2579 * but not the "(perl) suffix from the ps(1)
2580 * output, because that's what ps(1) shows if the
2581 * argv[] is modified. */
2582 setproctitle("-%s", s);
2583 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2584 /* This doesn't really work if you assume that
2585 * $0 = 'foobar'; will wipe out 'perl' from the $0
2586 * because in ps(1) output the result will be like
2587 * sprintf("perl: %s (perl)", s)
2588 * I guess this is a security feature:
2589 * one (a user process) cannot get rid of the original name.
2591 setproctitle("%s", s);
2595 #if defined(__hpux) && defined(PSTAT_SETCMD)
2596 if (PL_origalen != 1) {
2598 s = SvPV_const(sv, len);
2599 un.pst_command = (char *)s;
2600 pstat(PSTAT_SETCMD, un, len, 0, 0);
2603 if (PL_origalen > 1) {
2604 /* PL_origalen is set in perl_parse(). */
2605 s = SvPV_force(sv,len);
2606 if (len >= (STRLEN)PL_origalen-1) {
2607 /* Longer than original, will be truncated. We assume that
2608 * PL_origalen bytes are available. */
2609 Copy(s, PL_origargv[0], PL_origalen-1, char);
2612 /* Shorter than original, will be padded. */
2613 Copy(s, PL_origargv[0], len, char);
2614 PL_origargv[0][len] = 0;
2615 memset(PL_origargv[0] + len + 1,
2616 /* Is the space counterintuitive? Yes.
2617 * (You were expecting \0?)
2618 * Does it work? Seems to. (In Linux 2.4.20 at least.)
2621 PL_origalen - len - 1);
2623 PL_origargv[0][PL_origalen-1] = 0;
2624 for (i = 1; i < PL_origargc; i++)
2627 UNLOCK_DOLLARZERO_MUTEX;
2635 Perl_whichsig(pTHX_ const char *sig)
2637 register char* const* sigv;
2638 PERL_UNUSED_CONTEXT;
2640 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
2641 if (strEQ(sig,*sigv))
2642 return PL_sig_num[sigv - (char* const*)PL_sig_name];
2644 if (strEQ(sig,"CHLD"))
2648 if (strEQ(sig,"CLD"))
2655 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2656 Perl_sighandler(int sig, ...)
2658 Perl_sighandler(int sig)
2661 #ifdef PERL_GET_SIG_CONTEXT
2662 dTHXa(PERL_GET_SIG_CONTEXT);
2669 SV * const tSv = PL_Sv;
2673 XPV * const tXpv = PL_Xpv;
2675 if (PL_savestack_ix + 15 <= PL_savestack_max)
2677 if (PL_markstack_ptr < PL_markstack_max - 2)
2679 if (PL_scopestack_ix < PL_scopestack_max - 3)
2682 if (!PL_psig_ptr[sig]) {
2683 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2688 /* Max number of items pushed there is 3*n or 4. We cannot fix
2689 infinity, so we fix 4 (in fact 5): */
2691 PL_savestack_ix += 5; /* Protect save in progress. */
2692 SAVEDESTRUCTOR_X(S_unwind_handler_stack, (void*)&flags);
2695 PL_markstack_ptr++; /* Protect mark. */
2697 PL_scopestack_ix += 1;
2698 /* sv_2cv is too complicated, try a simpler variant first: */
2699 if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
2700 || SvTYPE(cv) != SVt_PVCV) {
2702 cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
2705 if (!cv || !CvROOT(cv)) {
2706 if (ckWARN(WARN_SIGNAL))
2707 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2708 PL_sig_name[sig], (gv ? GvENAME(gv)
2715 if(PL_psig_name[sig]) {
2716 sv = SvREFCNT_inc_NN(PL_psig_name[sig]);
2718 #if !defined(PERL_IMPLICIT_CONTEXT)
2722 sv = sv_newmortal();
2723 sv_setpv(sv,PL_sig_name[sig]);
2726 PUSHSTACKi(PERLSI_SIGNAL);
2729 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2731 struct sigaction oact;
2733 if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
2737 va_start(args, sig);
2738 sip = (siginfo_t*)va_arg(args, siginfo_t*);
2741 SV *rv = newRV_noinc((SV*)sih);
2742 /* The siginfo fields signo, code, errno, pid, uid,
2743 * addr, status, and band are defined by POSIX/SUSv3. */
2744 hv_store(sih, "signo", 5, newSViv(sip->si_signo), 0);
2745 hv_store(sih, "code", 4, newSViv(sip->si_code), 0);
2746 #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. */
2747 hv_store(sih, "errno", 5, newSViv(sip->si_errno), 0);
2748 hv_store(sih, "status", 6, newSViv(sip->si_status), 0);
2749 hv_store(sih, "uid", 3, newSViv(sip->si_uid), 0);
2750 hv_store(sih, "pid", 3, newSViv(sip->si_pid), 0);
2751 hv_store(sih, "addr", 4, newSVuv(PTR2UV(sip->si_addr)), 0);
2752 hv_store(sih, "band", 4, newSViv(sip->si_band), 0);
2756 PUSHs(newSVpv((char *)sip, sizeof(*sip)));
2765 call_sv((SV*)cv, G_DISCARD|G_EVAL);
2768 if (SvTRUE(ERRSV)) {
2770 #ifdef HAS_SIGPROCMASK
2771 /* Handler "died", for example to get out of a restart-able read().
2772 * Before we re-do that on its behalf re-enable the signal which was
2773 * blocked by the system when we entered.
2777 sigaddset(&set,sig);
2778 sigprocmask(SIG_UNBLOCK, &set, NULL);
2780 /* Not clear if this will work */
2781 (void)rsignal(sig, SIG_IGN);
2782 (void)rsignal(sig, PL_csighandlerp);
2784 #endif /* !PERL_MICRO */
2785 Perl_die(aTHX_ NULL);
2789 PL_savestack_ix -= 8; /* Unprotect save in progress. */
2793 PL_scopestack_ix -= 1;
2796 PL_op = myop; /* Apparently not needed... */
2798 PL_Sv = tSv; /* Restore global temporaries. */
2805 S_restore_magic(pTHX_ const void *p)
2808 MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
2809 SV* const sv = mgs->mgs_sv;
2814 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2816 #ifdef PERL_OLD_COPY_ON_WRITE
2817 /* While magic was saved (and off) sv_setsv may well have seen
2818 this SV as a prime candidate for COW. */
2820 sv_force_normal_flags(sv, 0);
2824 SvFLAGS(sv) |= mgs->mgs_flags;
2827 if (SvGMAGICAL(sv)) {
2828 /* downgrade public flags to private,
2829 and discard any other private flags */
2831 const U32 pubflags = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
2833 SvFLAGS(sv) &= ~( pubflags | (SVp_IOK|SVp_NOK|SVp_POK) );
2834 SvFLAGS(sv) |= ( pubflags << PRIVSHIFT );
2839 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
2841 /* If we're still on top of the stack, pop us off. (That condition
2842 * will be satisfied if restore_magic was called explicitly, but *not*
2843 * if it's being called via leave_scope.)
2844 * The reason for doing this is that otherwise, things like sv_2cv()
2845 * may leave alloc gunk on the savestack, and some code
2846 * (e.g. sighandler) doesn't expect that...
2848 if (PL_savestack_ix == mgs->mgs_ss_ix)
2850 I32 popval = SSPOPINT;
2851 assert(popval == SAVEt_DESTRUCTOR_X);
2852 PL_savestack_ix -= 2;
2854 assert(popval == SAVEt_ALLOC);
2856 PL_savestack_ix -= popval;
2862 S_unwind_handler_stack(pTHX_ const void *p)
2865 const U32 flags = *(const U32*)p;
2868 PL_savestack_ix -= 5; /* Unprotect save in progress. */
2869 #if !defined(PERL_IMPLICIT_CONTEXT)
2871 SvREFCNT_dec(PL_sig_sv);
2876 =for apidoc magic_sethint
2878 Triggered by a store to %^H, records the key/value pair to
2879 C<PL_compiling.cop_hints_hash>. It is assumed that hints aren't storing
2880 anything that would need a deep copy. Maybe we should warn if we find a
2886 Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
2889 assert(mg->mg_len == HEf_SVKEY);
2891 /* mg->mg_obj isn't being used. If needed, it would be possible to store
2892 an alternative leaf in there, with PL_compiling.cop_hints being used if
2893 it's NULL. If needed for threads, the alternative could lock a mutex,
2894 or take other more complex action. */
2896 /* Something changed in %^H, so it will need to be restored on scope exit.
2897 Doing this here saves a lot of doing it manually in perl code (and
2898 forgetting to do it, and consequent subtle errors. */
2899 PL_hints |= HINT_LOCALIZE_HH;
2900 PL_compiling.cop_hints_hash
2901 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
2902 (SV *)mg->mg_ptr, sv);
2907 =for apidoc magic_sethint
2909 Triggered by a delete from %^H, records the key to
2910 C<PL_compiling.cop_hints_hash>.
2915 Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
2918 PERL_UNUSED_ARG(sv);
2920 assert(mg->mg_len == HEf_SVKEY);
2922 PERL_UNUSED_ARG(sv);
2924 PL_hints |= HINT_LOCALIZE_HH;
2925 PL_compiling.cop_hints_hash
2926 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
2927 (SV *)mg->mg_ptr, &PL_sv_placeholder);
2933 * c-indentation-style: bsd
2935 * indent-tabs-mode: t
2938 * ex: set ts=8 sts=4 sw=4 noet: