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);
500 if (mg->mg_obj) { /* @+ */
501 /* return the number possible */
504 I32 paren = rx->lastparen;
506 /* return the last filled */
508 && (rx->startp[paren] == -1 || rx->endp[paren] == -1) )
519 Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
523 register const REGEXP * const rx = PM_GETRE(PL_curpm);
525 register const I32 paren = mg->mg_len;
530 if (paren <= (I32)rx->nparens &&
531 (s = rx->startp[paren]) != -1 &&
532 (t = rx->endp[paren]) != -1)
535 if (mg->mg_obj) /* @+ */
540 if (i > 0 && RX_MATCH_UTF8(rx)) {
541 const char * const b = rx->subbeg;
543 i = utf8_length((U8*)b, (U8*)(b+i));
554 Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
558 Perl_croak(aTHX_ PL_no_modify);
559 NORETURN_FUNCTION_END;
563 Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
568 register const REGEXP *rx;
571 switch (*mg->mg_ptr) {
572 case '1': case '2': case '3': case '4':
573 case '5': case '6': case '7': case '8': case '9': case '&':
574 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
576 paren = atoi(mg->mg_ptr); /* $& is in [0] */
578 if (paren <= (I32)rx->nparens &&
579 (s1 = rx->startp[paren]) != -1 &&
580 (t1 = rx->endp[paren]) != -1)
584 if (i > 0 && RX_MATCH_UTF8(rx)) {
585 const char * const s = rx->subbeg + s1;
590 if (is_utf8_string_loclen((U8*)s, i, &ep, &el))
594 Perl_croak(aTHX_ "panic: magic_len: %"IVdf, (IV)i);
598 if (ckWARN(WARN_UNINITIALIZED))
603 if (ckWARN(WARN_UNINITIALIZED))
608 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
609 paren = rx->lastparen;
614 case '\016': /* ^N */
615 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
616 paren = rx->lastcloseparen;
622 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
623 if (rx->startp[0] != -1) {
634 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
635 if (rx->endp[0] != -1) {
636 i = rx->sublen - rx->endp[0];
647 if (!SvPOK(sv) && SvNIOK(sv)) {
655 #define SvRTRIM(sv) STMT_START { \
657 STRLEN len = SvCUR(sv); \
658 char * const p = SvPVX(sv); \
659 while (len > 0 && isSPACE(p[len-1])) \
661 SvCUR_set(sv, len); \
667 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
671 register char *s = NULL;
674 const char * const remaining = mg->mg_ptr + 1;
675 const char nextchar = *remaining;
677 switch (*mg->mg_ptr) {
678 case '\001': /* ^A */
679 sv_setsv(sv, PL_bodytarget);
681 case '\003': /* ^C, ^CHILD_ERROR_NATIVE */
682 if (nextchar == '\0') {
683 sv_setiv(sv, (IV)PL_minus_c);
685 else if (strEQ(remaining, "HILD_ERROR_NATIVE")) {
686 sv_setiv(sv, (IV)STATUS_NATIVE);
690 case '\004': /* ^D */
691 sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
693 case '\005': /* ^E */
694 if (nextchar == '\0') {
695 #if defined(MACOS_TRADITIONAL)
699 sv_setnv(sv,(double)gMacPerl_OSErr);
700 sv_setpv(sv, gMacPerl_OSErr ? GetSysErrText(gMacPerl_OSErr, msg) : "");
704 # include <descrip.h>
705 # include <starlet.h>
707 $DESCRIPTOR(msgdsc,msg);
708 sv_setnv(sv,(NV) vaxc$errno);
709 if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
710 sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
715 if (!(_emx_env & 0x200)) { /* Under DOS */
716 sv_setnv(sv, (NV)errno);
717 sv_setpv(sv, errno ? Strerror(errno) : "");
719 if (errno != errno_isOS2) {
720 const int tmp = _syserrno();
721 if (tmp) /* 2nd call to _syserrno() makes it 0 */
724 sv_setnv(sv, (NV)Perl_rc);
725 sv_setpv(sv, os2error(Perl_rc));
729 const DWORD dwErr = GetLastError();
730 sv_setnv(sv, (NV)dwErr);
732 PerlProc_GetOSError(sv, dwErr);
735 sv_setpvn(sv, "", 0);
740 const int saveerrno = errno;
741 sv_setnv(sv, (NV)errno);
742 sv_setpv(sv, errno ? Strerror(errno) : "");
747 SvNOK_on(sv); /* what a wonderful hack! */
749 else if (strEQ(remaining, "NCODING"))
750 sv_setsv(sv, PL_encoding);
752 case '\006': /* ^F */
753 sv_setiv(sv, (IV)PL_maxsysfd);
755 case '\010': /* ^H */
756 sv_setiv(sv, (IV)PL_hints);
758 case '\011': /* ^I */ /* NOT \t in EBCDIC */
760 sv_setpv(sv, PL_inplace);
762 sv_setsv(sv, &PL_sv_undef);
764 case '\017': /* ^O & ^OPEN */
765 if (nextchar == '\0') {
766 sv_setpv(sv, PL_osname);
769 else if (strEQ(remaining, "PEN")) {
770 if (!(CopHINTS_get(&PL_compiling) & HINT_LEXICAL_IO))
771 sv_setsv(sv, &PL_sv_undef);
774 Perl_refcounted_he_fetch(aTHX_
775 PL_compiling.cop_hints_hash,
776 0, "open", 4, 0, 0));
780 case '\020': /* ^P */
781 sv_setiv(sv, (IV)PL_perldb);
783 case '\023': /* ^S */
784 if (nextchar == '\0') {
785 if (PL_lex_state != LEX_NOTPARSING)
788 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
793 case '\024': /* ^T */
794 if (nextchar == '\0') {
796 sv_setnv(sv, PL_basetime);
798 sv_setiv(sv, (IV)PL_basetime);
801 else if (strEQ(remaining, "AINT"))
802 sv_setiv(sv, PL_tainting
803 ? (PL_taint_warn || PL_unsafe ? -1 : 1)
806 case '\025': /* $^UNICODE, $^UTF8LOCALE, $^UTF8CACHE */
807 if (strEQ(remaining, "NICODE"))
808 sv_setuv(sv, (UV) PL_unicode);
809 else if (strEQ(remaining, "TF8LOCALE"))
810 sv_setuv(sv, (UV) PL_utf8locale);
811 else if (strEQ(remaining, "TF8CACHE"))
812 sv_setiv(sv, (IV) PL_utf8cache);
814 case '\027': /* ^W & $^WARNING_BITS */
815 if (nextchar == '\0')
816 sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
817 else if (strEQ(remaining, "ARNING_BITS")) {
818 if (PL_compiling.cop_warnings == pWARN_NONE) {
819 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
821 else if (PL_compiling.cop_warnings == pWARN_STD) {
824 (PL_dowarn & G_WARN_ON) ? WARN_ALLstring : WARN_NONEstring,
828 else if (PL_compiling.cop_warnings == pWARN_ALL) {
829 /* Get the bit mask for $warnings::Bits{all}, because
830 * it could have been extended by warnings::register */
831 HV * const bits=get_hv("warnings::Bits", FALSE);
833 SV ** const bits_all = hv_fetchs(bits, "all", FALSE);
835 sv_setsv(sv, *bits_all);
838 sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
842 sv_setpvn(sv, (char *) (PL_compiling.cop_warnings + 1),
843 *PL_compiling.cop_warnings);
848 case '1': case '2': case '3': case '4':
849 case '5': case '6': case '7': case '8': case '9': case '&':
850 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
854 * Pre-threads, this was paren = atoi(GvENAME((GV*)mg->mg_obj));
855 * XXX Does the new way break anything?
857 paren = atoi(mg->mg_ptr); /* $& is in [0] */
859 if (paren <= (I32)rx->nparens &&
860 (s1 = rx->startp[paren]) != -1 &&
861 (t1 = rx->endp[paren]) != -1)
866 assert(rx->sublen >= s1);
870 const int oldtainted = PL_tainted;
873 PL_tainted = oldtainted;
874 if ( (rx->extflags & RXf_CANY_SEEN)
876 && (!i || is_utf8_string((U8*)s, i)))
877 : (RX_MATCH_UTF8(rx)) )
884 if (RX_MATCH_TAINTED(rx)) {
885 MAGIC* const mg = SvMAGIC(sv);
888 SvMAGIC_set(sv, mg->mg_moremagic);
890 if ((mgt = SvMAGIC(sv))) {
891 mg->mg_moremagic = mgt;
901 sv_setsv(sv,&PL_sv_undef);
904 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
905 paren = rx->lastparen;
909 sv_setsv(sv,&PL_sv_undef);
911 case '\016': /* ^N */
912 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
913 paren = rx->lastcloseparen;
917 sv_setsv(sv,&PL_sv_undef);
920 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
921 if ((s = rx->subbeg) && rx->startp[0] != -1) {
926 sv_setsv(sv,&PL_sv_undef);
929 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
930 if (rx->subbeg && rx->endp[0] != -1) {
931 s = rx->subbeg + rx->endp[0];
932 i = rx->sublen - rx->endp[0];
936 sv_setsv(sv,&PL_sv_undef);
939 if (GvIO(PL_last_in_gv)) {
940 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
945 sv_setiv(sv, (IV)STATUS_CURRENT);
946 #ifdef COMPLEX_STATUS
947 LvTARGOFF(sv) = PL_statusvalue;
948 LvTARGLEN(sv) = PL_statusvalue_vms;
953 if (GvIOp(PL_defoutgv))
954 s = IoTOP_NAME(GvIOp(PL_defoutgv));
958 sv_setpv(sv,GvENAME(PL_defoutgv));
963 if (GvIOp(PL_defoutgv))
964 s = IoFMT_NAME(GvIOp(PL_defoutgv));
966 s = GvENAME(PL_defoutgv);
970 if (GvIOp(PL_defoutgv))
971 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
974 if (GvIOp(PL_defoutgv))
975 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
978 if (GvIOp(PL_defoutgv))
979 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
986 sv_setiv(sv, (IV)CopARYBASE_get(PL_curcop));
989 if (GvIOp(PL_defoutgv))
990 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
996 sv_copypv(sv, PL_ors_sv);
1000 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
1001 sv_setpv(sv, errno ? Strerror(errno) : "");
1004 const int saveerrno = errno;
1005 sv_setnv(sv, (NV)errno);
1007 if (errno == errno_isOS2 || errno == errno_isOS2_set)
1008 sv_setpv(sv, os2error(Perl_rc));
1011 sv_setpv(sv, errno ? Strerror(errno) : "");
1016 SvNOK_on(sv); /* what a wonderful hack! */
1019 sv_setiv(sv, (IV)PL_uid);
1022 sv_setiv(sv, (IV)PL_euid);
1025 sv_setiv(sv, (IV)PL_gid);
1028 sv_setiv(sv, (IV)PL_egid);
1030 #ifdef HAS_GETGROUPS
1032 Groups_t *gary = NULL;
1033 I32 i, num_groups = getgroups(0, gary);
1034 Newx(gary, num_groups, Groups_t);
1035 num_groups = getgroups(num_groups, gary);
1036 for (i = 0; i < num_groups; i++)
1037 Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]);
1040 (void)SvIOK_on(sv); /* what a wonderful hack! */
1043 #ifndef MACOS_TRADITIONAL
1052 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
1054 struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
1056 if (uf && uf->uf_val)
1057 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
1062 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
1065 STRLEN len = 0, klen;
1066 const char *s = SvOK(sv) ? SvPV_const(sv,len) : "";
1067 const char * const ptr = MgPV_const(mg,klen);
1070 #ifdef DYNAMIC_ENV_FETCH
1071 /* We just undefd an environment var. Is a replacement */
1072 /* waiting in the wings? */
1074 SV ** const valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE);
1076 s = SvOK(*valp) ? SvPV_const(*valp, len) : "";
1080 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
1081 /* And you'll never guess what the dog had */
1082 /* in its mouth... */
1084 MgTAINTEDDIR_off(mg);
1086 if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
1087 char pathbuf[256], eltbuf[256], *cp, *elt;
1091 my_strlcpy(eltbuf, s, sizeof(eltbuf));
1093 do { /* DCL$PATH may be a search list */
1094 while (1) { /* as may dev portion of any element */
1095 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1096 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1097 cando_by_name(S_IWUSR,0,elt) ) {
1098 MgTAINTEDDIR_on(mg);
1102 if ((cp = strchr(elt, ':')) != NULL)
1104 if (my_trnlnm(elt, eltbuf, j++))
1110 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1113 if (s && klen == 4 && strEQ(ptr,"PATH")) {
1114 const char * const strend = s + len;
1116 while (s < strend) {
1120 #ifdef VMS /* Hmm. How do we get $Config{path_sep} from C? */
1121 const char path_sep = '|';
1123 const char path_sep = ':';
1125 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
1126 s, strend, path_sep, &i);
1128 if (i >= (I32)sizeof tmpbuf /* too long -- assume the worst */
1130 || !strchr(tmpbuf, ':') /* no colon thus no device name -- assume relative path */
1132 || *tmpbuf != '/' /* no starting slash -- assume relative path */
1134 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1135 MgTAINTEDDIR_on(mg);
1141 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1147 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1149 PERL_UNUSED_ARG(sv);
1150 my_setenv(MgPV_nolen_const(mg),NULL);
1155 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1158 PERL_UNUSED_ARG(mg);
1160 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1162 if (PL_localizing) {
1165 hv_iterinit((HV*)sv);
1166 while ((entry = hv_iternext((HV*)sv))) {
1168 my_setenv(hv_iterkey(entry, &keylen),
1169 SvPV_nolen_const(hv_iterval((HV*)sv, entry)));
1177 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1180 PERL_UNUSED_ARG(sv);
1181 PERL_UNUSED_ARG(mg);
1183 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1191 #ifdef HAS_SIGPROCMASK
1193 restore_sigmask(pTHX_ SV *save_sv)
1195 const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1196 (void)sigprocmask(SIG_SETMASK, ossetp, NULL);
1200 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1203 /* Are we fetching a signal entry? */
1204 const I32 i = whichsig(MgPV_nolen_const(mg));
1207 sv_setsv(sv,PL_psig_ptr[i]);
1209 Sighandler_t sigstate = rsignal_state(i);
1210 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1211 if (PL_sig_handlers_initted && PL_sig_ignoring[i])
1214 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1215 if (PL_sig_handlers_initted && PL_sig_defaulting[i])
1218 /* cache state so we don't fetch it again */
1219 if(sigstate == (Sighandler_t) SIG_IGN)
1220 sv_setpv(sv,"IGNORE");
1222 sv_setsv(sv,&PL_sv_undef);
1223 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1230 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1232 /* XXX Some of this code was copied from Perl_magic_setsig. A little
1233 * refactoring might be in order.
1236 register const char * const s = MgPV_nolen_const(mg);
1237 PERL_UNUSED_ARG(sv);
1240 if (strEQ(s,"__DIE__"))
1242 else if (strEQ(s,"__WARN__") && PL_warnhook != PERL_WARNHOOK_FATAL)
1245 SV *const to_dec = *svp;
1247 SvREFCNT_dec(to_dec);
1251 /* Are we clearing a signal entry? */
1252 const I32 i = whichsig(s);
1254 #ifdef HAS_SIGPROCMASK
1257 /* Avoid having the signal arrive at a bad time, if possible. */
1260 sigprocmask(SIG_BLOCK, &set, &save);
1262 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1263 SAVEFREESV(save_sv);
1264 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1267 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1268 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1270 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1271 PL_sig_defaulting[i] = 1;
1272 (void)rsignal(i, PL_csighandlerp);
1274 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1276 if(PL_psig_name[i]) {
1277 SvREFCNT_dec(PL_psig_name[i]);
1280 if(PL_psig_ptr[i]) {
1281 SV * const to_dec=PL_psig_ptr[i];
1284 SvREFCNT_dec(to_dec);
1294 S_raise_signal(pTHX_ int sig)
1297 /* Set a flag to say this signal is pending */
1298 PL_psig_pend[sig]++;
1299 /* And one to say _a_ signal is pending */
1304 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1305 Perl_csighandler(int sig, ...)
1307 Perl_csighandler(int sig)
1310 #ifdef PERL_GET_SIG_CONTEXT
1311 dTHXa(PERL_GET_SIG_CONTEXT);
1315 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1316 (void) rsignal(sig, PL_csighandlerp);
1317 if (PL_sig_ignoring[sig]) return;
1319 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1320 if (PL_sig_defaulting[sig])
1321 #ifdef KILL_BY_SIGPRC
1322 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1337 (PL_signals & PERL_SIGNALS_UNSAFE_FLAG))
1338 /* Call the perl level handler now--
1339 * with risk we may be in malloc() etc. */
1340 (*PL_sighandlerp)(sig);
1342 S_raise_signal(aTHX_ sig);
1345 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1347 Perl_csighandler_init(void)
1350 if (PL_sig_handlers_initted) return;
1352 for (sig = 1; sig < SIG_SIZE; sig++) {
1353 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1355 PL_sig_defaulting[sig] = 1;
1356 (void) rsignal(sig, PL_csighandlerp);
1358 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1359 PL_sig_ignoring[sig] = 0;
1362 PL_sig_handlers_initted = 1;
1367 Perl_despatch_signals(pTHX)
1372 for (sig = 1; sig < SIG_SIZE; sig++) {
1373 if (PL_psig_pend[sig]) {
1374 PERL_BLOCKSIG_ADD(set, sig);
1375 PL_psig_pend[sig] = 0;
1376 PERL_BLOCKSIG_BLOCK(set);
1377 (*PL_sighandlerp)(sig);
1378 PERL_BLOCKSIG_UNBLOCK(set);
1384 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1389 /* Need to be careful with SvREFCNT_dec(), because that can have side
1390 * effects (due to closures). We must make sure that the new disposition
1391 * is in place before it is called.
1395 #ifdef HAS_SIGPROCMASK
1400 register const char *s = MgPV_const(mg,len);
1402 if (strEQ(s,"__DIE__"))
1404 else if (strEQ(s,"__WARN__"))
1407 Perl_croak(aTHX_ "No such hook: %s", s);
1410 if (*svp != PERL_WARNHOOK_FATAL)
1416 i = whichsig(s); /* ...no, a brick */
1418 if (ckWARN(WARN_SIGNAL))
1419 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
1422 #ifdef HAS_SIGPROCMASK
1423 /* Avoid having the signal arrive at a bad time, if possible. */
1426 sigprocmask(SIG_BLOCK, &set, &save);
1428 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1429 SAVEFREESV(save_sv);
1430 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1433 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1434 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1436 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1437 PL_sig_ignoring[i] = 0;
1439 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1440 PL_sig_defaulting[i] = 0;
1442 SvREFCNT_dec(PL_psig_name[i]);
1443 to_dec = PL_psig_ptr[i];
1444 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1445 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1446 PL_psig_name[i] = newSVpvn(s, len);
1447 SvREADONLY_on(PL_psig_name[i]);
1449 if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
1451 (void)rsignal(i, PL_csighandlerp);
1452 #ifdef HAS_SIGPROCMASK
1457 *svp = SvREFCNT_inc_simple_NN(sv);
1459 SvREFCNT_dec(to_dec);
1462 s = SvOK(sv) ? SvPV_force(sv,len) : "DEFAULT";
1463 if (strEQ(s,"IGNORE")) {
1465 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1466 PL_sig_ignoring[i] = 1;
1467 (void)rsignal(i, PL_csighandlerp);
1469 (void)rsignal(i, (Sighandler_t) SIG_IGN);
1473 else if (strEQ(s,"DEFAULT") || !*s) {
1475 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1477 PL_sig_defaulting[i] = 1;
1478 (void)rsignal(i, PL_csighandlerp);
1481 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1486 * We should warn if HINT_STRICT_REFS, but without
1487 * access to a known hint bit in a known OP, we can't
1488 * tell whether HINT_STRICT_REFS is in force or not.
1490 if (!strchr(s,':') && !strchr(s,'\''))
1491 Perl_sv_insert(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"));
1493 (void)rsignal(i, PL_csighandlerp);
1495 *svp = SvREFCNT_inc_simple_NN(sv);
1497 #ifdef HAS_SIGPROCMASK
1502 SvREFCNT_dec(to_dec);
1505 #endif /* !PERL_MICRO */
1508 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1511 PERL_UNUSED_ARG(sv);
1512 PERL_UNUSED_ARG(mg);
1513 PL_sub_generation++;
1518 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
1521 PERL_UNUSED_ARG(sv);
1522 PERL_UNUSED_ARG(mg);
1523 /* HV_badAMAGIC_on(Sv_STASH(sv)); */
1524 PL_amagic_generation++;
1530 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1532 HV * const hv = (HV*)LvTARG(sv);
1534 PERL_UNUSED_ARG(mg);
1537 (void) hv_iterinit(hv);
1538 if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
1541 while (hv_iternext(hv))
1546 sv_setiv(sv, (IV)i);
1551 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1553 PERL_UNUSED_ARG(mg);
1555 hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
1560 /* caller is responsible for stack switching/cleanup */
1562 S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV *val)
1569 PUSHs(SvTIED_obj(sv, mg));
1572 if (mg->mg_len >= 0)
1573 PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len)));
1574 else if (mg->mg_len == HEf_SVKEY)
1575 PUSHs((SV*)mg->mg_ptr);
1577 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1578 PUSHs(sv_2mortal(newSViv(mg->mg_len)));
1586 return call_method(meth, flags);
1590 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
1596 PUSHSTACKi(PERLSI_MAGIC);
1598 if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
1599 sv_setsv(sv, *PL_stack_sp--);
1609 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1612 mg->mg_flags |= MGf_GSKIP;
1613 magic_methpack(sv,mg,"FETCH");
1618 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1622 PUSHSTACKi(PERLSI_MAGIC);
1623 magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
1630 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1632 return magic_methpack(sv,mg,"DELETE");
1637 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1644 PUSHSTACKi(PERLSI_MAGIC);
1645 if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
1646 sv = *PL_stack_sp--;
1647 retval = (U32) SvIV(sv)-1;
1656 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1661 PUSHSTACKi(PERLSI_MAGIC);
1663 XPUSHs(SvTIED_obj(sv, mg));
1665 call_method("CLEAR", G_SCALAR|G_DISCARD);
1673 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1676 const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
1680 PUSHSTACKi(PERLSI_MAGIC);
1683 PUSHs(SvTIED_obj(sv, mg));
1688 if (call_method(meth, G_SCALAR))
1689 sv_setsv(key, *PL_stack_sp--);
1698 Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg)
1700 return magic_methpack(sv,mg,"EXISTS");
1704 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1708 SV * const tied = SvTIED_obj((SV*)hv, mg);
1709 HV * const pkg = SvSTASH((SV*)SvRV(tied));
1711 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1713 if (HvEITER_get(hv))
1714 /* we are in an iteration so the hash cannot be empty */
1716 /* no xhv_eiter so now use FIRSTKEY */
1717 key = sv_newmortal();
1718 magic_nextpack((SV*)hv, mg, key);
1719 HvEITER_set(hv, NULL); /* need to reset iterator */
1720 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1723 /* there is a SCALAR method that we can call */
1725 PUSHSTACKi(PERLSI_MAGIC);
1731 if (call_method("SCALAR", G_SCALAR))
1732 retval = *PL_stack_sp--;
1734 retval = &PL_sv_undef;
1741 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1744 GV * const gv = PL_DBline;
1745 const I32 i = SvTRUE(sv);
1746 SV ** const svp = av_fetch(GvAV(gv),
1747 atoi(MgPV_nolen_const(mg)), FALSE);
1748 if (svp && SvIOKp(*svp)) {
1749 OP * const o = INT2PTR(OP*,SvIVX(*svp));
1751 /* set or clear breakpoint in the relevant control op */
1753 o->op_flags |= OPf_SPECIAL;
1755 o->op_flags &= ~OPf_SPECIAL;
1762 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
1765 const AV * const obj = (AV*)mg->mg_obj;
1767 sv_setiv(sv, AvFILL(obj) + CopARYBASE_get(PL_curcop));
1775 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
1778 AV * const obj = (AV*)mg->mg_obj;
1780 av_fill(obj, SvIV(sv) - CopARYBASE_get(PL_curcop));
1782 if (ckWARN(WARN_MISC))
1783 Perl_warner(aTHX_ packWARN(WARN_MISC),
1784 "Attempt to set length of freed array");
1790 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
1793 PERL_UNUSED_ARG(sv);
1794 /* during global destruction, mg_obj may already have been freed */
1795 if (PL_in_clean_all)
1798 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
1801 /* arylen scalar holds a pointer back to the array, but doesn't own a
1802 reference. Hence the we (the array) are about to go away with it
1803 still pointing at us. Clear its pointer, else it would be pointing
1804 at free memory. See the comment in sv_magic about reference loops,
1805 and why it can't own a reference to us. */
1812 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
1815 SV* const lsv = LvTARG(sv);
1816 PERL_UNUSED_ARG(mg);
1818 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1819 MAGIC * const found = mg_find(lsv, PERL_MAGIC_regex_global);
1820 if (found && found->mg_len >= 0) {
1821 I32 i = found->mg_len;
1823 sv_pos_b2u(lsv, &i);
1824 sv_setiv(sv, i + CopARYBASE_get(PL_curcop));
1833 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
1836 SV* const lsv = LvTARG(sv);
1842 PERL_UNUSED_ARG(mg);
1844 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
1845 found = mg_find(lsv, PERL_MAGIC_regex_global);
1851 #ifdef PERL_OLD_COPY_ON_WRITE
1853 sv_force_normal_flags(lsv, 0);
1855 found = sv_magicext(lsv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
1858 else if (!SvOK(sv)) {
1862 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1864 pos = SvIV(sv) - CopARYBASE_get(PL_curcop);
1867 ulen = sv_len_utf8(lsv);
1877 else if (pos > (SSize_t)len)
1882 sv_pos_u2b(lsv, &p, 0);
1886 found->mg_len = pos;
1887 found->mg_flags &= ~MGf_MINMATCH;
1893 Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg)
1896 PERL_UNUSED_ARG(mg);
1900 if (SvFLAGS(sv) & SVp_SCREAM
1901 && (SvTYPE(sv) == SVt_PVGV || SvTYPE(sv) == SVt_PVGV)) {
1902 /* We're actually already a typeglob, so don't need the stuff below.
1906 gv = gv_fetchsv(sv, GV_ADD, SVt_PVGV);
1911 GvGP(sv) = gp_ref(GvGP(gv));
1916 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
1919 SV * const lsv = LvTARG(sv);
1920 const char * const tmps = SvPV_const(lsv,len);
1921 I32 offs = LvTARGOFF(sv);
1922 I32 rem = LvTARGLEN(sv);
1923 PERL_UNUSED_ARG(mg);
1926 sv_pos_u2b(lsv, &offs, &rem);
1927 if (offs > (I32)len)
1929 if (rem + offs > (I32)len)
1931 sv_setpvn(sv, tmps + offs, (STRLEN)rem);
1938 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
1942 const char * const tmps = SvPV_const(sv, len);
1943 SV * const lsv = LvTARG(sv);
1944 I32 lvoff = LvTARGOFF(sv);
1945 I32 lvlen = LvTARGLEN(sv);
1946 PERL_UNUSED_ARG(mg);
1949 sv_utf8_upgrade(lsv);
1950 sv_pos_u2b(lsv, &lvoff, &lvlen);
1951 sv_insert(lsv, lvoff, lvlen, tmps, len);
1952 LvTARGLEN(sv) = sv_len_utf8(sv);
1955 else if (lsv && SvUTF8(lsv)) {
1957 sv_pos_u2b(lsv, &lvoff, &lvlen);
1958 LvTARGLEN(sv) = len;
1959 utf8 = (char*)bytes_to_utf8((U8*)tmps, &len);
1960 sv_insert(lsv, lvoff, lvlen, utf8, len);
1964 sv_insert(lsv, lvoff, lvlen, tmps, len);
1965 LvTARGLEN(sv) = len;
1973 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
1976 PERL_UNUSED_ARG(sv);
1977 TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
1982 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
1985 PERL_UNUSED_ARG(sv);
1986 /* update taint status unless we're restoring at scope exit */
1987 if (PL_localizing != 2) {
1997 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
1999 SV * const lsv = LvTARG(sv);
2000 PERL_UNUSED_ARG(mg);
2003 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
2011 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
2013 PERL_UNUSED_ARG(mg);
2014 do_vecset(sv); /* XXX slurp this routine */
2019 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
2023 if (LvTARGLEN(sv)) {
2025 SV * const ahv = LvTARG(sv);
2026 HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
2031 AV* const av = (AV*)LvTARG(sv);
2032 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
2033 targ = AvARRAY(av)[LvTARGOFF(sv)];
2035 if (targ && (targ != &PL_sv_undef)) {
2036 /* somebody else defined it for us */
2037 SvREFCNT_dec(LvTARG(sv));
2038 LvTARG(sv) = SvREFCNT_inc_simple_NN(targ);
2040 SvREFCNT_dec(mg->mg_obj);
2042 mg->mg_flags &= ~MGf_REFCOUNTED;
2047 sv_setsv(sv, targ ? targ : &PL_sv_undef);
2052 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
2054 PERL_UNUSED_ARG(mg);
2058 sv_setsv(LvTARG(sv), sv);
2059 SvSETMAGIC(LvTARG(sv));
2065 Perl_vivify_defelem(pTHX_ SV *sv)
2071 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2074 SV * const ahv = LvTARG(sv);
2075 HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
2078 if (!value || value == &PL_sv_undef)
2079 Perl_croak(aTHX_ PL_no_helem_sv, mg->mg_obj);
2082 AV* const av = (AV*)LvTARG(sv);
2083 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
2084 LvTARG(sv) = NULL; /* array can't be extended */
2086 SV* const * const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
2087 if (!svp || (value = *svp) == &PL_sv_undef)
2088 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
2091 SvREFCNT_inc_simple_void(value);
2092 SvREFCNT_dec(LvTARG(sv));
2095 SvREFCNT_dec(mg->mg_obj);
2097 mg->mg_flags &= ~MGf_REFCOUNTED;
2101 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2103 return Perl_sv_kill_backrefs(aTHX_ sv, (AV*)mg->mg_obj);
2107 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2109 PERL_UNUSED_CONTEXT;
2116 Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
2118 PERL_UNUSED_ARG(mg);
2119 sv_unmagic(sv, PERL_MAGIC_bm);
2126 Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
2128 PERL_UNUSED_ARG(mg);
2129 sv_unmagic(sv, PERL_MAGIC_fm);
2135 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2137 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2139 if (uf && uf->uf_set)
2140 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2145 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2147 PERL_UNUSED_ARG(mg);
2148 sv_unmagic(sv, PERL_MAGIC_qr);
2153 Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
2156 regexp * const re = (regexp *)mg->mg_obj;
2157 PERL_UNUSED_ARG(sv);
2163 #ifdef USE_LOCALE_COLLATE
2165 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2168 * RenE<eacute> Descartes said "I think not."
2169 * and vanished with a faint plop.
2171 PERL_UNUSED_CONTEXT;
2172 PERL_UNUSED_ARG(sv);
2174 Safefree(mg->mg_ptr);
2180 #endif /* USE_LOCALE_COLLATE */
2182 /* Just clear the UTF-8 cache data. */
2184 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2186 PERL_UNUSED_CONTEXT;
2187 PERL_UNUSED_ARG(sv);
2188 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2190 mg->mg_len = -1; /* The mg_len holds the len cache. */
2195 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2198 register const char *s;
2201 switch (*mg->mg_ptr) {
2202 case '\001': /* ^A */
2203 sv_setsv(PL_bodytarget, sv);
2205 case '\003': /* ^C */
2206 PL_minus_c = (bool)SvIV(sv);
2209 case '\004': /* ^D */
2211 s = SvPV_nolen_const(sv);
2212 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2213 DEBUG_x(dump_all());
2215 PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG;
2218 case '\005': /* ^E */
2219 if (*(mg->mg_ptr+1) == '\0') {
2220 #ifdef MACOS_TRADITIONAL
2221 gMacPerl_OSErr = SvIV(sv);
2224 set_vaxc_errno(SvIV(sv));
2227 SetLastError( SvIV(sv) );
2230 os2_setsyserrno(SvIV(sv));
2232 /* will anyone ever use this? */
2233 SETERRNO(SvIV(sv), 4);
2239 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2241 SvREFCNT_dec(PL_encoding);
2242 if (SvOK(sv) || SvGMAGICAL(sv)) {
2243 PL_encoding = newSVsv(sv);
2250 case '\006': /* ^F */
2251 PL_maxsysfd = SvIV(sv);
2253 case '\010': /* ^H */
2254 PL_hints = SvIV(sv);
2256 case '\011': /* ^I */ /* NOT \t in EBCDIC */
2257 Safefree(PL_inplace);
2258 PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
2260 case '\017': /* ^O */
2261 if (*(mg->mg_ptr+1) == '\0') {
2262 Safefree(PL_osname);
2265 TAINT_PROPER("assigning to $^O");
2266 PL_osname = savesvpv(sv);
2269 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2270 PL_compiling.cop_hints |= HINT_LEXICAL_IO;
2271 PL_hints |= HINT_LOCALIZE_HH | HINT_LEXICAL_IO;
2272 PL_compiling.cop_hints_hash
2273 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
2274 sv_2mortal(newSVpvs("open")), sv);
2277 case '\020': /* ^P */
2278 PL_perldb = SvIV(sv);
2279 if (PL_perldb && !PL_DBsingle)
2282 case '\024': /* ^T */
2284 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2286 PL_basetime = (Time_t)SvIV(sv);
2289 case '\025': /* ^UTF8CACHE */
2290 if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
2291 PL_utf8cache = (signed char) sv_2iv(sv);
2294 case '\027': /* ^W & $^WARNING_BITS */
2295 if (*(mg->mg_ptr+1) == '\0') {
2296 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2298 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2299 | (i ? G_WARN_ON : G_WARN_OFF) ;
2302 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2303 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2304 if (!SvPOK(sv) && PL_localizing) {
2305 sv_setpvn(sv, WARN_NONEstring, WARNsize);
2306 PL_compiling.cop_warnings = pWARN_NONE;
2311 int accumulate = 0 ;
2312 int any_fatals = 0 ;
2313 const char * const ptr = SvPV_const(sv, len) ;
2314 for (i = 0 ; i < len ; ++i) {
2315 accumulate |= ptr[i] ;
2316 any_fatals |= (ptr[i] & 0xAA) ;
2319 if (!specialWARN(PL_compiling.cop_warnings))
2320 PerlMemShared_free(PL_compiling.cop_warnings);
2321 PL_compiling.cop_warnings = pWARN_NONE;
2323 /* Yuck. I can't see how to abstract this: */
2324 else if (isWARN_on(((STRLEN *)SvPV_nolen_const(sv)) - 1,
2325 WARN_ALL) && !any_fatals) {
2326 if (!specialWARN(PL_compiling.cop_warnings))
2327 PerlMemShared_free(PL_compiling.cop_warnings);
2328 PL_compiling.cop_warnings = pWARN_ALL;
2329 PL_dowarn |= G_WARN_ONCE ;
2333 const char *const p = SvPV_const(sv, len);
2335 PL_compiling.cop_warnings
2336 = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
2339 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2340 PL_dowarn |= G_WARN_ONCE ;
2348 if (PL_localizing) {
2349 if (PL_localizing == 1)
2350 SAVESPTR(PL_last_in_gv);
2352 else if (SvOK(sv) && GvIO(PL_last_in_gv))
2353 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2356 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2357 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2358 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2361 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2362 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2363 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2366 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
2369 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
2370 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2371 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2374 IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
2378 IO * const io = GvIOp(PL_defoutgv);
2381 if ((SvIV(sv)) == 0)
2382 IoFLAGS(io) &= ~IOf_FLUSH;
2384 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2385 PerlIO *ofp = IoOFP(io);
2387 (void)PerlIO_flush(ofp);
2388 IoFLAGS(io) |= IOf_FLUSH;
2394 SvREFCNT_dec(PL_rs);
2395 PL_rs = newSVsv(sv);
2399 SvREFCNT_dec(PL_ors_sv);
2400 if (SvOK(sv) || SvGMAGICAL(sv)) {
2401 PL_ors_sv = newSVsv(sv);
2409 SvREFCNT_dec(PL_ofs_sv);
2410 if (SvOK(sv) || SvGMAGICAL(sv)) {
2411 PL_ofs_sv = newSVsv(sv);
2418 CopARYBASE_set(&PL_compiling, SvIV(sv));
2421 #ifdef COMPLEX_STATUS
2422 if (PL_localizing == 2) {
2423 PL_statusvalue = LvTARGOFF(sv);
2424 PL_statusvalue_vms = LvTARGLEN(sv);
2428 #ifdef VMSISH_STATUS
2430 STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2433 STATUS_UNIX_EXIT_SET(SvIV(sv));
2438 # define PERL_VMS_BANG vaxc$errno
2440 # define PERL_VMS_BANG 0
2442 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2443 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2448 if (PL_delaymagic) {
2449 PL_delaymagic |= DM_RUID;
2450 break; /* don't do magic till later */
2453 (void)setruid((Uid_t)PL_uid);
2456 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2458 #ifdef HAS_SETRESUID
2459 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2461 if (PL_uid == PL_euid) { /* special case $< = $> */
2463 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2464 if (PL_uid != 0 && PerlProc_getuid() == 0)
2465 (void)PerlProc_setuid(0);
2467 (void)PerlProc_setuid(PL_uid);
2469 PL_uid = PerlProc_getuid();
2470 Perl_croak(aTHX_ "setruid() not implemented");
2475 PL_uid = PerlProc_getuid();
2476 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2480 if (PL_delaymagic) {
2481 PL_delaymagic |= DM_EUID;
2482 break; /* don't do magic till later */
2485 (void)seteuid((Uid_t)PL_euid);
2488 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2490 #ifdef HAS_SETRESUID
2491 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2493 if (PL_euid == PL_uid) /* special case $> = $< */
2494 PerlProc_setuid(PL_euid);
2496 PL_euid = PerlProc_geteuid();
2497 Perl_croak(aTHX_ "seteuid() not implemented");
2502 PL_euid = PerlProc_geteuid();
2503 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2507 if (PL_delaymagic) {
2508 PL_delaymagic |= DM_RGID;
2509 break; /* don't do magic till later */
2512 (void)setrgid((Gid_t)PL_gid);
2515 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2517 #ifdef HAS_SETRESGID
2518 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2520 if (PL_gid == PL_egid) /* special case $( = $) */
2521 (void)PerlProc_setgid(PL_gid);
2523 PL_gid = PerlProc_getgid();
2524 Perl_croak(aTHX_ "setrgid() not implemented");
2529 PL_gid = PerlProc_getgid();
2530 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2533 #ifdef HAS_SETGROUPS
2535 const char *p = SvPV_const(sv, len);
2536 Groups_t *gary = NULL;
2541 for (i = 0; i < NGROUPS; ++i) {
2542 while (*p && !isSPACE(*p))
2549 Newx(gary, i + 1, Groups_t);
2551 Renew(gary, i + 1, Groups_t);
2555 (void)setgroups(i, gary);
2558 #else /* HAS_SETGROUPS */
2560 #endif /* HAS_SETGROUPS */
2561 if (PL_delaymagic) {
2562 PL_delaymagic |= DM_EGID;
2563 break; /* don't do magic till later */
2566 (void)setegid((Gid_t)PL_egid);
2569 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2571 #ifdef HAS_SETRESGID
2572 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2574 if (PL_egid == PL_gid) /* special case $) = $( */
2575 (void)PerlProc_setgid(PL_egid);
2577 PL_egid = PerlProc_getegid();
2578 Perl_croak(aTHX_ "setegid() not implemented");
2583 PL_egid = PerlProc_getegid();
2584 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2587 PL_chopset = SvPV_force(sv,len);
2589 #ifndef MACOS_TRADITIONAL
2591 LOCK_DOLLARZERO_MUTEX;
2592 #ifdef HAS_SETPROCTITLE
2593 /* The BSDs don't show the argv[] in ps(1) output, they
2594 * show a string from the process struct and provide
2595 * the setproctitle() routine to manipulate that. */
2596 if (PL_origalen != 1) {
2597 s = SvPV_const(sv, len);
2598 # if __FreeBSD_version > 410001
2599 /* The leading "-" removes the "perl: " prefix,
2600 * but not the "(perl) suffix from the ps(1)
2601 * output, because that's what ps(1) shows if the
2602 * argv[] is modified. */
2603 setproctitle("-%s", s);
2604 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2605 /* This doesn't really work if you assume that
2606 * $0 = 'foobar'; will wipe out 'perl' from the $0
2607 * because in ps(1) output the result will be like
2608 * sprintf("perl: %s (perl)", s)
2609 * I guess this is a security feature:
2610 * one (a user process) cannot get rid of the original name.
2612 setproctitle("%s", s);
2615 #elif defined(__hpux) && defined(PSTAT_SETCMD)
2616 if (PL_origalen != 1) {
2618 s = SvPV_const(sv, len);
2619 un.pst_command = (char *)s;
2620 pstat(PSTAT_SETCMD, un, len, 0, 0);
2623 if (PL_origalen > 1) {
2624 /* PL_origalen is set in perl_parse(). */
2625 s = SvPV_force(sv,len);
2626 if (len >= (STRLEN)PL_origalen-1) {
2627 /* Longer than original, will be truncated. We assume that
2628 * PL_origalen bytes are available. */
2629 Copy(s, PL_origargv[0], PL_origalen-1, char);
2632 /* Shorter than original, will be padded. */
2634 /* Special case for Mac OS X: see [perl #38868] */
2637 /* Is the space counterintuitive? Yes.
2638 * (You were expecting \0?)
2639 * Does it work? Seems to. (In Linux 2.4.20 at least.)
2641 const int pad = ' ';
2643 Copy(s, PL_origargv[0], len, char);
2644 PL_origargv[0][len] = 0;
2645 memset(PL_origargv[0] + len + 1,
2646 pad, PL_origalen - len - 1);
2648 PL_origargv[0][PL_origalen-1] = 0;
2649 for (i = 1; i < PL_origargc; i++)
2653 UNLOCK_DOLLARZERO_MUTEX;
2661 Perl_whichsig(pTHX_ const char *sig)
2663 register char* const* sigv;
2664 PERL_UNUSED_CONTEXT;
2666 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
2667 if (strEQ(sig,*sigv))
2668 return PL_sig_num[sigv - (char* const*)PL_sig_name];
2670 if (strEQ(sig,"CHLD"))
2674 if (strEQ(sig,"CLD"))
2681 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2682 Perl_sighandler(int sig, ...)
2684 Perl_sighandler(int sig)
2687 #ifdef PERL_GET_SIG_CONTEXT
2688 dTHXa(PERL_GET_SIG_CONTEXT);
2695 SV * const tSv = PL_Sv;
2699 XPV * const tXpv = PL_Xpv;
2701 if (PL_savestack_ix + 15 <= PL_savestack_max)
2703 if (PL_markstack_ptr < PL_markstack_max - 2)
2705 if (PL_scopestack_ix < PL_scopestack_max - 3)
2708 if (!PL_psig_ptr[sig]) {
2709 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2714 /* Max number of items pushed there is 3*n or 4. We cannot fix
2715 infinity, so we fix 4 (in fact 5): */
2717 PL_savestack_ix += 5; /* Protect save in progress. */
2718 SAVEDESTRUCTOR_X(S_unwind_handler_stack, (void*)&flags);
2721 PL_markstack_ptr++; /* Protect mark. */
2723 PL_scopestack_ix += 1;
2724 /* sv_2cv is too complicated, try a simpler variant first: */
2725 if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
2726 || SvTYPE(cv) != SVt_PVCV) {
2728 cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
2731 if (!cv || !CvROOT(cv)) {
2732 if (ckWARN(WARN_SIGNAL))
2733 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2734 PL_sig_name[sig], (gv ? GvENAME(gv)
2741 if(PL_psig_name[sig]) {
2742 sv = SvREFCNT_inc_NN(PL_psig_name[sig]);
2744 #if !defined(PERL_IMPLICIT_CONTEXT)
2748 sv = sv_newmortal();
2749 sv_setpv(sv,PL_sig_name[sig]);
2752 PUSHSTACKi(PERLSI_SIGNAL);
2755 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2757 struct sigaction oact;
2759 if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
2763 va_start(args, sig);
2764 sip = (siginfo_t*)va_arg(args, siginfo_t*);
2767 SV *rv = newRV_noinc((SV*)sih);
2768 /* The siginfo fields signo, code, errno, pid, uid,
2769 * addr, status, and band are defined by POSIX/SUSv3. */
2770 hv_store(sih, "signo", 5, newSViv(sip->si_signo), 0);
2771 hv_store(sih, "code", 4, newSViv(sip->si_code), 0);
2772 #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. */
2773 hv_store(sih, "errno", 5, newSViv(sip->si_errno), 0);
2774 hv_store(sih, "status", 6, newSViv(sip->si_status), 0);
2775 hv_store(sih, "uid", 3, newSViv(sip->si_uid), 0);
2776 hv_store(sih, "pid", 3, newSViv(sip->si_pid), 0);
2777 hv_store(sih, "addr", 4, newSVuv(PTR2UV(sip->si_addr)), 0);
2778 hv_store(sih, "band", 4, newSViv(sip->si_band), 0);
2782 PUSHs(newSVpv((char *)sip, sizeof(*sip)));
2791 call_sv((SV*)cv, G_DISCARD|G_EVAL);
2794 if (SvTRUE(ERRSV)) {
2796 #ifdef HAS_SIGPROCMASK
2797 /* Handler "died", for example to get out of a restart-able read().
2798 * Before we re-do that on its behalf re-enable the signal which was
2799 * blocked by the system when we entered.
2803 sigaddset(&set,sig);
2804 sigprocmask(SIG_UNBLOCK, &set, NULL);
2806 /* Not clear if this will work */
2807 (void)rsignal(sig, SIG_IGN);
2808 (void)rsignal(sig, PL_csighandlerp);
2810 #endif /* !PERL_MICRO */
2811 Perl_die(aTHX_ NULL);
2815 PL_savestack_ix -= 8; /* Unprotect save in progress. */
2819 PL_scopestack_ix -= 1;
2822 PL_op = myop; /* Apparently not needed... */
2824 PL_Sv = tSv; /* Restore global temporaries. */
2831 S_restore_magic(pTHX_ const void *p)
2834 MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
2835 SV* const sv = mgs->mgs_sv;
2840 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2842 #ifdef PERL_OLD_COPY_ON_WRITE
2843 /* While magic was saved (and off) sv_setsv may well have seen
2844 this SV as a prime candidate for COW. */
2846 sv_force_normal_flags(sv, 0);
2850 SvFLAGS(sv) |= mgs->mgs_flags;
2853 if (SvGMAGICAL(sv)) {
2854 /* downgrade public flags to private,
2855 and discard any other private flags */
2857 const U32 pubflags = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
2859 SvFLAGS(sv) &= ~( pubflags | (SVp_IOK|SVp_NOK|SVp_POK) );
2860 SvFLAGS(sv) |= ( pubflags << PRIVSHIFT );
2865 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
2867 /* If we're still on top of the stack, pop us off. (That condition
2868 * will be satisfied if restore_magic was called explicitly, but *not*
2869 * if it's being called via leave_scope.)
2870 * The reason for doing this is that otherwise, things like sv_2cv()
2871 * may leave alloc gunk on the savestack, and some code
2872 * (e.g. sighandler) doesn't expect that...
2874 if (PL_savestack_ix == mgs->mgs_ss_ix)
2876 I32 popval = SSPOPINT;
2877 assert(popval == SAVEt_DESTRUCTOR_X);
2878 PL_savestack_ix -= 2;
2880 assert(popval == SAVEt_ALLOC);
2882 PL_savestack_ix -= popval;
2888 S_unwind_handler_stack(pTHX_ const void *p)
2891 const U32 flags = *(const U32*)p;
2894 PL_savestack_ix -= 5; /* Unprotect save in progress. */
2895 #if !defined(PERL_IMPLICIT_CONTEXT)
2897 SvREFCNT_dec(PL_sig_sv);
2902 =for apidoc magic_sethint
2904 Triggered by a store to %^H, records the key/value pair to
2905 C<PL_compiling.cop_hints_hash>. It is assumed that hints aren't storing
2906 anything that would need a deep copy. Maybe we should warn if we find a
2912 Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
2915 assert(mg->mg_len == HEf_SVKEY);
2917 /* mg->mg_obj isn't being used. If needed, it would be possible to store
2918 an alternative leaf in there, with PL_compiling.cop_hints being used if
2919 it's NULL. If needed for threads, the alternative could lock a mutex,
2920 or take other more complex action. */
2922 /* Something changed in %^H, so it will need to be restored on scope exit.
2923 Doing this here saves a lot of doing it manually in perl code (and
2924 forgetting to do it, and consequent subtle errors. */
2925 PL_hints |= HINT_LOCALIZE_HH;
2926 PL_compiling.cop_hints_hash
2927 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
2928 (SV *)mg->mg_ptr, sv);
2933 =for apidoc magic_sethint
2935 Triggered by a delete from %^H, records the key to
2936 C<PL_compiling.cop_hints_hash>.
2941 Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
2944 PERL_UNUSED_ARG(sv);
2946 assert(mg->mg_len == HEf_SVKEY);
2948 PERL_UNUSED_ARG(sv);
2950 PL_hints |= HINT_LOCALIZE_HH;
2951 PL_compiling.cop_hints_hash
2952 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
2953 (SV *)mg->mg_ptr, &PL_sv_placeholder);
2959 * c-indentation-style: bsd
2961 * indent-tabs-mode: t
2964 * ex: set ts=8 sts=4 sw=4 noet: