3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 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 if (!(SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK))) {
104 /* No public flags are set, so promote any private flags to public. */
105 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
110 =for apidoc mg_magical
112 Turns on the magical status of an SV. See C<sv_magic>.
118 Perl_mg_magical(pTHX_ SV *sv)
122 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
123 const MGVTBL* const vtbl = mg->mg_virtual;
125 if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
129 if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)) || vtbl->svt_clear)
138 Do magic after a value is retrieved from the SV. See C<sv_magic>.
144 Perl_mg_get(pTHX_ SV *sv)
147 const I32 mgs_ix = SSNEW(sizeof(MGS));
148 const bool was_temp = (bool)SvTEMP(sv);
150 MAGIC *newmg, *head, *cur, *mg;
151 /* guard against sv having being freed midway by holding a private
154 /* sv_2mortal has this side effect of turning on the TEMP flag, which can
155 cause the SV's buffer to get stolen (and maybe other stuff).
158 sv_2mortal(SvREFCNT_inc_simple_NN(sv));
163 save_magic(mgs_ix, sv);
165 /* We must call svt_get(sv, mg) for each valid entry in the linked
166 list of magic. svt_get() may delete the current entry, add new
167 magic to the head of the list, or upgrade the SV. AMS 20010810 */
169 newmg = cur = head = mg = SvMAGIC(sv);
171 const MGVTBL * const vtbl = mg->mg_virtual;
173 if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
174 CALL_FPTR(vtbl->svt_get)(aTHX_ sv, mg);
176 /* guard against magic having been deleted - eg FETCH calling
181 /* Don't restore the flags for this entry if it was deleted. */
182 if (mg->mg_flags & MGf_GSKIP)
183 (SSPTR(mgs_ix, MGS *))->mgs_flags = 0;
186 mg = mg->mg_moremagic;
189 /* Have we finished with the new entries we saw? Start again
190 where we left off (unless there are more new entries). */
198 /* Were any new entries added? */
199 if (!have_new && (newmg = SvMAGIC(sv)) != head) {
206 restore_magic(INT2PTR(void *, (IV)mgs_ix));
208 if (SvREFCNT(sv) == 1) {
209 /* We hold the last reference to this SV, which implies that the
210 SV was deleted as a side effect of the routines we called. */
219 Do magic after a value is assigned to the SV. See C<sv_magic>.
225 Perl_mg_set(pTHX_ SV *sv)
228 const I32 mgs_ix = SSNEW(sizeof(MGS));
232 save_magic(mgs_ix, sv);
234 for (mg = SvMAGIC(sv); mg; mg = nextmg) {
235 const MGVTBL* vtbl = mg->mg_virtual;
236 nextmg = mg->mg_moremagic; /* it may delete itself */
237 if (mg->mg_flags & MGf_GSKIP) {
238 mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */
239 (SSPTR(mgs_ix, MGS*))->mgs_flags = 0;
241 if (vtbl && vtbl->svt_set)
242 CALL_FPTR(vtbl->svt_set)(aTHX_ sv, mg);
245 restore_magic(INT2PTR(void*, (IV)mgs_ix));
250 =for apidoc mg_length
252 Report on the SV's length. See C<sv_magic>.
258 Perl_mg_length(pTHX_ SV *sv)
264 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
265 const MGVTBL * const vtbl = mg->mg_virtual;
266 if (vtbl && vtbl->svt_len) {
267 const I32 mgs_ix = SSNEW(sizeof(MGS));
268 save_magic(mgs_ix, sv);
269 /* omit MGf_GSKIP -- not changed here */
270 len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
271 restore_magic(INT2PTR(void*, (IV)mgs_ix));
277 const U8 *s = (U8*)SvPV_const(sv, len);
278 len = utf8_length(s, s + len);
281 (void)SvPV_const(sv, len);
286 Perl_mg_size(pTHX_ SV *sv)
290 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
291 const MGVTBL* const vtbl = mg->mg_virtual;
292 if (vtbl && vtbl->svt_len) {
293 const I32 mgs_ix = SSNEW(sizeof(MGS));
295 save_magic(mgs_ix, sv);
296 /* omit MGf_GSKIP -- not changed here */
297 len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
298 restore_magic(INT2PTR(void*, (IV)mgs_ix));
305 return AvFILLp((AV *) sv); /* Fallback to non-tied array */
309 Perl_croak(aTHX_ "Size magic not implemented");
318 Clear something magical that the SV represents. See C<sv_magic>.
324 Perl_mg_clear(pTHX_ SV *sv)
326 const I32 mgs_ix = SSNEW(sizeof(MGS));
329 save_magic(mgs_ix, sv);
331 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
332 const MGVTBL* const vtbl = mg->mg_virtual;
333 /* omit GSKIP -- never set here */
335 if (vtbl && vtbl->svt_clear)
336 CALL_FPTR(vtbl->svt_clear)(aTHX_ sv, mg);
339 restore_magic(INT2PTR(void*, (IV)mgs_ix));
346 Finds the magic pointer for type matching the SV. See C<sv_magic>.
352 Perl_mg_find(pTHX_ const SV *sv, int type)
357 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
358 if (mg->mg_type == type)
368 Copies the magic from one SV to another. See C<sv_magic>.
374 Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
378 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
379 const MGVTBL* const vtbl = mg->mg_virtual;
380 if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){
381 count += CALL_FPTR(vtbl->svt_copy)(aTHX_ sv, mg, nsv, key, klen);
384 const char type = mg->mg_type;
385 if (isUPPER(type) && type != PERL_MAGIC_uvar) {
387 (type == PERL_MAGIC_tied)
389 : (type == PERL_MAGIC_regdata && mg->mg_obj)
392 toLOWER(type), key, klen);
401 =for apidoc mg_localize
403 Copy some of the magic from an existing SV to new localized version of
404 that SV. Container magic (eg %ENV, $1, tie) gets copied, value magic
405 doesn't (eg taint, pos).
411 Perl_mg_localize(pTHX_ SV *sv, SV *nsv)
415 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
416 const MGVTBL* const vtbl = mg->mg_virtual;
417 switch (mg->mg_type) {
418 /* value magic types: don't copy */
421 case PERL_MAGIC_regex_global:
422 case PERL_MAGIC_nkeys:
423 #ifdef USE_LOCALE_COLLATE
424 case PERL_MAGIC_collxfrm:
427 case PERL_MAGIC_taint:
429 case PERL_MAGIC_vstring:
430 case PERL_MAGIC_utf8:
431 case PERL_MAGIC_substr:
432 case PERL_MAGIC_defelem:
433 case PERL_MAGIC_arylen:
435 case PERL_MAGIC_backref:
436 case PERL_MAGIC_arylen_p:
437 case PERL_MAGIC_rhash:
438 case PERL_MAGIC_symtab:
442 if ((mg->mg_flags & MGf_LOCAL) && vtbl->svt_local)
443 (void)CALL_FPTR(vtbl->svt_local)(aTHX_ nsv, mg);
445 sv_magicext(nsv, mg->mg_obj, mg->mg_type, vtbl,
446 mg->mg_ptr, mg->mg_len);
448 /* container types should remain read-only across localization */
449 SvFLAGS(nsv) |= SvREADONLY(sv);
452 if (SvTYPE(nsv) >= SVt_PVMG && SvMAGIC(nsv)) {
453 SvFLAGS(nsv) |= SvMAGICAL(sv);
463 Free any magic storage used by the SV. See C<sv_magic>.
469 Perl_mg_free(pTHX_ SV *sv)
473 for (mg = SvMAGIC(sv); mg; mg = moremagic) {
474 const MGVTBL* const vtbl = mg->mg_virtual;
475 moremagic = mg->mg_moremagic;
476 if (vtbl && vtbl->svt_free)
477 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
478 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
479 if (mg->mg_len > 0 || mg->mg_type == PERL_MAGIC_utf8)
480 Safefree(mg->mg_ptr);
481 else if (mg->mg_len == HEf_SVKEY)
482 SvREFCNT_dec((SV*)mg->mg_ptr);
484 if (mg->mg_flags & MGf_REFCOUNTED)
485 SvREFCNT_dec(mg->mg_obj);
488 SvMAGIC_set(sv, NULL);
495 Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
501 register const REGEXP * const rx = PM_GETRE(PL_curpm);
503 if (mg->mg_obj) { /* @+ */
504 /* return the number possible */
507 I32 paren = rx->lastparen;
509 /* return the last filled */
511 && (rx->startp[paren] == -1 || rx->endp[paren] == -1) )
522 Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
526 register const REGEXP * const rx = PM_GETRE(PL_curpm);
528 register const I32 paren = mg->mg_len;
533 if (paren <= (I32)rx->nparens &&
534 (s = rx->startp[paren]) != -1 &&
535 (t = rx->endp[paren]) != -1)
538 if (mg->mg_obj) /* @+ */
543 if (i > 0 && RX_MATCH_UTF8(rx)) {
544 const char * const b = rx->subbeg;
546 i = utf8_length((U8*)b, (U8*)(b+i));
557 Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
561 Perl_croak(aTHX_ PL_no_modify);
562 NORETURN_FUNCTION_END;
566 Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
571 register const REGEXP *rx;
574 switch (*mg->mg_ptr) {
575 case '1': case '2': case '3': case '4':
576 case '5': case '6': case '7': case '8': case '9': case '&':
577 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
579 paren = atoi(mg->mg_ptr); /* $& is in [0] */
581 if (paren <= (I32)rx->nparens &&
582 (s1 = rx->startp[paren]) != -1 &&
583 (t1 = rx->endp[paren]) != -1)
587 if (i > 0 && RX_MATCH_UTF8(rx)) {
588 const char * const s = rx->subbeg + s1;
593 if (is_utf8_string_loclen((U8*)s, i, &ep, &el))
597 Perl_croak(aTHX_ "panic: magic_len: %"IVdf, (IV)i);
601 if (ckWARN(WARN_UNINITIALIZED))
606 if (ckWARN(WARN_UNINITIALIZED))
611 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
612 paren = rx->lastparen;
617 case '\016': /* ^N */
618 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
619 paren = rx->lastcloseparen;
625 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
626 if (rx->startp[0] != -1) {
637 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
638 if (rx->endp[0] != -1) {
639 i = rx->sublen - rx->endp[0];
650 if (!SvPOK(sv) && SvNIOK(sv)) {
658 #define SvRTRIM(sv) STMT_START { \
660 STRLEN len = SvCUR(sv); \
661 char * const p = SvPVX(sv); \
662 while (len > 0 && isSPACE(p[len-1])) \
664 SvCUR_set(sv, len); \
670 Perl_emulate_cop_io(pTHX_ const COP *const c, SV *const sv)
672 if (!(CopHINTS_get(c) & (HINT_LEXICAL_IO_IN|HINT_LEXICAL_IO_OUT)))
673 sv_setsv(sv, &PL_sv_undef);
677 if ((CopHINTS_get(c) & HINT_LEXICAL_IO_IN)) {
678 SV *const value = Perl_refcounted_he_fetch(aTHX_
680 0, "open<", 5, 0, 0);
685 if ((CopHINTS_get(c) & HINT_LEXICAL_IO_OUT)) {
686 SV *const value = Perl_refcounted_he_fetch(aTHX_
688 0, "open>", 5, 0, 0);
696 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
700 register char *s = NULL;
702 const char * const remaining = mg->mg_ptr + 1;
703 const char nextchar = *remaining;
705 switch (*mg->mg_ptr) {
706 case '\001': /* ^A */
707 sv_setsv(sv, PL_bodytarget);
709 case '\003': /* ^C, ^CHILD_ERROR_NATIVE */
710 if (nextchar == '\0') {
711 sv_setiv(sv, (IV)PL_minus_c);
713 else if (strEQ(remaining, "HILD_ERROR_NATIVE")) {
714 sv_setiv(sv, (IV)STATUS_NATIVE);
718 case '\004': /* ^D */
719 sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
721 case '\005': /* ^E */
722 if (nextchar == '\0') {
723 #if defined(MACOS_TRADITIONAL)
727 sv_setnv(sv,(double)gMacPerl_OSErr);
728 sv_setpv(sv, gMacPerl_OSErr ? GetSysErrText(gMacPerl_OSErr, msg) : "");
732 # include <descrip.h>
733 # include <starlet.h>
735 $DESCRIPTOR(msgdsc,msg);
736 sv_setnv(sv,(NV) vaxc$errno);
737 if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
738 sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
743 if (!(_emx_env & 0x200)) { /* Under DOS */
744 sv_setnv(sv, (NV)errno);
745 sv_setpv(sv, errno ? Strerror(errno) : "");
747 if (errno != errno_isOS2) {
748 const int tmp = _syserrno();
749 if (tmp) /* 2nd call to _syserrno() makes it 0 */
752 sv_setnv(sv, (NV)Perl_rc);
753 sv_setpv(sv, os2error(Perl_rc));
757 const DWORD dwErr = GetLastError();
758 sv_setnv(sv, (NV)dwErr);
760 PerlProc_GetOSError(sv, dwErr);
763 sv_setpvn(sv, "", 0);
768 const int saveerrno = errno;
769 sv_setnv(sv, (NV)errno);
770 sv_setpv(sv, errno ? Strerror(errno) : "");
775 SvNOK_on(sv); /* what a wonderful hack! */
777 else if (strEQ(remaining, "NCODING"))
778 sv_setsv(sv, PL_encoding);
780 case '\006': /* ^F */
781 sv_setiv(sv, (IV)PL_maxsysfd);
783 case '\010': /* ^H */
784 sv_setiv(sv, (IV)PL_hints);
786 case '\011': /* ^I */ /* NOT \t in EBCDIC */
788 sv_setpv(sv, PL_inplace);
790 sv_setsv(sv, &PL_sv_undef);
792 case '\017': /* ^O & ^OPEN */
793 if (nextchar == '\0') {
794 sv_setpv(sv, PL_osname);
797 else if (strEQ(remaining, "PEN")) {
798 Perl_emulate_cop_io(aTHX_ &PL_compiling, sv);
802 if (nextchar == '\0') { /* ^P */
803 sv_setiv(sv, (IV)PL_perldb);
804 } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
805 goto do_prematch_fetch;
806 } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
807 goto do_postmatch_fetch;
810 case '\023': /* ^S */
811 if (nextchar == '\0') {
812 if (PL_lex_state != LEX_NOTPARSING)
815 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
820 case '\024': /* ^T */
821 if (nextchar == '\0') {
823 sv_setnv(sv, PL_basetime);
825 sv_setiv(sv, (IV)PL_basetime);
828 else if (strEQ(remaining, "AINT"))
829 sv_setiv(sv, PL_tainting
830 ? (PL_taint_warn || PL_unsafe ? -1 : 1)
833 case '\025': /* $^UNICODE, $^UTF8LOCALE, $^UTF8CACHE */
834 if (strEQ(remaining, "NICODE"))
835 sv_setuv(sv, (UV) PL_unicode);
836 else if (strEQ(remaining, "TF8LOCALE"))
837 sv_setuv(sv, (UV) PL_utf8locale);
838 else if (strEQ(remaining, "TF8CACHE"))
839 sv_setiv(sv, (IV) PL_utf8cache);
841 case '\027': /* ^W & $^WARNING_BITS */
842 if (nextchar == '\0')
843 sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
844 else if (strEQ(remaining, "ARNING_BITS")) {
845 if (PL_compiling.cop_warnings == pWARN_NONE) {
846 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
848 else if (PL_compiling.cop_warnings == pWARN_STD) {
851 (PL_dowarn & G_WARN_ON) ? WARN_ALLstring : WARN_NONEstring,
855 else if (PL_compiling.cop_warnings == pWARN_ALL) {
856 /* Get the bit mask for $warnings::Bits{all}, because
857 * it could have been extended by warnings::register */
858 HV * const bits=get_hv("warnings::Bits", FALSE);
860 SV ** const bits_all = hv_fetchs(bits, "all", FALSE);
862 sv_setsv(sv, *bits_all);
865 sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
869 sv_setpvn(sv, (char *) (PL_compiling.cop_warnings + 1),
870 *PL_compiling.cop_warnings);
875 case '\015': /* $^MATCH */
876 if (strEQ(remaining, "ATCH")) {
877 case '1': case '2': case '3': case '4':
878 case '5': case '6': case '7': case '8': case '9': case '&':
879 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
881 * Pre-threads, this was paren = atoi(GvENAME((GV*)mg->mg_obj));
882 * XXX Does the new way break anything?
884 paren = atoi(mg->mg_ptr); /* $& is in [0] */
885 CALLREG_NUMBUF(rx,paren,sv);
888 sv_setsv(sv,&PL_sv_undef);
892 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
894 CALLREG_NUMBUF(rx,rx->lastparen,sv);
898 sv_setsv(sv,&PL_sv_undef);
900 case '\016': /* ^N */
901 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
902 if (rx->lastcloseparen) {
903 CALLREG_NUMBUF(rx,rx->lastcloseparen,sv);
908 sv_setsv(sv,&PL_sv_undef);
912 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
913 CALLREG_NUMBUF(rx,-2,sv);
916 sv_setsv(sv,&PL_sv_undef);
920 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
921 CALLREG_NUMBUF(rx,-1,sv);
924 sv_setsv(sv,&PL_sv_undef);
927 if (GvIO(PL_last_in_gv)) {
928 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
933 sv_setiv(sv, (IV)STATUS_CURRENT);
934 #ifdef COMPLEX_STATUS
935 LvTARGOFF(sv) = PL_statusvalue;
936 LvTARGLEN(sv) = PL_statusvalue_vms;
941 if (GvIOp(PL_defoutgv))
942 s = IoTOP_NAME(GvIOp(PL_defoutgv));
946 sv_setpv(sv,GvENAME(PL_defoutgv));
951 if (GvIOp(PL_defoutgv))
952 s = IoFMT_NAME(GvIOp(PL_defoutgv));
954 s = GvENAME(PL_defoutgv);
958 if (GvIOp(PL_defoutgv))
959 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
962 if (GvIOp(PL_defoutgv))
963 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
966 if (GvIOp(PL_defoutgv))
967 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
974 sv_setiv(sv, (IV)CopARYBASE_get(PL_curcop));
977 if (GvIOp(PL_defoutgv))
978 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
984 sv_copypv(sv, PL_ors_sv);
988 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
989 sv_setpv(sv, errno ? Strerror(errno) : "");
992 const int saveerrno = errno;
993 sv_setnv(sv, (NV)errno);
995 if (errno == errno_isOS2 || errno == errno_isOS2_set)
996 sv_setpv(sv, os2error(Perl_rc));
999 sv_setpv(sv, errno ? Strerror(errno) : "");
1004 SvNOK_on(sv); /* what a wonderful hack! */
1007 sv_setiv(sv, (IV)PL_uid);
1010 sv_setiv(sv, (IV)PL_euid);
1013 sv_setiv(sv, (IV)PL_gid);
1016 sv_setiv(sv, (IV)PL_egid);
1018 #ifdef HAS_GETGROUPS
1020 Groups_t *gary = NULL;
1021 I32 i, num_groups = getgroups(0, gary);
1022 Newx(gary, num_groups, Groups_t);
1023 num_groups = getgroups(num_groups, gary);
1024 for (i = 0; i < num_groups; i++)
1025 Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]);
1028 (void)SvIOK_on(sv); /* what a wonderful hack! */
1031 #ifndef MACOS_TRADITIONAL
1040 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
1042 struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
1044 if (uf && uf->uf_val)
1045 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
1050 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
1053 STRLEN len = 0, klen;
1054 const char *s = SvOK(sv) ? SvPV_const(sv,len) : "";
1055 const char * const ptr = MgPV_const(mg,klen);
1058 #ifdef DYNAMIC_ENV_FETCH
1059 /* We just undefd an environment var. Is a replacement */
1060 /* waiting in the wings? */
1062 SV ** const valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE);
1064 s = SvOK(*valp) ? SvPV_const(*valp, len) : "";
1068 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
1069 /* And you'll never guess what the dog had */
1070 /* in its mouth... */
1072 MgTAINTEDDIR_off(mg);
1074 if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
1075 char pathbuf[256], eltbuf[256], *cp, *elt;
1079 my_strlcpy(eltbuf, s, sizeof(eltbuf));
1081 do { /* DCL$PATH may be a search list */
1082 while (1) { /* as may dev portion of any element */
1083 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1084 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1085 cando_by_name(S_IWUSR,0,elt) ) {
1086 MgTAINTEDDIR_on(mg);
1090 if ((cp = strchr(elt, ':')) != NULL)
1092 if (my_trnlnm(elt, eltbuf, j++))
1098 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1101 if (s && klen == 4 && strEQ(ptr,"PATH")) {
1102 const char * const strend = s + len;
1104 while (s < strend) {
1108 #ifdef VMS /* Hmm. How do we get $Config{path_sep} from C? */
1109 const char path_sep = '|';
1111 const char path_sep = ':';
1113 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
1114 s, strend, path_sep, &i);
1116 if (i >= (I32)sizeof tmpbuf /* too long -- assume the worst */
1118 || !strchr(tmpbuf, ':') /* no colon thus no device name -- assume relative path */
1120 || *tmpbuf != '/' /* no starting slash -- assume relative path */
1122 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1123 MgTAINTEDDIR_on(mg);
1129 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1135 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1137 PERL_UNUSED_ARG(sv);
1138 my_setenv(MgPV_nolen_const(mg),NULL);
1143 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1146 PERL_UNUSED_ARG(mg);
1148 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1150 if (PL_localizing) {
1153 hv_iterinit((HV*)sv);
1154 while ((entry = hv_iternext((HV*)sv))) {
1156 my_setenv(hv_iterkey(entry, &keylen),
1157 SvPV_nolen_const(hv_iterval((HV*)sv, entry)));
1165 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1168 PERL_UNUSED_ARG(sv);
1169 PERL_UNUSED_ARG(mg);
1171 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1179 #ifdef HAS_SIGPROCMASK
1181 restore_sigmask(pTHX_ SV *save_sv)
1183 const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1184 (void)sigprocmask(SIG_SETMASK, ossetp, NULL);
1188 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1191 /* Are we fetching a signal entry? */
1192 const I32 i = whichsig(MgPV_nolen_const(mg));
1195 sv_setsv(sv,PL_psig_ptr[i]);
1197 Sighandler_t sigstate = rsignal_state(i);
1198 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1199 if (PL_sig_handlers_initted && PL_sig_ignoring[i])
1202 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1203 if (PL_sig_handlers_initted && PL_sig_defaulting[i])
1206 /* cache state so we don't fetch it again */
1207 if(sigstate == (Sighandler_t) SIG_IGN)
1208 sv_setpvs(sv,"IGNORE");
1210 sv_setsv(sv,&PL_sv_undef);
1211 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1218 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1220 /* XXX Some of this code was copied from Perl_magic_setsig. A little
1221 * refactoring might be in order.
1224 register const char * const s = MgPV_nolen_const(mg);
1225 PERL_UNUSED_ARG(sv);
1228 if (strEQ(s,"__DIE__"))
1230 else if (strEQ(s,"__WARN__") && PL_warnhook != PERL_WARNHOOK_FATAL)
1233 SV *const to_dec = *svp;
1235 SvREFCNT_dec(to_dec);
1239 /* Are we clearing a signal entry? */
1240 const I32 i = whichsig(s);
1242 #ifdef HAS_SIGPROCMASK
1245 /* Avoid having the signal arrive at a bad time, if possible. */
1248 sigprocmask(SIG_BLOCK, &set, &save);
1250 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1251 SAVEFREESV(save_sv);
1252 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1255 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1256 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1258 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1259 PL_sig_defaulting[i] = 1;
1260 (void)rsignal(i, PL_csighandlerp);
1262 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1264 if(PL_psig_name[i]) {
1265 SvREFCNT_dec(PL_psig_name[i]);
1268 if(PL_psig_ptr[i]) {
1269 SV * const to_dec=PL_psig_ptr[i];
1272 SvREFCNT_dec(to_dec);
1281 #ifndef SIG_PENDING_DIE_COUNT
1282 # define SIG_PENDING_DIE_COUNT 120
1286 S_raise_signal(pTHX_ int sig)
1289 /* Set a flag to say this signal is pending */
1290 PL_psig_pend[sig]++;
1291 /* And one to say _a_ signal is pending */
1292 if (++PL_sig_pending >= SIG_PENDING_DIE_COUNT)
1293 Perl_croak(aTHX_ "Maximal count of pending signals (%lu) exceeded",
1294 (unsigned long)SIG_PENDING_DIE_COUNT);
1298 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1299 Perl_csighandler(int sig, ...)
1301 Perl_csighandler(int sig)
1304 #ifdef PERL_GET_SIG_CONTEXT
1305 dTHXa(PERL_GET_SIG_CONTEXT);
1309 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1310 (void) rsignal(sig, PL_csighandlerp);
1311 if (PL_sig_ignoring[sig]) return;
1313 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1314 if (PL_sig_defaulting[sig])
1315 #ifdef KILL_BY_SIGPRC
1316 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1331 (PL_signals & PERL_SIGNALS_UNSAFE_FLAG))
1332 /* Call the perl level handler now--
1333 * with risk we may be in malloc() etc. */
1334 (*PL_sighandlerp)(sig);
1336 S_raise_signal(aTHX_ sig);
1339 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1341 Perl_csighandler_init(void)
1344 if (PL_sig_handlers_initted) return;
1346 for (sig = 1; sig < SIG_SIZE; sig++) {
1347 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1349 PL_sig_defaulting[sig] = 1;
1350 (void) rsignal(sig, PL_csighandlerp);
1352 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1353 PL_sig_ignoring[sig] = 0;
1356 PL_sig_handlers_initted = 1;
1361 Perl_despatch_signals(pTHX)
1366 for (sig = 1; sig < SIG_SIZE; sig++) {
1367 if (PL_psig_pend[sig]) {
1368 PERL_BLOCKSIG_ADD(set, sig);
1369 PL_psig_pend[sig] = 0;
1370 PERL_BLOCKSIG_BLOCK(set);
1371 (*PL_sighandlerp)(sig);
1372 PERL_BLOCKSIG_UNBLOCK(set);
1378 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1383 /* Need to be careful with SvREFCNT_dec(), because that can have side
1384 * effects (due to closures). We must make sure that the new disposition
1385 * is in place before it is called.
1389 #ifdef HAS_SIGPROCMASK
1394 register const char *s = MgPV_const(mg,len);
1396 if (strEQ(s,"__DIE__"))
1398 else if (strEQ(s,"__WARN__"))
1401 Perl_croak(aTHX_ "No such hook: %s", s);
1404 if (*svp != PERL_WARNHOOK_FATAL)
1410 i = whichsig(s); /* ...no, a brick */
1412 if (ckWARN(WARN_SIGNAL))
1413 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
1416 #ifdef HAS_SIGPROCMASK
1417 /* Avoid having the signal arrive at a bad time, if possible. */
1420 sigprocmask(SIG_BLOCK, &set, &save);
1422 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1423 SAVEFREESV(save_sv);
1424 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1427 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1428 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1430 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1431 PL_sig_ignoring[i] = 0;
1433 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1434 PL_sig_defaulting[i] = 0;
1436 SvREFCNT_dec(PL_psig_name[i]);
1437 to_dec = PL_psig_ptr[i];
1438 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1439 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1440 PL_psig_name[i] = newSVpvn(s, len);
1441 SvREADONLY_on(PL_psig_name[i]);
1443 if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
1445 (void)rsignal(i, PL_csighandlerp);
1446 #ifdef HAS_SIGPROCMASK
1451 *svp = SvREFCNT_inc_simple_NN(sv);
1453 SvREFCNT_dec(to_dec);
1456 s = SvOK(sv) ? SvPV_force(sv,len) : "DEFAULT";
1457 if (strEQ(s,"IGNORE")) {
1459 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1460 PL_sig_ignoring[i] = 1;
1461 (void)rsignal(i, PL_csighandlerp);
1463 (void)rsignal(i, (Sighandler_t) SIG_IGN);
1467 else if (strEQ(s,"DEFAULT") || !*s) {
1469 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1471 PL_sig_defaulting[i] = 1;
1472 (void)rsignal(i, PL_csighandlerp);
1475 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1480 * We should warn if HINT_STRICT_REFS, but without
1481 * access to a known hint bit in a known OP, we can't
1482 * tell whether HINT_STRICT_REFS is in force or not.
1484 if (!strchr(s,':') && !strchr(s,'\''))
1485 Perl_sv_insert(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"));
1487 (void)rsignal(i, PL_csighandlerp);
1489 *svp = SvREFCNT_inc_simple_NN(sv);
1491 #ifdef HAS_SIGPROCMASK
1496 SvREFCNT_dec(to_dec);
1499 #endif /* !PERL_MICRO */
1502 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1505 PERL_UNUSED_ARG(sv);
1506 PERL_UNUSED_ARG(mg);
1507 PL_sub_generation++;
1512 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
1515 PERL_UNUSED_ARG(sv);
1516 PERL_UNUSED_ARG(mg);
1517 /* HV_badAMAGIC_on(Sv_STASH(sv)); */
1518 PL_amagic_generation++;
1524 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1526 HV * const hv = (HV*)LvTARG(sv);
1528 PERL_UNUSED_ARG(mg);
1531 (void) hv_iterinit(hv);
1532 if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
1535 while (hv_iternext(hv))
1540 sv_setiv(sv, (IV)i);
1545 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1547 PERL_UNUSED_ARG(mg);
1549 hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
1554 /* caller is responsible for stack switching/cleanup */
1556 S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV *val)
1563 PUSHs(SvTIED_obj(sv, mg));
1566 if (mg->mg_len >= 0)
1567 PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len)));
1568 else if (mg->mg_len == HEf_SVKEY)
1569 PUSHs((SV*)mg->mg_ptr);
1571 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1572 PUSHs(sv_2mortal(newSViv(mg->mg_len)));
1580 return call_method(meth, flags);
1584 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
1590 PUSHSTACKi(PERLSI_MAGIC);
1592 if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
1593 sv_setsv(sv, *PL_stack_sp--);
1603 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1606 mg->mg_flags |= MGf_GSKIP;
1607 magic_methpack(sv,mg,"FETCH");
1612 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1616 PUSHSTACKi(PERLSI_MAGIC);
1617 magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
1624 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1626 return magic_methpack(sv,mg,"DELETE");
1631 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1638 PUSHSTACKi(PERLSI_MAGIC);
1639 if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
1640 sv = *PL_stack_sp--;
1641 retval = (U32) SvIV(sv)-1;
1650 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1655 PUSHSTACKi(PERLSI_MAGIC);
1657 XPUSHs(SvTIED_obj(sv, mg));
1659 call_method("CLEAR", G_SCALAR|G_DISCARD);
1667 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1670 const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
1674 PUSHSTACKi(PERLSI_MAGIC);
1677 PUSHs(SvTIED_obj(sv, mg));
1682 if (call_method(meth, G_SCALAR))
1683 sv_setsv(key, *PL_stack_sp--);
1692 Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg)
1694 return magic_methpack(sv,mg,"EXISTS");
1698 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1702 SV * const tied = SvTIED_obj((SV*)hv, mg);
1703 HV * const pkg = SvSTASH((SV*)SvRV(tied));
1705 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1707 if (HvEITER_get(hv))
1708 /* we are in an iteration so the hash cannot be empty */
1710 /* no xhv_eiter so now use FIRSTKEY */
1711 key = sv_newmortal();
1712 magic_nextpack((SV*)hv, mg, key);
1713 HvEITER_set(hv, NULL); /* need to reset iterator */
1714 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1717 /* there is a SCALAR method that we can call */
1719 PUSHSTACKi(PERLSI_MAGIC);
1725 if (call_method("SCALAR", G_SCALAR))
1726 retval = *PL_stack_sp--;
1728 retval = &PL_sv_undef;
1735 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1738 GV * const gv = PL_DBline;
1739 const I32 i = SvTRUE(sv);
1740 SV ** const svp = av_fetch(GvAV(gv),
1741 atoi(MgPV_nolen_const(mg)), FALSE);
1742 if (svp && SvIOKp(*svp)) {
1743 OP * const o = INT2PTR(OP*,SvIVX(*svp));
1745 /* set or clear breakpoint in the relevant control op */
1747 o->op_flags |= OPf_SPECIAL;
1749 o->op_flags &= ~OPf_SPECIAL;
1756 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
1759 const AV * const obj = (AV*)mg->mg_obj;
1761 sv_setiv(sv, AvFILL(obj) + CopARYBASE_get(PL_curcop));
1769 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
1772 AV * const obj = (AV*)mg->mg_obj;
1774 av_fill(obj, SvIV(sv) - CopARYBASE_get(PL_curcop));
1776 if (ckWARN(WARN_MISC))
1777 Perl_warner(aTHX_ packWARN(WARN_MISC),
1778 "Attempt to set length of freed array");
1784 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
1787 PERL_UNUSED_ARG(sv);
1788 /* during global destruction, mg_obj may already have been freed */
1789 if (PL_in_clean_all)
1792 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
1795 /* arylen scalar holds a pointer back to the array, but doesn't own a
1796 reference. Hence the we (the array) are about to go away with it
1797 still pointing at us. Clear its pointer, else it would be pointing
1798 at free memory. See the comment in sv_magic about reference loops,
1799 and why it can't own a reference to us. */
1806 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
1809 SV* const lsv = LvTARG(sv);
1810 PERL_UNUSED_ARG(mg);
1812 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1813 MAGIC * const found = mg_find(lsv, PERL_MAGIC_regex_global);
1814 if (found && found->mg_len >= 0) {
1815 I32 i = found->mg_len;
1817 sv_pos_b2u(lsv, &i);
1818 sv_setiv(sv, i + CopARYBASE_get(PL_curcop));
1827 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
1830 SV* const lsv = LvTARG(sv);
1836 PERL_UNUSED_ARG(mg);
1838 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
1839 found = mg_find(lsv, PERL_MAGIC_regex_global);
1845 #ifdef PERL_OLD_COPY_ON_WRITE
1847 sv_force_normal_flags(lsv, 0);
1849 found = sv_magicext(lsv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
1852 else if (!SvOK(sv)) {
1856 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1858 pos = SvIV(sv) - CopARYBASE_get(PL_curcop);
1861 ulen = sv_len_utf8(lsv);
1871 else if (pos > (SSize_t)len)
1876 sv_pos_u2b(lsv, &p, 0);
1880 found->mg_len = pos;
1881 found->mg_flags &= ~MGf_MINMATCH;
1887 Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg)
1890 PERL_UNUSED_ARG(mg);
1894 if (isGV_with_GP(sv)) {
1895 /* We're actually already a typeglob, so don't need the stuff below.
1899 gv = gv_fetchsv(sv, GV_ADD, SVt_PVGV);
1904 GvGP(sv) = gp_ref(GvGP(gv));
1909 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
1912 SV * const lsv = LvTARG(sv);
1913 const char * const tmps = SvPV_const(lsv,len);
1914 I32 offs = LvTARGOFF(sv);
1915 I32 rem = LvTARGLEN(sv);
1916 PERL_UNUSED_ARG(mg);
1919 sv_pos_u2b(lsv, &offs, &rem);
1920 if (offs > (I32)len)
1922 if (rem + offs > (I32)len)
1924 sv_setpvn(sv, tmps + offs, (STRLEN)rem);
1931 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
1935 const char * const tmps = SvPV_const(sv, len);
1936 SV * const lsv = LvTARG(sv);
1937 I32 lvoff = LvTARGOFF(sv);
1938 I32 lvlen = LvTARGLEN(sv);
1939 PERL_UNUSED_ARG(mg);
1942 sv_utf8_upgrade(lsv);
1943 sv_pos_u2b(lsv, &lvoff, &lvlen);
1944 sv_insert(lsv, lvoff, lvlen, tmps, len);
1945 LvTARGLEN(sv) = sv_len_utf8(sv);
1948 else if (lsv && SvUTF8(lsv)) {
1950 sv_pos_u2b(lsv, &lvoff, &lvlen);
1951 LvTARGLEN(sv) = len;
1952 utf8 = (char*)bytes_to_utf8((U8*)tmps, &len);
1953 sv_insert(lsv, lvoff, lvlen, utf8, len);
1957 sv_insert(lsv, lvoff, lvlen, tmps, len);
1958 LvTARGLEN(sv) = len;
1966 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
1969 PERL_UNUSED_ARG(sv);
1970 TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
1975 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
1978 PERL_UNUSED_ARG(sv);
1979 /* update taint status unless we're restoring at scope exit */
1980 if (PL_localizing != 2) {
1990 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
1992 SV * const lsv = LvTARG(sv);
1993 PERL_UNUSED_ARG(mg);
1996 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
2004 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
2006 PERL_UNUSED_ARG(mg);
2007 do_vecset(sv); /* XXX slurp this routine */
2012 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
2016 if (LvTARGLEN(sv)) {
2018 SV * const ahv = LvTARG(sv);
2019 HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
2024 AV* const av = (AV*)LvTARG(sv);
2025 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
2026 targ = AvARRAY(av)[LvTARGOFF(sv)];
2028 if (targ && (targ != &PL_sv_undef)) {
2029 /* somebody else defined it for us */
2030 SvREFCNT_dec(LvTARG(sv));
2031 LvTARG(sv) = SvREFCNT_inc_simple_NN(targ);
2033 SvREFCNT_dec(mg->mg_obj);
2035 mg->mg_flags &= ~MGf_REFCOUNTED;
2040 sv_setsv(sv, targ ? targ : &PL_sv_undef);
2045 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
2047 PERL_UNUSED_ARG(mg);
2051 sv_setsv(LvTARG(sv), sv);
2052 SvSETMAGIC(LvTARG(sv));
2058 Perl_vivify_defelem(pTHX_ SV *sv)
2064 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2067 SV * const ahv = LvTARG(sv);
2068 HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
2071 if (!value || value == &PL_sv_undef)
2072 Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(mg->mg_obj));
2075 AV* const av = (AV*)LvTARG(sv);
2076 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
2077 LvTARG(sv) = NULL; /* array can't be extended */
2079 SV* const * const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
2080 if (!svp || (value = *svp) == &PL_sv_undef)
2081 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
2084 SvREFCNT_inc_simple_void(value);
2085 SvREFCNT_dec(LvTARG(sv));
2088 SvREFCNT_dec(mg->mg_obj);
2090 mg->mg_flags &= ~MGf_REFCOUNTED;
2094 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2096 return Perl_sv_kill_backrefs(aTHX_ sv, (AV*)mg->mg_obj);
2100 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2102 PERL_UNUSED_CONTEXT;
2109 Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
2111 PERL_UNUSED_ARG(mg);
2112 sv_unmagic(sv, PERL_MAGIC_bm);
2119 Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
2121 PERL_UNUSED_ARG(mg);
2122 sv_unmagic(sv, PERL_MAGIC_fm);
2128 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2130 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2132 if (uf && uf->uf_set)
2133 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2138 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2140 PERL_UNUSED_ARG(mg);
2141 sv_unmagic(sv, PERL_MAGIC_qr);
2146 Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
2149 regexp * const re = (regexp *)mg->mg_obj;
2150 PERL_UNUSED_ARG(sv);
2156 #ifdef USE_LOCALE_COLLATE
2158 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2161 * RenE<eacute> Descartes said "I think not."
2162 * and vanished with a faint plop.
2164 PERL_UNUSED_CONTEXT;
2165 PERL_UNUSED_ARG(sv);
2167 Safefree(mg->mg_ptr);
2173 #endif /* USE_LOCALE_COLLATE */
2175 /* Just clear the UTF-8 cache data. */
2177 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2179 PERL_UNUSED_CONTEXT;
2180 PERL_UNUSED_ARG(sv);
2181 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2183 mg->mg_len = -1; /* The mg_len holds the len cache. */
2188 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2191 register const char *s;
2194 switch (*mg->mg_ptr) {
2195 case '\001': /* ^A */
2196 sv_setsv(PL_bodytarget, sv);
2198 case '\003': /* ^C */
2199 PL_minus_c = (bool)SvIV(sv);
2202 case '\004': /* ^D */
2204 s = SvPV_nolen_const(sv);
2205 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2206 DEBUG_x(dump_all());
2208 PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG;
2211 case '\005': /* ^E */
2212 if (*(mg->mg_ptr+1) == '\0') {
2213 #ifdef MACOS_TRADITIONAL
2214 gMacPerl_OSErr = SvIV(sv);
2217 set_vaxc_errno(SvIV(sv));
2220 SetLastError( SvIV(sv) );
2223 os2_setsyserrno(SvIV(sv));
2225 /* will anyone ever use this? */
2226 SETERRNO(SvIV(sv), 4);
2232 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2234 SvREFCNT_dec(PL_encoding);
2235 if (SvOK(sv) || SvGMAGICAL(sv)) {
2236 PL_encoding = newSVsv(sv);
2243 case '\006': /* ^F */
2244 PL_maxsysfd = SvIV(sv);
2246 case '\010': /* ^H */
2247 PL_hints = SvIV(sv);
2249 case '\011': /* ^I */ /* NOT \t in EBCDIC */
2250 Safefree(PL_inplace);
2251 PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
2253 case '\017': /* ^O */
2254 if (*(mg->mg_ptr+1) == '\0') {
2255 Safefree(PL_osname);
2258 TAINT_PROPER("assigning to $^O");
2259 PL_osname = savesvpv(sv);
2262 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2264 const char *const start = SvPV(sv, len);
2265 const char *out = (const char*)memchr(start, '\0', len);
2267 struct refcounted_he *tmp_he;
2270 PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2272 |= HINT_LOCALIZE_HH | HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2274 /* Opening for input is more common than opening for output, so
2275 ensure that hints for input are sooner on linked list. */
2276 tmp = sv_2mortal(out ? newSVpvn(out + 1, start + len - out - 1)
2278 SvFLAGS(tmp) |= SvUTF8(sv);
2281 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
2282 sv_2mortal(newSVpvs("open>")), tmp);
2284 /* The UTF-8 setting is carried over */
2285 sv_setpvn(tmp, start, out ? (STRLEN)(out - start) : len);
2287 PL_compiling.cop_hints_hash
2288 = Perl_refcounted_he_new(aTHX_ tmp_he,
2289 sv_2mortal(newSVpvs("open<")), tmp);
2292 case '\020': /* ^P */
2293 PL_perldb = SvIV(sv);
2294 if (PL_perldb && !PL_DBsingle)
2297 case '\024': /* ^T */
2299 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2301 PL_basetime = (Time_t)SvIV(sv);
2304 case '\025': /* ^UTF8CACHE */
2305 if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
2306 PL_utf8cache = (signed char) sv_2iv(sv);
2309 case '\027': /* ^W & $^WARNING_BITS */
2310 if (*(mg->mg_ptr+1) == '\0') {
2311 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2313 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2314 | (i ? G_WARN_ON : G_WARN_OFF) ;
2317 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2318 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2319 if (!SvPOK(sv) && PL_localizing) {
2320 sv_setpvn(sv, WARN_NONEstring, WARNsize);
2321 PL_compiling.cop_warnings = pWARN_NONE;
2326 int accumulate = 0 ;
2327 int any_fatals = 0 ;
2328 const char * const ptr = SvPV_const(sv, len) ;
2329 for (i = 0 ; i < len ; ++i) {
2330 accumulate |= ptr[i] ;
2331 any_fatals |= (ptr[i] & 0xAA) ;
2334 if (!specialWARN(PL_compiling.cop_warnings))
2335 PerlMemShared_free(PL_compiling.cop_warnings);
2336 PL_compiling.cop_warnings = pWARN_NONE;
2338 /* Yuck. I can't see how to abstract this: */
2339 else if (isWARN_on(((STRLEN *)SvPV_nolen_const(sv)) - 1,
2340 WARN_ALL) && !any_fatals) {
2341 if (!specialWARN(PL_compiling.cop_warnings))
2342 PerlMemShared_free(PL_compiling.cop_warnings);
2343 PL_compiling.cop_warnings = pWARN_ALL;
2344 PL_dowarn |= G_WARN_ONCE ;
2348 const char *const p = SvPV_const(sv, len);
2350 PL_compiling.cop_warnings
2351 = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
2354 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2355 PL_dowarn |= G_WARN_ONCE ;
2363 if (PL_localizing) {
2364 if (PL_localizing == 1)
2365 SAVESPTR(PL_last_in_gv);
2367 else if (SvOK(sv) && GvIO(PL_last_in_gv))
2368 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2371 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2372 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2373 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2376 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2377 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2378 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2381 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
2384 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
2385 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2386 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2389 IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
2393 IO * const io = GvIOp(PL_defoutgv);
2396 if ((SvIV(sv)) == 0)
2397 IoFLAGS(io) &= ~IOf_FLUSH;
2399 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2400 PerlIO *ofp = IoOFP(io);
2402 (void)PerlIO_flush(ofp);
2403 IoFLAGS(io) |= IOf_FLUSH;
2409 SvREFCNT_dec(PL_rs);
2410 PL_rs = newSVsv(sv);
2414 SvREFCNT_dec(PL_ors_sv);
2415 if (SvOK(sv) || SvGMAGICAL(sv)) {
2416 PL_ors_sv = newSVsv(sv);
2424 SvREFCNT_dec(PL_ofs_sv);
2425 if (SvOK(sv) || SvGMAGICAL(sv)) {
2426 PL_ofs_sv = newSVsv(sv);
2433 CopARYBASE_set(&PL_compiling, SvIV(sv));
2436 #ifdef COMPLEX_STATUS
2437 if (PL_localizing == 2) {
2438 PL_statusvalue = LvTARGOFF(sv);
2439 PL_statusvalue_vms = LvTARGLEN(sv);
2443 #ifdef VMSISH_STATUS
2445 STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2448 STATUS_UNIX_EXIT_SET(SvIV(sv));
2453 # define PERL_VMS_BANG vaxc$errno
2455 # define PERL_VMS_BANG 0
2457 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2458 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2463 if (PL_delaymagic) {
2464 PL_delaymagic |= DM_RUID;
2465 break; /* don't do magic till later */
2468 (void)setruid((Uid_t)PL_uid);
2471 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2473 #ifdef HAS_SETRESUID
2474 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2476 if (PL_uid == PL_euid) { /* special case $< = $> */
2478 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2479 if (PL_uid != 0 && PerlProc_getuid() == 0)
2480 (void)PerlProc_setuid(0);
2482 (void)PerlProc_setuid(PL_uid);
2484 PL_uid = PerlProc_getuid();
2485 Perl_croak(aTHX_ "setruid() not implemented");
2490 PL_uid = PerlProc_getuid();
2491 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2495 if (PL_delaymagic) {
2496 PL_delaymagic |= DM_EUID;
2497 break; /* don't do magic till later */
2500 (void)seteuid((Uid_t)PL_euid);
2503 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2505 #ifdef HAS_SETRESUID
2506 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2508 if (PL_euid == PL_uid) /* special case $> = $< */
2509 PerlProc_setuid(PL_euid);
2511 PL_euid = PerlProc_geteuid();
2512 Perl_croak(aTHX_ "seteuid() not implemented");
2517 PL_euid = PerlProc_geteuid();
2518 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2522 if (PL_delaymagic) {
2523 PL_delaymagic |= DM_RGID;
2524 break; /* don't do magic till later */
2527 (void)setrgid((Gid_t)PL_gid);
2530 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2532 #ifdef HAS_SETRESGID
2533 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2535 if (PL_gid == PL_egid) /* special case $( = $) */
2536 (void)PerlProc_setgid(PL_gid);
2538 PL_gid = PerlProc_getgid();
2539 Perl_croak(aTHX_ "setrgid() not implemented");
2544 PL_gid = PerlProc_getgid();
2545 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2548 #ifdef HAS_SETGROUPS
2550 const char *p = SvPV_const(sv, len);
2551 Groups_t *gary = NULL;
2556 for (i = 0; i < NGROUPS; ++i) {
2557 while (*p && !isSPACE(*p))
2564 Newx(gary, i + 1, Groups_t);
2566 Renew(gary, i + 1, Groups_t);
2570 (void)setgroups(i, gary);
2573 #else /* HAS_SETGROUPS */
2575 #endif /* HAS_SETGROUPS */
2576 if (PL_delaymagic) {
2577 PL_delaymagic |= DM_EGID;
2578 break; /* don't do magic till later */
2581 (void)setegid((Gid_t)PL_egid);
2584 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2586 #ifdef HAS_SETRESGID
2587 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2589 if (PL_egid == PL_gid) /* special case $) = $( */
2590 (void)PerlProc_setgid(PL_egid);
2592 PL_egid = PerlProc_getegid();
2593 Perl_croak(aTHX_ "setegid() not implemented");
2598 PL_egid = PerlProc_getegid();
2599 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2602 PL_chopset = SvPV_force(sv,len);
2604 #ifndef MACOS_TRADITIONAL
2606 LOCK_DOLLARZERO_MUTEX;
2607 #ifdef HAS_SETPROCTITLE
2608 /* The BSDs don't show the argv[] in ps(1) output, they
2609 * show a string from the process struct and provide
2610 * the setproctitle() routine to manipulate that. */
2611 if (PL_origalen != 1) {
2612 s = SvPV_const(sv, len);
2613 # if __FreeBSD_version > 410001
2614 /* The leading "-" removes the "perl: " prefix,
2615 * but not the "(perl) suffix from the ps(1)
2616 * output, because that's what ps(1) shows if the
2617 * argv[] is modified. */
2618 setproctitle("-%s", s);
2619 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2620 /* This doesn't really work if you assume that
2621 * $0 = 'foobar'; will wipe out 'perl' from the $0
2622 * because in ps(1) output the result will be like
2623 * sprintf("perl: %s (perl)", s)
2624 * I guess this is a security feature:
2625 * one (a user process) cannot get rid of the original name.
2627 setproctitle("%s", s);
2630 #elif defined(__hpux) && defined(PSTAT_SETCMD)
2631 if (PL_origalen != 1) {
2633 s = SvPV_const(sv, len);
2634 un.pst_command = (char *)s;
2635 pstat(PSTAT_SETCMD, un, len, 0, 0);
2638 if (PL_origalen > 1) {
2639 /* PL_origalen is set in perl_parse(). */
2640 s = SvPV_force(sv,len);
2641 if (len >= (STRLEN)PL_origalen-1) {
2642 /* Longer than original, will be truncated. We assume that
2643 * PL_origalen bytes are available. */
2644 Copy(s, PL_origargv[0], PL_origalen-1, char);
2647 /* Shorter than original, will be padded. */
2649 /* Special case for Mac OS X: see [perl #38868] */
2652 /* Is the space counterintuitive? Yes.
2653 * (You were expecting \0?)
2654 * Does it work? Seems to. (In Linux 2.4.20 at least.)
2656 const int pad = ' ';
2658 Copy(s, PL_origargv[0], len, char);
2659 PL_origargv[0][len] = 0;
2660 memset(PL_origargv[0] + len + 1,
2661 pad, PL_origalen - len - 1);
2663 PL_origargv[0][PL_origalen-1] = 0;
2664 for (i = 1; i < PL_origargc; i++)
2668 UNLOCK_DOLLARZERO_MUTEX;
2676 Perl_whichsig(pTHX_ const char *sig)
2678 register char* const* sigv;
2679 PERL_UNUSED_CONTEXT;
2681 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
2682 if (strEQ(sig,*sigv))
2683 return PL_sig_num[sigv - (char* const*)PL_sig_name];
2685 if (strEQ(sig,"CHLD"))
2689 if (strEQ(sig,"CLD"))
2696 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2697 Perl_sighandler(int sig, ...)
2699 Perl_sighandler(int sig)
2702 #ifdef PERL_GET_SIG_CONTEXT
2703 dTHXa(PERL_GET_SIG_CONTEXT);
2710 SV * const tSv = PL_Sv;
2714 XPV * const tXpv = PL_Xpv;
2716 if (PL_savestack_ix + 15 <= PL_savestack_max)
2718 if (PL_markstack_ptr < PL_markstack_max - 2)
2720 if (PL_scopestack_ix < PL_scopestack_max - 3)
2723 if (!PL_psig_ptr[sig]) {
2724 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2729 /* Max number of items pushed there is 3*n or 4. We cannot fix
2730 infinity, so we fix 4 (in fact 5): */
2732 PL_savestack_ix += 5; /* Protect save in progress. */
2733 SAVEDESTRUCTOR_X(S_unwind_handler_stack, (void*)&flags);
2736 PL_markstack_ptr++; /* Protect mark. */
2738 PL_scopestack_ix += 1;
2739 /* sv_2cv is too complicated, try a simpler variant first: */
2740 if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
2741 || SvTYPE(cv) != SVt_PVCV) {
2743 cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
2746 if (!cv || !CvROOT(cv)) {
2747 if (ckWARN(WARN_SIGNAL))
2748 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2749 PL_sig_name[sig], (gv ? GvENAME(gv)
2756 if(PL_psig_name[sig]) {
2757 sv = SvREFCNT_inc_NN(PL_psig_name[sig]);
2759 #if !defined(PERL_IMPLICIT_CONTEXT)
2763 sv = sv_newmortal();
2764 sv_setpv(sv,PL_sig_name[sig]);
2767 PUSHSTACKi(PERLSI_SIGNAL);
2770 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2772 struct sigaction oact;
2774 if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
2778 va_start(args, sig);
2779 sip = (siginfo_t*)va_arg(args, siginfo_t*);
2782 SV *rv = newRV_noinc((SV*)sih);
2783 /* The siginfo fields signo, code, errno, pid, uid,
2784 * addr, status, and band are defined by POSIX/SUSv3. */
2785 hv_store(sih, "signo", 5, newSViv(sip->si_signo), 0);
2786 hv_store(sih, "code", 4, newSViv(sip->si_code), 0);
2787 #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. */
2788 hv_store(sih, "errno", 5, newSViv(sip->si_errno), 0);
2789 hv_store(sih, "status", 6, newSViv(sip->si_status), 0);
2790 hv_store(sih, "uid", 3, newSViv(sip->si_uid), 0);
2791 hv_store(sih, "pid", 3, newSViv(sip->si_pid), 0);
2792 hv_store(sih, "addr", 4, newSVuv(PTR2UV(sip->si_addr)), 0);
2793 hv_store(sih, "band", 4, newSViv(sip->si_band), 0);
2797 PUSHs(newSVpv((char *)sip, sizeof(*sip)));
2806 call_sv((SV*)cv, G_DISCARD|G_EVAL);
2809 if (SvTRUE(ERRSV)) {
2811 #ifdef HAS_SIGPROCMASK
2812 /* Handler "died", for example to get out of a restart-able read().
2813 * Before we re-do that on its behalf re-enable the signal which was
2814 * blocked by the system when we entered.
2818 sigaddset(&set,sig);
2819 sigprocmask(SIG_UNBLOCK, &set, NULL);
2821 /* Not clear if this will work */
2822 (void)rsignal(sig, SIG_IGN);
2823 (void)rsignal(sig, PL_csighandlerp);
2825 #endif /* !PERL_MICRO */
2826 Perl_die(aTHX_ NULL);
2830 PL_savestack_ix -= 8; /* Unprotect save in progress. */
2834 PL_scopestack_ix -= 1;
2837 PL_op = myop; /* Apparently not needed... */
2839 PL_Sv = tSv; /* Restore global temporaries. */
2846 S_restore_magic(pTHX_ const void *p)
2849 MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
2850 SV* const sv = mgs->mgs_sv;
2855 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2857 #ifdef PERL_OLD_COPY_ON_WRITE
2858 /* While magic was saved (and off) sv_setsv may well have seen
2859 this SV as a prime candidate for COW. */
2861 sv_force_normal_flags(sv, 0);
2865 SvFLAGS(sv) |= mgs->mgs_flags;
2868 if (SvGMAGICAL(sv)) {
2869 /* downgrade public flags to private,
2870 and discard any other private flags */
2872 const U32 pubflags = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
2874 SvFLAGS(sv) &= ~( pubflags | (SVp_IOK|SVp_NOK|SVp_POK) );
2875 SvFLAGS(sv) |= ( pubflags << PRIVSHIFT );
2880 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
2882 /* If we're still on top of the stack, pop us off. (That condition
2883 * will be satisfied if restore_magic was called explicitly, but *not*
2884 * if it's being called via leave_scope.)
2885 * The reason for doing this is that otherwise, things like sv_2cv()
2886 * may leave alloc gunk on the savestack, and some code
2887 * (e.g. sighandler) doesn't expect that...
2889 if (PL_savestack_ix == mgs->mgs_ss_ix)
2891 I32 popval = SSPOPINT;
2892 assert(popval == SAVEt_DESTRUCTOR_X);
2893 PL_savestack_ix -= 2;
2895 assert(popval == SAVEt_ALLOC);
2897 PL_savestack_ix -= popval;
2903 S_unwind_handler_stack(pTHX_ const void *p)
2906 const U32 flags = *(const U32*)p;
2909 PL_savestack_ix -= 5; /* Unprotect save in progress. */
2910 #if !defined(PERL_IMPLICIT_CONTEXT)
2912 SvREFCNT_dec(PL_sig_sv);
2917 =for apidoc magic_sethint
2919 Triggered by a store to %^H, records the key/value pair to
2920 C<PL_compiling.cop_hints_hash>. It is assumed that hints aren't storing
2921 anything that would need a deep copy. Maybe we should warn if we find a
2927 Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
2930 assert(mg->mg_len == HEf_SVKEY);
2932 /* mg->mg_obj isn't being used. If needed, it would be possible to store
2933 an alternative leaf in there, with PL_compiling.cop_hints being used if
2934 it's NULL. If needed for threads, the alternative could lock a mutex,
2935 or take other more complex action. */
2937 /* Something changed in %^H, so it will need to be restored on scope exit.
2938 Doing this here saves a lot of doing it manually in perl code (and
2939 forgetting to do it, and consequent subtle errors. */
2940 PL_hints |= HINT_LOCALIZE_HH;
2941 PL_compiling.cop_hints_hash
2942 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
2943 (SV *)mg->mg_ptr, sv);
2948 =for apidoc magic_sethint
2950 Triggered by a delete from %^H, records the key to
2951 C<PL_compiling.cop_hints_hash>.
2956 Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
2959 PERL_UNUSED_ARG(sv);
2961 assert(mg->mg_len == HEf_SVKEY);
2963 PERL_UNUSED_ARG(sv);
2965 PL_hints |= HINT_LOCALIZE_HH;
2966 PL_compiling.cop_hints_hash
2967 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
2968 (SV *)mg->mg_ptr, &PL_sv_placeholder);
2974 * c-indentation-style: bsd
2976 * indent-tabs-mode: t
2979 * ex: set ts=8 sts=4 sw=4 noet: