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);
1293 #ifndef SIG_PENDING_DIE_COUNT
1294 # define SIG_PENDING_DIE_COUNT 120
1298 S_raise_signal(pTHX_ int sig)
1301 /* Set a flag to say this signal is pending */
1302 PL_psig_pend[sig]++;
1303 /* And one to say _a_ signal is pending */
1304 if (++PL_sig_pending >= SIG_PENDING_DIE_COUNT)
1305 Perl_croak(aTHX_ "Maximal count of pending signals (%lu) exceeded",
1306 (unsigned long)SIG_PENDING_DIE_COUNT);
1310 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1311 Perl_csighandler(int sig, ...)
1313 Perl_csighandler(int sig)
1316 #ifdef PERL_GET_SIG_CONTEXT
1317 dTHXa(PERL_GET_SIG_CONTEXT);
1321 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1322 (void) rsignal(sig, PL_csighandlerp);
1323 if (PL_sig_ignoring[sig]) return;
1325 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1326 if (PL_sig_defaulting[sig])
1327 #ifdef KILL_BY_SIGPRC
1328 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1343 (PL_signals & PERL_SIGNALS_UNSAFE_FLAG))
1344 /* Call the perl level handler now--
1345 * with risk we may be in malloc() etc. */
1346 (*PL_sighandlerp)(sig);
1348 S_raise_signal(aTHX_ sig);
1351 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1353 Perl_csighandler_init(void)
1356 if (PL_sig_handlers_initted) return;
1358 for (sig = 1; sig < SIG_SIZE; sig++) {
1359 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1361 PL_sig_defaulting[sig] = 1;
1362 (void) rsignal(sig, PL_csighandlerp);
1364 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1365 PL_sig_ignoring[sig] = 0;
1368 PL_sig_handlers_initted = 1;
1373 Perl_despatch_signals(pTHX)
1378 for (sig = 1; sig < SIG_SIZE; sig++) {
1379 if (PL_psig_pend[sig]) {
1380 PERL_BLOCKSIG_ADD(set, sig);
1381 PL_psig_pend[sig] = 0;
1382 PERL_BLOCKSIG_BLOCK(set);
1383 (*PL_sighandlerp)(sig);
1384 PERL_BLOCKSIG_UNBLOCK(set);
1390 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1395 /* Need to be careful with SvREFCNT_dec(), because that can have side
1396 * effects (due to closures). We must make sure that the new disposition
1397 * is in place before it is called.
1401 #ifdef HAS_SIGPROCMASK
1406 register const char *s = MgPV_const(mg,len);
1408 if (strEQ(s,"__DIE__"))
1410 else if (strEQ(s,"__WARN__"))
1413 Perl_croak(aTHX_ "No such hook: %s", s);
1416 if (*svp != PERL_WARNHOOK_FATAL)
1422 i = whichsig(s); /* ...no, a brick */
1424 if (ckWARN(WARN_SIGNAL))
1425 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
1428 #ifdef HAS_SIGPROCMASK
1429 /* Avoid having the signal arrive at a bad time, if possible. */
1432 sigprocmask(SIG_BLOCK, &set, &save);
1434 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1435 SAVEFREESV(save_sv);
1436 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1439 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1440 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1442 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1443 PL_sig_ignoring[i] = 0;
1445 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1446 PL_sig_defaulting[i] = 0;
1448 SvREFCNT_dec(PL_psig_name[i]);
1449 to_dec = PL_psig_ptr[i];
1450 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1451 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1452 PL_psig_name[i] = newSVpvn(s, len);
1453 SvREADONLY_on(PL_psig_name[i]);
1455 if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
1457 (void)rsignal(i, PL_csighandlerp);
1458 #ifdef HAS_SIGPROCMASK
1463 *svp = SvREFCNT_inc_simple_NN(sv);
1465 SvREFCNT_dec(to_dec);
1468 s = SvOK(sv) ? SvPV_force(sv,len) : "DEFAULT";
1469 if (strEQ(s,"IGNORE")) {
1471 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1472 PL_sig_ignoring[i] = 1;
1473 (void)rsignal(i, PL_csighandlerp);
1475 (void)rsignal(i, (Sighandler_t) SIG_IGN);
1479 else if (strEQ(s,"DEFAULT") || !*s) {
1481 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1483 PL_sig_defaulting[i] = 1;
1484 (void)rsignal(i, PL_csighandlerp);
1487 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1492 * We should warn if HINT_STRICT_REFS, but without
1493 * access to a known hint bit in a known OP, we can't
1494 * tell whether HINT_STRICT_REFS is in force or not.
1496 if (!strchr(s,':') && !strchr(s,'\''))
1497 Perl_sv_insert(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"));
1499 (void)rsignal(i, PL_csighandlerp);
1501 *svp = SvREFCNT_inc_simple_NN(sv);
1503 #ifdef HAS_SIGPROCMASK
1508 SvREFCNT_dec(to_dec);
1511 #endif /* !PERL_MICRO */
1514 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1517 PERL_UNUSED_ARG(sv);
1518 PERL_UNUSED_ARG(mg);
1519 PL_sub_generation++;
1524 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
1527 PERL_UNUSED_ARG(sv);
1528 PERL_UNUSED_ARG(mg);
1529 /* HV_badAMAGIC_on(Sv_STASH(sv)); */
1530 PL_amagic_generation++;
1536 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1538 HV * const hv = (HV*)LvTARG(sv);
1540 PERL_UNUSED_ARG(mg);
1543 (void) hv_iterinit(hv);
1544 if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
1547 while (hv_iternext(hv))
1552 sv_setiv(sv, (IV)i);
1557 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1559 PERL_UNUSED_ARG(mg);
1561 hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
1566 /* caller is responsible for stack switching/cleanup */
1568 S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV *val)
1575 PUSHs(SvTIED_obj(sv, mg));
1578 if (mg->mg_len >= 0)
1579 PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len)));
1580 else if (mg->mg_len == HEf_SVKEY)
1581 PUSHs((SV*)mg->mg_ptr);
1583 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1584 PUSHs(sv_2mortal(newSViv(mg->mg_len)));
1592 return call_method(meth, flags);
1596 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
1602 PUSHSTACKi(PERLSI_MAGIC);
1604 if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
1605 sv_setsv(sv, *PL_stack_sp--);
1615 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1618 mg->mg_flags |= MGf_GSKIP;
1619 magic_methpack(sv,mg,"FETCH");
1624 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1628 PUSHSTACKi(PERLSI_MAGIC);
1629 magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
1636 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1638 return magic_methpack(sv,mg,"DELETE");
1643 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1650 PUSHSTACKi(PERLSI_MAGIC);
1651 if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
1652 sv = *PL_stack_sp--;
1653 retval = (U32) SvIV(sv)-1;
1662 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1667 PUSHSTACKi(PERLSI_MAGIC);
1669 XPUSHs(SvTIED_obj(sv, mg));
1671 call_method("CLEAR", G_SCALAR|G_DISCARD);
1679 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1682 const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
1686 PUSHSTACKi(PERLSI_MAGIC);
1689 PUSHs(SvTIED_obj(sv, mg));
1694 if (call_method(meth, G_SCALAR))
1695 sv_setsv(key, *PL_stack_sp--);
1704 Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg)
1706 return magic_methpack(sv,mg,"EXISTS");
1710 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1714 SV * const tied = SvTIED_obj((SV*)hv, mg);
1715 HV * const pkg = SvSTASH((SV*)SvRV(tied));
1717 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1719 if (HvEITER_get(hv))
1720 /* we are in an iteration so the hash cannot be empty */
1722 /* no xhv_eiter so now use FIRSTKEY */
1723 key = sv_newmortal();
1724 magic_nextpack((SV*)hv, mg, key);
1725 HvEITER_set(hv, NULL); /* need to reset iterator */
1726 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1729 /* there is a SCALAR method that we can call */
1731 PUSHSTACKi(PERLSI_MAGIC);
1737 if (call_method("SCALAR", G_SCALAR))
1738 retval = *PL_stack_sp--;
1740 retval = &PL_sv_undef;
1747 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1750 GV * const gv = PL_DBline;
1751 const I32 i = SvTRUE(sv);
1752 SV ** const svp = av_fetch(GvAV(gv),
1753 atoi(MgPV_nolen_const(mg)), FALSE);
1754 if (svp && SvIOKp(*svp)) {
1755 OP * const o = INT2PTR(OP*,SvIVX(*svp));
1757 /* set or clear breakpoint in the relevant control op */
1759 o->op_flags |= OPf_SPECIAL;
1761 o->op_flags &= ~OPf_SPECIAL;
1768 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
1771 const AV * const obj = (AV*)mg->mg_obj;
1773 sv_setiv(sv, AvFILL(obj) + CopARYBASE_get(PL_curcop));
1781 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
1784 AV * const obj = (AV*)mg->mg_obj;
1786 av_fill(obj, SvIV(sv) - CopARYBASE_get(PL_curcop));
1788 if (ckWARN(WARN_MISC))
1789 Perl_warner(aTHX_ packWARN(WARN_MISC),
1790 "Attempt to set length of freed array");
1796 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
1799 PERL_UNUSED_ARG(sv);
1800 /* during global destruction, mg_obj may already have been freed */
1801 if (PL_in_clean_all)
1804 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
1807 /* arylen scalar holds a pointer back to the array, but doesn't own a
1808 reference. Hence the we (the array) are about to go away with it
1809 still pointing at us. Clear its pointer, else it would be pointing
1810 at free memory. See the comment in sv_magic about reference loops,
1811 and why it can't own a reference to us. */
1818 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
1821 SV* const lsv = LvTARG(sv);
1822 PERL_UNUSED_ARG(mg);
1824 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1825 MAGIC * const found = mg_find(lsv, PERL_MAGIC_regex_global);
1826 if (found && found->mg_len >= 0) {
1827 I32 i = found->mg_len;
1829 sv_pos_b2u(lsv, &i);
1830 sv_setiv(sv, i + CopARYBASE_get(PL_curcop));
1839 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
1842 SV* const lsv = LvTARG(sv);
1848 PERL_UNUSED_ARG(mg);
1850 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
1851 found = mg_find(lsv, PERL_MAGIC_regex_global);
1857 #ifdef PERL_OLD_COPY_ON_WRITE
1859 sv_force_normal_flags(lsv, 0);
1861 found = sv_magicext(lsv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
1864 else if (!SvOK(sv)) {
1868 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1870 pos = SvIV(sv) - CopARYBASE_get(PL_curcop);
1873 ulen = sv_len_utf8(lsv);
1883 else if (pos > (SSize_t)len)
1888 sv_pos_u2b(lsv, &p, 0);
1892 found->mg_len = pos;
1893 found->mg_flags &= ~MGf_MINMATCH;
1899 Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg)
1902 PERL_UNUSED_ARG(mg);
1906 if (isGV_with_GP(sv)) {
1907 /* We're actually already a typeglob, so don't need the stuff below.
1911 gv = gv_fetchsv(sv, GV_ADD, SVt_PVGV);
1916 GvGP(sv) = gp_ref(GvGP(gv));
1921 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
1924 SV * const lsv = LvTARG(sv);
1925 const char * const tmps = SvPV_const(lsv,len);
1926 I32 offs = LvTARGOFF(sv);
1927 I32 rem = LvTARGLEN(sv);
1928 PERL_UNUSED_ARG(mg);
1931 sv_pos_u2b(lsv, &offs, &rem);
1932 if (offs > (I32)len)
1934 if (rem + offs > (I32)len)
1936 sv_setpvn(sv, tmps + offs, (STRLEN)rem);
1943 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
1947 const char * const tmps = SvPV_const(sv, len);
1948 SV * const lsv = LvTARG(sv);
1949 I32 lvoff = LvTARGOFF(sv);
1950 I32 lvlen = LvTARGLEN(sv);
1951 PERL_UNUSED_ARG(mg);
1954 sv_utf8_upgrade(lsv);
1955 sv_pos_u2b(lsv, &lvoff, &lvlen);
1956 sv_insert(lsv, lvoff, lvlen, tmps, len);
1957 LvTARGLEN(sv) = sv_len_utf8(sv);
1960 else if (lsv && SvUTF8(lsv)) {
1962 sv_pos_u2b(lsv, &lvoff, &lvlen);
1963 LvTARGLEN(sv) = len;
1964 utf8 = (char*)bytes_to_utf8((U8*)tmps, &len);
1965 sv_insert(lsv, lvoff, lvlen, utf8, len);
1969 sv_insert(lsv, lvoff, lvlen, tmps, len);
1970 LvTARGLEN(sv) = len;
1978 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
1981 PERL_UNUSED_ARG(sv);
1982 TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
1987 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
1990 PERL_UNUSED_ARG(sv);
1991 /* update taint status unless we're restoring at scope exit */
1992 if (PL_localizing != 2) {
2002 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
2004 SV * const lsv = LvTARG(sv);
2005 PERL_UNUSED_ARG(mg);
2008 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
2016 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
2018 PERL_UNUSED_ARG(mg);
2019 do_vecset(sv); /* XXX slurp this routine */
2024 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
2028 if (LvTARGLEN(sv)) {
2030 SV * const ahv = LvTARG(sv);
2031 HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
2036 AV* const av = (AV*)LvTARG(sv);
2037 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
2038 targ = AvARRAY(av)[LvTARGOFF(sv)];
2040 if (targ && (targ != &PL_sv_undef)) {
2041 /* somebody else defined it for us */
2042 SvREFCNT_dec(LvTARG(sv));
2043 LvTARG(sv) = SvREFCNT_inc_simple_NN(targ);
2045 SvREFCNT_dec(mg->mg_obj);
2047 mg->mg_flags &= ~MGf_REFCOUNTED;
2052 sv_setsv(sv, targ ? targ : &PL_sv_undef);
2057 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
2059 PERL_UNUSED_ARG(mg);
2063 sv_setsv(LvTARG(sv), sv);
2064 SvSETMAGIC(LvTARG(sv));
2070 Perl_vivify_defelem(pTHX_ SV *sv)
2076 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2079 SV * const ahv = LvTARG(sv);
2080 HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
2083 if (!value || value == &PL_sv_undef)
2084 Perl_croak(aTHX_ PL_no_helem_sv, mg->mg_obj);
2087 AV* const av = (AV*)LvTARG(sv);
2088 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
2089 LvTARG(sv) = NULL; /* array can't be extended */
2091 SV* const * const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
2092 if (!svp || (value = *svp) == &PL_sv_undef)
2093 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
2096 SvREFCNT_inc_simple_void(value);
2097 SvREFCNT_dec(LvTARG(sv));
2100 SvREFCNT_dec(mg->mg_obj);
2102 mg->mg_flags &= ~MGf_REFCOUNTED;
2106 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2108 return Perl_sv_kill_backrefs(aTHX_ sv, (AV*)mg->mg_obj);
2112 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2114 PERL_UNUSED_CONTEXT;
2121 Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
2123 PERL_UNUSED_ARG(mg);
2124 sv_unmagic(sv, PERL_MAGIC_bm);
2131 Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
2133 PERL_UNUSED_ARG(mg);
2134 sv_unmagic(sv, PERL_MAGIC_fm);
2140 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2142 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2144 if (uf && uf->uf_set)
2145 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2150 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2152 PERL_UNUSED_ARG(mg);
2153 sv_unmagic(sv, PERL_MAGIC_qr);
2158 Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
2161 regexp * const re = (regexp *)mg->mg_obj;
2162 PERL_UNUSED_ARG(sv);
2168 #ifdef USE_LOCALE_COLLATE
2170 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2173 * RenE<eacute> Descartes said "I think not."
2174 * and vanished with a faint plop.
2176 PERL_UNUSED_CONTEXT;
2177 PERL_UNUSED_ARG(sv);
2179 Safefree(mg->mg_ptr);
2185 #endif /* USE_LOCALE_COLLATE */
2187 /* Just clear the UTF-8 cache data. */
2189 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2191 PERL_UNUSED_CONTEXT;
2192 PERL_UNUSED_ARG(sv);
2193 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2195 mg->mg_len = -1; /* The mg_len holds the len cache. */
2200 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2203 register const char *s;
2206 switch (*mg->mg_ptr) {
2207 case '\001': /* ^A */
2208 sv_setsv(PL_bodytarget, sv);
2210 case '\003': /* ^C */
2211 PL_minus_c = (bool)SvIV(sv);
2214 case '\004': /* ^D */
2216 s = SvPV_nolen_const(sv);
2217 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2218 DEBUG_x(dump_all());
2220 PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG;
2223 case '\005': /* ^E */
2224 if (*(mg->mg_ptr+1) == '\0') {
2225 #ifdef MACOS_TRADITIONAL
2226 gMacPerl_OSErr = SvIV(sv);
2229 set_vaxc_errno(SvIV(sv));
2232 SetLastError( SvIV(sv) );
2235 os2_setsyserrno(SvIV(sv));
2237 /* will anyone ever use this? */
2238 SETERRNO(SvIV(sv), 4);
2244 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2246 SvREFCNT_dec(PL_encoding);
2247 if (SvOK(sv) || SvGMAGICAL(sv)) {
2248 PL_encoding = newSVsv(sv);
2255 case '\006': /* ^F */
2256 PL_maxsysfd = SvIV(sv);
2258 case '\010': /* ^H */
2259 PL_hints = SvIV(sv);
2261 case '\011': /* ^I */ /* NOT \t in EBCDIC */
2262 Safefree(PL_inplace);
2263 PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
2265 case '\017': /* ^O */
2266 if (*(mg->mg_ptr+1) == '\0') {
2267 Safefree(PL_osname);
2270 TAINT_PROPER("assigning to $^O");
2271 PL_osname = savesvpv(sv);
2274 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2275 PL_compiling.cop_hints |= HINT_LEXICAL_IO;
2276 PL_hints |= HINT_LOCALIZE_HH | HINT_LEXICAL_IO;
2277 PL_compiling.cop_hints_hash
2278 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
2279 sv_2mortal(newSVpvs("open")), sv);
2282 case '\020': /* ^P */
2283 PL_perldb = SvIV(sv);
2284 if (PL_perldb && !PL_DBsingle)
2287 case '\024': /* ^T */
2289 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2291 PL_basetime = (Time_t)SvIV(sv);
2294 case '\025': /* ^UTF8CACHE */
2295 if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
2296 PL_utf8cache = (signed char) sv_2iv(sv);
2299 case '\027': /* ^W & $^WARNING_BITS */
2300 if (*(mg->mg_ptr+1) == '\0') {
2301 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2303 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2304 | (i ? G_WARN_ON : G_WARN_OFF) ;
2307 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2308 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2309 if (!SvPOK(sv) && PL_localizing) {
2310 sv_setpvn(sv, WARN_NONEstring, WARNsize);
2311 PL_compiling.cop_warnings = pWARN_NONE;
2316 int accumulate = 0 ;
2317 int any_fatals = 0 ;
2318 const char * const ptr = SvPV_const(sv, len) ;
2319 for (i = 0 ; i < len ; ++i) {
2320 accumulate |= ptr[i] ;
2321 any_fatals |= (ptr[i] & 0xAA) ;
2324 if (!specialWARN(PL_compiling.cop_warnings))
2325 PerlMemShared_free(PL_compiling.cop_warnings);
2326 PL_compiling.cop_warnings = pWARN_NONE;
2328 /* Yuck. I can't see how to abstract this: */
2329 else if (isWARN_on(((STRLEN *)SvPV_nolen_const(sv)) - 1,
2330 WARN_ALL) && !any_fatals) {
2331 if (!specialWARN(PL_compiling.cop_warnings))
2332 PerlMemShared_free(PL_compiling.cop_warnings);
2333 PL_compiling.cop_warnings = pWARN_ALL;
2334 PL_dowarn |= G_WARN_ONCE ;
2338 const char *const p = SvPV_const(sv, len);
2340 PL_compiling.cop_warnings
2341 = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
2344 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2345 PL_dowarn |= G_WARN_ONCE ;
2353 if (PL_localizing) {
2354 if (PL_localizing == 1)
2355 SAVESPTR(PL_last_in_gv);
2357 else if (SvOK(sv) && GvIO(PL_last_in_gv))
2358 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2361 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2362 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2363 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2366 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2367 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2368 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2371 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
2374 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
2375 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2376 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2379 IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
2383 IO * const io = GvIOp(PL_defoutgv);
2386 if ((SvIV(sv)) == 0)
2387 IoFLAGS(io) &= ~IOf_FLUSH;
2389 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2390 PerlIO *ofp = IoOFP(io);
2392 (void)PerlIO_flush(ofp);
2393 IoFLAGS(io) |= IOf_FLUSH;
2399 SvREFCNT_dec(PL_rs);
2400 PL_rs = newSVsv(sv);
2404 SvREFCNT_dec(PL_ors_sv);
2405 if (SvOK(sv) || SvGMAGICAL(sv)) {
2406 PL_ors_sv = newSVsv(sv);
2414 SvREFCNT_dec(PL_ofs_sv);
2415 if (SvOK(sv) || SvGMAGICAL(sv)) {
2416 PL_ofs_sv = newSVsv(sv);
2423 CopARYBASE_set(&PL_compiling, SvIV(sv));
2426 #ifdef COMPLEX_STATUS
2427 if (PL_localizing == 2) {
2428 PL_statusvalue = LvTARGOFF(sv);
2429 PL_statusvalue_vms = LvTARGLEN(sv);
2433 #ifdef VMSISH_STATUS
2435 STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2438 STATUS_UNIX_EXIT_SET(SvIV(sv));
2443 # define PERL_VMS_BANG vaxc$errno
2445 # define PERL_VMS_BANG 0
2447 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2448 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2453 if (PL_delaymagic) {
2454 PL_delaymagic |= DM_RUID;
2455 break; /* don't do magic till later */
2458 (void)setruid((Uid_t)PL_uid);
2461 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2463 #ifdef HAS_SETRESUID
2464 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2466 if (PL_uid == PL_euid) { /* special case $< = $> */
2468 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2469 if (PL_uid != 0 && PerlProc_getuid() == 0)
2470 (void)PerlProc_setuid(0);
2472 (void)PerlProc_setuid(PL_uid);
2474 PL_uid = PerlProc_getuid();
2475 Perl_croak(aTHX_ "setruid() not implemented");
2480 PL_uid = PerlProc_getuid();
2481 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2485 if (PL_delaymagic) {
2486 PL_delaymagic |= DM_EUID;
2487 break; /* don't do magic till later */
2490 (void)seteuid((Uid_t)PL_euid);
2493 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2495 #ifdef HAS_SETRESUID
2496 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2498 if (PL_euid == PL_uid) /* special case $> = $< */
2499 PerlProc_setuid(PL_euid);
2501 PL_euid = PerlProc_geteuid();
2502 Perl_croak(aTHX_ "seteuid() not implemented");
2507 PL_euid = PerlProc_geteuid();
2508 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2512 if (PL_delaymagic) {
2513 PL_delaymagic |= DM_RGID;
2514 break; /* don't do magic till later */
2517 (void)setrgid((Gid_t)PL_gid);
2520 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2522 #ifdef HAS_SETRESGID
2523 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2525 if (PL_gid == PL_egid) /* special case $( = $) */
2526 (void)PerlProc_setgid(PL_gid);
2528 PL_gid = PerlProc_getgid();
2529 Perl_croak(aTHX_ "setrgid() not implemented");
2534 PL_gid = PerlProc_getgid();
2535 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2538 #ifdef HAS_SETGROUPS
2540 const char *p = SvPV_const(sv, len);
2541 Groups_t *gary = NULL;
2546 for (i = 0; i < NGROUPS; ++i) {
2547 while (*p && !isSPACE(*p))
2554 Newx(gary, i + 1, Groups_t);
2556 Renew(gary, i + 1, Groups_t);
2560 (void)setgroups(i, gary);
2563 #else /* HAS_SETGROUPS */
2565 #endif /* HAS_SETGROUPS */
2566 if (PL_delaymagic) {
2567 PL_delaymagic |= DM_EGID;
2568 break; /* don't do magic till later */
2571 (void)setegid((Gid_t)PL_egid);
2574 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2576 #ifdef HAS_SETRESGID
2577 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2579 if (PL_egid == PL_gid) /* special case $) = $( */
2580 (void)PerlProc_setgid(PL_egid);
2582 PL_egid = PerlProc_getegid();
2583 Perl_croak(aTHX_ "setegid() not implemented");
2588 PL_egid = PerlProc_getegid();
2589 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2592 PL_chopset = SvPV_force(sv,len);
2594 #ifndef MACOS_TRADITIONAL
2596 LOCK_DOLLARZERO_MUTEX;
2597 #ifdef HAS_SETPROCTITLE
2598 /* The BSDs don't show the argv[] in ps(1) output, they
2599 * show a string from the process struct and provide
2600 * the setproctitle() routine to manipulate that. */
2601 if (PL_origalen != 1) {
2602 s = SvPV_const(sv, len);
2603 # if __FreeBSD_version > 410001
2604 /* The leading "-" removes the "perl: " prefix,
2605 * but not the "(perl) suffix from the ps(1)
2606 * output, because that's what ps(1) shows if the
2607 * argv[] is modified. */
2608 setproctitle("-%s", s);
2609 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2610 /* This doesn't really work if you assume that
2611 * $0 = 'foobar'; will wipe out 'perl' from the $0
2612 * because in ps(1) output the result will be like
2613 * sprintf("perl: %s (perl)", s)
2614 * I guess this is a security feature:
2615 * one (a user process) cannot get rid of the original name.
2617 setproctitle("%s", s);
2620 #elif defined(__hpux) && defined(PSTAT_SETCMD)
2621 if (PL_origalen != 1) {
2623 s = SvPV_const(sv, len);
2624 un.pst_command = (char *)s;
2625 pstat(PSTAT_SETCMD, un, len, 0, 0);
2628 if (PL_origalen > 1) {
2629 /* PL_origalen is set in perl_parse(). */
2630 s = SvPV_force(sv,len);
2631 if (len >= (STRLEN)PL_origalen-1) {
2632 /* Longer than original, will be truncated. We assume that
2633 * PL_origalen bytes are available. */
2634 Copy(s, PL_origargv[0], PL_origalen-1, char);
2637 /* Shorter than original, will be padded. */
2639 /* Special case for Mac OS X: see [perl #38868] */
2642 /* Is the space counterintuitive? Yes.
2643 * (You were expecting \0?)
2644 * Does it work? Seems to. (In Linux 2.4.20 at least.)
2646 const int pad = ' ';
2648 Copy(s, PL_origargv[0], len, char);
2649 PL_origargv[0][len] = 0;
2650 memset(PL_origargv[0] + len + 1,
2651 pad, PL_origalen - len - 1);
2653 PL_origargv[0][PL_origalen-1] = 0;
2654 for (i = 1; i < PL_origargc; i++)
2658 UNLOCK_DOLLARZERO_MUTEX;
2666 Perl_whichsig(pTHX_ const char *sig)
2668 register char* const* sigv;
2669 PERL_UNUSED_CONTEXT;
2671 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
2672 if (strEQ(sig,*sigv))
2673 return PL_sig_num[sigv - (char* const*)PL_sig_name];
2675 if (strEQ(sig,"CHLD"))
2679 if (strEQ(sig,"CLD"))
2686 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2687 Perl_sighandler(int sig, ...)
2689 Perl_sighandler(int sig)
2692 #ifdef PERL_GET_SIG_CONTEXT
2693 dTHXa(PERL_GET_SIG_CONTEXT);
2700 SV * const tSv = PL_Sv;
2704 XPV * const tXpv = PL_Xpv;
2706 if (PL_savestack_ix + 15 <= PL_savestack_max)
2708 if (PL_markstack_ptr < PL_markstack_max - 2)
2710 if (PL_scopestack_ix < PL_scopestack_max - 3)
2713 if (!PL_psig_ptr[sig]) {
2714 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2719 /* Max number of items pushed there is 3*n or 4. We cannot fix
2720 infinity, so we fix 4 (in fact 5): */
2722 PL_savestack_ix += 5; /* Protect save in progress. */
2723 SAVEDESTRUCTOR_X(S_unwind_handler_stack, (void*)&flags);
2726 PL_markstack_ptr++; /* Protect mark. */
2728 PL_scopestack_ix += 1;
2729 /* sv_2cv is too complicated, try a simpler variant first: */
2730 if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
2731 || SvTYPE(cv) != SVt_PVCV) {
2733 cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
2736 if (!cv || !CvROOT(cv)) {
2737 if (ckWARN(WARN_SIGNAL))
2738 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2739 PL_sig_name[sig], (gv ? GvENAME(gv)
2746 if(PL_psig_name[sig]) {
2747 sv = SvREFCNT_inc_NN(PL_psig_name[sig]);
2749 #if !defined(PERL_IMPLICIT_CONTEXT)
2753 sv = sv_newmortal();
2754 sv_setpv(sv,PL_sig_name[sig]);
2757 PUSHSTACKi(PERLSI_SIGNAL);
2760 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2762 struct sigaction oact;
2764 if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
2768 va_start(args, sig);
2769 sip = (siginfo_t*)va_arg(args, siginfo_t*);
2772 SV *rv = newRV_noinc((SV*)sih);
2773 /* The siginfo fields signo, code, errno, pid, uid,
2774 * addr, status, and band are defined by POSIX/SUSv3. */
2775 hv_store(sih, "signo", 5, newSViv(sip->si_signo), 0);
2776 hv_store(sih, "code", 4, newSViv(sip->si_code), 0);
2777 #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. */
2778 hv_store(sih, "errno", 5, newSViv(sip->si_errno), 0);
2779 hv_store(sih, "status", 6, newSViv(sip->si_status), 0);
2780 hv_store(sih, "uid", 3, newSViv(sip->si_uid), 0);
2781 hv_store(sih, "pid", 3, newSViv(sip->si_pid), 0);
2782 hv_store(sih, "addr", 4, newSVuv(PTR2UV(sip->si_addr)), 0);
2783 hv_store(sih, "band", 4, newSViv(sip->si_band), 0);
2787 PUSHs(newSVpv((char *)sip, sizeof(*sip)));
2796 call_sv((SV*)cv, G_DISCARD|G_EVAL);
2799 if (SvTRUE(ERRSV)) {
2801 #ifdef HAS_SIGPROCMASK
2802 /* Handler "died", for example to get out of a restart-able read().
2803 * Before we re-do that on its behalf re-enable the signal which was
2804 * blocked by the system when we entered.
2808 sigaddset(&set,sig);
2809 sigprocmask(SIG_UNBLOCK, &set, NULL);
2811 /* Not clear if this will work */
2812 (void)rsignal(sig, SIG_IGN);
2813 (void)rsignal(sig, PL_csighandlerp);
2815 #endif /* !PERL_MICRO */
2816 Perl_die(aTHX_ NULL);
2820 PL_savestack_ix -= 8; /* Unprotect save in progress. */
2824 PL_scopestack_ix -= 1;
2827 PL_op = myop; /* Apparently not needed... */
2829 PL_Sv = tSv; /* Restore global temporaries. */
2836 S_restore_magic(pTHX_ const void *p)
2839 MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
2840 SV* const sv = mgs->mgs_sv;
2845 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2847 #ifdef PERL_OLD_COPY_ON_WRITE
2848 /* While magic was saved (and off) sv_setsv may well have seen
2849 this SV as a prime candidate for COW. */
2851 sv_force_normal_flags(sv, 0);
2855 SvFLAGS(sv) |= mgs->mgs_flags;
2858 if (SvGMAGICAL(sv)) {
2859 /* downgrade public flags to private,
2860 and discard any other private flags */
2862 const U32 pubflags = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
2864 SvFLAGS(sv) &= ~( pubflags | (SVp_IOK|SVp_NOK|SVp_POK) );
2865 SvFLAGS(sv) |= ( pubflags << PRIVSHIFT );
2870 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
2872 /* If we're still on top of the stack, pop us off. (That condition
2873 * will be satisfied if restore_magic was called explicitly, but *not*
2874 * if it's being called via leave_scope.)
2875 * The reason for doing this is that otherwise, things like sv_2cv()
2876 * may leave alloc gunk on the savestack, and some code
2877 * (e.g. sighandler) doesn't expect that...
2879 if (PL_savestack_ix == mgs->mgs_ss_ix)
2881 I32 popval = SSPOPINT;
2882 assert(popval == SAVEt_DESTRUCTOR_X);
2883 PL_savestack_ix -= 2;
2885 assert(popval == SAVEt_ALLOC);
2887 PL_savestack_ix -= popval;
2893 S_unwind_handler_stack(pTHX_ const void *p)
2896 const U32 flags = *(const U32*)p;
2899 PL_savestack_ix -= 5; /* Unprotect save in progress. */
2900 #if !defined(PERL_IMPLICIT_CONTEXT)
2902 SvREFCNT_dec(PL_sig_sv);
2907 =for apidoc magic_sethint
2909 Triggered by a store to %^H, records the key/value pair to
2910 C<PL_compiling.cop_hints_hash>. It is assumed that hints aren't storing
2911 anything that would need a deep copy. Maybe we should warn if we find a
2917 Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
2920 assert(mg->mg_len == HEf_SVKEY);
2922 /* mg->mg_obj isn't being used. If needed, it would be possible to store
2923 an alternative leaf in there, with PL_compiling.cop_hints being used if
2924 it's NULL. If needed for threads, the alternative could lock a mutex,
2925 or take other more complex action. */
2927 /* Something changed in %^H, so it will need to be restored on scope exit.
2928 Doing this here saves a lot of doing it manually in perl code (and
2929 forgetting to do it, and consequent subtle errors. */
2930 PL_hints |= HINT_LOCALIZE_HH;
2931 PL_compiling.cop_hints_hash
2932 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
2933 (SV *)mg->mg_ptr, sv);
2938 =for apidoc magic_sethint
2940 Triggered by a delete from %^H, records the key to
2941 C<PL_compiling.cop_hints_hash>.
2946 Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
2949 PERL_UNUSED_ARG(sv);
2951 assert(mg->mg_len == HEf_SVKEY);
2953 PERL_UNUSED_ARG(sv);
2955 PL_hints |= HINT_LOCALIZE_HH;
2956 PL_compiling.cop_hints_hash
2957 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
2958 (SV *)mg->mg_ptr, &PL_sv_placeholder);
2964 * c-indentation-style: bsd
2966 * indent-tabs-mode: t
2969 * ex: set ts=8 sts=4 sw=4 noet: