3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * "Sam sat on the ground and put his head in his hands. 'I wish I had never
13 * come here, and I don't want to see no more magic,' he said, and fell silent."
17 =head1 Magical Functions
19 "Magic" is special data attached to SV structures in order to give them
20 "magical" properties. When any Perl code tries to read from, or assign to,
21 an SV marked as magical, it calls the 'get' or 'set' function associated
22 with that SV's magic. A get is called prior to reading an SV, in order to
23 give it a chance to update its internal value (get on $. writes the line
24 number of the last read filehandle into to the SV's IV slot), while
25 set is called after an SV has been written to, in order to allow it to make
26 use of its changed value (set on $/ copies the SV's new value to the
27 PL_rs global variable).
29 Magic is implemented as a linked list of MAGIC structures attached to the
30 SV. Each MAGIC struct holds the type of the magic, a pointer to an array
31 of functions that implement the get(), set(), length() etc functions,
32 plus space for some flags and pointers. For example, a tied variable has
33 a MAGIC structure that contains a pointer to the object associated with the
42 #if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS)
48 #if defined(HAS_SETGROUPS)
55 # include <sys/pstat.h>
58 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
59 Signal_t Perl_csighandler(int sig, ...);
61 Signal_t Perl_csighandler(int sig);
65 /* Missing protos on LynxOS */
66 void setruid(uid_t id);
67 void seteuid(uid_t id);
68 void setrgid(uid_t id);
69 void setegid(uid_t id);
73 * Use the "DESTRUCTOR" scope cleanup to reinstate magic.
81 /* MGS is typedef'ed to struct magic_state in perl.h */
84 S_save_magic(pTHX_ I32 mgs_ix, SV *sv)
88 assert(SvMAGICAL(sv));
89 /* Turning READONLY off for a copy-on-write scalar (including shared
90 hash keys) is a bad idea. */
92 sv_force_normal_flags(sv, 0);
94 SAVEDESTRUCTOR_X(S_restore_magic, INT2PTR(void*, (IV)mgs_ix));
96 mgs = SSPTR(mgs_ix, MGS*);
98 mgs->mgs_flags = SvMAGICAL(sv) | SvREADONLY(sv);
99 mgs->mgs_ss_ix = PL_savestack_ix; /* points after the saved destructor */
103 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
107 =for apidoc mg_magical
109 Turns on the magical status of an SV. See C<sv_magic>.
115 Perl_mg_magical(pTHX_ SV *sv)
119 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
120 const MGVTBL* const vtbl = mg->mg_virtual;
122 if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
126 if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)) || vtbl->svt_clear)
135 Do magic after a value is retrieved from the SV. See C<sv_magic>.
141 Perl_mg_get(pTHX_ SV *sv)
144 const I32 mgs_ix = SSNEW(sizeof(MGS));
145 const bool was_temp = (bool)SvTEMP(sv);
147 MAGIC *newmg, *head, *cur, *mg;
148 /* guard against sv having being freed midway by holding a private
151 /* sv_2mortal has this side effect of turning on the TEMP flag, which can
152 cause the SV's buffer to get stolen (and maybe other stuff).
155 sv_2mortal(SvREFCNT_inc_simple(sv));
160 save_magic(mgs_ix, sv);
162 /* We must call svt_get(sv, mg) for each valid entry in the linked
163 list of magic. svt_get() may delete the current entry, add new
164 magic to the head of the list, or upgrade the SV. AMS 20010810 */
166 newmg = cur = head = mg = SvMAGIC(sv);
168 const MGVTBL * const vtbl = mg->mg_virtual;
170 if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
171 CALL_FPTR(vtbl->svt_get)(aTHX_ sv, mg);
173 /* guard against magic having been deleted - eg FETCH calling
178 /* Don't restore the flags for this entry if it was deleted. */
179 if (mg->mg_flags & MGf_GSKIP)
180 (SSPTR(mgs_ix, MGS *))->mgs_flags = 0;
183 mg = mg->mg_moremagic;
186 /* Have we finished with the new entries we saw? Start again
187 where we left off (unless there are more new entries). */
195 /* Were any new entries added? */
196 if (!have_new && (newmg = SvMAGIC(sv)) != head) {
203 restore_magic(INT2PTR(void *, (IV)mgs_ix));
205 if (SvREFCNT(sv) == 1) {
206 /* We hold the last reference to this SV, which implies that the
207 SV was deleted as a side effect of the routines we called. */
216 Do magic after a value is assigned to the SV. See C<sv_magic>.
222 Perl_mg_set(pTHX_ SV *sv)
225 const I32 mgs_ix = SSNEW(sizeof(MGS));
229 save_magic(mgs_ix, sv);
231 for (mg = SvMAGIC(sv); mg; mg = nextmg) {
232 const MGVTBL* vtbl = mg->mg_virtual;
233 nextmg = mg->mg_moremagic; /* it may delete itself */
234 if (mg->mg_flags & MGf_GSKIP) {
235 mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */
236 (SSPTR(mgs_ix, MGS*))->mgs_flags = 0;
238 if (vtbl && vtbl->svt_set)
239 CALL_FPTR(vtbl->svt_set)(aTHX_ sv, mg);
242 restore_magic(INT2PTR(void*, (IV)mgs_ix));
247 =for apidoc mg_length
249 Report on the SV's length. See C<sv_magic>.
255 Perl_mg_length(pTHX_ SV *sv)
261 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
262 const MGVTBL * const vtbl = mg->mg_virtual;
263 if (vtbl && vtbl->svt_len) {
264 const I32 mgs_ix = SSNEW(sizeof(MGS));
265 save_magic(mgs_ix, sv);
266 /* omit MGf_GSKIP -- not changed here */
267 len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
268 restore_magic(INT2PTR(void*, (IV)mgs_ix));
274 const U8 *s = (U8*)SvPV_const(sv, len);
275 len = Perl_utf8_length(aTHX_ s, s + len);
278 (void)SvPV_const(sv, len);
283 Perl_mg_size(pTHX_ SV *sv)
287 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
288 const MGVTBL* const vtbl = mg->mg_virtual;
289 if (vtbl && vtbl->svt_len) {
290 const I32 mgs_ix = SSNEW(sizeof(MGS));
292 save_magic(mgs_ix, sv);
293 /* omit MGf_GSKIP -- not changed here */
294 len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
295 restore_magic(INT2PTR(void*, (IV)mgs_ix));
302 return AvFILLp((AV *) sv); /* Fallback to non-tied array */
306 Perl_croak(aTHX_ "Size magic not implemented");
315 Clear something magical that the SV represents. See C<sv_magic>.
321 Perl_mg_clear(pTHX_ SV *sv)
323 const I32 mgs_ix = SSNEW(sizeof(MGS));
326 save_magic(mgs_ix, sv);
328 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
329 const MGVTBL* const vtbl = mg->mg_virtual;
330 /* omit GSKIP -- never set here */
332 if (vtbl && vtbl->svt_clear)
333 CALL_FPTR(vtbl->svt_clear)(aTHX_ sv, mg);
336 restore_magic(INT2PTR(void*, (IV)mgs_ix));
343 Finds the magic pointer for type matching the SV. See C<sv_magic>.
349 Perl_mg_find(pTHX_ const SV *sv, int type)
354 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
355 if (mg->mg_type == type)
365 Copies the magic from one SV to another. See C<sv_magic>.
371 Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
375 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
376 const MGVTBL* const vtbl = mg->mg_virtual;
377 if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){
378 count += CALL_FPTR(vtbl->svt_copy)(aTHX_ sv, mg, nsv, key, klen);
381 const char type = mg->mg_type;
384 (type == PERL_MAGIC_tied)
386 : (type == PERL_MAGIC_regdata && mg->mg_obj)
389 toLOWER(type), key, klen);
398 =for apidoc mg_localize
400 Copy some of the magic from an existing SV to new localized version of
401 that SV. Container magic (eg %ENV, $1, tie) gets copied, value magic
402 doesn't (eg taint, pos).
408 Perl_mg_localize(pTHX_ SV *sv, SV *nsv)
412 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
413 MGVTBL* const vtbl = mg->mg_virtual;
414 switch (mg->mg_type) {
415 /* value magic types: don't copy */
418 case PERL_MAGIC_regex_global:
419 case PERL_MAGIC_nkeys:
420 #ifdef USE_LOCALE_COLLATE
421 case PERL_MAGIC_collxfrm:
424 case PERL_MAGIC_taint:
426 case PERL_MAGIC_vstring:
427 case PERL_MAGIC_utf8:
428 case PERL_MAGIC_substr:
429 case PERL_MAGIC_defelem:
430 case PERL_MAGIC_arylen:
432 case PERL_MAGIC_backref:
433 case PERL_MAGIC_arylen_p:
434 case PERL_MAGIC_rhash:
435 case PERL_MAGIC_symtab:
439 if ((mg->mg_flags & MGf_LOCAL) && vtbl->svt_local)
440 (void)CALL_FPTR(vtbl->svt_local)(aTHX_ nsv, mg);
442 sv_magicext(nsv, mg->mg_obj, mg->mg_type, vtbl,
443 mg->mg_ptr, mg->mg_len);
445 /* container types should remain read-only across localization */
446 SvFLAGS(nsv) |= SvREADONLY(sv);
449 if (SvTYPE(nsv) >= SVt_PVMG && SvMAGIC(nsv)) {
450 SvFLAGS(nsv) |= SvMAGICAL(sv);
460 Free any magic storage used by the SV. See C<sv_magic>.
466 Perl_mg_free(pTHX_ SV *sv)
470 for (mg = SvMAGIC(sv); mg; mg = moremagic) {
471 const MGVTBL* const vtbl = mg->mg_virtual;
472 moremagic = mg->mg_moremagic;
473 if (vtbl && vtbl->svt_free)
474 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
475 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
476 if (mg->mg_len > 0 || mg->mg_type == PERL_MAGIC_utf8)
477 Safefree(mg->mg_ptr);
478 else if (mg->mg_len == HEf_SVKEY)
479 SvREFCNT_dec((SV*)mg->mg_ptr);
481 if (mg->mg_flags & MGf_REFCOUNTED)
482 SvREFCNT_dec(mg->mg_obj);
485 SvMAGIC_set(sv, NULL);
492 Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
498 register const REGEXP * const rx = PM_GETRE(PL_curpm);
501 ? rx->nparens /* @+ */
502 : rx->lastparen; /* @- */
510 Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
514 register const REGEXP * const rx = PM_GETRE(PL_curpm);
516 register const I32 paren = mg->mg_len;
521 if (paren <= (I32)rx->nparens &&
522 (s = rx->startp[paren]) != -1 &&
523 (t = rx->endp[paren]) != -1)
526 if (mg->mg_obj) /* @+ */
531 if (i > 0 && RX_MATCH_UTF8(rx)) {
532 const char * const b = rx->subbeg;
534 i = Perl_utf8_length(aTHX_ (U8*)b, (U8*)(b+i));
545 Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
549 Perl_croak(aTHX_ PL_no_modify);
550 NORETURN_FUNCTION_END;
554 Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
559 register const REGEXP *rx;
562 switch (*mg->mg_ptr) {
563 case '1': case '2': case '3': case '4':
564 case '5': case '6': case '7': case '8': case '9': case '&':
565 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
567 paren = atoi(mg->mg_ptr); /* $& is in [0] */
569 if (paren <= (I32)rx->nparens &&
570 (s1 = rx->startp[paren]) != -1 &&
571 (t1 = rx->endp[paren]) != -1)
575 if (i > 0 && RX_MATCH_UTF8(rx)) {
576 const char * const s = rx->subbeg + s1;
581 if (is_utf8_string_loclen((U8*)s, i, &ep, &el))
585 Perl_croak(aTHX_ "panic: magic_len: %"IVdf, (IV)i);
589 if (ckWARN(WARN_UNINITIALIZED))
594 if (ckWARN(WARN_UNINITIALIZED))
599 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
600 paren = rx->lastparen;
605 case '\016': /* ^N */
606 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
607 paren = rx->lastcloseparen;
613 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
614 if (rx->startp[0] != -1) {
625 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
626 if (rx->endp[0] != -1) {
627 i = rx->sublen - rx->endp[0];
638 if (!SvPOK(sv) && SvNIOK(sv)) {
646 #define SvRTRIM(sv) STMT_START { \
648 STRLEN len = SvCUR(sv); \
649 char * const p = SvPVX(sv); \
650 while (len > 0 && isSPACE(p[len-1])) \
652 SvCUR_set(sv, len); \
658 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
662 register char *s = NULL;
665 const char * const remaining = mg->mg_ptr + 1;
666 const char nextchar = *remaining;
668 switch (*mg->mg_ptr) {
669 case '\001': /* ^A */
670 sv_setsv(sv, PL_bodytarget);
672 case '\003': /* ^C, ^CHILD_ERROR_NATIVE */
673 if (nextchar == '\0') {
674 sv_setiv(sv, (IV)PL_minus_c);
676 else if (strEQ(remaining, "HILD_ERROR_NATIVE")) {
677 sv_setiv(sv, (IV)STATUS_NATIVE);
681 case '\004': /* ^D */
682 sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
684 case '\005': /* ^E */
685 if (nextchar == '\0') {
686 #if defined(MACOS_TRADITIONAL)
690 sv_setnv(sv,(double)gMacPerl_OSErr);
691 sv_setpv(sv, gMacPerl_OSErr ? GetSysErrText(gMacPerl_OSErr, msg) : "");
695 # include <descrip.h>
696 # include <starlet.h>
698 $DESCRIPTOR(msgdsc,msg);
699 sv_setnv(sv,(NV) vaxc$errno);
700 if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
701 sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
706 if (!(_emx_env & 0x200)) { /* Under DOS */
707 sv_setnv(sv, (NV)errno);
708 sv_setpv(sv, errno ? Strerror(errno) : "");
710 if (errno != errno_isOS2) {
711 const int tmp = _syserrno();
712 if (tmp) /* 2nd call to _syserrno() makes it 0 */
715 sv_setnv(sv, (NV)Perl_rc);
716 sv_setpv(sv, os2error(Perl_rc));
720 const DWORD dwErr = GetLastError();
721 sv_setnv(sv, (NV)dwErr);
723 PerlProc_GetOSError(sv, dwErr);
726 sv_setpvn(sv, "", 0);
731 const int saveerrno = errno;
732 sv_setnv(sv, (NV)errno);
733 sv_setpv(sv, errno ? Strerror(errno) : "");
738 SvNOK_on(sv); /* what a wonderful hack! */
740 else if (strEQ(remaining, "NCODING"))
741 sv_setsv(sv, PL_encoding);
743 case '\006': /* ^F */
744 sv_setiv(sv, (IV)PL_maxsysfd);
746 case '\010': /* ^H */
747 sv_setiv(sv, (IV)PL_hints);
749 case '\011': /* ^I */ /* NOT \t in EBCDIC */
751 sv_setpv(sv, PL_inplace);
753 sv_setsv(sv, &PL_sv_undef);
755 case '\017': /* ^O & ^OPEN */
756 if (nextchar == '\0') {
757 sv_setpv(sv, PL_osname);
760 else if (strEQ(remaining, "PEN")) {
761 if (!PL_compiling.cop_io)
762 sv_setsv(sv, &PL_sv_undef);
764 sv_setsv(sv, PL_compiling.cop_io);
768 case '\020': /* ^P */
769 sv_setiv(sv, (IV)PL_perldb);
771 case '\023': /* ^S */
772 if (nextchar == '\0') {
773 if (PL_lex_state != LEX_NOTPARSING)
776 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
781 case '\024': /* ^T */
782 if (nextchar == '\0') {
784 sv_setnv(sv, PL_basetime);
786 sv_setiv(sv, (IV)PL_basetime);
789 else if (strEQ(remaining, "AINT"))
790 sv_setiv(sv, PL_tainting
791 ? (PL_taint_warn || PL_unsafe ? -1 : 1)
794 case '\025': /* $^UNICODE, $^UTF8LOCALE, $^UTF8CACHE */
795 if (strEQ(remaining, "NICODE"))
796 sv_setuv(sv, (UV) PL_unicode);
797 else if (strEQ(remaining, "TF8LOCALE"))
798 sv_setuv(sv, (UV) PL_utf8locale);
799 else if (strEQ(remaining, "TF8CACHE"))
800 sv_setiv(sv, (IV) PL_utf8cache);
802 case '\027': /* ^W & $^WARNING_BITS */
803 if (nextchar == '\0')
804 sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
805 else if (strEQ(remaining, "ARNING_BITS")) {
806 if (PL_compiling.cop_warnings == pWARN_NONE) {
807 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
809 else if (PL_compiling.cop_warnings == pWARN_STD) {
812 (PL_dowarn & G_WARN_ON) ? WARN_ALLstring : WARN_NONEstring,
816 else if (PL_compiling.cop_warnings == pWARN_ALL) {
817 /* Get the bit mask for $warnings::Bits{all}, because
818 * it could have been extended by warnings::register */
820 HV * const bits=get_hv("warnings::Bits", FALSE);
821 if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
822 sv_setsv(sv, *bits_all);
825 sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
829 sv_setsv(sv, PL_compiling.cop_warnings);
834 case '1': case '2': case '3': case '4':
835 case '5': case '6': case '7': case '8': case '9': case '&':
836 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
840 * Pre-threads, this was paren = atoi(GvENAME((GV*)mg->mg_obj));
841 * XXX Does the new way break anything?
843 paren = atoi(mg->mg_ptr); /* $& is in [0] */
845 if (paren <= (I32)rx->nparens &&
846 (s1 = rx->startp[paren]) != -1 &&
847 (t1 = rx->endp[paren]) != -1)
855 const int oldtainted = PL_tainted;
858 PL_tainted = oldtainted;
859 if (RX_MATCH_UTF8(rx) && is_utf8_string((U8*)s, i))
864 if (RX_MATCH_TAINTED(rx)) {
865 MAGIC* const mg = SvMAGIC(sv);
868 SvMAGIC_set(sv, mg->mg_moremagic);
870 if ((mgt = SvMAGIC(sv))) {
871 mg->mg_moremagic = mgt;
881 sv_setsv(sv,&PL_sv_undef);
884 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
885 paren = rx->lastparen;
889 sv_setsv(sv,&PL_sv_undef);
891 case '\016': /* ^N */
892 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
893 paren = rx->lastcloseparen;
897 sv_setsv(sv,&PL_sv_undef);
900 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
901 if ((s = rx->subbeg) && rx->startp[0] != -1) {
906 sv_setsv(sv,&PL_sv_undef);
909 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
910 if (rx->subbeg && rx->endp[0] != -1) {
911 s = rx->subbeg + rx->endp[0];
912 i = rx->sublen - rx->endp[0];
916 sv_setsv(sv,&PL_sv_undef);
919 if (GvIO(PL_last_in_gv)) {
920 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
925 sv_setiv(sv, (IV)STATUS_CURRENT);
926 #ifdef COMPLEX_STATUS
927 LvTARGOFF(sv) = PL_statusvalue;
928 LvTARGLEN(sv) = PL_statusvalue_vms;
933 if (GvIOp(PL_defoutgv))
934 s = IoTOP_NAME(GvIOp(PL_defoutgv));
938 sv_setpv(sv,GvENAME(PL_defoutgv));
943 if (GvIOp(PL_defoutgv))
944 s = IoFMT_NAME(GvIOp(PL_defoutgv));
946 s = GvENAME(PL_defoutgv);
950 if (GvIOp(PL_defoutgv))
951 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
954 if (GvIOp(PL_defoutgv))
955 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
958 if (GvIOp(PL_defoutgv))
959 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
966 WITH_THR(sv_setiv(sv, (IV)CopARYBASE_get(PL_curcop)));
969 if (GvIOp(PL_defoutgv))
970 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
976 sv_copypv(sv, PL_ors_sv);
980 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
981 sv_setpv(sv, errno ? Strerror(errno) : "");
984 const int saveerrno = errno;
985 sv_setnv(sv, (NV)errno);
987 if (errno == errno_isOS2 || errno == errno_isOS2_set)
988 sv_setpv(sv, os2error(Perl_rc));
991 sv_setpv(sv, errno ? Strerror(errno) : "");
996 SvNOK_on(sv); /* what a wonderful hack! */
999 sv_setiv(sv, (IV)PL_uid);
1002 sv_setiv(sv, (IV)PL_euid);
1005 sv_setiv(sv, (IV)PL_gid);
1008 sv_setiv(sv, (IV)PL_egid);
1010 #ifdef HAS_GETGROUPS
1012 Groups_t *gary = NULL;
1013 I32 i, num_groups = getgroups(0, gary);
1014 Newx(gary, num_groups, Groups_t);
1015 num_groups = getgroups(num_groups, gary);
1016 for (i = 0; i < num_groups; i++)
1017 Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]);
1020 (void)SvIOK_on(sv); /* what a wonderful hack! */
1023 #ifndef MACOS_TRADITIONAL
1032 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
1034 struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
1036 if (uf && uf->uf_val)
1037 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
1042 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
1045 STRLEN len = 0, klen;
1046 const char *s = SvOK(sv) ? SvPV_const(sv,len) : "";
1047 const char * const ptr = MgPV_const(mg,klen);
1050 #ifdef DYNAMIC_ENV_FETCH
1051 /* We just undefd an environment var. Is a replacement */
1052 /* waiting in the wings? */
1054 SV ** const valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE);
1056 s = SvPV_const(*valp, len);
1060 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
1061 /* And you'll never guess what the dog had */
1062 /* in its mouth... */
1064 MgTAINTEDDIR_off(mg);
1066 if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
1067 char pathbuf[256], eltbuf[256], *cp, *elt;
1071 strncpy(eltbuf, s, 255);
1074 do { /* DCL$PATH may be a search list */
1075 while (1) { /* as may dev portion of any element */
1076 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1077 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1078 cando_by_name(S_IWUSR,0,elt) ) {
1079 MgTAINTEDDIR_on(mg);
1083 if ((cp = strchr(elt, ':')) != NULL)
1085 if (my_trnlnm(elt, eltbuf, j++))
1091 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1094 if (s && klen == 4 && strEQ(ptr,"PATH")) {
1095 const char * const strend = s + len;
1097 while (s < strend) {
1101 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
1102 s, strend, ':', &i);
1104 if (i >= sizeof tmpbuf /* too long -- assume the worst */
1106 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1107 MgTAINTEDDIR_on(mg);
1113 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1119 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1121 PERL_UNUSED_ARG(sv);
1122 my_setenv(MgPV_nolen_const(mg),NULL);
1127 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1130 PERL_UNUSED_ARG(mg);
1132 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1134 if (PL_localizing) {
1137 hv_iterinit((HV*)sv);
1138 while ((entry = hv_iternext((HV*)sv))) {
1140 my_setenv(hv_iterkey(entry, &keylen),
1141 SvPV_nolen_const(hv_iterval((HV*)sv, entry)));
1149 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1152 PERL_UNUSED_ARG(sv);
1153 PERL_UNUSED_ARG(mg);
1155 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1163 #ifdef HAS_SIGPROCMASK
1165 restore_sigmask(pTHX_ SV *save_sv)
1167 const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1168 (void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0);
1172 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1175 /* Are we fetching a signal entry? */
1176 const I32 i = whichsig(MgPV_nolen_const(mg));
1179 sv_setsv(sv,PL_psig_ptr[i]);
1181 Sighandler_t sigstate;
1182 sigstate = rsignal_state(i);
1183 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1184 if (PL_sig_handlers_initted && PL_sig_ignoring[i]) sigstate = SIG_IGN;
1186 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1187 if (PL_sig_handlers_initted && PL_sig_defaulting[i]) sigstate = SIG_DFL;
1189 /* cache state so we don't fetch it again */
1190 if(sigstate == (Sighandler_t) SIG_IGN)
1191 sv_setpv(sv,"IGNORE");
1193 sv_setsv(sv,&PL_sv_undef);
1194 PL_psig_ptr[i] = SvREFCNT_inc_simple(sv);
1201 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1203 /* XXX Some of this code was copied from Perl_magic_setsig. A little
1204 * refactoring might be in order.
1207 register const char * const s = MgPV_nolen_const(mg);
1208 PERL_UNUSED_ARG(sv);
1211 if (strEQ(s,"__DIE__"))
1213 else if (strEQ(s,"__WARN__"))
1216 Perl_croak(aTHX_ "No such hook: %s", s);
1218 SV * const to_dec = *svp;
1220 SvREFCNT_dec(to_dec);
1224 /* Are we clearing a signal entry? */
1225 const I32 i = whichsig(s);
1227 #ifdef HAS_SIGPROCMASK
1230 /* Avoid having the signal arrive at a bad time, if possible. */
1233 sigprocmask(SIG_BLOCK, &set, &save);
1235 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1236 SAVEFREESV(save_sv);
1237 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1240 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1241 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1243 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1244 PL_sig_defaulting[i] = 1;
1245 (void)rsignal(i, PL_csighandlerp);
1247 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1249 if(PL_psig_name[i]) {
1250 SvREFCNT_dec(PL_psig_name[i]);
1253 if(PL_psig_ptr[i]) {
1254 SV * const to_dec=PL_psig_ptr[i];
1257 SvREFCNT_dec(to_dec);
1267 S_raise_signal(pTHX_ int sig)
1270 /* Set a flag to say this signal is pending */
1271 PL_psig_pend[sig]++;
1272 /* And one to say _a_ signal is pending */
1277 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1278 Perl_csighandler(int sig, ...)
1280 Perl_csighandler(int sig)
1283 #ifdef PERL_GET_SIG_CONTEXT
1284 dTHXa(PERL_GET_SIG_CONTEXT);
1288 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1289 (void) rsignal(sig, PL_csighandlerp);
1290 if (PL_sig_ignoring[sig]) return;
1292 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1293 if (PL_sig_defaulting[sig])
1294 #ifdef KILL_BY_SIGPRC
1295 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1300 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
1301 /* Call the perl level handler now--
1302 * with risk we may be in malloc() etc. */
1303 (*PL_sighandlerp)(sig);
1305 S_raise_signal(aTHX_ sig);
1308 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1310 Perl_csighandler_init(void)
1313 if (PL_sig_handlers_initted) return;
1315 for (sig = 1; sig < SIG_SIZE; sig++) {
1316 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1318 PL_sig_defaulting[sig] = 1;
1319 (void) rsignal(sig, PL_csighandlerp);
1321 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1322 PL_sig_ignoring[sig] = 0;
1325 PL_sig_handlers_initted = 1;
1330 Perl_despatch_signals(pTHX)
1335 for (sig = 1; sig < SIG_SIZE; sig++) {
1336 if (PL_psig_pend[sig]) {
1337 PERL_BLOCKSIG_ADD(set, sig);
1338 PL_psig_pend[sig] = 0;
1339 PERL_BLOCKSIG_BLOCK(set);
1340 (*PL_sighandlerp)(sig);
1341 PERL_BLOCKSIG_UNBLOCK(set);
1347 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1352 /* Need to be careful with SvREFCNT_dec(), because that can have side
1353 * effects (due to closures). We must make sure that the new disposition
1354 * is in place before it is called.
1358 #ifdef HAS_SIGPROCMASK
1363 register const char *s = MgPV_const(mg,len);
1365 if (strEQ(s,"__DIE__"))
1367 else if (strEQ(s,"__WARN__"))
1370 Perl_croak(aTHX_ "No such hook: %s", s);
1378 i = whichsig(s); /* ...no, a brick */
1380 if (ckWARN(WARN_SIGNAL))
1381 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
1384 #ifdef HAS_SIGPROCMASK
1385 /* Avoid having the signal arrive at a bad time, if possible. */
1388 sigprocmask(SIG_BLOCK, &set, &save);
1390 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1391 SAVEFREESV(save_sv);
1392 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1395 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1396 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1398 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1399 PL_sig_ignoring[i] = 0;
1401 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1402 PL_sig_defaulting[i] = 0;
1404 SvREFCNT_dec(PL_psig_name[i]);
1405 to_dec = PL_psig_ptr[i];
1406 PL_psig_ptr[i] = SvREFCNT_inc_simple(sv);
1407 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1408 PL_psig_name[i] = newSVpvn(s, len);
1409 SvREADONLY_on(PL_psig_name[i]);
1411 if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
1413 (void)rsignal(i, PL_csighandlerp);
1414 #ifdef HAS_SIGPROCMASK
1419 *svp = SvREFCNT_inc_simple_NN(sv);
1421 SvREFCNT_dec(to_dec);
1424 s = SvPV_force(sv,len);
1425 if (strEQ(s,"IGNORE")) {
1427 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1428 PL_sig_ignoring[i] = 1;
1429 (void)rsignal(i, PL_csighandlerp);
1431 (void)rsignal(i, (Sighandler_t) SIG_IGN);
1435 else if (strEQ(s,"DEFAULT") || !*s) {
1437 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1439 PL_sig_defaulting[i] = 1;
1440 (void)rsignal(i, PL_csighandlerp);
1443 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1448 * We should warn if HINT_STRICT_REFS, but without
1449 * access to a known hint bit in a known OP, we can't
1450 * tell whether HINT_STRICT_REFS is in force or not.
1452 if (!strchr(s,':') && !strchr(s,'\''))
1453 Perl_sv_insert(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"));
1455 (void)rsignal(i, PL_csighandlerp);
1457 *svp = SvREFCNT_inc_simple(sv);
1459 #ifdef HAS_SIGPROCMASK
1464 SvREFCNT_dec(to_dec);
1467 #endif /* !PERL_MICRO */
1470 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1473 PERL_UNUSED_ARG(sv);
1474 PERL_UNUSED_ARG(mg);
1475 PL_sub_generation++;
1480 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
1483 PERL_UNUSED_ARG(sv);
1484 PERL_UNUSED_ARG(mg);
1485 /* HV_badAMAGIC_on(Sv_STASH(sv)); */
1486 PL_amagic_generation++;
1492 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1494 HV * const hv = (HV*)LvTARG(sv);
1496 PERL_UNUSED_ARG(mg);
1499 (void) hv_iterinit(hv);
1500 if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
1503 while (hv_iternext(hv))
1508 sv_setiv(sv, (IV)i);
1513 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1515 PERL_UNUSED_ARG(mg);
1517 hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
1522 /* caller is responsible for stack switching/cleanup */
1524 S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV *val)
1531 PUSHs(SvTIED_obj(sv, mg));
1534 if (mg->mg_len >= 0)
1535 PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len)));
1536 else if (mg->mg_len == HEf_SVKEY)
1537 PUSHs((SV*)mg->mg_ptr);
1539 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1540 PUSHs(sv_2mortal(newSViv(mg->mg_len)));
1548 return call_method(meth, flags);
1552 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
1558 PUSHSTACKi(PERLSI_MAGIC);
1560 if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
1561 sv_setsv(sv, *PL_stack_sp--);
1571 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1574 mg->mg_flags |= MGf_GSKIP;
1575 magic_methpack(sv,mg,"FETCH");
1580 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1584 PUSHSTACKi(PERLSI_MAGIC);
1585 magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
1592 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1594 return magic_methpack(sv,mg,"DELETE");
1599 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1606 PUSHSTACKi(PERLSI_MAGIC);
1607 if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
1608 sv = *PL_stack_sp--;
1609 retval = (U32) SvIV(sv)-1;
1618 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1623 PUSHSTACKi(PERLSI_MAGIC);
1625 XPUSHs(SvTIED_obj(sv, mg));
1627 call_method("CLEAR", G_SCALAR|G_DISCARD);
1635 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1638 const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
1642 PUSHSTACKi(PERLSI_MAGIC);
1645 PUSHs(SvTIED_obj(sv, mg));
1650 if (call_method(meth, G_SCALAR))
1651 sv_setsv(key, *PL_stack_sp--);
1660 Perl_magic_existspack(pTHX_ SV *sv, MAGIC *mg)
1662 return magic_methpack(sv,mg,"EXISTS");
1666 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1669 SV *retval = &PL_sv_undef;
1670 SV * const tied = SvTIED_obj((SV*)hv, mg);
1671 HV * const pkg = SvSTASH((SV*)SvRV(tied));
1673 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1675 if (HvEITER_get(hv))
1676 /* we are in an iteration so the hash cannot be empty */
1678 /* no xhv_eiter so now use FIRSTKEY */
1679 key = sv_newmortal();
1680 magic_nextpack((SV*)hv, mg, key);
1681 HvEITER_set(hv, NULL); /* need to reset iterator */
1682 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1685 /* there is a SCALAR method that we can call */
1687 PUSHSTACKi(PERLSI_MAGIC);
1693 if (call_method("SCALAR", G_SCALAR))
1694 retval = *PL_stack_sp--;
1701 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1704 GV * const gv = PL_DBline;
1705 const I32 i = SvTRUE(sv);
1706 SV ** const svp = av_fetch(GvAV(gv),
1707 atoi(MgPV_nolen_const(mg)), FALSE);
1708 if (svp && SvIOKp(*svp)) {
1709 OP * const o = INT2PTR(OP*,SvIVX(*svp));
1711 /* set or clear breakpoint in the relevant control op */
1713 o->op_flags |= OPf_SPECIAL;
1715 o->op_flags &= ~OPf_SPECIAL;
1722 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
1725 const AV * const obj = (AV*)mg->mg_obj;
1727 sv_setiv(sv, AvFILL(obj) + CopARYBASE_get(PL_curcop));
1735 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
1738 AV * const obj = (AV*)mg->mg_obj;
1740 av_fill(obj, SvIV(sv) - CopARYBASE_get(PL_curcop));
1742 if (ckWARN(WARN_MISC))
1743 Perl_warner(aTHX_ packWARN(WARN_MISC),
1744 "Attempt to set length of freed array");
1750 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
1753 PERL_UNUSED_ARG(sv);
1754 /* during global destruction, mg_obj may already have been freed */
1755 if (PL_in_clean_all)
1758 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
1761 /* arylen scalar holds a pointer back to the array, but doesn't own a
1762 reference. Hence the we (the array) are about to go away with it
1763 still pointing at us. Clear its pointer, else it would be pointing
1764 at free memory. See the comment in sv_magic about reference loops,
1765 and why it can't own a reference to us. */
1772 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
1775 SV* const lsv = LvTARG(sv);
1777 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1778 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1779 if (mg && mg->mg_len >= 0) {
1782 sv_pos_b2u(lsv, &i);
1783 sv_setiv(sv, i + CopARYBASE_get(PL_curcop));
1792 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
1795 SV* const lsv = LvTARG(sv);
1802 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
1803 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1807 #ifdef PERL_OLD_COPY_ON_WRITE
1809 sv_force_normal_flags(lsv, 0);
1811 mg = sv_magicext(lsv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
1814 else if (!SvOK(sv)) {
1818 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1820 pos = SvIV(sv) - CopARYBASE_get(PL_curcop);
1823 ulen = sv_len_utf8(lsv);
1833 else if (pos > (SSize_t)len)
1838 sv_pos_u2b(lsv, &p, 0);
1843 mg->mg_flags &= ~MGf_MINMATCH;
1849 Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg)
1852 PERL_UNUSED_ARG(mg);
1856 if (SvFLAGS(sv) & SVp_SCREAM
1857 && (SvTYPE(sv) == SVt_PVGV || SvTYPE(sv) == SVt_PVGV)) {
1858 /* We're actually already a typeglob, so don't need the stuff below.
1862 gv = gv_fetchsv(sv, GV_ADD, SVt_PVGV);
1867 GvGP(sv) = gp_ref(GvGP(gv));
1872 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
1875 SV * const lsv = LvTARG(sv);
1876 const char * const tmps = SvPV_const(lsv,len);
1877 I32 offs = LvTARGOFF(sv);
1878 I32 rem = LvTARGLEN(sv);
1879 PERL_UNUSED_ARG(mg);
1882 sv_pos_u2b(lsv, &offs, &rem);
1883 if (offs > (I32)len)
1885 if (rem + offs > (I32)len)
1887 sv_setpvn(sv, tmps + offs, (STRLEN)rem);
1894 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
1898 const char *tmps = SvPV_const(sv, len);
1899 SV * const lsv = LvTARG(sv);
1900 I32 lvoff = LvTARGOFF(sv);
1901 I32 lvlen = LvTARGLEN(sv);
1902 PERL_UNUSED_ARG(mg);
1905 sv_utf8_upgrade(lsv);
1906 sv_pos_u2b(lsv, &lvoff, &lvlen);
1907 sv_insert(lsv, lvoff, lvlen, tmps, len);
1908 LvTARGLEN(sv) = sv_len_utf8(sv);
1911 else if (lsv && SvUTF8(lsv)) {
1912 sv_pos_u2b(lsv, &lvoff, &lvlen);
1913 LvTARGLEN(sv) = len;
1914 tmps = (char*)bytes_to_utf8((U8*)tmps, &len);
1915 sv_insert(lsv, lvoff, lvlen, tmps, len);
1919 sv_insert(lsv, lvoff, lvlen, tmps, len);
1920 LvTARGLEN(sv) = len;
1928 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
1931 PERL_UNUSED_ARG(sv);
1932 TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
1937 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
1940 PERL_UNUSED_ARG(sv);
1941 /* update taint status unless we're restoring at scope exit */
1942 if (PL_localizing != 2) {
1952 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
1954 SV * const lsv = LvTARG(sv);
1955 PERL_UNUSED_ARG(mg);
1958 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
1966 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
1968 PERL_UNUSED_ARG(mg);
1969 do_vecset(sv); /* XXX slurp this routine */
1974 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
1978 if (LvTARGLEN(sv)) {
1980 SV * const ahv = LvTARG(sv);
1981 HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
1986 AV* const av = (AV*)LvTARG(sv);
1987 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
1988 targ = AvARRAY(av)[LvTARGOFF(sv)];
1990 if (targ && targ != &PL_sv_undef) {
1991 /* somebody else defined it for us */
1992 SvREFCNT_dec(LvTARG(sv));
1993 LvTARG(sv) = SvREFCNT_inc_simple_NN(targ);
1995 SvREFCNT_dec(mg->mg_obj);
1997 mg->mg_flags &= ~MGf_REFCOUNTED;
2002 sv_setsv(sv, targ ? targ : &PL_sv_undef);
2007 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
2009 PERL_UNUSED_ARG(mg);
2013 sv_setsv(LvTARG(sv), sv);
2014 SvSETMAGIC(LvTARG(sv));
2020 Perl_vivify_defelem(pTHX_ SV *sv)
2026 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2029 SV * const ahv = LvTARG(sv);
2030 HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
2033 if (!value || value == &PL_sv_undef)
2034 Perl_croak(aTHX_ PL_no_helem_sv, mg->mg_obj);
2037 AV* const av = (AV*)LvTARG(sv);
2038 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
2039 LvTARG(sv) = NULL; /* array can't be extended */
2041 SV* const * const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
2042 if (!svp || (value = *svp) == &PL_sv_undef)
2043 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
2046 SvREFCNT_inc_simple_void(value);
2047 SvREFCNT_dec(LvTARG(sv));
2050 SvREFCNT_dec(mg->mg_obj);
2052 mg->mg_flags &= ~MGf_REFCOUNTED;
2056 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2058 return Perl_sv_kill_backrefs(aTHX_ sv, (AV*)mg->mg_obj);
2062 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2064 PERL_UNUSED_CONTEXT;
2071 Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
2073 PERL_UNUSED_ARG(mg);
2074 sv_unmagic(sv, PERL_MAGIC_bm);
2080 Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
2082 PERL_UNUSED_ARG(mg);
2083 sv_unmagic(sv, PERL_MAGIC_fm);
2089 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2091 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2093 if (uf && uf->uf_set)
2094 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2099 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2101 PERL_UNUSED_ARG(mg);
2102 sv_unmagic(sv, PERL_MAGIC_qr);
2107 Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
2110 regexp * const re = (regexp *)mg->mg_obj;
2111 PERL_UNUSED_ARG(sv);
2117 #ifdef USE_LOCALE_COLLATE
2119 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2122 * RenE<eacute> Descartes said "I think not."
2123 * and vanished with a faint plop.
2125 PERL_UNUSED_CONTEXT;
2126 PERL_UNUSED_ARG(sv);
2128 Safefree(mg->mg_ptr);
2134 #endif /* USE_LOCALE_COLLATE */
2136 /* Just clear the UTF-8 cache data. */
2138 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2140 PERL_UNUSED_CONTEXT;
2141 PERL_UNUSED_ARG(sv);
2142 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2144 mg->mg_len = -1; /* The mg_len holds the len cache. */
2149 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2152 register const char *s;
2155 switch (*mg->mg_ptr) {
2156 case '\001': /* ^A */
2157 sv_setsv(PL_bodytarget, sv);
2159 case '\003': /* ^C */
2160 PL_minus_c = (bool)SvIV(sv);
2163 case '\004': /* ^D */
2165 s = SvPV_nolen_const(sv);
2166 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2167 DEBUG_x(dump_all());
2169 PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG;
2172 case '\005': /* ^E */
2173 if (*(mg->mg_ptr+1) == '\0') {
2174 #ifdef MACOS_TRADITIONAL
2175 gMacPerl_OSErr = SvIV(sv);
2178 set_vaxc_errno(SvIV(sv));
2181 SetLastError( SvIV(sv) );
2184 os2_setsyserrno(SvIV(sv));
2186 /* will anyone ever use this? */
2187 SETERRNO(SvIV(sv), 4);
2193 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2195 SvREFCNT_dec(PL_encoding);
2196 if (SvOK(sv) || SvGMAGICAL(sv)) {
2197 PL_encoding = newSVsv(sv);
2204 case '\006': /* ^F */
2205 PL_maxsysfd = SvIV(sv);
2207 case '\010': /* ^H */
2208 PL_hints = SvIV(sv);
2210 case '\011': /* ^I */ /* NOT \t in EBCDIC */
2211 Safefree(PL_inplace);
2212 PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
2214 case '\017': /* ^O */
2215 if (*(mg->mg_ptr+1) == '\0') {
2216 Safefree(PL_osname);
2219 TAINT_PROPER("assigning to $^O");
2220 PL_osname = savesvpv(sv);
2223 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2224 if (!PL_compiling.cop_io)
2225 PL_compiling.cop_io = newSVsv(sv);
2227 sv_setsv(PL_compiling.cop_io,sv);
2230 case '\020': /* ^P */
2231 PL_perldb = SvIV(sv);
2232 if (PL_perldb && !PL_DBsingle)
2235 case '\024': /* ^T */
2237 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2239 PL_basetime = (Time_t)SvIV(sv);
2242 case '\025': /* ^UTF8CACHE */
2243 if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
2244 PL_utf8cache = (signed char) sv_2iv(sv);
2247 case '\027': /* ^W & $^WARNING_BITS */
2248 if (*(mg->mg_ptr+1) == '\0') {
2249 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2251 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2252 | (i ? G_WARN_ON : G_WARN_OFF) ;
2255 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2256 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2257 if (!SvPOK(sv) && PL_localizing) {
2258 sv_setpvn(sv, WARN_NONEstring, WARNsize);
2259 PL_compiling.cop_warnings = pWARN_NONE;
2264 int accumulate = 0 ;
2265 int any_fatals = 0 ;
2266 const char * const ptr = SvPV_const(sv, len) ;
2267 for (i = 0 ; i < len ; ++i) {
2268 accumulate |= ptr[i] ;
2269 any_fatals |= (ptr[i] & 0xAA) ;
2272 PL_compiling.cop_warnings = pWARN_NONE;
2273 else if (isWARN_on(sv, WARN_ALL) && !any_fatals) {
2274 PL_compiling.cop_warnings = pWARN_ALL;
2275 PL_dowarn |= G_WARN_ONCE ;
2278 if (specialWARN(PL_compiling.cop_warnings))
2279 PL_compiling.cop_warnings = newSVsv(sv) ;
2281 sv_setsv(PL_compiling.cop_warnings, sv);
2282 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2283 PL_dowarn |= G_WARN_ONCE ;
2291 if (PL_localizing) {
2292 if (PL_localizing == 1)
2293 SAVESPTR(PL_last_in_gv);
2295 else if (SvOK(sv) && GvIO(PL_last_in_gv))
2296 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2299 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2300 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2301 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2304 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2305 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2306 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2309 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
2312 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
2313 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2314 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2317 IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
2321 IO * const io = GvIOp(PL_defoutgv);
2324 if ((SvIV(sv)) == 0)
2325 IoFLAGS(io) &= ~IOf_FLUSH;
2327 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2328 PerlIO *ofp = IoOFP(io);
2330 (void)PerlIO_flush(ofp);
2331 IoFLAGS(io) |= IOf_FLUSH;
2337 SvREFCNT_dec(PL_rs);
2338 PL_rs = newSVsv(sv);
2342 SvREFCNT_dec(PL_ors_sv);
2343 if (SvOK(sv) || SvGMAGICAL(sv)) {
2344 PL_ors_sv = newSVsv(sv);
2352 SvREFCNT_dec(PL_ofs_sv);
2353 if (SvOK(sv) || SvGMAGICAL(sv)) {
2354 PL_ofs_sv = newSVsv(sv);
2361 CopARYBASE_set(&PL_compiling, SvIV(sv));
2364 #ifdef COMPLEX_STATUS
2365 if (PL_localizing == 2) {
2366 PL_statusvalue = LvTARGOFF(sv);
2367 PL_statusvalue_vms = LvTARGLEN(sv);
2371 #ifdef VMSISH_STATUS
2373 STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2376 STATUS_UNIX_EXIT_SET(SvIV(sv));
2381 # define PERL_VMS_BANG vaxc$errno
2383 # define PERL_VMS_BANG 0
2385 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2386 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2391 if (PL_delaymagic) {
2392 PL_delaymagic |= DM_RUID;
2393 break; /* don't do magic till later */
2396 (void)setruid((Uid_t)PL_uid);
2399 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2401 #ifdef HAS_SETRESUID
2402 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2404 if (PL_uid == PL_euid) { /* special case $< = $> */
2406 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2407 if (PL_uid != 0 && PerlProc_getuid() == 0)
2408 (void)PerlProc_setuid(0);
2410 (void)PerlProc_setuid(PL_uid);
2412 PL_uid = PerlProc_getuid();
2413 Perl_croak(aTHX_ "setruid() not implemented");
2418 PL_uid = PerlProc_getuid();
2419 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2423 if (PL_delaymagic) {
2424 PL_delaymagic |= DM_EUID;
2425 break; /* don't do magic till later */
2428 (void)seteuid((Uid_t)PL_euid);
2431 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2433 #ifdef HAS_SETRESUID
2434 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2436 if (PL_euid == PL_uid) /* special case $> = $< */
2437 PerlProc_setuid(PL_euid);
2439 PL_euid = PerlProc_geteuid();
2440 Perl_croak(aTHX_ "seteuid() not implemented");
2445 PL_euid = PerlProc_geteuid();
2446 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2450 if (PL_delaymagic) {
2451 PL_delaymagic |= DM_RGID;
2452 break; /* don't do magic till later */
2455 (void)setrgid((Gid_t)PL_gid);
2458 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2460 #ifdef HAS_SETRESGID
2461 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2463 if (PL_gid == PL_egid) /* special case $( = $) */
2464 (void)PerlProc_setgid(PL_gid);
2466 PL_gid = PerlProc_getgid();
2467 Perl_croak(aTHX_ "setrgid() not implemented");
2472 PL_gid = PerlProc_getgid();
2473 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2476 #ifdef HAS_SETGROUPS
2478 const char *p = SvPV_const(sv, len);
2479 Groups_t *gary = NULL;
2484 for (i = 0; i < NGROUPS; ++i) {
2485 while (*p && !isSPACE(*p))
2492 Newx(gary, i + 1, Groups_t);
2494 Renew(gary, i + 1, Groups_t);
2498 (void)setgroups(i, gary);
2502 #else /* HAS_SETGROUPS */
2504 #endif /* HAS_SETGROUPS */
2505 if (PL_delaymagic) {
2506 PL_delaymagic |= DM_EGID;
2507 break; /* don't do magic till later */
2510 (void)setegid((Gid_t)PL_egid);
2513 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2515 #ifdef HAS_SETRESGID
2516 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2518 if (PL_egid == PL_gid) /* special case $) = $( */
2519 (void)PerlProc_setgid(PL_egid);
2521 PL_egid = PerlProc_getegid();
2522 Perl_croak(aTHX_ "setegid() not implemented");
2527 PL_egid = PerlProc_getegid();
2528 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2531 PL_chopset = SvPV_force(sv,len);
2533 #ifndef MACOS_TRADITIONAL
2535 LOCK_DOLLARZERO_MUTEX;
2536 #ifdef HAS_SETPROCTITLE
2537 /* The BSDs don't show the argv[] in ps(1) output, they
2538 * show a string from the process struct and provide
2539 * the setproctitle() routine to manipulate that. */
2540 if (PL_origalen != 1) {
2541 s = SvPV_const(sv, len);
2542 # if __FreeBSD_version > 410001
2543 /* The leading "-" removes the "perl: " prefix,
2544 * but not the "(perl) suffix from the ps(1)
2545 * output, because that's what ps(1) shows if the
2546 * argv[] is modified. */
2547 setproctitle("-%s", s);
2548 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2549 /* This doesn't really work if you assume that
2550 * $0 = 'foobar'; will wipe out 'perl' from the $0
2551 * because in ps(1) output the result will be like
2552 * sprintf("perl: %s (perl)", s)
2553 * I guess this is a security feature:
2554 * one (a user process) cannot get rid of the original name.
2556 setproctitle("%s", s);
2560 #if defined(__hpux) && defined(PSTAT_SETCMD)
2561 if (PL_origalen != 1) {
2563 s = SvPV_const(sv, len);
2564 un.pst_command = (char *)s;
2565 pstat(PSTAT_SETCMD, un, len, 0, 0);
2568 if (PL_origalen > 1) {
2569 /* PL_origalen is set in perl_parse(). */
2570 s = SvPV_force(sv,len);
2571 if (len >= (STRLEN)PL_origalen-1) {
2572 /* Longer than original, will be truncated. We assume that
2573 * PL_origalen bytes are available. */
2574 Copy(s, PL_origargv[0], PL_origalen-1, char);
2577 /* Shorter than original, will be padded. */
2578 Copy(s, PL_origargv[0], len, char);
2579 PL_origargv[0][len] = 0;
2580 memset(PL_origargv[0] + len + 1,
2581 /* Is the space counterintuitive? Yes.
2582 * (You were expecting \0?)
2583 * Does it work? Seems to. (In Linux 2.4.20 at least.)
2586 PL_origalen - len - 1);
2588 PL_origargv[0][PL_origalen-1] = 0;
2589 for (i = 1; i < PL_origargc; i++)
2592 UNLOCK_DOLLARZERO_MUTEX;
2600 Perl_whichsig(pTHX_ const char *sig)
2602 register char* const* sigv;
2603 PERL_UNUSED_CONTEXT;
2605 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
2606 if (strEQ(sig,*sigv))
2607 return PL_sig_num[sigv - (char* const*)PL_sig_name];
2609 if (strEQ(sig,"CHLD"))
2613 if (strEQ(sig,"CLD"))
2620 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2621 Perl_sighandler(int sig, ...)
2623 Perl_sighandler(int sig)
2626 #ifdef PERL_GET_SIG_CONTEXT
2627 dTHXa(PERL_GET_SIG_CONTEXT);
2634 SV * const tSv = PL_Sv;
2638 XPV * const tXpv = PL_Xpv;
2640 if (PL_savestack_ix + 15 <= PL_savestack_max)
2642 if (PL_markstack_ptr < PL_markstack_max - 2)
2644 if (PL_scopestack_ix < PL_scopestack_max - 3)
2647 if (!PL_psig_ptr[sig]) {
2648 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2653 /* Max number of items pushed there is 3*n or 4. We cannot fix
2654 infinity, so we fix 4 (in fact 5): */
2656 PL_savestack_ix += 5; /* Protect save in progress. */
2657 SAVEDESTRUCTOR_X(S_unwind_handler_stack, (void*)&flags);
2660 PL_markstack_ptr++; /* Protect mark. */
2662 PL_scopestack_ix += 1;
2663 /* sv_2cv is too complicated, try a simpler variant first: */
2664 if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
2665 || SvTYPE(cv) != SVt_PVCV) {
2667 cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
2670 if (!cv || !CvROOT(cv)) {
2671 if (ckWARN(WARN_SIGNAL))
2672 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2673 PL_sig_name[sig], (gv ? GvENAME(gv)
2680 if(PL_psig_name[sig]) {
2681 sv = SvREFCNT_inc_NN(PL_psig_name[sig]);
2683 #if !defined(PERL_IMPLICIT_CONTEXT)
2687 sv = sv_newmortal();
2688 sv_setpv(sv,PL_sig_name[sig]);
2691 PUSHSTACKi(PERLSI_SIGNAL);
2694 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2696 struct sigaction oact;
2698 if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
2702 va_start(args, sig);
2703 sip = (siginfo_t*)va_arg(args, siginfo_t*);
2706 SV *rv = newRV_noinc((SV*)sih);
2707 /* The siginfo fields signo, code, errno, pid, uid,
2708 * addr, status, and band are defined by POSIX/SUSv3. */
2709 hv_store(sih, "signo", 5, newSViv(sip->si_signo), 0);
2710 hv_store(sih, "code", 4, newSViv(sip->si_code), 0);
2711 #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. */
2712 hv_store(sih, "errno", 5, newSViv(sip->si_errno), 0);
2713 hv_store(sih, "status", 6, newSViv(sip->si_status), 0);
2714 hv_store(sih, "uid", 3, newSViv(sip->si_uid), 0);
2715 hv_store(sih, "pid", 3, newSViv(sip->si_pid), 0);
2716 hv_store(sih, "addr", 4, newSVuv(PTR2UV(sip->si_addr)), 0);
2717 hv_store(sih, "band", 4, newSViv(sip->si_band), 0);
2721 PUSHs(newSVpv((void*)sip, sizeof(*sip)));
2730 call_sv((SV*)cv, G_DISCARD|G_EVAL);
2733 if (SvTRUE(ERRSV)) {
2735 #ifdef HAS_SIGPROCMASK
2736 /* Handler "died", for example to get out of a restart-able read().
2737 * Before we re-do that on its behalf re-enable the signal which was
2738 * blocked by the system when we entered.
2742 sigaddset(&set,sig);
2743 sigprocmask(SIG_UNBLOCK, &set, NULL);
2745 /* Not clear if this will work */
2746 (void)rsignal(sig, SIG_IGN);
2747 (void)rsignal(sig, PL_csighandlerp);
2749 #endif /* !PERL_MICRO */
2750 Perl_die(aTHX_ NULL);
2754 PL_savestack_ix -= 8; /* Unprotect save in progress. */
2758 PL_scopestack_ix -= 1;
2761 PL_op = myop; /* Apparently not needed... */
2763 PL_Sv = tSv; /* Restore global temporaries. */
2770 S_restore_magic(pTHX_ const void *p)
2773 MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
2774 SV* const sv = mgs->mgs_sv;
2779 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2781 #ifdef PERL_OLD_COPY_ON_WRITE
2782 /* While magic was saved (and off) sv_setsv may well have seen
2783 this SV as a prime candidate for COW. */
2785 sv_force_normal_flags(sv, 0);
2789 SvFLAGS(sv) |= mgs->mgs_flags;
2792 if (SvGMAGICAL(sv)) {
2793 /* downgrade public flags to private,
2794 and discard any other private flags */
2796 U32 public = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
2798 SvFLAGS(sv) &= ~( public | SVp_IOK|SVp_NOK|SVp_POK );
2799 SvFLAGS(sv) |= ( public << PRIVSHIFT );
2804 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
2806 /* If we're still on top of the stack, pop us off. (That condition
2807 * will be satisfied if restore_magic was called explicitly, but *not*
2808 * if it's being called via leave_scope.)
2809 * The reason for doing this is that otherwise, things like sv_2cv()
2810 * may leave alloc gunk on the savestack, and some code
2811 * (e.g. sighandler) doesn't expect that...
2813 if (PL_savestack_ix == mgs->mgs_ss_ix)
2815 I32 popval = SSPOPINT;
2816 assert(popval == SAVEt_DESTRUCTOR_X);
2817 PL_savestack_ix -= 2;
2819 assert(popval == SAVEt_ALLOC);
2821 PL_savestack_ix -= popval;
2827 S_unwind_handler_stack(pTHX_ const void *p)
2830 const U32 flags = *(const U32*)p;
2833 PL_savestack_ix -= 5; /* Unprotect save in progress. */
2834 #if !defined(PERL_IMPLICIT_CONTEXT)
2836 SvREFCNT_dec(PL_sig_sv);
2841 =for apidoc magic_sethint
2843 Triggered by a store to %^H, records the key/value pair to
2844 C<PL_compiling.cop_hints>. It is assumed that hints aren't storing anything
2845 that would need a deep copy. Maybe we should warn if we find a reference.
2850 Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
2853 assert(mg->mg_len == HEf_SVKEY);
2855 /* mg->mg_obj isn't being used. If needed, it would be possible to store
2856 an alternative leaf in there, with PL_compiling.cop_hints being used if
2857 it's NULL. If needed for threads, the alternative could lock a mutex,
2858 or take other more complex action. */
2860 /* Something changed in %^H, so it will need to be restored on scope exit.
2861 Doing this here saves a lot of doing it manually in perl code (and
2862 forgetting to do it, and consequent subtle errors. */
2863 PL_hints |= HINT_LOCALIZE_HH;
2864 PL_compiling.cop_hints
2865 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints,
2866 (SV *)mg->mg_ptr, newSVsv(sv));
2871 =for apidoc magic_sethint
2873 Triggered by a delete from %^H, records the key to C<PL_compiling.cop_hints>.
2878 Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
2881 assert(mg->mg_len == HEf_SVKEY);
2883 PL_hints |= HINT_LOCALIZE_HH;
2884 PL_compiling.cop_hints
2885 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints,
2886 (SV *)mg->mg_ptr, &PL_sv_placeholder);
2892 * c-indentation-style: bsd
2894 * indent-tabs-mode: t
2897 * ex: set ts=8 sts=4 sw=4 noet: