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.
89 /* MGS is typedef'ed to struct magic_state in perl.h */
92 S_save_magic(pTHX_ I32 mgs_ix, SV *sv)
98 PERL_ARGS_ASSERT_SAVE_MAGIC;
100 /* we shouldn't really be called here with RC==0, but it can sometimes
101 * happen via mg_clear() (which also shouldn't be called when RC==0,
102 * but it can happen). Handle this case gracefully(ish) by not RC++
103 * and thus avoiding the resultant double free */
104 if (SvREFCNT(sv) > 0) {
105 /* guard against sv getting freed midway through the mg clearing,
106 * by holding a private reference for the duration. */
107 SvREFCNT_inc_simple_void_NN(sv);
111 assert(SvMAGICAL(sv));
112 /* Turning READONLY off for a copy-on-write scalar (including shared
113 hash keys) is a bad idea. */
115 sv_force_normal_flags(sv, 0);
117 SAVEDESTRUCTOR_X(S_restore_magic, INT2PTR(void*, (IV)mgs_ix));
119 mgs = SSPTR(mgs_ix, MGS*);
121 mgs->mgs_magical = SvMAGICAL(sv);
122 mgs->mgs_readonly = SvREADONLY(sv) != 0;
123 mgs->mgs_ss_ix = PL_savestack_ix; /* points after the saved destructor */
124 mgs->mgs_bumped = bumped;
128 if (!(SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK))) {
129 /* No public flags are set, so promote any private flags to public. */
130 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
135 =for apidoc mg_magical
137 Turns on the magical status of an SV. See C<sv_magic>.
143 Perl_mg_magical(pTHX_ SV *sv)
146 PERL_ARGS_ASSERT_MG_MAGICAL;
150 if ((mg = SvMAGIC(sv))) {
152 const MGVTBL* const vtbl = mg->mg_virtual;
154 if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
161 } while ((mg = mg->mg_moremagic));
162 if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)))
168 /* is this container magic (%ENV, $1 etc), or value magic (pos, taint etc)? */
171 S_is_container_magic(const MAGIC *mg)
174 switch (mg->mg_type) {
177 case PERL_MAGIC_regex_global:
178 case PERL_MAGIC_nkeys:
179 #ifdef USE_LOCALE_COLLATE
180 case PERL_MAGIC_collxfrm:
183 case PERL_MAGIC_taint:
185 case PERL_MAGIC_vstring:
186 case PERL_MAGIC_utf8:
187 case PERL_MAGIC_substr:
188 case PERL_MAGIC_defelem:
189 case PERL_MAGIC_arylen:
191 case PERL_MAGIC_backref:
192 case PERL_MAGIC_arylen_p:
193 case PERL_MAGIC_rhash:
194 case PERL_MAGIC_symtab:
195 case PERL_MAGIC_tied: /* treat as value, so 'local @tied' isn't tied */
196 case PERL_MAGIC_checkcall:
206 Do magic after a value is retrieved from the SV. See C<sv_magic>.
212 Perl_mg_get(pTHX_ SV *sv)
215 const I32 mgs_ix = SSNEW(sizeof(MGS));
217 MAGIC *newmg, *head, *cur, *mg;
219 PERL_ARGS_ASSERT_MG_GET;
221 save_magic(mgs_ix, sv);
223 /* We must call svt_get(sv, mg) for each valid entry in the linked
224 list of magic. svt_get() may delete the current entry, add new
225 magic to the head of the list, or upgrade the SV. AMS 20010810 */
227 newmg = cur = head = mg = SvMAGIC(sv);
229 const MGVTBL * const vtbl = mg->mg_virtual;
230 MAGIC * const nextmg = mg->mg_moremagic; /* it may delete itself */
232 if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
233 vtbl->svt_get(aTHX_ sv, mg);
235 /* guard against magic having been deleted - eg FETCH calling
238 (SSPTR(mgs_ix, MGS *))->mgs_magical = 0; /* recalculate flags */
242 /* recalculate flags if this entry was deleted. */
243 if (mg->mg_flags & MGf_GSKIP)
244 (SSPTR(mgs_ix, MGS *))->mgs_magical = 0;
250 /* Have we finished with the new entries we saw? Start again
251 where we left off (unless there are more new entries). */
259 /* Were any new entries added? */
260 if (!have_new && (newmg = SvMAGIC(sv)) != head) {
264 (SSPTR(mgs_ix, MGS *))->mgs_magical = 0; /* recalculate flags */
268 restore_magic(INT2PTR(void *, (IV)mgs_ix));
275 Do magic after a value is assigned to the SV. See C<sv_magic>.
281 Perl_mg_set(pTHX_ SV *sv)
284 const I32 mgs_ix = SSNEW(sizeof(MGS));
288 PERL_ARGS_ASSERT_MG_SET;
290 save_magic(mgs_ix, sv);
292 for (mg = SvMAGIC(sv); mg; mg = nextmg) {
293 const MGVTBL* vtbl = mg->mg_virtual;
294 nextmg = mg->mg_moremagic; /* it may delete itself */
295 if (mg->mg_flags & MGf_GSKIP) {
296 mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */
297 (SSPTR(mgs_ix, MGS*))->mgs_magical = 0;
299 if (PL_localizing == 2 && (!S_is_container_magic(mg) || sv == DEFSV))
301 if (vtbl && vtbl->svt_set)
302 vtbl->svt_set(aTHX_ sv, mg);
305 restore_magic(INT2PTR(void*, (IV)mgs_ix));
310 =for apidoc mg_length
312 Report on the SV's length. See C<sv_magic>.
318 Perl_mg_length(pTHX_ SV *sv)
324 PERL_ARGS_ASSERT_MG_LENGTH;
326 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
327 const MGVTBL * const vtbl = mg->mg_virtual;
328 if (vtbl && vtbl->svt_len) {
329 const I32 mgs_ix = SSNEW(sizeof(MGS));
330 save_magic(mgs_ix, sv);
331 /* omit MGf_GSKIP -- not changed here */
332 len = vtbl->svt_len(aTHX_ sv, mg);
333 restore_magic(INT2PTR(void*, (IV)mgs_ix));
339 /* You can't know whether it's UTF-8 until you get the string again...
341 const U8 *s = (U8*)SvPV_const(sv, len);
344 len = utf8_length(s, s + len);
351 Perl_mg_size(pTHX_ SV *sv)
355 PERL_ARGS_ASSERT_MG_SIZE;
357 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
358 const MGVTBL* const vtbl = mg->mg_virtual;
359 if (vtbl && vtbl->svt_len) {
360 const I32 mgs_ix = SSNEW(sizeof(MGS));
362 save_magic(mgs_ix, sv);
363 /* omit MGf_GSKIP -- not changed here */
364 len = vtbl->svt_len(aTHX_ sv, mg);
365 restore_magic(INT2PTR(void*, (IV)mgs_ix));
372 return AvFILLp((const AV *) sv); /* Fallback to non-tied array */
376 Perl_croak(aTHX_ "Size magic not implemented");
385 Clear something magical that the SV represents. See C<sv_magic>.
391 Perl_mg_clear(pTHX_ SV *sv)
393 const I32 mgs_ix = SSNEW(sizeof(MGS));
397 PERL_ARGS_ASSERT_MG_CLEAR;
399 save_magic(mgs_ix, sv);
401 for (mg = SvMAGIC(sv); mg; mg = nextmg) {
402 const MGVTBL* const vtbl = mg->mg_virtual;
403 /* omit GSKIP -- never set here */
405 nextmg = mg->mg_moremagic; /* it may delete itself */
407 if (vtbl && vtbl->svt_clear)
408 vtbl->svt_clear(aTHX_ sv, mg);
411 restore_magic(INT2PTR(void*, (IV)mgs_ix));
416 S_mg_findext_flags(pTHX_ const SV *sv, int type, const MGVTBL *vtbl, U32 flags)
425 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
426 if (mg->mg_type == type && (!flags || mg->mg_virtual == vtbl)) {
438 Finds the magic pointer for type matching the SV. See C<sv_magic>.
444 Perl_mg_find(pTHX_ const SV *sv, int type)
446 return S_mg_findext_flags(aTHX_ sv, type, NULL, 0);
450 =for apidoc mg_findext
452 Finds the magic pointer of C<type> with the given C<vtbl> for the C<SV>. See
459 Perl_mg_findext(pTHX_ const SV *sv, int type, const MGVTBL *vtbl)
461 return S_mg_findext_flags(aTHX_ sv, type, vtbl, 1);
467 Copies the magic from one SV to another. See C<sv_magic>.
473 Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
478 PERL_ARGS_ASSERT_MG_COPY;
480 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
481 const MGVTBL* const vtbl = mg->mg_virtual;
482 if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){
483 count += vtbl->svt_copy(aTHX_ sv, mg, nsv, key, klen);
486 const char type = mg->mg_type;
487 if (isUPPER(type) && type != PERL_MAGIC_uvar) {
489 (type == PERL_MAGIC_tied)
491 : (type == PERL_MAGIC_regdata && mg->mg_obj)
494 toLOWER(type), key, klen);
503 =for apidoc mg_localize
505 Copy some of the magic from an existing SV to new localized version of that
506 SV. Container magic (eg %ENV, $1, tie) gets copied, value magic doesn't (eg
509 If setmagic is false then no set magic will be called on the new (empty) SV.
510 This typically means that assignment will soon follow (e.g. 'local $x = $y'),
511 and that will handle the magic.
517 Perl_mg_localize(pTHX_ SV *sv, SV *nsv, bool setmagic)
522 PERL_ARGS_ASSERT_MG_LOCALIZE;
527 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
528 const MGVTBL* const vtbl = mg->mg_virtual;
529 if (!S_is_container_magic(mg))
532 if ((mg->mg_flags & MGf_LOCAL) && vtbl->svt_local)
533 (void)vtbl->svt_local(aTHX_ nsv, mg);
535 sv_magicext(nsv, mg->mg_obj, mg->mg_type, vtbl,
536 mg->mg_ptr, mg->mg_len);
538 /* container types should remain read-only across localization */
539 SvFLAGS(nsv) |= SvREADONLY(sv);
542 if (SvTYPE(nsv) >= SVt_PVMG && SvMAGIC(nsv)) {
543 SvFLAGS(nsv) |= SvMAGICAL(sv);
552 #define mg_free_struct(sv, mg) S_mg_free_struct(aTHX_ sv, mg)
554 S_mg_free_struct(pTHX_ SV *sv, MAGIC *mg)
556 const MGVTBL* const vtbl = mg->mg_virtual;
557 if (vtbl && vtbl->svt_free)
558 vtbl->svt_free(aTHX_ sv, mg);
559 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
560 if (mg->mg_len > 0 || mg->mg_type == PERL_MAGIC_utf8)
561 Safefree(mg->mg_ptr);
562 else if (mg->mg_len == HEf_SVKEY)
563 SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr));
565 if (mg->mg_flags & MGf_REFCOUNTED)
566 SvREFCNT_dec(mg->mg_obj);
573 Free any magic storage used by the SV. See C<sv_magic>.
579 Perl_mg_free(pTHX_ SV *sv)
584 PERL_ARGS_ASSERT_MG_FREE;
586 for (mg = SvMAGIC(sv); mg; mg = moremagic) {
587 moremagic = mg->mg_moremagic;
588 mg_free_struct(sv, mg);
589 SvMAGIC_set(sv, moremagic);
591 SvMAGIC_set(sv, NULL);
597 =for apidoc Am|void|mg_free_type|SV *sv|int how
599 Remove any magic of type I<how> from the SV I<sv>. See L</sv_magic>.
605 Perl_mg_free_type(pTHX_ SV *sv, int how)
607 MAGIC *mg, *prevmg, *moremg;
608 PERL_ARGS_ASSERT_MG_FREE_TYPE;
609 for (prevmg = NULL, mg = SvMAGIC(sv); mg; prevmg = mg, mg = moremg) {
611 moremg = mg->mg_moremagic;
612 if (mg->mg_type == how) {
613 /* temporarily move to the head of the magic chain, in case
614 custom free code relies on this historical aspect of mg_free */
616 prevmg->mg_moremagic = moremg;
617 mg->mg_moremagic = SvMAGIC(sv);
620 newhead = mg->mg_moremagic;
621 mg_free_struct(sv, mg);
622 SvMAGIC_set(sv, newhead);
632 Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
637 PERL_ARGS_ASSERT_MAGIC_REGDATA_CNT;
640 register const REGEXP * const rx = PM_GETRE(PL_curpm);
642 if (mg->mg_obj) { /* @+ */
643 /* return the number possible */
644 return RX_NPARENS(rx);
646 I32 paren = RX_LASTPAREN(rx);
648 /* return the last filled */
650 && (RX_OFFS(rx)[paren].start == -1
651 || RX_OFFS(rx)[paren].end == -1) )
662 Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
666 PERL_ARGS_ASSERT_MAGIC_REGDATUM_GET;
669 register const REGEXP * const rx = PM_GETRE(PL_curpm);
671 register const I32 paren = mg->mg_len;
676 if (paren <= (I32)RX_NPARENS(rx) &&
677 (s = RX_OFFS(rx)[paren].start) != -1 &&
678 (t = RX_OFFS(rx)[paren].end) != -1)
681 if (mg->mg_obj) /* @+ */
686 if (i > 0 && RX_MATCH_UTF8(rx)) {
687 const char * const b = RX_SUBBEG(rx);
689 i = utf8_length((U8*)b, (U8*)(b+i));
700 Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
702 PERL_ARGS_ASSERT_MAGIC_REGDATUM_SET;
705 Perl_croak_no_modify(aTHX);
706 NORETURN_FUNCTION_END;
710 Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
715 register const REGEXP * rx;
716 const char * const remaining = mg->mg_ptr + 1;
718 PERL_ARGS_ASSERT_MAGIC_LEN;
720 switch (*mg->mg_ptr) {
722 if (*remaining == '\0') { /* ^P */
724 } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
726 } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
730 case '\015': /* $^MATCH */
731 if (strEQ(remaining, "ATCH")) {
738 paren = RX_BUFF_IDX_PREMATCH;
742 paren = RX_BUFF_IDX_POSTMATCH;
746 paren = RX_BUFF_IDX_FULLMATCH;
748 case '1': case '2': case '3': case '4':
749 case '5': case '6': case '7': case '8': case '9':
750 paren = atoi(mg->mg_ptr);
752 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
754 i = CALLREG_NUMBUF_LENGTH((REGEXP * const)rx, sv, paren);
757 Perl_croak(aTHX_ "panic: magic_len: %"IVdf, (IV)i);
760 if (ckWARN(WARN_UNINITIALIZED))
765 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
766 paren = RX_LASTPAREN(rx);
771 case '\016': /* ^N */
772 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
773 paren = RX_LASTCLOSEPAREN(rx);
780 if (!SvPOK(sv) && SvNIOK(sv)) {
788 #define SvRTRIM(sv) STMT_START { \
790 STRLEN len = SvCUR(sv); \
791 char * const p = SvPVX(sv); \
792 while (len > 0 && isSPACE(p[len-1])) \
794 SvCUR_set(sv, len); \
800 Perl_emulate_cop_io(pTHX_ const COP *const c, SV *const sv)
802 PERL_ARGS_ASSERT_EMULATE_COP_IO;
804 if (!(CopHINTS_get(c) & (HINT_LEXICAL_IO_IN|HINT_LEXICAL_IO_OUT)))
805 sv_setsv(sv, &PL_sv_undef);
809 if ((CopHINTS_get(c) & HINT_LEXICAL_IO_IN)) {
810 SV *const value = cop_hints_fetch_pvs(c, "open<", 0);
815 if ((CopHINTS_get(c) & HINT_LEXICAL_IO_OUT)) {
816 SV *const value = cop_hints_fetch_pvs(c, "open>", 0);
824 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
828 register const char *s = NULL;
830 const char * const remaining = mg->mg_ptr + 1;
831 const char nextchar = *remaining;
833 PERL_ARGS_ASSERT_MAGIC_GET;
835 switch (*mg->mg_ptr) {
836 case '\001': /* ^A */
837 sv_setsv(sv, PL_bodytarget);
838 if (SvTAINTED(PL_bodytarget))
841 case '\003': /* ^C, ^CHILD_ERROR_NATIVE */
842 if (nextchar == '\0') {
843 sv_setiv(sv, (IV)PL_minus_c);
845 else if (strEQ(remaining, "HILD_ERROR_NATIVE")) {
846 sv_setiv(sv, (IV)STATUS_NATIVE);
850 case '\004': /* ^D */
851 sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
853 case '\005': /* ^E */
854 if (nextchar == '\0') {
857 # include <descrip.h>
858 # include <starlet.h>
860 $DESCRIPTOR(msgdsc,msg);
861 sv_setnv(sv,(NV) vaxc$errno);
862 if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
863 sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
868 if (!(_emx_env & 0x200)) { /* Under DOS */
869 sv_setnv(sv, (NV)errno);
870 sv_setpv(sv, errno ? Strerror(errno) : "");
872 if (errno != errno_isOS2) {
873 const int tmp = _syserrno();
874 if (tmp) /* 2nd call to _syserrno() makes it 0 */
877 sv_setnv(sv, (NV)Perl_rc);
878 sv_setpv(sv, os2error(Perl_rc));
882 const DWORD dwErr = GetLastError();
883 sv_setnv(sv, (NV)dwErr);
885 PerlProc_GetOSError(sv, dwErr);
894 sv_setnv(sv, (NV)errno);
895 sv_setpv(sv, errno ? Strerror(errno) : "");
900 SvNOK_on(sv); /* what a wonderful hack! */
902 else if (strEQ(remaining, "NCODING"))
903 sv_setsv(sv, PL_encoding);
905 case '\006': /* ^F */
906 sv_setiv(sv, (IV)PL_maxsysfd);
908 case '\007': /* ^GLOBAL_PHASE */
909 if (strEQ(remaining, "LOBAL_PHASE")) {
910 sv_setpvn(sv, PL_phase_names[PL_phase],
911 strlen(PL_phase_names[PL_phase]));
914 case '\010': /* ^H */
915 sv_setiv(sv, (IV)PL_hints);
917 case '\011': /* ^I */ /* NOT \t in EBCDIC */
918 sv_setpv(sv, PL_inplace); /* Will undefine sv if PL_inplace is NULL */
920 case '\017': /* ^O & ^OPEN */
921 if (nextchar == '\0') {
922 sv_setpv(sv, PL_osname);
925 else if (strEQ(remaining, "PEN")) {
926 Perl_emulate_cop_io(aTHX_ &PL_compiling, sv);
930 if (nextchar == '\0') { /* ^P */
931 sv_setiv(sv, (IV)PL_perldb);
932 } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
933 goto do_prematch_fetch;
934 } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
935 goto do_postmatch_fetch;
938 case '\023': /* ^S */
939 if (nextchar == '\0') {
940 if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING)
943 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
948 case '\024': /* ^T */
949 if (nextchar == '\0') {
951 sv_setnv(sv, PL_basetime);
953 sv_setiv(sv, (IV)PL_basetime);
956 else if (strEQ(remaining, "AINT"))
957 sv_setiv(sv, PL_tainting
958 ? (PL_taint_warn || PL_unsafe ? -1 : 1)
961 case '\025': /* $^UNICODE, $^UTF8LOCALE, $^UTF8CACHE */
962 if (strEQ(remaining, "NICODE"))
963 sv_setuv(sv, (UV) PL_unicode);
964 else if (strEQ(remaining, "TF8LOCALE"))
965 sv_setuv(sv, (UV) PL_utf8locale);
966 else if (strEQ(remaining, "TF8CACHE"))
967 sv_setiv(sv, (IV) PL_utf8cache);
969 case '\027': /* ^W & $^WARNING_BITS */
970 if (nextchar == '\0')
971 sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
972 else if (strEQ(remaining, "ARNING_BITS")) {
973 if (PL_compiling.cop_warnings == pWARN_NONE) {
974 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
976 else if (PL_compiling.cop_warnings == pWARN_STD) {
979 (PL_dowarn & G_WARN_ON) ? WARN_ALLstring : WARN_NONEstring,
983 else if (PL_compiling.cop_warnings == pWARN_ALL) {
984 /* Get the bit mask for $warnings::Bits{all}, because
985 * it could have been extended by warnings::register */
986 HV * const bits=get_hv("warnings::Bits", 0);
988 SV ** const bits_all = hv_fetchs(bits, "all", FALSE);
990 sv_setsv(sv, *bits_all);
993 sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
997 sv_setpvn(sv, (char *) (PL_compiling.cop_warnings + 1),
998 *PL_compiling.cop_warnings);
1003 case '\015': /* $^MATCH */
1004 if (strEQ(remaining, "ATCH")) {
1005 case '1': case '2': case '3': case '4':
1006 case '5': case '6': case '7': case '8': case '9': case '&':
1007 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
1009 * Pre-threads, this was paren = atoi(GvENAME((const GV *)mg->mg_obj));
1010 * XXX Does the new way break anything?
1012 paren = atoi(mg->mg_ptr); /* $& is in [0] */
1013 CALLREG_NUMBUF_FETCH(rx,paren,sv);
1016 sv_setsv(sv,&PL_sv_undef);
1020 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
1021 if (RX_LASTPAREN(rx)) {
1022 CALLREG_NUMBUF_FETCH(rx,RX_LASTPAREN(rx),sv);
1026 sv_setsv(sv,&PL_sv_undef);
1028 case '\016': /* ^N */
1029 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
1030 if (RX_LASTCLOSEPAREN(rx)) {
1031 CALLREG_NUMBUF_FETCH(rx,RX_LASTCLOSEPAREN(rx),sv);
1036 sv_setsv(sv,&PL_sv_undef);
1040 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
1041 CALLREG_NUMBUF_FETCH(rx,-2,sv);
1044 sv_setsv(sv,&PL_sv_undef);
1048 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
1049 CALLREG_NUMBUF_FETCH(rx,-1,sv);
1052 sv_setsv(sv,&PL_sv_undef);
1055 if (GvIO(PL_last_in_gv)) {
1056 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
1061 sv_setiv(sv, (IV)STATUS_CURRENT);
1062 #ifdef COMPLEX_STATUS
1063 SvUPGRADE(sv, SVt_PVLV);
1064 LvTARGOFF(sv) = PL_statusvalue;
1065 LvTARGLEN(sv) = PL_statusvalue_vms;
1070 if (!isGV_with_GP(PL_defoutgv))
1072 else if (GvIOp(PL_defoutgv))
1073 s = IoTOP_NAME(GvIOp(PL_defoutgv));
1077 sv_setpv(sv,GvENAME(PL_defoutgv));
1078 sv_catpvs(sv,"_TOP");
1082 if (!isGV_with_GP(PL_defoutgv))
1084 else if (GvIOp(PL_defoutgv))
1085 s = IoFMT_NAME(GvIOp(PL_defoutgv));
1087 s = GvENAME(PL_defoutgv);
1091 if (GvIO(PL_defoutgv))
1092 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
1095 if (GvIO(PL_defoutgv))
1096 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
1099 if (GvIO(PL_defoutgv))
1100 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
1107 sv_setiv(sv, (IV)CopARYBASE_get(PL_curcop));
1110 if (GvIO(PL_defoutgv))
1111 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
1115 sv_copypv(sv, PL_ors_sv);
1121 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
1123 sv_setnv(sv, (NV)errno);
1126 if (errno == errno_isOS2 || errno == errno_isOS2_set)
1127 sv_setpv(sv, os2error(Perl_rc));
1130 sv_setpv(sv, errno ? Strerror(errno) : "");
1132 SvPOK_on(sv); /* may have got removed during taint processing */
1137 SvNOK_on(sv); /* what a wonderful hack! */
1140 sv_setiv(sv, (IV)PL_uid);
1143 sv_setiv(sv, (IV)PL_euid);
1146 sv_setiv(sv, (IV)PL_gid);
1149 sv_setiv(sv, (IV)PL_egid);
1151 #ifdef HAS_GETGROUPS
1153 Groups_t *gary = NULL;
1154 I32 i, num_groups = getgroups(0, gary);
1155 Newx(gary, num_groups, Groups_t);
1156 num_groups = getgroups(num_groups, gary);
1157 for (i = 0; i < num_groups; i++)
1158 Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]);
1161 (void)SvIOK_on(sv); /* what a wonderful hack! */
1171 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
1173 struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
1175 PERL_ARGS_ASSERT_MAGIC_GETUVAR;
1177 if (uf && uf->uf_val)
1178 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
1183 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
1186 STRLEN len = 0, klen;
1187 const char *s = SvOK(sv) ? SvPV_const(sv,len) : "";
1188 const char * const ptr = MgPV_const(mg,klen);
1191 PERL_ARGS_ASSERT_MAGIC_SETENV;
1193 #ifdef DYNAMIC_ENV_FETCH
1194 /* We just undefd an environment var. Is a replacement */
1195 /* waiting in the wings? */
1197 SV ** const valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE);
1199 s = SvOK(*valp) ? SvPV_const(*valp, len) : "";
1203 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
1204 /* And you'll never guess what the dog had */
1205 /* in its mouth... */
1207 MgTAINTEDDIR_off(mg);
1209 if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
1210 char pathbuf[256], eltbuf[256], *cp, *elt;
1213 my_strlcpy(eltbuf, s, sizeof(eltbuf));
1215 do { /* DCL$PATH may be a search list */
1216 while (1) { /* as may dev portion of any element */
1217 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1218 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1219 cando_by_name(S_IWUSR,0,elt) ) {
1220 MgTAINTEDDIR_on(mg);
1224 if ((cp = strchr(elt, ':')) != NULL)
1226 if (my_trnlnm(elt, eltbuf, j++))
1232 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1235 if (s && klen == 4 && strEQ(ptr,"PATH")) {
1236 const char * const strend = s + len;
1238 while (s < strend) {
1242 #ifdef VMS /* Hmm. How do we get $Config{path_sep} from C? */
1243 const char path_sep = '|';
1245 const char path_sep = ':';
1247 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
1248 s, strend, path_sep, &i);
1250 if (i >= (I32)sizeof tmpbuf /* too long -- assume the worst */
1252 || !strchr(tmpbuf, ':') /* no colon thus no device name -- assume relative path */
1254 || *tmpbuf != '/' /* no starting slash -- assume relative path */
1256 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1257 MgTAINTEDDIR_on(mg);
1263 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1269 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1271 PERL_ARGS_ASSERT_MAGIC_CLEARENV;
1272 PERL_UNUSED_ARG(sv);
1273 my_setenv(MgPV_nolen_const(mg),NULL);
1278 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1281 PERL_ARGS_ASSERT_MAGIC_SET_ALL_ENV;
1282 PERL_UNUSED_ARG(mg);
1284 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1286 if (PL_localizing) {
1289 hv_iterinit(MUTABLE_HV(sv));
1290 while ((entry = hv_iternext(MUTABLE_HV(sv)))) {
1292 my_setenv(hv_iterkey(entry, &keylen),
1293 SvPV_nolen_const(hv_iterval(MUTABLE_HV(sv), entry)));
1301 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1304 PERL_ARGS_ASSERT_MAGIC_CLEAR_ALL_ENV;
1305 PERL_UNUSED_ARG(sv);
1306 PERL_UNUSED_ARG(mg);
1308 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1316 #ifdef HAS_SIGPROCMASK
1318 restore_sigmask(pTHX_ SV *save_sv)
1320 const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1321 (void)sigprocmask(SIG_SETMASK, ossetp, NULL);
1325 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1328 /* Are we fetching a signal entry? */
1329 int i = (I16)mg->mg_private;
1331 PERL_ARGS_ASSERT_MAGIC_GETSIG;
1334 mg->mg_private = i = whichsig(MgPV_nolen_const(mg));
1339 sv_setsv(sv,PL_psig_ptr[i]);
1341 Sighandler_t sigstate = rsignal_state(i);
1342 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1343 if (PL_sig_handlers_initted && PL_sig_ignoring[i])
1346 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1347 if (PL_sig_handlers_initted && PL_sig_defaulting[i])
1350 /* cache state so we don't fetch it again */
1351 if(sigstate == (Sighandler_t) SIG_IGN)
1352 sv_setpvs(sv,"IGNORE");
1354 sv_setsv(sv,&PL_sv_undef);
1355 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1362 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1364 PERL_ARGS_ASSERT_MAGIC_CLEARSIG;
1365 PERL_UNUSED_ARG(sv);
1367 magic_setsig(NULL, mg);
1368 return sv_unmagic(sv, mg->mg_type);
1372 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1373 Perl_csighandler(int sig, siginfo_t *sip PERL_UNUSED_DECL, void *uap PERL_UNUSED_DECL)
1375 Perl_csighandler(int sig)
1378 #ifdef PERL_GET_SIG_CONTEXT
1379 dTHXa(PERL_GET_SIG_CONTEXT);
1383 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1384 (void) rsignal(sig, PL_csighandlerp);
1385 if (PL_sig_ignoring[sig]) return;
1387 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1388 if (PL_sig_defaulting[sig])
1389 #ifdef KILL_BY_SIGPRC
1390 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1405 (PL_signals & PERL_SIGNALS_UNSAFE_FLAG))
1406 /* Call the perl level handler now--
1407 * with risk we may be in malloc() or being destructed etc. */
1408 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1409 (*PL_sighandlerp)(sig, NULL, NULL);
1411 (*PL_sighandlerp)(sig);
1414 if (!PL_psig_pend) return;
1415 /* Set a flag to say this signal is pending, that is awaiting delivery after
1416 * the current Perl opcode completes */
1417 PL_psig_pend[sig]++;
1419 #ifndef SIG_PENDING_DIE_COUNT
1420 # define SIG_PENDING_DIE_COUNT 120
1422 /* Add one to say _a_ signal is pending */
1423 if (++PL_sig_pending >= SIG_PENDING_DIE_COUNT)
1424 Perl_croak(aTHX_ "Maximal count of pending signals (%lu) exceeded",
1425 (unsigned long)SIG_PENDING_DIE_COUNT);
1429 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1431 Perl_csighandler_init(void)
1434 if (PL_sig_handlers_initted) return;
1436 for (sig = 1; sig < SIG_SIZE; sig++) {
1437 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1439 PL_sig_defaulting[sig] = 1;
1440 (void) rsignal(sig, PL_csighandlerp);
1442 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1443 PL_sig_ignoring[sig] = 0;
1446 PL_sig_handlers_initted = 1;
1450 #if defined HAS_SIGPROCMASK
1452 unblock_sigmask(pTHX_ void* newset)
1454 sigprocmask(SIG_UNBLOCK, (sigset_t*)newset, NULL);
1459 Perl_despatch_signals(pTHX)
1464 for (sig = 1; sig < SIG_SIZE; sig++) {
1465 if (PL_psig_pend[sig]) {
1467 #ifdef HAS_SIGPROCMASK
1468 /* From sigaction(2) (FreeBSD man page):
1469 * | Signal routines normally execute with the signal that
1470 * | caused their invocation blocked, but other signals may
1472 * Emulation of this behavior (from within Perl) is enabled
1476 sigset_t newset, oldset;
1478 sigemptyset(&newset);
1479 sigaddset(&newset, sig);
1480 sigprocmask(SIG_BLOCK, &newset, &oldset);
1481 was_blocked = sigismember(&oldset, sig);
1483 SV* save_sv = newSVpvn((char *)(&newset), sizeof(sigset_t));
1485 SAVEFREESV(save_sv);
1486 SAVEDESTRUCTOR_X(unblock_sigmask, SvPV_nolen(save_sv));
1489 PL_psig_pend[sig] = 0;
1490 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1491 (*PL_sighandlerp)(sig, NULL, NULL);
1493 (*PL_sighandlerp)(sig);
1495 #ifdef HAS_SIGPROCMASK
1504 /* sv of NULL signifies that we're acting as magic_clearsig. */
1506 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1511 /* Need to be careful with SvREFCNT_dec(), because that can have side
1512 * effects (due to closures). We must make sure that the new disposition
1513 * is in place before it is called.
1517 #ifdef HAS_SIGPROCMASK
1521 register const char *s = MgPV_const(mg,len);
1523 PERL_ARGS_ASSERT_MAGIC_SETSIG;
1526 if (strEQ(s,"__DIE__"))
1528 else if (strEQ(s,"__WARN__")
1529 && (sv ? 1 : PL_warnhook != PERL_WARNHOOK_FATAL)) {
1530 /* Merge the existing behaviours, which are as follows:
1531 magic_setsig, we always set svp to &PL_warnhook
1532 (hence we always change the warnings handler)
1533 For magic_clearsig, we don't change the warnings handler if it's
1534 set to the &PL_warnhook. */
1537 Perl_croak(aTHX_ "No such hook: %s", s);
1540 if (*svp != PERL_WARNHOOK_FATAL)
1546 i = (I16)mg->mg_private;
1548 i = whichsig(s); /* ...no, a brick */
1549 mg->mg_private = (U16)i;
1553 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
1556 #ifdef HAS_SIGPROCMASK
1557 /* Avoid having the signal arrive at a bad time, if possible. */
1560 sigprocmask(SIG_BLOCK, &set, &save);
1562 save_sv = newSVpvn((char *)(&save), sizeof(sigset_t));
1563 SAVEFREESV(save_sv);
1564 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1567 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1568 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1570 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1571 PL_sig_ignoring[i] = 0;
1573 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1574 PL_sig_defaulting[i] = 0;
1576 to_dec = PL_psig_ptr[i];
1578 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1579 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1581 /* Signals don't change name during the program's execution, so once
1582 they're cached in the appropriate slot of PL_psig_name, they can
1585 Ideally we'd find some way of making SVs at (C) compile time, or
1586 at least, doing most of the work. */
1587 if (!PL_psig_name[i]) {
1588 PL_psig_name[i] = newSVpvn(s, len);
1589 SvREADONLY_on(PL_psig_name[i]);
1592 SvREFCNT_dec(PL_psig_name[i]);
1593 PL_psig_name[i] = NULL;
1594 PL_psig_ptr[i] = NULL;
1597 if (sv && (isGV_with_GP(sv) || SvROK(sv))) {
1599 (void)rsignal(i, PL_csighandlerp);
1602 *svp = SvREFCNT_inc_simple_NN(sv);
1604 if (sv && SvOK(sv)) {
1605 s = SvPV_force(sv, len);
1609 if (sv && strEQ(s,"IGNORE")) {
1611 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1612 PL_sig_ignoring[i] = 1;
1613 (void)rsignal(i, PL_csighandlerp);
1615 (void)rsignal(i, (Sighandler_t) SIG_IGN);
1619 else if (!sv || strEQ(s,"DEFAULT") || !len) {
1621 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1622 PL_sig_defaulting[i] = 1;
1623 (void)rsignal(i, PL_csighandlerp);
1625 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1631 * We should warn if HINT_STRICT_REFS, but without
1632 * access to a known hint bit in a known OP, we can't
1633 * tell whether HINT_STRICT_REFS is in force or not.
1635 if (!strchr(s,':') && !strchr(s,'\''))
1636 Perl_sv_insert_flags(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"),
1639 (void)rsignal(i, PL_csighandlerp);
1641 *svp = SvREFCNT_inc_simple_NN(sv);
1645 #ifdef HAS_SIGPROCMASK
1649 SvREFCNT_dec(to_dec);
1652 #endif /* !PERL_MICRO */
1655 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1658 PERL_ARGS_ASSERT_MAGIC_SETISA;
1659 PERL_UNUSED_ARG(sv);
1661 /* Skip _isaelem because _isa will handle it shortly */
1662 if (PL_delaymagic & DM_ARRAY_ISA && mg->mg_type == PERL_MAGIC_isaelem)
1665 return magic_clearisa(NULL, mg);
1668 /* sv of NULL signifies that we're acting as magic_setisa. */
1670 Perl_magic_clearisa(pTHX_ SV *sv, MAGIC *mg)
1675 PERL_ARGS_ASSERT_MAGIC_CLEARISA;
1677 /* Bail out if destruction is going on */
1678 if(PL_phase == PERL_PHASE_DESTRUCT) return 0;
1681 av_clear(MUTABLE_AV(sv));
1683 if (SvTYPE(mg->mg_obj) != SVt_PVGV && SvSMAGICAL(mg->mg_obj))
1684 /* This occurs with setisa_elem magic, which calls this
1686 mg = mg_find(mg->mg_obj, PERL_MAGIC_isa);
1688 if (SvTYPE(mg->mg_obj) == SVt_PVAV) { /* multiple stashes */
1689 SV **svp = AvARRAY((AV *)mg->mg_obj);
1690 I32 items = AvFILLp((AV *)mg->mg_obj) + 1;
1692 stash = GvSTASH((GV *)*svp++);
1693 if (stash && HvENAME(stash)) mro_isa_changed_in(stash);
1700 (const GV *)mg->mg_obj
1703 /* The stash may have been detached from the symbol table, so check its
1704 name before doing anything. */
1705 if (stash && HvENAME_get(stash))
1706 mro_isa_changed_in(stash);
1712 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
1715 PERL_ARGS_ASSERT_MAGIC_SETAMAGIC;
1716 PERL_UNUSED_ARG(sv);
1717 PERL_UNUSED_ARG(mg);
1718 PL_amagic_generation++;
1724 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1726 HV * const hv = MUTABLE_HV(LvTARG(sv));
1729 PERL_ARGS_ASSERT_MAGIC_GETNKEYS;
1730 PERL_UNUSED_ARG(mg);
1733 (void) hv_iterinit(hv);
1734 if (! SvTIED_mg((const SV *)hv, PERL_MAGIC_tied))
1737 while (hv_iternext(hv))
1742 sv_setiv(sv, (IV)i);
1747 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1749 PERL_ARGS_ASSERT_MAGIC_SETNKEYS;
1750 PERL_UNUSED_ARG(mg);
1752 hv_ksplit(MUTABLE_HV(LvTARG(sv)), SvIV(sv));
1758 =for apidoc magic_methcall
1760 Invoke a magic method (like FETCH).
1762 * sv and mg are the tied thingy and the tie magic;
1763 * meth is the name of the method to call;
1764 * argc is the number of args (in addition to $self) to pass to the method;
1765 the args themselves are any values following the argc argument.
1767 G_DISCARD: invoke method with G_DISCARD flag and don't return a value
1768 G_UNDEF_FILL: fill the stack with argc pointers to PL_sv_undef.
1770 Returns the SV (if any) returned by the method, or NULL on failure.
1777 Perl_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, U32 flags,
1784 PERL_ARGS_ASSERT_MAGIC_METHCALL;
1788 if (flags & G_WRITING_TO_STDERR) {
1792 SAVESPTR(PL_stderrgv);
1796 PUSHSTACKi(PERLSI_MAGIC);
1800 PUSHs(SvTIED_obj(sv, mg));
1801 if (flags & G_UNDEF_FILL) {
1803 PUSHs(&PL_sv_undef);
1805 } else if (argc > 0) {
1807 va_start(args, argc);
1810 SV *const sv = va_arg(args, SV *);
1817 if (flags & G_DISCARD) {
1818 call_method(meth, G_SCALAR|G_DISCARD);
1821 if (call_method(meth, G_SCALAR))
1822 ret = *PL_stack_sp--;
1825 if (flags & G_WRITING_TO_STDERR)
1832 /* wrapper for magic_methcall that creates the first arg */
1835 S_magic_methcall1(pTHX_ SV *sv, const MAGIC *mg, const char *meth, U32 flags,
1841 PERL_ARGS_ASSERT_MAGIC_METHCALL1;
1844 if (mg->mg_len >= 0) {
1845 arg1 = newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
1847 else if (mg->mg_len == HEf_SVKEY)
1848 arg1 = MUTABLE_SV(mg->mg_ptr);
1850 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1851 arg1 = newSViv((IV)(mg->mg_len));
1855 return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n - 1, val);
1857 return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n, arg1, val);
1861 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
1866 PERL_ARGS_ASSERT_MAGIC_METHPACK;
1868 ret = magic_methcall1(sv, mg, meth, 0, 1, NULL);
1875 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1877 PERL_ARGS_ASSERT_MAGIC_GETPACK;
1879 if (mg->mg_type == PERL_MAGIC_tiedelem)
1880 mg->mg_flags |= MGf_GSKIP;
1881 magic_methpack(sv,mg,"FETCH");
1886 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1892 PERL_ARGS_ASSERT_MAGIC_SETPACK;
1894 /* in the code C<$tied{foo} = $val>, the "thing" that gets passed to
1895 * STORE() is not $val, but rather a PVLV (the sv in this call), whose
1896 * public flags indicate its value based on copying from $val. Doing
1897 * mg_set() on the PVLV temporarily does SvMAGICAL_off(), then calls us.
1898 * So STORE()'s $_[2] arg is a temporarily disarmed PVLV. This goes
1899 * wrong if $val happened to be tainted, as sv hasn't got magic
1900 * enabled, even though taint magic is in the chain. In which case,
1901 * fake up a temporary tainted value (this is easier than temporarily
1902 * re-enabling magic on sv). */
1904 if (PL_tainting && (tmg = mg_find(sv, PERL_MAGIC_taint))
1905 && (tmg->mg_len & 1))
1907 val = sv_mortalcopy(sv);
1913 magic_methcall1(sv, mg, "STORE", G_DISCARD, 2, val);
1918 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1920 PERL_ARGS_ASSERT_MAGIC_CLEARPACK;
1922 return magic_methpack(sv,mg,"DELETE");
1927 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1933 PERL_ARGS_ASSERT_MAGIC_SIZEPACK;
1935 retsv = magic_methcall1(sv, mg, "FETCHSIZE", 0, 1, NULL);
1937 retval = SvIV(retsv)-1;
1939 Perl_croak(aTHX_ "FETCHSIZE returned a negative value");
1941 return (U32) retval;
1945 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1949 PERL_ARGS_ASSERT_MAGIC_WIPEPACK;
1951 Perl_magic_methcall(aTHX_ sv, mg, "CLEAR", G_DISCARD, 0);
1956 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1961 PERL_ARGS_ASSERT_MAGIC_NEXTPACK;
1963 ret = SvOK(key) ? Perl_magic_methcall(aTHX_ sv, mg, "NEXTKEY", 0, 1, key)
1964 : Perl_magic_methcall(aTHX_ sv, mg, "FIRSTKEY", 0, 0);
1971 Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg)
1973 PERL_ARGS_ASSERT_MAGIC_EXISTSPACK;
1975 return magic_methpack(sv,mg,"EXISTS");
1979 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1983 SV * const tied = SvTIED_obj(MUTABLE_SV(hv), mg);
1984 HV * const pkg = SvSTASH((const SV *)SvRV(tied));
1986 PERL_ARGS_ASSERT_MAGIC_SCALARPACK;
1988 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1990 if (HvEITER_get(hv))
1991 /* we are in an iteration so the hash cannot be empty */
1993 /* no xhv_eiter so now use FIRSTKEY */
1994 key = sv_newmortal();
1995 magic_nextpack(MUTABLE_SV(hv), mg, key);
1996 HvEITER_set(hv, NULL); /* need to reset iterator */
1997 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
2000 /* there is a SCALAR method that we can call */
2001 retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(hv), mg, "SCALAR", 0, 0);
2003 retval = &PL_sv_undef;
2008 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
2011 GV * const gv = PL_DBline;
2012 const I32 i = SvTRUE(sv);
2013 SV ** const svp = av_fetch(GvAV(gv),
2014 atoi(MgPV_nolen_const(mg)), FALSE);
2016 PERL_ARGS_ASSERT_MAGIC_SETDBLINE;
2018 if (svp && SvIOKp(*svp)) {
2019 OP * const o = INT2PTR(OP*,SvIVX(*svp));
2021 /* set or clear breakpoint in the relevant control op */
2023 o->op_flags |= OPf_SPECIAL;
2025 o->op_flags &= ~OPf_SPECIAL;
2032 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
2035 AV * const obj = MUTABLE_AV(mg->mg_obj);
2037 PERL_ARGS_ASSERT_MAGIC_GETARYLEN;
2040 sv_setiv(sv, AvFILL(obj) + CopARYBASE_get(PL_curcop));
2048 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
2051 AV * const obj = MUTABLE_AV(mg->mg_obj);
2053 PERL_ARGS_ASSERT_MAGIC_SETARYLEN;
2056 av_fill(obj, SvIV(sv) - CopARYBASE_get(PL_curcop));
2058 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
2059 "Attempt to set length of freed array");
2065 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
2069 PERL_ARGS_ASSERT_MAGIC_FREEARYLEN_P;
2070 PERL_UNUSED_ARG(sv);
2072 /* during global destruction, mg_obj may already have been freed */
2073 if (PL_in_clean_all)
2076 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
2079 /* arylen scalar holds a pointer back to the array, but doesn't own a
2080 reference. Hence the we (the array) are about to go away with it
2081 still pointing at us. Clear its pointer, else it would be pointing
2082 at free memory. See the comment in sv_magic about reference loops,
2083 and why it can't own a reference to us. */
2090 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
2093 SV* const lsv = LvTARG(sv);
2095 PERL_ARGS_ASSERT_MAGIC_GETPOS;
2096 PERL_UNUSED_ARG(mg);
2098 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
2099 MAGIC * const found = mg_find(lsv, PERL_MAGIC_regex_global);
2100 if (found && found->mg_len >= 0) {
2101 I32 i = found->mg_len;
2103 sv_pos_b2u(lsv, &i);
2104 sv_setiv(sv, i + CopARYBASE_get(PL_curcop));
2113 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
2116 SV* const lsv = LvTARG(sv);
2122 PERL_ARGS_ASSERT_MAGIC_SETPOS;
2123 PERL_UNUSED_ARG(mg);
2125 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
2126 found = mg_find(lsv, PERL_MAGIC_regex_global);
2132 #ifdef PERL_OLD_COPY_ON_WRITE
2134 sv_force_normal_flags(lsv, 0);
2136 found = sv_magicext(lsv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
2139 else if (!SvOK(sv)) {
2143 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
2145 pos = SvIV(sv) - CopARYBASE_get(PL_curcop);
2148 ulen = sv_len_utf8(lsv);
2158 else if (pos > (SSize_t)len)
2163 sv_pos_u2b(lsv, &p, 0);
2167 found->mg_len = pos;
2168 found->mg_flags &= ~MGf_MINMATCH;
2174 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
2177 SV * const lsv = LvTARG(sv);
2178 const char * const tmps = SvPV_const(lsv,len);
2179 STRLEN offs = LvTARGOFF(sv);
2180 STRLEN rem = LvTARGLEN(sv);
2182 PERL_ARGS_ASSERT_MAGIC_GETSUBSTR;
2183 PERL_UNUSED_ARG(mg);
2186 offs = sv_pos_u2b_flags(lsv, offs, &rem, SV_CONST_RETURN);
2189 if (rem > len - offs)
2191 sv_setpvn(sv, tmps + offs, rem);
2198 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
2202 const char * const tmps = SvPV_const(sv, len);
2203 SV * const lsv = LvTARG(sv);
2204 STRLEN lvoff = LvTARGOFF(sv);
2205 STRLEN lvlen = LvTARGLEN(sv);
2207 PERL_ARGS_ASSERT_MAGIC_SETSUBSTR;
2208 PERL_UNUSED_ARG(mg);
2211 sv_utf8_upgrade(lsv);
2212 lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
2213 sv_insert(lsv, lvoff, lvlen, tmps, len);
2214 LvTARGLEN(sv) = sv_len_utf8(sv);
2217 else if (lsv && SvUTF8(lsv)) {
2219 lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
2220 LvTARGLEN(sv) = len;
2221 utf8 = (char*)bytes_to_utf8((U8*)tmps, &len);
2222 sv_insert(lsv, lvoff, lvlen, utf8, len);
2226 sv_insert(lsv, lvoff, lvlen, tmps, len);
2227 LvTARGLEN(sv) = len;
2234 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
2238 PERL_ARGS_ASSERT_MAGIC_GETTAINT;
2239 PERL_UNUSED_ARG(sv);
2241 TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
2246 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
2250 PERL_ARGS_ASSERT_MAGIC_SETTAINT;
2251 PERL_UNUSED_ARG(sv);
2253 /* update taint status */
2262 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
2264 SV * const lsv = LvTARG(sv);
2266 PERL_ARGS_ASSERT_MAGIC_GETVEC;
2267 PERL_UNUSED_ARG(mg);
2270 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
2278 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
2280 PERL_ARGS_ASSERT_MAGIC_SETVEC;
2281 PERL_UNUSED_ARG(mg);
2282 do_vecset(sv); /* XXX slurp this routine */
2287 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
2292 PERL_ARGS_ASSERT_MAGIC_GETDEFELEM;
2294 if (LvTARGLEN(sv)) {
2296 SV * const ahv = LvTARG(sv);
2297 HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, FALSE, 0);
2302 AV *const av = MUTABLE_AV(LvTARG(sv));
2303 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
2304 targ = AvARRAY(av)[LvTARGOFF(sv)];
2306 if (targ && (targ != &PL_sv_undef)) {
2307 /* somebody else defined it for us */
2308 SvREFCNT_dec(LvTARG(sv));
2309 LvTARG(sv) = SvREFCNT_inc_simple_NN(targ);
2311 SvREFCNT_dec(mg->mg_obj);
2313 mg->mg_flags &= ~MGf_REFCOUNTED;
2318 sv_setsv(sv, targ ? targ : &PL_sv_undef);
2323 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
2325 PERL_ARGS_ASSERT_MAGIC_SETDEFELEM;
2326 PERL_UNUSED_ARG(mg);
2330 sv_setsv(LvTARG(sv), sv);
2331 SvSETMAGIC(LvTARG(sv));
2337 Perl_vivify_defelem(pTHX_ SV *sv)
2343 PERL_ARGS_ASSERT_VIVIFY_DEFELEM;
2345 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2348 SV * const ahv = LvTARG(sv);
2349 HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, TRUE, 0);
2352 if (!value || value == &PL_sv_undef)
2353 Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(mg->mg_obj));
2356 AV *const av = MUTABLE_AV(LvTARG(sv));
2357 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
2358 LvTARG(sv) = NULL; /* array can't be extended */
2360 SV* const * const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
2361 if (!svp || (value = *svp) == &PL_sv_undef)
2362 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
2365 SvREFCNT_inc_simple_void(value);
2366 SvREFCNT_dec(LvTARG(sv));
2369 SvREFCNT_dec(mg->mg_obj);
2371 mg->mg_flags &= ~MGf_REFCOUNTED;
2375 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2377 PERL_ARGS_ASSERT_MAGIC_KILLBACKREFS;
2378 Perl_sv_kill_backrefs(aTHX_ sv, MUTABLE_AV(mg->mg_obj));
2383 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2385 PERL_ARGS_ASSERT_MAGIC_SETMGLOB;
2386 PERL_UNUSED_CONTEXT;
2388 if (!isGV_with_GP(sv))
2394 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2396 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2398 PERL_ARGS_ASSERT_MAGIC_SETUVAR;
2400 if (uf && uf->uf_set)
2401 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2406 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2408 const char type = mg->mg_type;
2410 PERL_ARGS_ASSERT_MAGIC_SETREGEXP;
2412 if (type == PERL_MAGIC_qr) {
2413 } else if (type == PERL_MAGIC_bm) {
2417 assert(type == PERL_MAGIC_fm);
2420 return sv_unmagic(sv, type);
2423 #ifdef USE_LOCALE_COLLATE
2425 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2427 PERL_ARGS_ASSERT_MAGIC_SETCOLLXFRM;
2430 * RenE<eacute> Descartes said "I think not."
2431 * and vanished with a faint plop.
2433 PERL_UNUSED_CONTEXT;
2434 PERL_UNUSED_ARG(sv);
2436 Safefree(mg->mg_ptr);
2442 #endif /* USE_LOCALE_COLLATE */
2444 /* Just clear the UTF-8 cache data. */
2446 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2448 PERL_ARGS_ASSERT_MAGIC_SETUTF8;
2449 PERL_UNUSED_CONTEXT;
2450 PERL_UNUSED_ARG(sv);
2451 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2453 mg->mg_len = -1; /* The mg_len holds the len cache. */
2458 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2461 register const char *s;
2463 register const REGEXP * rx;
2464 const char * const remaining = mg->mg_ptr + 1;
2469 PERL_ARGS_ASSERT_MAGIC_SET;
2471 switch (*mg->mg_ptr) {
2472 case '\015': /* $^MATCH */
2473 if (strEQ(remaining, "ATCH"))
2475 case '`': /* ${^PREMATCH} caught below */
2477 paren = RX_BUFF_IDX_PREMATCH;
2479 case '\'': /* ${^POSTMATCH} caught below */
2481 paren = RX_BUFF_IDX_POSTMATCH;
2485 paren = RX_BUFF_IDX_FULLMATCH;
2487 case '1': case '2': case '3': case '4':
2488 case '5': case '6': case '7': case '8': case '9':
2489 paren = atoi(mg->mg_ptr);
2491 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
2492 CALLREG_NUMBUF_STORE((REGEXP * const)rx,paren,sv);
2494 /* Croak with a READONLY error when a numbered match var is
2495 * set without a previous pattern match. Unless it's C<local $1>
2497 if (!PL_localizing) {
2498 Perl_croak_no_modify(aTHX);
2502 case '\001': /* ^A */
2503 sv_setsv(PL_bodytarget, sv);
2504 /* mg_set() has temporarily made sv non-magical */
2506 if ((tmg = mg_find(sv,PERL_MAGIC_taint)) && tmg->mg_len & 1)
2507 SvTAINTED_on(PL_bodytarget);
2509 SvTAINTED_off(PL_bodytarget);
2512 case '\003': /* ^C */
2513 PL_minus_c = cBOOL(SvIV(sv));
2516 case '\004': /* ^D */
2518 s = SvPV_nolen_const(sv);
2519 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2520 if (DEBUG_x_TEST || DEBUG_B_TEST)
2521 dump_all_perl(!DEBUG_B_TEST);
2523 PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG;
2526 case '\005': /* ^E */
2527 if (*(mg->mg_ptr+1) == '\0') {
2529 set_vaxc_errno(SvIV(sv));
2532 SetLastError( SvIV(sv) );
2535 os2_setsyserrno(SvIV(sv));
2537 /* will anyone ever use this? */
2538 SETERRNO(SvIV(sv), 4);
2543 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2544 SvREFCNT_dec(PL_encoding);
2545 if (SvOK(sv) || SvGMAGICAL(sv)) {
2546 PL_encoding = newSVsv(sv);
2553 case '\006': /* ^F */
2554 PL_maxsysfd = SvIV(sv);
2556 case '\010': /* ^H */
2557 PL_hints = SvIV(sv);
2559 case '\011': /* ^I */ /* NOT \t in EBCDIC */
2560 Safefree(PL_inplace);
2561 PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
2563 case '\017': /* ^O */
2564 if (*(mg->mg_ptr+1) == '\0') {
2565 Safefree(PL_osname);
2568 TAINT_PROPER("assigning to $^O");
2569 PL_osname = savesvpv(sv);
2572 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2574 const char *const start = SvPV(sv, len);
2575 const char *out = (const char*)memchr(start, '\0', len);
2579 PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2580 PL_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2582 /* Opening for input is more common than opening for output, so
2583 ensure that hints for input are sooner on linked list. */
2584 tmp = out ? newSVpvn_flags(out + 1, start + len - out - 1,
2586 : newSVpvs_flags("", SvUTF8(sv));
2587 (void)hv_stores(GvHV(PL_hintgv), "open>", tmp);
2590 tmp = newSVpvn_flags(start, out ? (STRLEN)(out - start) : len,
2592 (void)hv_stores(GvHV(PL_hintgv), "open<", tmp);
2596 case '\020': /* ^P */
2597 if (*remaining == '\0') { /* ^P */
2598 PL_perldb = SvIV(sv);
2599 if (PL_perldb && !PL_DBsingle)
2602 } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
2604 } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
2608 case '\024': /* ^T */
2610 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2612 PL_basetime = (Time_t)SvIV(sv);
2615 case '\025': /* ^UTF8CACHE */
2616 if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
2617 PL_utf8cache = (signed char) sv_2iv(sv);
2620 case '\027': /* ^W & $^WARNING_BITS */
2621 if (*(mg->mg_ptr+1) == '\0') {
2622 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2624 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2625 | (i ? G_WARN_ON : G_WARN_OFF) ;
2628 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2629 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2630 if (!SvPOK(sv) && PL_localizing) {
2631 sv_setpvn(sv, WARN_NONEstring, WARNsize);
2632 PL_compiling.cop_warnings = pWARN_NONE;
2637 int accumulate = 0 ;
2638 int any_fatals = 0 ;
2639 const char * const ptr = SvPV_const(sv, len) ;
2640 for (i = 0 ; i < len ; ++i) {
2641 accumulate |= ptr[i] ;
2642 any_fatals |= (ptr[i] & 0xAA) ;
2645 if (!specialWARN(PL_compiling.cop_warnings))
2646 PerlMemShared_free(PL_compiling.cop_warnings);
2647 PL_compiling.cop_warnings = pWARN_NONE;
2649 /* Yuck. I can't see how to abstract this: */
2650 else if (isWARN_on(((STRLEN *)SvPV_nolen_const(sv)) - 1,
2651 WARN_ALL) && !any_fatals) {
2652 if (!specialWARN(PL_compiling.cop_warnings))
2653 PerlMemShared_free(PL_compiling.cop_warnings);
2654 PL_compiling.cop_warnings = pWARN_ALL;
2655 PL_dowarn |= G_WARN_ONCE ;
2659 const char *const p = SvPV_const(sv, len);
2661 PL_compiling.cop_warnings
2662 = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
2665 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2666 PL_dowarn |= G_WARN_ONCE ;
2674 if (PL_localizing) {
2675 if (PL_localizing == 1)
2676 SAVESPTR(PL_last_in_gv);
2678 else if (SvOK(sv) && GvIO(PL_last_in_gv))
2679 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2682 if (isGV_with_GP(PL_defoutgv)) {
2683 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2684 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2685 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2689 if (isGV_with_GP(PL_defoutgv)) {
2690 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2691 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2692 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2696 if (isGV_with_GP(PL_defoutgv))
2697 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
2700 if (isGV_with_GP(PL_defoutgv)) {
2701 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
2702 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2703 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2707 if (isGV_with_GP(PL_defoutgv))
2708 IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
2712 IO * const io = GvIO(PL_defoutgv);
2715 if ((SvIV(sv)) == 0)
2716 IoFLAGS(io) &= ~IOf_FLUSH;
2718 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2719 PerlIO *ofp = IoOFP(io);
2721 (void)PerlIO_flush(ofp);
2722 IoFLAGS(io) |= IOf_FLUSH;
2728 SvREFCNT_dec(PL_rs);
2729 PL_rs = newSVsv(sv);
2732 SvREFCNT_dec(PL_ors_sv);
2733 if (SvOK(sv) || SvGMAGICAL(sv)) {
2734 PL_ors_sv = newSVsv(sv);
2741 CopARYBASE_set(&PL_compiling, SvIV(sv));
2744 #ifdef COMPLEX_STATUS
2745 if (PL_localizing == 2) {
2746 SvUPGRADE(sv, SVt_PVLV);
2747 PL_statusvalue = LvTARGOFF(sv);
2748 PL_statusvalue_vms = LvTARGLEN(sv);
2752 #ifdef VMSISH_STATUS
2754 STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2757 STATUS_UNIX_EXIT_SET(SvIV(sv));
2762 # define PERL_VMS_BANG vaxc$errno
2764 # define PERL_VMS_BANG 0
2766 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2767 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2772 if (PL_delaymagic) {
2773 PL_delaymagic |= DM_RUID;
2774 break; /* don't do magic till later */
2777 (void)setruid((Uid_t)PL_uid);
2780 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2782 #ifdef HAS_SETRESUID
2783 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2785 if (PL_uid == PL_euid) { /* special case $< = $> */
2787 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2788 if (PL_uid != 0 && PerlProc_getuid() == 0)
2789 (void)PerlProc_setuid(0);
2791 (void)PerlProc_setuid(PL_uid);
2793 PL_uid = PerlProc_getuid();
2794 Perl_croak(aTHX_ "setruid() not implemented");
2799 PL_uid = PerlProc_getuid();
2803 if (PL_delaymagic) {
2804 PL_delaymagic |= DM_EUID;
2805 break; /* don't do magic till later */
2808 (void)seteuid((Uid_t)PL_euid);
2811 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2813 #ifdef HAS_SETRESUID
2814 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2816 if (PL_euid == PL_uid) /* special case $> = $< */
2817 PerlProc_setuid(PL_euid);
2819 PL_euid = PerlProc_geteuid();
2820 Perl_croak(aTHX_ "seteuid() not implemented");
2825 PL_euid = PerlProc_geteuid();
2829 if (PL_delaymagic) {
2830 PL_delaymagic |= DM_RGID;
2831 break; /* don't do magic till later */
2834 (void)setrgid((Gid_t)PL_gid);
2837 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2839 #ifdef HAS_SETRESGID
2840 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2842 if (PL_gid == PL_egid) /* special case $( = $) */
2843 (void)PerlProc_setgid(PL_gid);
2845 PL_gid = PerlProc_getgid();
2846 Perl_croak(aTHX_ "setrgid() not implemented");
2851 PL_gid = PerlProc_getgid();
2854 #ifdef HAS_SETGROUPS
2856 const char *p = SvPV_const(sv, len);
2857 Groups_t *gary = NULL;
2858 #ifdef _SC_NGROUPS_MAX
2859 int maxgrp = sysconf(_SC_NGROUPS_MAX);
2864 int maxgrp = NGROUPS;
2870 for (i = 0; i < maxgrp; ++i) {
2871 while (*p && !isSPACE(*p))
2878 Newx(gary, i + 1, Groups_t);
2880 Renew(gary, i + 1, Groups_t);
2884 (void)setgroups(i, gary);
2887 #else /* HAS_SETGROUPS */
2889 #endif /* HAS_SETGROUPS */
2890 if (PL_delaymagic) {
2891 PL_delaymagic |= DM_EGID;
2892 break; /* don't do magic till later */
2895 (void)setegid((Gid_t)PL_egid);
2898 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2900 #ifdef HAS_SETRESGID
2901 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2903 if (PL_egid == PL_gid) /* special case $) = $( */
2904 (void)PerlProc_setgid(PL_egid);
2906 PL_egid = PerlProc_getegid();
2907 Perl_croak(aTHX_ "setegid() not implemented");
2912 PL_egid = PerlProc_getegid();
2915 PL_chopset = SvPV_force(sv,len);
2918 LOCK_DOLLARZERO_MUTEX;
2919 #ifdef HAS_SETPROCTITLE
2920 /* The BSDs don't show the argv[] in ps(1) output, they
2921 * show a string from the process struct and provide
2922 * the setproctitle() routine to manipulate that. */
2923 if (PL_origalen != 1) {
2924 s = SvPV_const(sv, len);
2925 # if __FreeBSD_version > 410001
2926 /* The leading "-" removes the "perl: " prefix,
2927 * but not the "(perl) suffix from the ps(1)
2928 * output, because that's what ps(1) shows if the
2929 * argv[] is modified. */
2930 setproctitle("-%s", s);
2931 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2932 /* This doesn't really work if you assume that
2933 * $0 = 'foobar'; will wipe out 'perl' from the $0
2934 * because in ps(1) output the result will be like
2935 * sprintf("perl: %s (perl)", s)
2936 * I guess this is a security feature:
2937 * one (a user process) cannot get rid of the original name.
2939 setproctitle("%s", s);
2942 #elif defined(__hpux) && defined(PSTAT_SETCMD)
2943 if (PL_origalen != 1) {
2945 s = SvPV_const(sv, len);
2946 un.pst_command = (char *)s;
2947 pstat(PSTAT_SETCMD, un, len, 0, 0);
2950 if (PL_origalen > 1) {
2951 /* PL_origalen is set in perl_parse(). */
2952 s = SvPV_force(sv,len);
2953 if (len >= (STRLEN)PL_origalen-1) {
2954 /* Longer than original, will be truncated. We assume that
2955 * PL_origalen bytes are available. */
2956 Copy(s, PL_origargv[0], PL_origalen-1, char);
2959 /* Shorter than original, will be padded. */
2961 /* Special case for Mac OS X: see [perl #38868] */
2964 /* Is the space counterintuitive? Yes.
2965 * (You were expecting \0?)
2966 * Does it work? Seems to. (In Linux 2.4.20 at least.)
2968 const int pad = ' ';
2970 Copy(s, PL_origargv[0], len, char);
2971 PL_origargv[0][len] = 0;
2972 memset(PL_origargv[0] + len + 1,
2973 pad, PL_origalen - len - 1);
2975 PL_origargv[0][PL_origalen-1] = 0;
2976 for (i = 1; i < PL_origargc; i++)
2978 #ifdef HAS_PRCTL_SET_NAME
2979 /* Set the legacy process name in addition to the POSIX name on Linux */
2980 if (prctl(PR_SET_NAME, (unsigned long)s, 0, 0, 0) != 0) {
2981 /* diag_listed_as: SKIPME */
2982 Perl_croak(aTHX_ "Can't set $0 with prctl(): %s", Strerror(errno));
2987 UNLOCK_DOLLARZERO_MUTEX;
2994 Perl_whichsig(pTHX_ const char *sig)
2996 register char* const* sigv;
2998 PERL_ARGS_ASSERT_WHICHSIG;
2999 PERL_UNUSED_CONTEXT;
3001 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
3002 if (strEQ(sig,*sigv))
3003 return PL_sig_num[sigv - (char* const*)PL_sig_name];
3005 if (strEQ(sig,"CHLD"))
3009 if (strEQ(sig,"CLD"))
3016 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3017 Perl_sighandler(int sig, siginfo_t *sip, void *uap)
3019 Perl_sighandler(int sig)
3022 #ifdef PERL_GET_SIG_CONTEXT
3023 dTHXa(PERL_GET_SIG_CONTEXT);
3030 SV * const tSv = PL_Sv;
3034 XPV * const tXpv = PL_Xpv;
3035 I32 old_ss_ix = PL_savestack_ix;
3038 if (!PL_psig_ptr[sig]) {
3039 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
3044 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) {
3045 /* Max number of items pushed there is 3*n or 4. We cannot fix
3046 infinity, so we fix 4 (in fact 5): */
3047 if (PL_savestack_ix + 15 <= PL_savestack_max) {
3049 PL_savestack_ix += 5; /* Protect save in progress. */
3050 SAVEDESTRUCTOR_X(S_unwind_handler_stack, NULL);
3053 /* sv_2cv is too complicated, try a simpler variant first: */
3054 if (!SvROK(PL_psig_ptr[sig]) || !(cv = MUTABLE_CV(SvRV(PL_psig_ptr[sig])))
3055 || SvTYPE(cv) != SVt_PVCV) {
3057 cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
3060 if (!cv || !CvROOT(cv)) {
3061 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
3062 PL_sig_name[sig], (gv ? GvENAME(gv)
3069 sv = PL_psig_name[sig]
3070 ? SvREFCNT_inc_NN(PL_psig_name[sig])
3071 : newSVpv(PL_sig_name[sig],0);
3075 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) {
3076 /* make sure our assumption about the size of the SAVEs are correct:
3077 * 3 for SAVEDESTRUCTOR_X, 2 for SAVEFREESV */
3078 assert(old_ss_ix + 2 + ((flags & 1) ? 3+5 : 0) == PL_savestack_ix);
3081 PUSHSTACKi(PERLSI_SIGNAL);
3084 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3086 struct sigaction oact;
3088 if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
3091 SV *rv = newRV_noinc(MUTABLE_SV(sih));
3092 /* The siginfo fields signo, code, errno, pid, uid,
3093 * addr, status, and band are defined by POSIX/SUSv3. */
3094 (void)hv_stores(sih, "signo", newSViv(sip->si_signo));
3095 (void)hv_stores(sih, "code", newSViv(sip->si_code));
3096 #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. */
3097 hv_stores(sih, "errno", newSViv(sip->si_errno));
3098 hv_stores(sih, "status", newSViv(sip->si_status));
3099 hv_stores(sih, "uid", newSViv(sip->si_uid));
3100 hv_stores(sih, "pid", newSViv(sip->si_pid));
3101 hv_stores(sih, "addr", newSVuv(PTR2UV(sip->si_addr)));
3102 hv_stores(sih, "band", newSViv(sip->si_band));
3106 mPUSHp((char *)sip, sizeof(*sip));
3114 call_sv(MUTABLE_SV(cv), G_DISCARD|G_EVAL);
3117 if (SvTRUE(ERRSV)) {
3119 /* Handler "died", for example to get out of a restart-able read().
3120 * Before we re-do that on its behalf re-enable the signal which was
3121 * blocked by the system when we entered.
3123 #ifdef HAS_SIGPROCMASK
3124 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3130 sigaddset(&set,sig);
3131 sigprocmask(SIG_UNBLOCK, &set, NULL);
3134 /* Not clear if this will work */
3135 (void)rsignal(sig, SIG_IGN);
3136 (void)rsignal(sig, PL_csighandlerp);
3138 #endif /* !PERL_MICRO */
3142 /* pop any of SAVEFREESV, SAVEDESTRUCTOR_X and "save in progress" */
3143 PL_savestack_ix = old_ss_ix;
3146 PL_op = myop; /* Apparently not needed... */
3148 PL_Sv = tSv; /* Restore global temporaries. */
3155 S_restore_magic(pTHX_ const void *p)
3158 MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
3159 SV* const sv = mgs->mgs_sv;
3165 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
3167 #ifdef PERL_OLD_COPY_ON_WRITE
3168 /* While magic was saved (and off) sv_setsv may well have seen
3169 this SV as a prime candidate for COW. */
3171 sv_force_normal_flags(sv, 0);
3174 if (mgs->mgs_readonly)
3176 if (mgs->mgs_magical)
3177 SvFLAGS(sv) |= mgs->mgs_magical;
3180 if (SvGMAGICAL(sv)) {
3181 /* downgrade public flags to private,
3182 and discard any other private flags */
3184 const U32 pubflags = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
3186 SvFLAGS(sv) &= ~( pubflags | (SVp_IOK|SVp_NOK|SVp_POK) );
3187 SvFLAGS(sv) |= ( pubflags << PRIVSHIFT );
3192 bumped = mgs->mgs_bumped;
3193 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
3195 /* If we're still on top of the stack, pop us off. (That condition
3196 * will be satisfied if restore_magic was called explicitly, but *not*
3197 * if it's being called via leave_scope.)
3198 * The reason for doing this is that otherwise, things like sv_2cv()
3199 * may leave alloc gunk on the savestack, and some code
3200 * (e.g. sighandler) doesn't expect that...
3202 if (PL_savestack_ix == mgs->mgs_ss_ix)
3204 UV popval = SSPOPUV;
3205 assert(popval == SAVEt_DESTRUCTOR_X);
3206 PL_savestack_ix -= 2;
3208 assert((popval & SAVE_MASK) == SAVEt_ALLOC);
3209 PL_savestack_ix -= popval >> SAVE_TIGHT_SHIFT;
3212 if (SvREFCNT(sv) == 1) {
3213 /* We hold the last reference to this SV, which implies that the
3214 SV was deleted as a side effect of the routines we called.
3215 So artificially keep it alive a bit longer.
3216 We avoid turning on the TEMP flag, which can cause the SV's
3217 buffer to get stolen (and maybe other stuff). */
3218 int was_temp = SvTEMP(sv);
3226 SvREFCNT_dec(sv); /* undo the inc in S_save_magic() */
3230 /* clean up the mess created by Perl_sighandler().
3231 * Note that this is only called during an exit in a signal handler;
3232 * a die is trapped by the call_sv() and the SAVEDESTRUCTOR_X manually
3236 S_unwind_handler_stack(pTHX_ const void *p)
3241 PL_savestack_ix -= 5; /* Unprotect save in progress. */
3245 =for apidoc magic_sethint
3247 Triggered by a store to %^H, records the key/value pair to
3248 C<PL_compiling.cop_hints_hash>. It is assumed that hints aren't storing
3249 anything that would need a deep copy. Maybe we should warn if we find a
3255 Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
3258 SV *key = (mg->mg_len == HEf_SVKEY) ? MUTABLE_SV(mg->mg_ptr)
3259 : newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
3261 PERL_ARGS_ASSERT_MAGIC_SETHINT;
3263 /* mg->mg_obj isn't being used. If needed, it would be possible to store
3264 an alternative leaf in there, with PL_compiling.cop_hints being used if
3265 it's NULL. If needed for threads, the alternative could lock a mutex,
3266 or take other more complex action. */
3268 /* Something changed in %^H, so it will need to be restored on scope exit.
3269 Doing this here saves a lot of doing it manually in perl code (and
3270 forgetting to do it, and consequent subtle errors. */
3271 PL_hints |= HINT_LOCALIZE_HH;
3272 CopHINTHASH_set(&PL_compiling,
3273 cophh_store_sv(CopHINTHASH_get(&PL_compiling), key, 0, sv, 0));
3278 =for apidoc magic_clearhint
3280 Triggered by a delete from %^H, records the key to
3281 C<PL_compiling.cop_hints_hash>.
3286 Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
3290 PERL_ARGS_ASSERT_MAGIC_CLEARHINT;
3291 PERL_UNUSED_ARG(sv);
3293 assert(mg->mg_len == HEf_SVKEY);
3295 PERL_UNUSED_ARG(sv);
3297 PL_hints |= HINT_LOCALIZE_HH;
3298 CopHINTHASH_set(&PL_compiling,
3299 cophh_delete_sv(CopHINTHASH_get(&PL_compiling),
3300 MUTABLE_SV(mg->mg_ptr), 0, 0));
3305 =for apidoc magic_clearhints
3307 Triggered by clearing %^H, resets C<PL_compiling.cop_hints_hash>.
3312 Perl_magic_clearhints(pTHX_ SV *sv, MAGIC *mg)
3314 PERL_ARGS_ASSERT_MAGIC_CLEARHINTS;
3315 PERL_UNUSED_ARG(sv);
3316 PERL_UNUSED_ARG(mg);
3317 cophh_free(CopHINTHASH_get(&PL_compiling));
3318 CopHINTHASH_set(&PL_compiling, cophh_new_empty());
3324 * c-indentation-style: bsd
3326 * indent-tabs-mode: t
3329 * ex: set ts=8 sts=4 sw=4 noet: