3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 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.
15 * [p.363 of _The Lord of the Rings_, II/vii: "The Mirror of Galadriel"]
19 =head1 Magical Functions
21 "Magic" is special data attached to SV structures in order to give them
22 "magical" properties. When any Perl code tries to read from, or assign to,
23 an SV marked as magical, it calls the 'get' or 'set' function associated
24 with that SV's magic. A get is called prior to reading an SV, in order to
25 give it a chance to update its internal value (get on $. writes the line
26 number of the last read filehandle into to the SV's IV slot), while
27 set is called after an SV has been written to, in order to allow it to make
28 use of its changed value (set on $/ copies the SV's new value to the
29 PL_rs global variable).
31 Magic is implemented as a linked list of MAGIC structures attached to the
32 SV. Each MAGIC struct holds the type of the magic, a pointer to an array
33 of functions that implement the get(), set(), length() etc functions,
34 plus space for some flags and pointers. For example, a tied variable has
35 a MAGIC structure that contains a pointer to the object associated with the
44 #if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS)
50 #if defined(HAS_SETGROUPS)
57 # include <sys/pstat.h>
60 #ifdef HAS_PRCTL_SET_NAME
61 # include <sys/prctl.h>
64 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
65 Signal_t Perl_csighandler(int sig, siginfo_t *, void *);
67 Signal_t Perl_csighandler(int sig);
71 /* Missing protos on LynxOS */
72 void setruid(uid_t id);
73 void seteuid(uid_t id);
74 void setrgid(uid_t id);
75 void setegid(uid_t id);
79 * Use the "DESTRUCTOR" scope cleanup to reinstate magic.
88 /* MGS is typedef'ed to struct magic_state in perl.h */
91 S_save_magic(pTHX_ I32 mgs_ix, SV *sv)
96 PERL_ARGS_ASSERT_SAVE_MAGIC;
98 /* guard against sv having being freed midway by holding a private
100 SvREFCNT_inc_simple_void_NN(sv);
102 assert(SvMAGICAL(sv));
103 /* Turning READONLY off for a copy-on-write scalar (including shared
104 hash keys) is a bad idea. */
106 sv_force_normal_flags(sv, 0);
108 SAVEDESTRUCTOR_X(S_restore_magic, INT2PTR(void*, (IV)mgs_ix));
110 mgs = SSPTR(mgs_ix, MGS*);
112 mgs->mgs_magical = SvMAGICAL(sv);
113 mgs->mgs_readonly = SvREADONLY(sv) != 0;
114 mgs->mgs_ss_ix = PL_savestack_ix; /* points after the saved destructor */
118 if (!(SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK))) {
119 /* No public flags are set, so promote any private flags to public. */
120 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
125 =for apidoc mg_magical
127 Turns on the magical status of an SV. See C<sv_magic>.
133 Perl_mg_magical(pTHX_ SV *sv)
136 PERL_ARGS_ASSERT_MG_MAGICAL;
140 if ((mg = SvMAGIC(sv))) {
142 const MGVTBL* const vtbl = mg->mg_virtual;
144 if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
151 } while ((mg = mg->mg_moremagic));
152 if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)))
158 /* is this container magic (%ENV, $1 etc), or value magic (pos, taint etc)? */
161 S_is_container_magic(const MAGIC *mg)
164 switch (mg->mg_type) {
167 case PERL_MAGIC_regex_global:
168 case PERL_MAGIC_nkeys:
169 #ifdef USE_LOCALE_COLLATE
170 case PERL_MAGIC_collxfrm:
173 case PERL_MAGIC_taint:
175 case PERL_MAGIC_vstring:
176 case PERL_MAGIC_utf8:
177 case PERL_MAGIC_substr:
178 case PERL_MAGIC_defelem:
179 case PERL_MAGIC_arylen:
181 case PERL_MAGIC_backref:
182 case PERL_MAGIC_arylen_p:
183 case PERL_MAGIC_rhash:
184 case PERL_MAGIC_symtab:
185 case PERL_MAGIC_tied: /* treat as value, so 'local @tied' isn't tied */
186 case PERL_MAGIC_checkcall:
196 Do magic after a value is retrieved from the SV. See C<sv_magic>.
202 Perl_mg_get(pTHX_ SV *sv)
205 const I32 mgs_ix = SSNEW(sizeof(MGS));
207 MAGIC *newmg, *head, *cur, *mg;
209 PERL_ARGS_ASSERT_MG_GET;
211 save_magic(mgs_ix, sv);
213 /* We must call svt_get(sv, mg) for each valid entry in the linked
214 list of magic. svt_get() may delete the current entry, add new
215 magic to the head of the list, or upgrade the SV. AMS 20010810 */
217 newmg = cur = head = mg = SvMAGIC(sv);
219 const MGVTBL * const vtbl = mg->mg_virtual;
220 MAGIC * const nextmg = mg->mg_moremagic; /* it may delete itself */
222 if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
223 vtbl->svt_get(aTHX_ sv, mg);
225 /* guard against magic having been deleted - eg FETCH calling
228 (SSPTR(mgs_ix, MGS *))->mgs_magical = 0; /* recalculate flags */
232 /* recalculate flags if this entry was deleted. */
233 if (mg->mg_flags & MGf_GSKIP)
234 (SSPTR(mgs_ix, MGS *))->mgs_magical = 0;
240 /* Have we finished with the new entries we saw? Start again
241 where we left off (unless there are more new entries). */
249 /* Were any new entries added? */
250 if (!have_new && (newmg = SvMAGIC(sv)) != head) {
254 (SSPTR(mgs_ix, MGS *))->mgs_magical = 0; /* recalculate flags */
258 restore_magic(INT2PTR(void *, (IV)mgs_ix));
265 Do magic after a value is assigned to the SV. See C<sv_magic>.
271 Perl_mg_set(pTHX_ SV *sv)
274 const I32 mgs_ix = SSNEW(sizeof(MGS));
278 PERL_ARGS_ASSERT_MG_SET;
280 save_magic(mgs_ix, sv);
282 for (mg = SvMAGIC(sv); mg; mg = nextmg) {
283 const MGVTBL* vtbl = mg->mg_virtual;
284 nextmg = mg->mg_moremagic; /* it may delete itself */
285 if (mg->mg_flags & MGf_GSKIP) {
286 mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */
287 (SSPTR(mgs_ix, MGS*))->mgs_magical = 0;
289 if (PL_localizing == 2 && (!S_is_container_magic(mg) || sv == DEFSV))
291 if (vtbl && vtbl->svt_set)
292 vtbl->svt_set(aTHX_ sv, mg);
295 restore_magic(INT2PTR(void*, (IV)mgs_ix));
300 =for apidoc mg_length
302 Report on the SV's length. See C<sv_magic>.
308 Perl_mg_length(pTHX_ SV *sv)
314 PERL_ARGS_ASSERT_MG_LENGTH;
316 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
317 const MGVTBL * const vtbl = mg->mg_virtual;
318 if (vtbl && vtbl->svt_len) {
319 const I32 mgs_ix = SSNEW(sizeof(MGS));
320 save_magic(mgs_ix, sv);
321 /* omit MGf_GSKIP -- not changed here */
322 len = vtbl->svt_len(aTHX_ sv, mg);
323 restore_magic(INT2PTR(void*, (IV)mgs_ix));
329 /* You can't know whether it's UTF-8 until you get the string again...
331 const U8 *s = (U8*)SvPV_const(sv, len);
334 len = utf8_length(s, s + len);
341 Perl_mg_size(pTHX_ SV *sv)
345 PERL_ARGS_ASSERT_MG_SIZE;
347 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
348 const MGVTBL* const vtbl = mg->mg_virtual;
349 if (vtbl && vtbl->svt_len) {
350 const I32 mgs_ix = SSNEW(sizeof(MGS));
352 save_magic(mgs_ix, sv);
353 /* omit MGf_GSKIP -- not changed here */
354 len = vtbl->svt_len(aTHX_ sv, mg);
355 restore_magic(INT2PTR(void*, (IV)mgs_ix));
362 return AvFILLp((const AV *) sv); /* Fallback to non-tied array */
366 Perl_croak(aTHX_ "Size magic not implemented");
375 Clear something magical that the SV represents. See C<sv_magic>.
381 Perl_mg_clear(pTHX_ SV *sv)
383 const I32 mgs_ix = SSNEW(sizeof(MGS));
387 PERL_ARGS_ASSERT_MG_CLEAR;
389 save_magic(mgs_ix, sv);
391 for (mg = SvMAGIC(sv); mg; mg = nextmg) {
392 const MGVTBL* const vtbl = mg->mg_virtual;
393 /* omit GSKIP -- never set here */
395 nextmg = mg->mg_moremagic; /* it may delete itself */
397 if (vtbl && vtbl->svt_clear)
398 vtbl->svt_clear(aTHX_ sv, mg);
401 restore_magic(INT2PTR(void*, (IV)mgs_ix));
406 S_mg_findext_flags(pTHX_ const SV *sv, int type, const MGVTBL *vtbl, U32 flags)
415 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
416 if (mg->mg_type == type && (!flags || mg->mg_virtual == vtbl)) {
428 Finds the magic pointer for type matching the SV. See C<sv_magic>.
434 Perl_mg_find(pTHX_ const SV *sv, int type)
436 return S_mg_findext_flags(aTHX_ sv, type, NULL, 0);
440 =for apidoc mg_findext
442 Finds the magic pointer of C<type> with the given C<vtbl> for the C<SV>. See
449 Perl_mg_findext(pTHX_ const SV *sv, int type, const MGVTBL *vtbl)
451 return S_mg_findext_flags(aTHX_ sv, type, vtbl, 1);
457 Copies the magic from one SV to another. See C<sv_magic>.
463 Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
468 PERL_ARGS_ASSERT_MG_COPY;
470 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
471 const MGVTBL* const vtbl = mg->mg_virtual;
472 if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){
473 count += vtbl->svt_copy(aTHX_ sv, mg, nsv, key, klen);
476 const char type = mg->mg_type;
477 if (isUPPER(type) && type != PERL_MAGIC_uvar) {
479 (type == PERL_MAGIC_tied)
481 : (type == PERL_MAGIC_regdata && mg->mg_obj)
484 toLOWER(type), key, klen);
493 =for apidoc mg_localize
495 Copy some of the magic from an existing SV to new localized version of that
496 SV. Container magic (eg %ENV, $1, tie) gets copied, value magic doesn't (eg
499 If setmagic is false then no set magic will be called on the new (empty) SV.
500 This typically means that assignment will soon follow (e.g. 'local $x = $y'),
501 and that will handle the magic.
507 Perl_mg_localize(pTHX_ SV *sv, SV *nsv, bool setmagic)
512 PERL_ARGS_ASSERT_MG_LOCALIZE;
517 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
518 const MGVTBL* const vtbl = mg->mg_virtual;
519 if (!S_is_container_magic(mg))
522 if ((mg->mg_flags & MGf_LOCAL) && vtbl->svt_local)
523 (void)vtbl->svt_local(aTHX_ nsv, mg);
525 sv_magicext(nsv, mg->mg_obj, mg->mg_type, vtbl,
526 mg->mg_ptr, mg->mg_len);
528 /* container types should remain read-only across localization */
529 SvFLAGS(nsv) |= SvREADONLY(sv);
532 if (SvTYPE(nsv) >= SVt_PVMG && SvMAGIC(nsv)) {
533 SvFLAGS(nsv) |= SvMAGICAL(sv);
542 #define mg_free_struct(sv, mg) S_mg_free_struct(aTHX_ sv, mg)
544 S_mg_free_struct(pTHX_ SV *sv, MAGIC *mg)
546 const MGVTBL* const vtbl = mg->mg_virtual;
547 if (vtbl && vtbl->svt_free)
548 vtbl->svt_free(aTHX_ sv, mg);
549 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
550 if (mg->mg_len > 0 || mg->mg_type == PERL_MAGIC_utf8)
551 Safefree(mg->mg_ptr);
552 else if (mg->mg_len == HEf_SVKEY)
553 SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr));
555 if (mg->mg_flags & MGf_REFCOUNTED)
556 SvREFCNT_dec(mg->mg_obj);
563 Free any magic storage used by the SV. See C<sv_magic>.
569 Perl_mg_free(pTHX_ SV *sv)
574 PERL_ARGS_ASSERT_MG_FREE;
576 for (mg = SvMAGIC(sv); mg; mg = moremagic) {
577 moremagic = mg->mg_moremagic;
578 mg_free_struct(sv, mg);
579 SvMAGIC_set(sv, moremagic);
581 SvMAGIC_set(sv, NULL);
587 =for apidoc Am|void|mg_free_type|SV *sv|int how
589 Remove any magic of type I<how> from the SV I<sv>. See L</sv_magic>.
595 Perl_mg_free_type(pTHX_ SV *sv, int how)
597 MAGIC *mg, *prevmg, *moremg;
598 PERL_ARGS_ASSERT_MG_FREE_TYPE;
599 for (prevmg = NULL, mg = SvMAGIC(sv); mg; prevmg = mg, mg = moremg) {
601 moremg = mg->mg_moremagic;
602 if (mg->mg_type == how) {
603 /* temporarily move to the head of the magic chain, in case
604 custom free code relies on this historical aspect of mg_free */
606 prevmg->mg_moremagic = moremg;
607 mg->mg_moremagic = SvMAGIC(sv);
610 newhead = mg->mg_moremagic;
611 mg_free_struct(sv, mg);
612 SvMAGIC_set(sv, newhead);
622 Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
627 PERL_ARGS_ASSERT_MAGIC_REGDATA_CNT;
630 register const REGEXP * const rx = PM_GETRE(PL_curpm);
632 if (mg->mg_obj) { /* @+ */
633 /* return the number possible */
634 return RX_NPARENS(rx);
636 I32 paren = RX_LASTPAREN(rx);
638 /* return the last filled */
640 && (RX_OFFS(rx)[paren].start == -1
641 || RX_OFFS(rx)[paren].end == -1) )
652 Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
656 PERL_ARGS_ASSERT_MAGIC_REGDATUM_GET;
659 register const REGEXP * const rx = PM_GETRE(PL_curpm);
661 register const I32 paren = mg->mg_len;
666 if (paren <= (I32)RX_NPARENS(rx) &&
667 (s = RX_OFFS(rx)[paren].start) != -1 &&
668 (t = RX_OFFS(rx)[paren].end) != -1)
671 if (mg->mg_obj) /* @+ */
676 if (i > 0 && RX_MATCH_UTF8(rx)) {
677 const char * const b = RX_SUBBEG(rx);
679 i = utf8_length((U8*)b, (U8*)(b+i));
690 Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
692 PERL_ARGS_ASSERT_MAGIC_REGDATUM_SET;
695 Perl_croak_no_modify(aTHX);
696 NORETURN_FUNCTION_END;
700 Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
705 register const REGEXP * rx;
706 const char * const remaining = mg->mg_ptr + 1;
708 PERL_ARGS_ASSERT_MAGIC_LEN;
710 switch (*mg->mg_ptr) {
712 if (*remaining == '\0') { /* ^P */
714 } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
716 } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
720 case '\015': /* $^MATCH */
721 if (strEQ(remaining, "ATCH")) {
728 paren = RX_BUFF_IDX_PREMATCH;
732 paren = RX_BUFF_IDX_POSTMATCH;
736 paren = RX_BUFF_IDX_FULLMATCH;
738 case '1': case '2': case '3': case '4':
739 case '5': case '6': case '7': case '8': case '9':
740 paren = atoi(mg->mg_ptr);
742 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
744 i = CALLREG_NUMBUF_LENGTH((REGEXP * const)rx, sv, paren);
747 Perl_croak(aTHX_ "panic: magic_len: %"IVdf, (IV)i);
750 if (ckWARN(WARN_UNINITIALIZED))
755 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
756 paren = RX_LASTPAREN(rx);
761 case '\016': /* ^N */
762 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
763 paren = RX_LASTCLOSEPAREN(rx);
770 if (!SvPOK(sv) && SvNIOK(sv)) {
778 #define SvRTRIM(sv) STMT_START { \
780 STRLEN len = SvCUR(sv); \
781 char * const p = SvPVX(sv); \
782 while (len > 0 && isSPACE(p[len-1])) \
784 SvCUR_set(sv, len); \
790 Perl_emulate_cop_io(pTHX_ const COP *const c, SV *const sv)
792 PERL_ARGS_ASSERT_EMULATE_COP_IO;
794 if (!(CopHINTS_get(c) & (HINT_LEXICAL_IO_IN|HINT_LEXICAL_IO_OUT)))
795 sv_setsv(sv, &PL_sv_undef);
799 if ((CopHINTS_get(c) & HINT_LEXICAL_IO_IN)) {
800 SV *const value = cop_hints_fetch_pvs(c, "open<", 0);
805 if ((CopHINTS_get(c) & HINT_LEXICAL_IO_OUT)) {
806 SV *const value = cop_hints_fetch_pvs(c, "open>", 0);
814 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
818 register const char *s = NULL;
820 const char * const remaining = mg->mg_ptr + 1;
821 const char nextchar = *remaining;
823 PERL_ARGS_ASSERT_MAGIC_GET;
825 switch (*mg->mg_ptr) {
826 case '\001': /* ^A */
827 sv_setsv(sv, PL_bodytarget);
828 if (SvTAINTED(PL_bodytarget))
831 case '\003': /* ^C, ^CHILD_ERROR_NATIVE */
832 if (nextchar == '\0') {
833 sv_setiv(sv, (IV)PL_minus_c);
835 else if (strEQ(remaining, "HILD_ERROR_NATIVE")) {
836 sv_setiv(sv, (IV)STATUS_NATIVE);
840 case '\004': /* ^D */
841 sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
843 case '\005': /* ^E */
844 if (nextchar == '\0') {
847 # include <descrip.h>
848 # include <starlet.h>
850 $DESCRIPTOR(msgdsc,msg);
851 sv_setnv(sv,(NV) vaxc$errno);
852 if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
853 sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
858 if (!(_emx_env & 0x200)) { /* Under DOS */
859 sv_setnv(sv, (NV)errno);
860 sv_setpv(sv, errno ? Strerror(errno) : "");
862 if (errno != errno_isOS2) {
863 const int tmp = _syserrno();
864 if (tmp) /* 2nd call to _syserrno() makes it 0 */
867 sv_setnv(sv, (NV)Perl_rc);
868 sv_setpv(sv, os2error(Perl_rc));
872 const DWORD dwErr = GetLastError();
873 sv_setnv(sv, (NV)dwErr);
875 PerlProc_GetOSError(sv, dwErr);
884 sv_setnv(sv, (NV)errno);
885 sv_setpv(sv, errno ? Strerror(errno) : "");
890 SvNOK_on(sv); /* what a wonderful hack! */
892 else if (strEQ(remaining, "NCODING"))
893 sv_setsv(sv, PL_encoding);
895 case '\006': /* ^F */
896 sv_setiv(sv, (IV)PL_maxsysfd);
898 case '\007': /* ^GLOBAL_PHASE */
899 if (strEQ(remaining, "LOBAL_PHASE")) {
900 sv_setpvn(sv, PL_phase_names[PL_phase],
901 strlen(PL_phase_names[PL_phase]));
904 case '\010': /* ^H */
905 sv_setiv(sv, (IV)PL_hints);
907 case '\011': /* ^I */ /* NOT \t in EBCDIC */
908 sv_setpv(sv, PL_inplace); /* Will undefine sv if PL_inplace is NULL */
910 case '\017': /* ^O & ^OPEN */
911 if (nextchar == '\0') {
912 sv_setpv(sv, PL_osname);
915 else if (strEQ(remaining, "PEN")) {
916 Perl_emulate_cop_io(aTHX_ &PL_compiling, sv);
920 if (nextchar == '\0') { /* ^P */
921 sv_setiv(sv, (IV)PL_perldb);
922 } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
923 goto do_prematch_fetch;
924 } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
925 goto do_postmatch_fetch;
928 case '\023': /* ^S */
929 if (nextchar == '\0') {
930 if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING)
933 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
938 case '\024': /* ^T */
939 if (nextchar == '\0') {
941 sv_setnv(sv, PL_basetime);
943 sv_setiv(sv, (IV)PL_basetime);
946 else if (strEQ(remaining, "AINT"))
947 sv_setiv(sv, PL_tainting
948 ? (PL_taint_warn || PL_unsafe ? -1 : 1)
951 case '\025': /* $^UNICODE, $^UTF8LOCALE, $^UTF8CACHE */
952 if (strEQ(remaining, "NICODE"))
953 sv_setuv(sv, (UV) PL_unicode);
954 else if (strEQ(remaining, "TF8LOCALE"))
955 sv_setuv(sv, (UV) PL_utf8locale);
956 else if (strEQ(remaining, "TF8CACHE"))
957 sv_setiv(sv, (IV) PL_utf8cache);
959 case '\027': /* ^W & $^WARNING_BITS */
960 if (nextchar == '\0')
961 sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
962 else if (strEQ(remaining, "ARNING_BITS")) {
963 if (PL_compiling.cop_warnings == pWARN_NONE) {
964 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
966 else if (PL_compiling.cop_warnings == pWARN_STD) {
969 (PL_dowarn & G_WARN_ON) ? WARN_ALLstring : WARN_NONEstring,
973 else if (PL_compiling.cop_warnings == pWARN_ALL) {
974 /* Get the bit mask for $warnings::Bits{all}, because
975 * it could have been extended by warnings::register */
976 HV * const bits=get_hv("warnings::Bits", 0);
978 SV ** const bits_all = hv_fetchs(bits, "all", FALSE);
980 sv_setsv(sv, *bits_all);
983 sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
987 sv_setpvn(sv, (char *) (PL_compiling.cop_warnings + 1),
988 *PL_compiling.cop_warnings);
993 case '\015': /* $^MATCH */
994 if (strEQ(remaining, "ATCH")) {
995 case '1': case '2': case '3': case '4':
996 case '5': case '6': case '7': case '8': case '9': case '&':
997 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
999 * Pre-threads, this was paren = atoi(GvENAME((const GV *)mg->mg_obj));
1000 * XXX Does the new way break anything?
1002 paren = atoi(mg->mg_ptr); /* $& is in [0] */
1003 CALLREG_NUMBUF_FETCH(rx,paren,sv);
1006 sv_setsv(sv,&PL_sv_undef);
1010 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
1011 if (RX_LASTPAREN(rx)) {
1012 CALLREG_NUMBUF_FETCH(rx,RX_LASTPAREN(rx),sv);
1016 sv_setsv(sv,&PL_sv_undef);
1018 case '\016': /* ^N */
1019 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
1020 if (RX_LASTCLOSEPAREN(rx)) {
1021 CALLREG_NUMBUF_FETCH(rx,RX_LASTCLOSEPAREN(rx),sv);
1026 sv_setsv(sv,&PL_sv_undef);
1030 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
1031 CALLREG_NUMBUF_FETCH(rx,-2,sv);
1034 sv_setsv(sv,&PL_sv_undef);
1038 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
1039 CALLREG_NUMBUF_FETCH(rx,-1,sv);
1042 sv_setsv(sv,&PL_sv_undef);
1045 if (GvIO(PL_last_in_gv)) {
1046 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
1051 sv_setiv(sv, (IV)STATUS_CURRENT);
1052 #ifdef COMPLEX_STATUS
1053 SvUPGRADE(sv, SVt_PVLV);
1054 LvTARGOFF(sv) = PL_statusvalue;
1055 LvTARGLEN(sv) = PL_statusvalue_vms;
1060 if (!isGV_with_GP(PL_defoutgv))
1062 else if (GvIOp(PL_defoutgv))
1063 s = IoTOP_NAME(GvIOp(PL_defoutgv));
1067 sv_setpv(sv,GvENAME(PL_defoutgv));
1068 sv_catpvs(sv,"_TOP");
1072 if (!isGV_with_GP(PL_defoutgv))
1074 else if (GvIOp(PL_defoutgv))
1075 s = IoFMT_NAME(GvIOp(PL_defoutgv));
1077 s = GvENAME(PL_defoutgv);
1081 if (GvIO(PL_defoutgv))
1082 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
1085 if (GvIO(PL_defoutgv))
1086 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
1089 if (GvIO(PL_defoutgv))
1090 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
1097 sv_setiv(sv, (IV)CopARYBASE_get(PL_curcop));
1100 if (GvIO(PL_defoutgv))
1101 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
1105 sv_copypv(sv, PL_ors_sv);
1111 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
1113 sv_setnv(sv, (NV)errno);
1116 if (errno == errno_isOS2 || errno == errno_isOS2_set)
1117 sv_setpv(sv, os2error(Perl_rc));
1120 sv_setpv(sv, errno ? Strerror(errno) : "");
1122 SvPOK_on(sv); /* may have got removed during taint processing */
1127 SvNOK_on(sv); /* what a wonderful hack! */
1130 sv_setiv(sv, (IV)PL_uid);
1133 sv_setiv(sv, (IV)PL_euid);
1136 sv_setiv(sv, (IV)PL_gid);
1139 sv_setiv(sv, (IV)PL_egid);
1141 #ifdef HAS_GETGROUPS
1143 Groups_t *gary = NULL;
1144 I32 i, num_groups = getgroups(0, gary);
1145 Newx(gary, num_groups, Groups_t);
1146 num_groups = getgroups(num_groups, gary);
1147 for (i = 0; i < num_groups; i++)
1148 Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]);
1151 (void)SvIOK_on(sv); /* what a wonderful hack! */
1161 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
1163 struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
1165 PERL_ARGS_ASSERT_MAGIC_GETUVAR;
1167 if (uf && uf->uf_val)
1168 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
1173 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
1176 STRLEN len = 0, klen;
1177 const char *s = SvOK(sv) ? SvPV_const(sv,len) : "";
1178 const char * const ptr = MgPV_const(mg,klen);
1181 PERL_ARGS_ASSERT_MAGIC_SETENV;
1183 #ifdef DYNAMIC_ENV_FETCH
1184 /* We just undefd an environment var. Is a replacement */
1185 /* waiting in the wings? */
1187 SV ** const valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE);
1189 s = SvOK(*valp) ? SvPV_const(*valp, len) : "";
1193 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
1194 /* And you'll never guess what the dog had */
1195 /* in its mouth... */
1197 MgTAINTEDDIR_off(mg);
1199 if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
1200 char pathbuf[256], eltbuf[256], *cp, *elt;
1203 my_strlcpy(eltbuf, s, sizeof(eltbuf));
1205 do { /* DCL$PATH may be a search list */
1206 while (1) { /* as may dev portion of any element */
1207 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1208 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1209 cando_by_name(S_IWUSR,0,elt) ) {
1210 MgTAINTEDDIR_on(mg);
1214 if ((cp = strchr(elt, ':')) != NULL)
1216 if (my_trnlnm(elt, eltbuf, j++))
1222 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1225 if (s && klen == 4 && strEQ(ptr,"PATH")) {
1226 const char * const strend = s + len;
1228 while (s < strend) {
1232 #ifdef VMS /* Hmm. How do we get $Config{path_sep} from C? */
1233 const char path_sep = '|';
1235 const char path_sep = ':';
1237 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
1238 s, strend, path_sep, &i);
1240 if (i >= (I32)sizeof tmpbuf /* too long -- assume the worst */
1242 || !strchr(tmpbuf, ':') /* no colon thus no device name -- assume relative path */
1244 || *tmpbuf != '/' /* no starting slash -- assume relative path */
1246 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1247 MgTAINTEDDIR_on(mg);
1253 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1259 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1261 PERL_ARGS_ASSERT_MAGIC_CLEARENV;
1262 PERL_UNUSED_ARG(sv);
1263 my_setenv(MgPV_nolen_const(mg),NULL);
1268 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1271 PERL_ARGS_ASSERT_MAGIC_SET_ALL_ENV;
1272 PERL_UNUSED_ARG(mg);
1274 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1276 if (PL_localizing) {
1279 hv_iterinit(MUTABLE_HV(sv));
1280 while ((entry = hv_iternext(MUTABLE_HV(sv)))) {
1282 my_setenv(hv_iterkey(entry, &keylen),
1283 SvPV_nolen_const(hv_iterval(MUTABLE_HV(sv), entry)));
1291 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1294 PERL_ARGS_ASSERT_MAGIC_CLEAR_ALL_ENV;
1295 PERL_UNUSED_ARG(sv);
1296 PERL_UNUSED_ARG(mg);
1298 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1306 #ifdef HAS_SIGPROCMASK
1308 restore_sigmask(pTHX_ SV *save_sv)
1310 const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1311 (void)sigprocmask(SIG_SETMASK, ossetp, NULL);
1315 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1318 /* Are we fetching a signal entry? */
1319 int i = (I16)mg->mg_private;
1321 PERL_ARGS_ASSERT_MAGIC_GETSIG;
1324 mg->mg_private = i = whichsig(MgPV_nolen_const(mg));
1329 sv_setsv(sv,PL_psig_ptr[i]);
1331 Sighandler_t sigstate = rsignal_state(i);
1332 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1333 if (PL_sig_handlers_initted && PL_sig_ignoring[i])
1336 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1337 if (PL_sig_handlers_initted && PL_sig_defaulting[i])
1340 /* cache state so we don't fetch it again */
1341 if(sigstate == (Sighandler_t) SIG_IGN)
1342 sv_setpvs(sv,"IGNORE");
1344 sv_setsv(sv,&PL_sv_undef);
1345 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1352 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1354 PERL_ARGS_ASSERT_MAGIC_CLEARSIG;
1355 PERL_UNUSED_ARG(sv);
1357 magic_setsig(NULL, mg);
1358 return sv_unmagic(sv, mg->mg_type);
1362 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1363 Perl_csighandler(int sig, siginfo_t *sip PERL_UNUSED_DECL, void *uap PERL_UNUSED_DECL)
1365 Perl_csighandler(int sig)
1368 #ifdef PERL_GET_SIG_CONTEXT
1369 dTHXa(PERL_GET_SIG_CONTEXT);
1373 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1374 (void) rsignal(sig, PL_csighandlerp);
1375 if (PL_sig_ignoring[sig]) return;
1377 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1378 if (PL_sig_defaulting[sig])
1379 #ifdef KILL_BY_SIGPRC
1380 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1395 (PL_signals & PERL_SIGNALS_UNSAFE_FLAG))
1396 /* Call the perl level handler now--
1397 * with risk we may be in malloc() or being destructed etc. */
1398 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1399 (*PL_sighandlerp)(sig, NULL, NULL);
1401 (*PL_sighandlerp)(sig);
1404 if (!PL_psig_pend) return;
1405 /* Set a flag to say this signal is pending, that is awaiting delivery after
1406 * the current Perl opcode completes */
1407 PL_psig_pend[sig]++;
1409 #ifndef SIG_PENDING_DIE_COUNT
1410 # define SIG_PENDING_DIE_COUNT 120
1412 /* Add one to say _a_ signal is pending */
1413 if (++PL_sig_pending >= SIG_PENDING_DIE_COUNT)
1414 Perl_croak(aTHX_ "Maximal count of pending signals (%lu) exceeded",
1415 (unsigned long)SIG_PENDING_DIE_COUNT);
1419 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1421 Perl_csighandler_init(void)
1424 if (PL_sig_handlers_initted) return;
1426 for (sig = 1; sig < SIG_SIZE; sig++) {
1427 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1429 PL_sig_defaulting[sig] = 1;
1430 (void) rsignal(sig, PL_csighandlerp);
1432 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1433 PL_sig_ignoring[sig] = 0;
1436 PL_sig_handlers_initted = 1;
1440 #if defined HAS_SIGPROCMASK
1442 unblock_sigmask(pTHX_ void* newset)
1444 sigprocmask(SIG_UNBLOCK, (sigset_t*)newset, NULL);
1449 Perl_despatch_signals(pTHX)
1454 for (sig = 1; sig < SIG_SIZE; sig++) {
1455 if (PL_psig_pend[sig]) {
1457 #ifdef HAS_SIGPROCMASK
1458 /* From sigaction(2) (FreeBSD man page):
1459 * | Signal routines normally execute with the signal that
1460 * | caused their invocation blocked, but other signals may
1462 * Emulation of this behavior (from within Perl) is enabled
1466 sigset_t newset, oldset;
1468 sigemptyset(&newset);
1469 sigaddset(&newset, sig);
1470 sigprocmask(SIG_BLOCK, &newset, &oldset);
1471 was_blocked = sigismember(&oldset, sig);
1473 SV* save_sv = newSVpvn((char *)(&newset), sizeof(sigset_t));
1475 SAVEFREESV(save_sv);
1476 SAVEDESTRUCTOR_X(unblock_sigmask, SvPV_nolen(save_sv));
1479 PL_psig_pend[sig] = 0;
1480 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1481 (*PL_sighandlerp)(sig, NULL, NULL);
1483 (*PL_sighandlerp)(sig);
1485 #ifdef HAS_SIGPROCMASK
1494 /* sv of NULL signifies that we're acting as magic_clearsig. */
1496 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1501 /* Need to be careful with SvREFCNT_dec(), because that can have side
1502 * effects (due to closures). We must make sure that the new disposition
1503 * is in place before it is called.
1507 #ifdef HAS_SIGPROCMASK
1511 register const char *s = MgPV_const(mg,len);
1513 PERL_ARGS_ASSERT_MAGIC_SETSIG;
1516 if (strEQ(s,"__DIE__"))
1518 else if (strEQ(s,"__WARN__")
1519 && (sv ? 1 : PL_warnhook != PERL_WARNHOOK_FATAL)) {
1520 /* Merge the existing behaviours, which are as follows:
1521 magic_setsig, we always set svp to &PL_warnhook
1522 (hence we always change the warnings handler)
1523 For magic_clearsig, we don't change the warnings handler if it's
1524 set to the &PL_warnhook. */
1527 Perl_croak(aTHX_ "No such hook: %s", s);
1530 if (*svp != PERL_WARNHOOK_FATAL)
1536 i = (I16)mg->mg_private;
1538 i = whichsig(s); /* ...no, a brick */
1539 mg->mg_private = (U16)i;
1543 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
1546 #ifdef HAS_SIGPROCMASK
1547 /* Avoid having the signal arrive at a bad time, if possible. */
1550 sigprocmask(SIG_BLOCK, &set, &save);
1552 save_sv = newSVpvn((char *)(&save), sizeof(sigset_t));
1553 SAVEFREESV(save_sv);
1554 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1557 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1558 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1560 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1561 PL_sig_ignoring[i] = 0;
1563 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1564 PL_sig_defaulting[i] = 0;
1566 to_dec = PL_psig_ptr[i];
1568 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1569 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1571 /* Signals don't change name during the program's execution, so once
1572 they're cached in the appropriate slot of PL_psig_name, they can
1575 Ideally we'd find some way of making SVs at (C) compile time, or
1576 at least, doing most of the work. */
1577 if (!PL_psig_name[i]) {
1578 PL_psig_name[i] = newSVpvn(s, len);
1579 SvREADONLY_on(PL_psig_name[i]);
1582 SvREFCNT_dec(PL_psig_name[i]);
1583 PL_psig_name[i] = NULL;
1584 PL_psig_ptr[i] = NULL;
1587 if (sv && (isGV_with_GP(sv) || SvROK(sv))) {
1589 (void)rsignal(i, PL_csighandlerp);
1592 *svp = SvREFCNT_inc_simple_NN(sv);
1594 if (sv && SvOK(sv)) {
1595 s = SvPV_force(sv, len);
1599 if (sv && strEQ(s,"IGNORE")) {
1601 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1602 PL_sig_ignoring[i] = 1;
1603 (void)rsignal(i, PL_csighandlerp);
1605 (void)rsignal(i, (Sighandler_t) SIG_IGN);
1609 else if (!sv || strEQ(s,"DEFAULT") || !len) {
1611 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1612 PL_sig_defaulting[i] = 1;
1613 (void)rsignal(i, PL_csighandlerp);
1615 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1621 * We should warn if HINT_STRICT_REFS, but without
1622 * access to a known hint bit in a known OP, we can't
1623 * tell whether HINT_STRICT_REFS is in force or not.
1625 if (!strchr(s,':') && !strchr(s,'\''))
1626 Perl_sv_insert_flags(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"),
1629 (void)rsignal(i, PL_csighandlerp);
1631 *svp = SvREFCNT_inc_simple_NN(sv);
1635 #ifdef HAS_SIGPROCMASK
1639 SvREFCNT_dec(to_dec);
1642 #endif /* !PERL_MICRO */
1645 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1648 PERL_ARGS_ASSERT_MAGIC_SETISA;
1649 PERL_UNUSED_ARG(sv);
1651 /* Skip _isaelem because _isa will handle it shortly */
1652 if (PL_delaymagic & DM_ARRAY_ISA && mg->mg_type == PERL_MAGIC_isaelem)
1655 return magic_clearisa(NULL, mg);
1658 /* sv of NULL signifies that we're acting as magic_setisa. */
1660 Perl_magic_clearisa(pTHX_ SV *sv, MAGIC *mg)
1665 PERL_ARGS_ASSERT_MAGIC_CLEARISA;
1667 /* Bail out if destruction is going on */
1668 if(PL_phase == PERL_PHASE_DESTRUCT) return 0;
1671 av_clear(MUTABLE_AV(sv));
1673 if (SvTYPE(mg->mg_obj) != SVt_PVGV && SvSMAGICAL(mg->mg_obj))
1674 /* This occurs with setisa_elem magic, which calls this
1676 mg = mg_find(mg->mg_obj, PERL_MAGIC_isa);
1678 if (SvTYPE(mg->mg_obj) == SVt_PVAV) { /* multiple stashes */
1679 SV **svp = AvARRAY((AV *)mg->mg_obj);
1680 I32 items = AvFILLp((AV *)mg->mg_obj) + 1;
1682 stash = GvSTASH((GV *)*svp++);
1683 if (stash && HvENAME(stash)) mro_isa_changed_in(stash);
1690 (const GV *)mg->mg_obj
1693 /* The stash may have been detached from the symbol table, so check its
1694 name before doing anything. */
1695 if (stash && HvENAME_get(stash))
1696 mro_isa_changed_in(stash);
1702 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
1705 PERL_ARGS_ASSERT_MAGIC_SETAMAGIC;
1706 PERL_UNUSED_ARG(sv);
1707 PERL_UNUSED_ARG(mg);
1708 PL_amagic_generation++;
1714 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1716 HV * const hv = MUTABLE_HV(LvTARG(sv));
1719 PERL_ARGS_ASSERT_MAGIC_GETNKEYS;
1720 PERL_UNUSED_ARG(mg);
1723 (void) hv_iterinit(hv);
1724 if (! SvTIED_mg((const SV *)hv, PERL_MAGIC_tied))
1727 while (hv_iternext(hv))
1732 sv_setiv(sv, (IV)i);
1737 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1739 PERL_ARGS_ASSERT_MAGIC_SETNKEYS;
1740 PERL_UNUSED_ARG(mg);
1742 hv_ksplit(MUTABLE_HV(LvTARG(sv)), SvIV(sv));
1748 =for apidoc magic_methcall
1750 Invoke a magic method (like FETCH).
1752 * sv and mg are the tied thingy and the tie magic;
1753 * meth is the name of the method to call;
1754 * argc is the number of args (in addition to $self) to pass to the method;
1755 the args themselves are any values following the argc argument.
1757 G_DISCARD: invoke method with G_DISCARD flag and don't return a value
1758 G_UNDEF_FILL: fill the stack with argc pointers to PL_sv_undef.
1760 Returns the SV (if any) returned by the method, or NULL on failure.
1767 Perl_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, U32 flags,
1774 PERL_ARGS_ASSERT_MAGIC_METHCALL;
1778 if (flags & G_WRITING_TO_STDERR) {
1782 SAVESPTR(PL_stderrgv);
1786 PUSHSTACKi(PERLSI_MAGIC);
1790 PUSHs(SvTIED_obj(sv, mg));
1791 if (flags & G_UNDEF_FILL) {
1793 PUSHs(&PL_sv_undef);
1795 } else if (argc > 0) {
1797 va_start(args, argc);
1800 SV *const sv = va_arg(args, SV *);
1807 if (flags & G_DISCARD) {
1808 call_method(meth, G_SCALAR|G_DISCARD);
1811 if (call_method(meth, G_SCALAR))
1812 ret = *PL_stack_sp--;
1815 if (flags & G_WRITING_TO_STDERR)
1822 /* wrapper for magic_methcall that creates the first arg */
1825 S_magic_methcall1(pTHX_ SV *sv, const MAGIC *mg, const char *meth, U32 flags,
1831 PERL_ARGS_ASSERT_MAGIC_METHCALL1;
1834 if (mg->mg_len >= 0) {
1835 arg1 = newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
1837 else if (mg->mg_len == HEf_SVKEY)
1838 arg1 = MUTABLE_SV(mg->mg_ptr);
1840 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1841 arg1 = newSViv((IV)(mg->mg_len));
1845 return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n - 1, val);
1847 return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n, arg1, val);
1851 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
1856 PERL_ARGS_ASSERT_MAGIC_METHPACK;
1858 ret = magic_methcall1(sv, mg, meth, 0, 1, NULL);
1865 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1867 PERL_ARGS_ASSERT_MAGIC_GETPACK;
1869 if (mg->mg_type == PERL_MAGIC_tiedelem)
1870 mg->mg_flags |= MGf_GSKIP;
1871 magic_methpack(sv,mg,"FETCH");
1876 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1882 PERL_ARGS_ASSERT_MAGIC_SETPACK;
1884 /* in the code C<$tied{foo} = $val>, the "thing" that gets passed to
1885 * STORE() is not $val, but rather a PVLV (the sv in this call), whose
1886 * public flags indicate its value based on copying from $val. Doing
1887 * mg_set() on the PVLV temporarily does SvMAGICAL_off(), then calls us.
1888 * So STORE()'s $_[2] arg is a temporarily disarmed PVLV. This goes
1889 * wrong if $val happened to be tainted, as sv hasn't got magic
1890 * enabled, even though taint magic is in the chain. In which case,
1891 * fake up a temporary tainted value (this is easier than temporarily
1892 * re-enabling magic on sv). */
1894 if (PL_tainting && (tmg = mg_find(sv, PERL_MAGIC_taint))
1895 && (tmg->mg_len & 1))
1897 val = sv_mortalcopy(sv);
1903 magic_methcall1(sv, mg, "STORE", G_DISCARD, 2, val);
1908 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1910 PERL_ARGS_ASSERT_MAGIC_CLEARPACK;
1912 return magic_methpack(sv,mg,"DELETE");
1917 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1923 PERL_ARGS_ASSERT_MAGIC_SIZEPACK;
1925 retsv = magic_methcall1(sv, mg, "FETCHSIZE", 0, 1, NULL);
1927 retval = SvIV(retsv)-1;
1929 Perl_croak(aTHX_ "FETCHSIZE returned a negative value");
1931 return (U32) retval;
1935 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1939 PERL_ARGS_ASSERT_MAGIC_WIPEPACK;
1941 Perl_magic_methcall(aTHX_ sv, mg, "CLEAR", G_DISCARD, 0);
1946 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1951 PERL_ARGS_ASSERT_MAGIC_NEXTPACK;
1953 ret = SvOK(key) ? Perl_magic_methcall(aTHX_ sv, mg, "NEXTKEY", 0, 1, key)
1954 : Perl_magic_methcall(aTHX_ sv, mg, "FIRSTKEY", 0, 0);
1961 Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg)
1963 PERL_ARGS_ASSERT_MAGIC_EXISTSPACK;
1965 return magic_methpack(sv,mg,"EXISTS");
1969 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1973 SV * const tied = SvTIED_obj(MUTABLE_SV(hv), mg);
1974 HV * const pkg = SvSTASH((const SV *)SvRV(tied));
1976 PERL_ARGS_ASSERT_MAGIC_SCALARPACK;
1978 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1980 if (HvEITER_get(hv))
1981 /* we are in an iteration so the hash cannot be empty */
1983 /* no xhv_eiter so now use FIRSTKEY */
1984 key = sv_newmortal();
1985 magic_nextpack(MUTABLE_SV(hv), mg, key);
1986 HvEITER_set(hv, NULL); /* need to reset iterator */
1987 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1990 /* there is a SCALAR method that we can call */
1991 retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(hv), mg, "SCALAR", 0, 0);
1993 retval = &PL_sv_undef;
1998 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
2001 GV * const gv = PL_DBline;
2002 const I32 i = SvTRUE(sv);
2003 SV ** const svp = av_fetch(GvAV(gv),
2004 atoi(MgPV_nolen_const(mg)), FALSE);
2006 PERL_ARGS_ASSERT_MAGIC_SETDBLINE;
2008 if (svp && SvIOKp(*svp)) {
2009 OP * const o = INT2PTR(OP*,SvIVX(*svp));
2011 /* set or clear breakpoint in the relevant control op */
2013 o->op_flags |= OPf_SPECIAL;
2015 o->op_flags &= ~OPf_SPECIAL;
2022 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
2025 AV * const obj = MUTABLE_AV(mg->mg_obj);
2027 PERL_ARGS_ASSERT_MAGIC_GETARYLEN;
2030 sv_setiv(sv, AvFILL(obj) + CopARYBASE_get(PL_curcop));
2038 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
2041 AV * const obj = MUTABLE_AV(mg->mg_obj);
2043 PERL_ARGS_ASSERT_MAGIC_SETARYLEN;
2046 av_fill(obj, SvIV(sv) - CopARYBASE_get(PL_curcop));
2048 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
2049 "Attempt to set length of freed array");
2055 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
2059 PERL_ARGS_ASSERT_MAGIC_FREEARYLEN_P;
2060 PERL_UNUSED_ARG(sv);
2062 /* during global destruction, mg_obj may already have been freed */
2063 if (PL_in_clean_all)
2066 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
2069 /* arylen scalar holds a pointer back to the array, but doesn't own a
2070 reference. Hence the we (the array) are about to go away with it
2071 still pointing at us. Clear its pointer, else it would be pointing
2072 at free memory. See the comment in sv_magic about reference loops,
2073 and why it can't own a reference to us. */
2080 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
2083 SV* const lsv = LvTARG(sv);
2085 PERL_ARGS_ASSERT_MAGIC_GETPOS;
2086 PERL_UNUSED_ARG(mg);
2088 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
2089 MAGIC * const found = mg_find(lsv, PERL_MAGIC_regex_global);
2090 if (found && found->mg_len >= 0) {
2091 I32 i = found->mg_len;
2093 sv_pos_b2u(lsv, &i);
2094 sv_setiv(sv, i + CopARYBASE_get(PL_curcop));
2103 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
2106 SV* const lsv = LvTARG(sv);
2112 PERL_ARGS_ASSERT_MAGIC_SETPOS;
2113 PERL_UNUSED_ARG(mg);
2115 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
2116 found = mg_find(lsv, PERL_MAGIC_regex_global);
2122 #ifdef PERL_OLD_COPY_ON_WRITE
2124 sv_force_normal_flags(lsv, 0);
2126 found = sv_magicext(lsv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
2129 else if (!SvOK(sv)) {
2133 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
2135 pos = SvIV(sv) - CopARYBASE_get(PL_curcop);
2138 ulen = sv_len_utf8(lsv);
2148 else if (pos > (SSize_t)len)
2153 sv_pos_u2b(lsv, &p, 0);
2157 found->mg_len = pos;
2158 found->mg_flags &= ~MGf_MINMATCH;
2164 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
2167 SV * const lsv = LvTARG(sv);
2168 const char * const tmps = SvPV_const(lsv,len);
2169 STRLEN offs = LvTARGOFF(sv);
2170 STRLEN rem = LvTARGLEN(sv);
2172 PERL_ARGS_ASSERT_MAGIC_GETSUBSTR;
2173 PERL_UNUSED_ARG(mg);
2176 offs = sv_pos_u2b_flags(lsv, offs, &rem, SV_CONST_RETURN);
2179 if (rem > len - offs)
2181 sv_setpvn(sv, tmps + offs, rem);
2188 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
2192 const char * const tmps = SvPV_const(sv, len);
2193 SV * const lsv = LvTARG(sv);
2194 STRLEN lvoff = LvTARGOFF(sv);
2195 STRLEN lvlen = LvTARGLEN(sv);
2197 PERL_ARGS_ASSERT_MAGIC_SETSUBSTR;
2198 PERL_UNUSED_ARG(mg);
2201 sv_utf8_upgrade(lsv);
2202 lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
2203 sv_insert(lsv, lvoff, lvlen, tmps, len);
2204 LvTARGLEN(sv) = sv_len_utf8(sv);
2207 else if (lsv && SvUTF8(lsv)) {
2209 lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
2210 LvTARGLEN(sv) = len;
2211 utf8 = (char*)bytes_to_utf8((U8*)tmps, &len);
2212 sv_insert(lsv, lvoff, lvlen, utf8, len);
2216 sv_insert(lsv, lvoff, lvlen, tmps, len);
2217 LvTARGLEN(sv) = len;
2224 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
2228 PERL_ARGS_ASSERT_MAGIC_GETTAINT;
2229 PERL_UNUSED_ARG(sv);
2231 TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
2236 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
2240 PERL_ARGS_ASSERT_MAGIC_SETTAINT;
2241 PERL_UNUSED_ARG(sv);
2243 /* update taint status */
2252 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
2254 SV * const lsv = LvTARG(sv);
2256 PERL_ARGS_ASSERT_MAGIC_GETVEC;
2257 PERL_UNUSED_ARG(mg);
2260 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
2268 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
2270 PERL_ARGS_ASSERT_MAGIC_SETVEC;
2271 PERL_UNUSED_ARG(mg);
2272 do_vecset(sv); /* XXX slurp this routine */
2277 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
2282 PERL_ARGS_ASSERT_MAGIC_GETDEFELEM;
2284 if (LvTARGLEN(sv)) {
2286 SV * const ahv = LvTARG(sv);
2287 HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, FALSE, 0);
2292 AV *const av = MUTABLE_AV(LvTARG(sv));
2293 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
2294 targ = AvARRAY(av)[LvTARGOFF(sv)];
2296 if (targ && (targ != &PL_sv_undef)) {
2297 /* somebody else defined it for us */
2298 SvREFCNT_dec(LvTARG(sv));
2299 LvTARG(sv) = SvREFCNT_inc_simple_NN(targ);
2301 SvREFCNT_dec(mg->mg_obj);
2303 mg->mg_flags &= ~MGf_REFCOUNTED;
2308 sv_setsv(sv, targ ? targ : &PL_sv_undef);
2313 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
2315 PERL_ARGS_ASSERT_MAGIC_SETDEFELEM;
2316 PERL_UNUSED_ARG(mg);
2320 sv_setsv(LvTARG(sv), sv);
2321 SvSETMAGIC(LvTARG(sv));
2327 Perl_vivify_defelem(pTHX_ SV *sv)
2333 PERL_ARGS_ASSERT_VIVIFY_DEFELEM;
2335 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2338 SV * const ahv = LvTARG(sv);
2339 HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, TRUE, 0);
2342 if (!value || value == &PL_sv_undef)
2343 Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(mg->mg_obj));
2346 AV *const av = MUTABLE_AV(LvTARG(sv));
2347 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
2348 LvTARG(sv) = NULL; /* array can't be extended */
2350 SV* const * const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
2351 if (!svp || (value = *svp) == &PL_sv_undef)
2352 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
2355 SvREFCNT_inc_simple_void(value);
2356 SvREFCNT_dec(LvTARG(sv));
2359 SvREFCNT_dec(mg->mg_obj);
2361 mg->mg_flags &= ~MGf_REFCOUNTED;
2365 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2367 PERL_ARGS_ASSERT_MAGIC_KILLBACKREFS;
2368 Perl_sv_kill_backrefs(aTHX_ sv, MUTABLE_AV(mg->mg_obj));
2373 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2375 PERL_ARGS_ASSERT_MAGIC_SETMGLOB;
2376 PERL_UNUSED_CONTEXT;
2378 if (!isGV_with_GP(sv))
2384 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2386 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2388 PERL_ARGS_ASSERT_MAGIC_SETUVAR;
2390 if (uf && uf->uf_set)
2391 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2396 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2398 const char type = mg->mg_type;
2400 PERL_ARGS_ASSERT_MAGIC_SETREGEXP;
2402 if (type == PERL_MAGIC_qr) {
2403 } else if (type == PERL_MAGIC_bm) {
2407 assert(type == PERL_MAGIC_fm);
2410 return sv_unmagic(sv, type);
2413 #ifdef USE_LOCALE_COLLATE
2415 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2417 PERL_ARGS_ASSERT_MAGIC_SETCOLLXFRM;
2420 * RenE<eacute> Descartes said "I think not."
2421 * and vanished with a faint plop.
2423 PERL_UNUSED_CONTEXT;
2424 PERL_UNUSED_ARG(sv);
2426 Safefree(mg->mg_ptr);
2432 #endif /* USE_LOCALE_COLLATE */
2434 /* Just clear the UTF-8 cache data. */
2436 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2438 PERL_ARGS_ASSERT_MAGIC_SETUTF8;
2439 PERL_UNUSED_CONTEXT;
2440 PERL_UNUSED_ARG(sv);
2441 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2443 mg->mg_len = -1; /* The mg_len holds the len cache. */
2448 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2451 register const char *s;
2453 register const REGEXP * rx;
2454 const char * const remaining = mg->mg_ptr + 1;
2459 PERL_ARGS_ASSERT_MAGIC_SET;
2461 switch (*mg->mg_ptr) {
2462 case '\015': /* $^MATCH */
2463 if (strEQ(remaining, "ATCH"))
2465 case '`': /* ${^PREMATCH} caught below */
2467 paren = RX_BUFF_IDX_PREMATCH;
2469 case '\'': /* ${^POSTMATCH} caught below */
2471 paren = RX_BUFF_IDX_POSTMATCH;
2475 paren = RX_BUFF_IDX_FULLMATCH;
2477 case '1': case '2': case '3': case '4':
2478 case '5': case '6': case '7': case '8': case '9':
2479 paren = atoi(mg->mg_ptr);
2481 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
2482 CALLREG_NUMBUF_STORE((REGEXP * const)rx,paren,sv);
2484 /* Croak with a READONLY error when a numbered match var is
2485 * set without a previous pattern match. Unless it's C<local $1>
2487 if (!PL_localizing) {
2488 Perl_croak_no_modify(aTHX);
2492 case '\001': /* ^A */
2493 sv_setsv(PL_bodytarget, sv);
2494 /* mg_set() has temporarily made sv non-magical */
2496 if ((tmg = mg_find(sv,PERL_MAGIC_taint)) && tmg->mg_len & 1)
2497 SvTAINTED_on(PL_bodytarget);
2499 SvTAINTED_off(PL_bodytarget);
2502 case '\003': /* ^C */
2503 PL_minus_c = cBOOL(SvIV(sv));
2506 case '\004': /* ^D */
2508 s = SvPV_nolen_const(sv);
2509 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2510 if (DEBUG_x_TEST || DEBUG_B_TEST)
2511 dump_all_perl(!DEBUG_B_TEST);
2513 PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG;
2516 case '\005': /* ^E */
2517 if (*(mg->mg_ptr+1) == '\0') {
2519 set_vaxc_errno(SvIV(sv));
2522 SetLastError( SvIV(sv) );
2525 os2_setsyserrno(SvIV(sv));
2527 /* will anyone ever use this? */
2528 SETERRNO(SvIV(sv), 4);
2533 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2534 SvREFCNT_dec(PL_encoding);
2535 if (SvOK(sv) || SvGMAGICAL(sv)) {
2536 PL_encoding = newSVsv(sv);
2543 case '\006': /* ^F */
2544 PL_maxsysfd = SvIV(sv);
2546 case '\010': /* ^H */
2547 PL_hints = SvIV(sv);
2549 case '\011': /* ^I */ /* NOT \t in EBCDIC */
2550 Safefree(PL_inplace);
2551 PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
2553 case '\017': /* ^O */
2554 if (*(mg->mg_ptr+1) == '\0') {
2555 Safefree(PL_osname);
2558 TAINT_PROPER("assigning to $^O");
2559 PL_osname = savesvpv(sv);
2562 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2564 const char *const start = SvPV(sv, len);
2565 const char *out = (const char*)memchr(start, '\0', len);
2569 PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2570 PL_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2572 /* Opening for input is more common than opening for output, so
2573 ensure that hints for input are sooner on linked list. */
2574 tmp = out ? newSVpvn_flags(out + 1, start + len - out - 1,
2576 : newSVpvs_flags("", SvUTF8(sv));
2577 (void)hv_stores(GvHV(PL_hintgv), "open>", tmp);
2580 tmp = newSVpvn_flags(start, out ? (STRLEN)(out - start) : len,
2582 (void)hv_stores(GvHV(PL_hintgv), "open<", tmp);
2586 case '\020': /* ^P */
2587 if (*remaining == '\0') { /* ^P */
2588 PL_perldb = SvIV(sv);
2589 if (PL_perldb && !PL_DBsingle)
2592 } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
2594 } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
2598 case '\024': /* ^T */
2600 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2602 PL_basetime = (Time_t)SvIV(sv);
2605 case '\025': /* ^UTF8CACHE */
2606 if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
2607 PL_utf8cache = (signed char) sv_2iv(sv);
2610 case '\027': /* ^W & $^WARNING_BITS */
2611 if (*(mg->mg_ptr+1) == '\0') {
2612 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2614 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2615 | (i ? G_WARN_ON : G_WARN_OFF) ;
2618 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2619 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2620 if (!SvPOK(sv) && PL_localizing) {
2621 sv_setpvn(sv, WARN_NONEstring, WARNsize);
2622 PL_compiling.cop_warnings = pWARN_NONE;
2627 int accumulate = 0 ;
2628 int any_fatals = 0 ;
2629 const char * const ptr = SvPV_const(sv, len) ;
2630 for (i = 0 ; i < len ; ++i) {
2631 accumulate |= ptr[i] ;
2632 any_fatals |= (ptr[i] & 0xAA) ;
2635 if (!specialWARN(PL_compiling.cop_warnings))
2636 PerlMemShared_free(PL_compiling.cop_warnings);
2637 PL_compiling.cop_warnings = pWARN_NONE;
2639 /* Yuck. I can't see how to abstract this: */
2640 else if (isWARN_on(((STRLEN *)SvPV_nolen_const(sv)) - 1,
2641 WARN_ALL) && !any_fatals) {
2642 if (!specialWARN(PL_compiling.cop_warnings))
2643 PerlMemShared_free(PL_compiling.cop_warnings);
2644 PL_compiling.cop_warnings = pWARN_ALL;
2645 PL_dowarn |= G_WARN_ONCE ;
2649 const char *const p = SvPV_const(sv, len);
2651 PL_compiling.cop_warnings
2652 = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
2655 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2656 PL_dowarn |= G_WARN_ONCE ;
2664 if (PL_localizing) {
2665 if (PL_localizing == 1)
2666 SAVESPTR(PL_last_in_gv);
2668 else if (SvOK(sv) && GvIO(PL_last_in_gv))
2669 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2672 if (isGV_with_GP(PL_defoutgv)) {
2673 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2674 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2675 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2679 if (isGV_with_GP(PL_defoutgv)) {
2680 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2681 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2682 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2686 if (isGV_with_GP(PL_defoutgv))
2687 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
2690 if (isGV_with_GP(PL_defoutgv)) {
2691 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
2692 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2693 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2697 if (isGV_with_GP(PL_defoutgv))
2698 IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
2702 IO * const io = GvIO(PL_defoutgv);
2705 if ((SvIV(sv)) == 0)
2706 IoFLAGS(io) &= ~IOf_FLUSH;
2708 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2709 PerlIO *ofp = IoOFP(io);
2711 (void)PerlIO_flush(ofp);
2712 IoFLAGS(io) |= IOf_FLUSH;
2718 SvREFCNT_dec(PL_rs);
2719 PL_rs = newSVsv(sv);
2722 SvREFCNT_dec(PL_ors_sv);
2723 if (SvOK(sv) || SvGMAGICAL(sv)) {
2724 PL_ors_sv = newSVsv(sv);
2731 CopARYBASE_set(&PL_compiling, SvIV(sv));
2734 #ifdef COMPLEX_STATUS
2735 if (PL_localizing == 2) {
2736 SvUPGRADE(sv, SVt_PVLV);
2737 PL_statusvalue = LvTARGOFF(sv);
2738 PL_statusvalue_vms = LvTARGLEN(sv);
2742 #ifdef VMSISH_STATUS
2744 STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2747 STATUS_UNIX_EXIT_SET(SvIV(sv));
2752 # define PERL_VMS_BANG vaxc$errno
2754 # define PERL_VMS_BANG 0
2756 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2757 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2762 if (PL_delaymagic) {
2763 PL_delaymagic |= DM_RUID;
2764 break; /* don't do magic till later */
2767 (void)setruid((Uid_t)PL_uid);
2770 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2772 #ifdef HAS_SETRESUID
2773 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2775 if (PL_uid == PL_euid) { /* special case $< = $> */
2777 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2778 if (PL_uid != 0 && PerlProc_getuid() == 0)
2779 (void)PerlProc_setuid(0);
2781 (void)PerlProc_setuid(PL_uid);
2783 PL_uid = PerlProc_getuid();
2784 Perl_croak(aTHX_ "setruid() not implemented");
2789 PL_uid = PerlProc_getuid();
2793 if (PL_delaymagic) {
2794 PL_delaymagic |= DM_EUID;
2795 break; /* don't do magic till later */
2798 (void)seteuid((Uid_t)PL_euid);
2801 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2803 #ifdef HAS_SETRESUID
2804 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2806 if (PL_euid == PL_uid) /* special case $> = $< */
2807 PerlProc_setuid(PL_euid);
2809 PL_euid = PerlProc_geteuid();
2810 Perl_croak(aTHX_ "seteuid() not implemented");
2815 PL_euid = PerlProc_geteuid();
2819 if (PL_delaymagic) {
2820 PL_delaymagic |= DM_RGID;
2821 break; /* don't do magic till later */
2824 (void)setrgid((Gid_t)PL_gid);
2827 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2829 #ifdef HAS_SETRESGID
2830 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2832 if (PL_gid == PL_egid) /* special case $( = $) */
2833 (void)PerlProc_setgid(PL_gid);
2835 PL_gid = PerlProc_getgid();
2836 Perl_croak(aTHX_ "setrgid() not implemented");
2841 PL_gid = PerlProc_getgid();
2844 #ifdef HAS_SETGROUPS
2846 const char *p = SvPV_const(sv, len);
2847 Groups_t *gary = NULL;
2848 #ifdef _SC_NGROUPS_MAX
2849 int maxgrp = sysconf(_SC_NGROUPS_MAX);
2854 int maxgrp = NGROUPS;
2860 for (i = 0; i < maxgrp; ++i) {
2861 while (*p && !isSPACE(*p))
2868 Newx(gary, i + 1, Groups_t);
2870 Renew(gary, i + 1, Groups_t);
2874 (void)setgroups(i, gary);
2877 #else /* HAS_SETGROUPS */
2879 #endif /* HAS_SETGROUPS */
2880 if (PL_delaymagic) {
2881 PL_delaymagic |= DM_EGID;
2882 break; /* don't do magic till later */
2885 (void)setegid((Gid_t)PL_egid);
2888 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2890 #ifdef HAS_SETRESGID
2891 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2893 if (PL_egid == PL_gid) /* special case $) = $( */
2894 (void)PerlProc_setgid(PL_egid);
2896 PL_egid = PerlProc_getegid();
2897 Perl_croak(aTHX_ "setegid() not implemented");
2902 PL_egid = PerlProc_getegid();
2905 PL_chopset = SvPV_force(sv,len);
2908 LOCK_DOLLARZERO_MUTEX;
2909 #ifdef HAS_SETPROCTITLE
2910 /* The BSDs don't show the argv[] in ps(1) output, they
2911 * show a string from the process struct and provide
2912 * the setproctitle() routine to manipulate that. */
2913 if (PL_origalen != 1) {
2914 s = SvPV_const(sv, len);
2915 # if __FreeBSD_version > 410001
2916 /* The leading "-" removes the "perl: " prefix,
2917 * but not the "(perl) suffix from the ps(1)
2918 * output, because that's what ps(1) shows if the
2919 * argv[] is modified. */
2920 setproctitle("-%s", s);
2921 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2922 /* This doesn't really work if you assume that
2923 * $0 = 'foobar'; will wipe out 'perl' from the $0
2924 * because in ps(1) output the result will be like
2925 * sprintf("perl: %s (perl)", s)
2926 * I guess this is a security feature:
2927 * one (a user process) cannot get rid of the original name.
2929 setproctitle("%s", s);
2932 #elif defined(__hpux) && defined(PSTAT_SETCMD)
2933 if (PL_origalen != 1) {
2935 s = SvPV_const(sv, len);
2936 un.pst_command = (char *)s;
2937 pstat(PSTAT_SETCMD, un, len, 0, 0);
2940 if (PL_origalen > 1) {
2941 /* PL_origalen is set in perl_parse(). */
2942 s = SvPV_force(sv,len);
2943 if (len >= (STRLEN)PL_origalen-1) {
2944 /* Longer than original, will be truncated. We assume that
2945 * PL_origalen bytes are available. */
2946 Copy(s, PL_origargv[0], PL_origalen-1, char);
2949 /* Shorter than original, will be padded. */
2951 /* Special case for Mac OS X: see [perl #38868] */
2954 /* Is the space counterintuitive? Yes.
2955 * (You were expecting \0?)
2956 * Does it work? Seems to. (In Linux 2.4.20 at least.)
2958 const int pad = ' ';
2960 Copy(s, PL_origargv[0], len, char);
2961 PL_origargv[0][len] = 0;
2962 memset(PL_origargv[0] + len + 1,
2963 pad, PL_origalen - len - 1);
2965 PL_origargv[0][PL_origalen-1] = 0;
2966 for (i = 1; i < PL_origargc; i++)
2968 #ifdef HAS_PRCTL_SET_NAME
2969 /* Set the legacy process name in addition to the POSIX name on Linux */
2970 if (prctl(PR_SET_NAME, (unsigned long)s, 0, 0, 0) != 0) {
2971 /* diag_listed_as: SKIPME */
2972 Perl_croak(aTHX_ "Can't set $0 with prctl(): %s", Strerror(errno));
2977 UNLOCK_DOLLARZERO_MUTEX;
2984 Perl_whichsig(pTHX_ const char *sig)
2986 register char* const* sigv;
2988 PERL_ARGS_ASSERT_WHICHSIG;
2989 PERL_UNUSED_CONTEXT;
2991 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
2992 if (strEQ(sig,*sigv))
2993 return PL_sig_num[sigv - (char* const*)PL_sig_name];
2995 if (strEQ(sig,"CHLD"))
2999 if (strEQ(sig,"CLD"))
3006 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3007 Perl_sighandler(int sig, siginfo_t *sip, void *uap)
3009 Perl_sighandler(int sig)
3012 #ifdef PERL_GET_SIG_CONTEXT
3013 dTHXa(PERL_GET_SIG_CONTEXT);
3020 SV * const tSv = PL_Sv;
3024 XPV * const tXpv = PL_Xpv;
3025 I32 old_ss_ix = PL_savestack_ix;
3028 if (!PL_psig_ptr[sig]) {
3029 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
3034 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) {
3035 /* Max number of items pushed there is 3*n or 4. We cannot fix
3036 infinity, so we fix 4 (in fact 5): */
3037 if (PL_savestack_ix + 15 <= PL_savestack_max) {
3039 PL_savestack_ix += 5; /* Protect save in progress. */
3040 SAVEDESTRUCTOR_X(S_unwind_handler_stack, NULL);
3043 /* sv_2cv is too complicated, try a simpler variant first: */
3044 if (!SvROK(PL_psig_ptr[sig]) || !(cv = MUTABLE_CV(SvRV(PL_psig_ptr[sig])))
3045 || SvTYPE(cv) != SVt_PVCV) {
3047 cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
3050 if (!cv || !CvROOT(cv)) {
3051 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
3052 PL_sig_name[sig], (gv ? GvENAME(gv)
3059 sv = PL_psig_name[sig]
3060 ? SvREFCNT_inc_NN(PL_psig_name[sig])
3061 : newSVpv(PL_sig_name[sig],0);
3065 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) {
3066 /* make sure our assumption about the size of the SAVEs are correct:
3067 * 3 for SAVEDESTRUCTOR_X, 2 for SAVEFREESV */
3068 assert(old_ss_ix + 2 + ((flags & 1) ? 3+5 : 0) == PL_savestack_ix);
3071 PUSHSTACKi(PERLSI_SIGNAL);
3074 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3076 struct sigaction oact;
3078 if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
3081 SV *rv = newRV_noinc(MUTABLE_SV(sih));
3082 /* The siginfo fields signo, code, errno, pid, uid,
3083 * addr, status, and band are defined by POSIX/SUSv3. */
3084 (void)hv_stores(sih, "signo", newSViv(sip->si_signo));
3085 (void)hv_stores(sih, "code", newSViv(sip->si_code));
3086 #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. */
3087 hv_stores(sih, "errno", newSViv(sip->si_errno));
3088 hv_stores(sih, "status", newSViv(sip->si_status));
3089 hv_stores(sih, "uid", newSViv(sip->si_uid));
3090 hv_stores(sih, "pid", newSViv(sip->si_pid));
3091 hv_stores(sih, "addr", newSVuv(PTR2UV(sip->si_addr)));
3092 hv_stores(sih, "band", newSViv(sip->si_band));
3096 mPUSHp((char *)sip, sizeof(*sip));
3104 call_sv(MUTABLE_SV(cv), G_DISCARD|G_EVAL);
3107 if (SvTRUE(ERRSV)) {
3109 /* Handler "died", for example to get out of a restart-able read().
3110 * Before we re-do that on its behalf re-enable the signal which was
3111 * blocked by the system when we entered.
3113 #ifdef HAS_SIGPROCMASK
3114 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3120 sigaddset(&set,sig);
3121 sigprocmask(SIG_UNBLOCK, &set, NULL);
3124 /* Not clear if this will work */
3125 (void)rsignal(sig, SIG_IGN);
3126 (void)rsignal(sig, PL_csighandlerp);
3128 #endif /* !PERL_MICRO */
3132 /* pop any of SAVEFREESV, SAVEDESTRUCTOR_X and "save in progress" */
3133 PL_savestack_ix = old_ss_ix;
3136 PL_op = myop; /* Apparently not needed... */
3138 PL_Sv = tSv; /* Restore global temporaries. */
3145 S_restore_magic(pTHX_ const void *p)
3148 MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
3149 SV* const sv = mgs->mgs_sv;
3154 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
3156 #ifdef PERL_OLD_COPY_ON_WRITE
3157 /* While magic was saved (and off) sv_setsv may well have seen
3158 this SV as a prime candidate for COW. */
3160 sv_force_normal_flags(sv, 0);
3163 if (mgs->mgs_readonly)
3165 if (mgs->mgs_magical)
3166 SvFLAGS(sv) |= mgs->mgs_magical;
3169 if (SvGMAGICAL(sv)) {
3170 /* downgrade public flags to private,
3171 and discard any other private flags */
3173 const U32 pubflags = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
3175 SvFLAGS(sv) &= ~( pubflags | (SVp_IOK|SVp_NOK|SVp_POK) );
3176 SvFLAGS(sv) |= ( pubflags << PRIVSHIFT );
3181 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
3183 /* If we're still on top of the stack, pop us off. (That condition
3184 * will be satisfied if restore_magic was called explicitly, but *not*
3185 * if it's being called via leave_scope.)
3186 * The reason for doing this is that otherwise, things like sv_2cv()
3187 * may leave alloc gunk on the savestack, and some code
3188 * (e.g. sighandler) doesn't expect that...
3190 if (PL_savestack_ix == mgs->mgs_ss_ix)
3192 UV popval = SSPOPUV;
3193 assert(popval == SAVEt_DESTRUCTOR_X);
3194 PL_savestack_ix -= 2;
3196 assert((popval & SAVE_MASK) == SAVEt_ALLOC);
3197 PL_savestack_ix -= popval >> SAVE_TIGHT_SHIFT;
3199 if (SvREFCNT(sv) == 1) {
3200 /* We hold the last reference to this SV, which implies that the
3201 SV was deleted as a side effect of the routines we called.
3202 So artificially keep it alive a bit longer.
3203 We avoid turning on the TEMP flag, which can cause the SV's
3204 buffer to get stolen (and maybe other stuff). */
3205 int was_temp = SvTEMP(sv);
3213 SvREFCNT_dec(sv); /* undo the inc in S_save_magic() */
3216 /* clean up the mess created by Perl_sighandler().
3217 * Note that this is only called during an exit in a signal handler;
3218 * a die is trapped by the call_sv() and the SAVEDESTRUCTOR_X manually
3222 S_unwind_handler_stack(pTHX_ const void *p)
3227 PL_savestack_ix -= 5; /* Unprotect save in progress. */
3231 =for apidoc magic_sethint
3233 Triggered by a store to %^H, records the key/value pair to
3234 C<PL_compiling.cop_hints_hash>. It is assumed that hints aren't storing
3235 anything that would need a deep copy. Maybe we should warn if we find a
3241 Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
3244 SV *key = (mg->mg_len == HEf_SVKEY) ? MUTABLE_SV(mg->mg_ptr)
3245 : newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
3247 PERL_ARGS_ASSERT_MAGIC_SETHINT;
3249 /* mg->mg_obj isn't being used. If needed, it would be possible to store
3250 an alternative leaf in there, with PL_compiling.cop_hints being used if
3251 it's NULL. If needed for threads, the alternative could lock a mutex,
3252 or take other more complex action. */
3254 /* Something changed in %^H, so it will need to be restored on scope exit.
3255 Doing this here saves a lot of doing it manually in perl code (and
3256 forgetting to do it, and consequent subtle errors. */
3257 PL_hints |= HINT_LOCALIZE_HH;
3258 CopHINTHASH_set(&PL_compiling,
3259 cophh_store_sv(CopHINTHASH_get(&PL_compiling), key, 0, sv, 0));
3264 =for apidoc magic_clearhint
3266 Triggered by a delete from %^H, records the key to
3267 C<PL_compiling.cop_hints_hash>.
3272 Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
3276 PERL_ARGS_ASSERT_MAGIC_CLEARHINT;
3277 PERL_UNUSED_ARG(sv);
3279 assert(mg->mg_len == HEf_SVKEY);
3281 PERL_UNUSED_ARG(sv);
3283 PL_hints |= HINT_LOCALIZE_HH;
3284 CopHINTHASH_set(&PL_compiling,
3285 cophh_delete_sv(CopHINTHASH_get(&PL_compiling),
3286 MUTABLE_SV(mg->mg_ptr), 0, 0));
3291 =for apidoc magic_clearhints
3293 Triggered by clearing %^H, resets C<PL_compiling.cop_hints_hash>.
3298 Perl_magic_clearhints(pTHX_ SV *sv, MAGIC *mg)
3300 PERL_ARGS_ASSERT_MAGIC_CLEARHINTS;
3301 PERL_UNUSED_ARG(sv);
3302 PERL_UNUSED_ARG(mg);
3303 cophh_free(CopHINTHASH_get(&PL_compiling));
3304 CopHINTHASH_set(&PL_compiling, cophh_new_empty());
3310 * c-indentation-style: bsd
3312 * indent-tabs-mode: t
3315 * ex: set ts=8 sts=4 sw=4 noet: