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 assert(SvMAGICAL(sv));
99 /* Turning READONLY off for a copy-on-write scalar (including shared
100 hash keys) is a bad idea. */
102 sv_force_normal_flags(sv, 0);
104 SAVEDESTRUCTOR_X(S_restore_magic, INT2PTR(void*, (IV)mgs_ix));
106 mgs = SSPTR(mgs_ix, MGS*);
108 mgs->mgs_magical = SvMAGICAL(sv);
109 mgs->mgs_readonly = SvREADONLY(sv) != 0;
110 mgs->mgs_ss_ix = PL_savestack_ix; /* points after the saved destructor */
114 if (!(SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK))) {
115 /* No public flags are set, so promote any private flags to public. */
116 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
121 =for apidoc mg_magical
123 Turns on the magical status of an SV. See C<sv_magic>.
129 Perl_mg_magical(pTHX_ SV *sv)
132 PERL_ARGS_ASSERT_MG_MAGICAL;
136 if ((mg = SvMAGIC(sv))) {
138 const MGVTBL* const vtbl = mg->mg_virtual;
140 if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
147 } while ((mg = mg->mg_moremagic));
148 if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)))
154 /* is this container magic (%ENV, $1 etc), or value magic (pos, taint etc)? */
157 S_is_container_magic(const MAGIC *mg)
160 switch (mg->mg_type) {
163 case PERL_MAGIC_regex_global:
164 case PERL_MAGIC_nkeys:
165 #ifdef USE_LOCALE_COLLATE
166 case PERL_MAGIC_collxfrm:
169 case PERL_MAGIC_taint:
171 case PERL_MAGIC_vstring:
172 case PERL_MAGIC_utf8:
173 case PERL_MAGIC_substr:
174 case PERL_MAGIC_defelem:
175 case PERL_MAGIC_arylen:
177 case PERL_MAGIC_backref:
178 case PERL_MAGIC_arylen_p:
179 case PERL_MAGIC_rhash:
180 case PERL_MAGIC_symtab:
181 case PERL_MAGIC_tied: /* treat as value, so 'local @tied' isn't tied */
182 case PERL_MAGIC_checkcall:
192 Do magic after a value is retrieved from the SV. See C<sv_magic>.
198 Perl_mg_get(pTHX_ SV *sv)
201 const I32 mgs_ix = SSNEW(sizeof(MGS));
202 const bool was_temp = cBOOL(SvTEMP(sv));
204 MAGIC *newmg, *head, *cur, *mg;
205 /* guard against sv having being freed midway by holding a private
208 PERL_ARGS_ASSERT_MG_GET;
210 /* sv_2mortal has this side effect of turning on the TEMP flag, which can
211 cause the SV's buffer to get stolen (and maybe other stuff).
214 sv_2mortal(SvREFCNT_inc_simple_NN(sv));
219 save_magic(mgs_ix, sv);
221 /* We must call svt_get(sv, mg) for each valid entry in the linked
222 list of magic. svt_get() may delete the current entry, add new
223 magic to the head of the list, or upgrade the SV. AMS 20010810 */
225 newmg = cur = head = mg = SvMAGIC(sv);
227 const MGVTBL * const vtbl = mg->mg_virtual;
228 MAGIC * const nextmg = mg->mg_moremagic; /* it may delete itself */
230 if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
231 vtbl->svt_get(aTHX_ sv, mg);
233 /* guard against magic having been deleted - eg FETCH calling
236 (SSPTR(mgs_ix, MGS *))->mgs_magical = 0; /* recalculate flags */
240 /* recalculate flags if this entry was deleted. */
241 if (mg->mg_flags & MGf_GSKIP)
242 (SSPTR(mgs_ix, MGS *))->mgs_magical = 0;
248 /* Have we finished with the new entries we saw? Start again
249 where we left off (unless there are more new entries). */
257 /* Were any new entries added? */
258 if (!have_new && (newmg = SvMAGIC(sv)) != head) {
262 (SSPTR(mgs_ix, MGS *))->mgs_magical = 0; /* recalculate flags */
266 restore_magic(INT2PTR(void *, (IV)mgs_ix));
268 if (SvREFCNT(sv) == 1) {
269 /* We hold the last reference to this SV, which implies that the
270 SV was deleted as a side effect of the routines we called. */
279 Do magic after a value is assigned to the SV. See C<sv_magic>.
285 Perl_mg_set(pTHX_ SV *sv)
288 const I32 mgs_ix = SSNEW(sizeof(MGS));
292 PERL_ARGS_ASSERT_MG_SET;
294 save_magic(mgs_ix, sv);
296 for (mg = SvMAGIC(sv); mg; mg = nextmg) {
297 const MGVTBL* vtbl = mg->mg_virtual;
298 nextmg = mg->mg_moremagic; /* it may delete itself */
299 if (mg->mg_flags & MGf_GSKIP) {
300 mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */
301 (SSPTR(mgs_ix, MGS*))->mgs_magical = 0;
303 if (PL_localizing == 2 && !S_is_container_magic(mg))
305 if (vtbl && vtbl->svt_set)
306 vtbl->svt_set(aTHX_ sv, mg);
309 restore_magic(INT2PTR(void*, (IV)mgs_ix));
314 =for apidoc mg_length
316 Report on the SV's length. See C<sv_magic>.
322 Perl_mg_length(pTHX_ SV *sv)
328 PERL_ARGS_ASSERT_MG_LENGTH;
330 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
331 const MGVTBL * const vtbl = mg->mg_virtual;
332 if (vtbl && vtbl->svt_len) {
333 const I32 mgs_ix = SSNEW(sizeof(MGS));
334 save_magic(mgs_ix, sv);
335 /* omit MGf_GSKIP -- not changed here */
336 len = vtbl->svt_len(aTHX_ sv, mg);
337 restore_magic(INT2PTR(void*, (IV)mgs_ix));
343 /* You can't know whether it's UTF-8 until you get the string again...
345 const U8 *s = (U8*)SvPV_const(sv, len);
348 len = utf8_length(s, s + len);
355 Perl_mg_size(pTHX_ SV *sv)
359 PERL_ARGS_ASSERT_MG_SIZE;
361 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
362 const MGVTBL* const vtbl = mg->mg_virtual;
363 if (vtbl && vtbl->svt_len) {
364 const I32 mgs_ix = SSNEW(sizeof(MGS));
366 save_magic(mgs_ix, sv);
367 /* omit MGf_GSKIP -- not changed here */
368 len = vtbl->svt_len(aTHX_ sv, mg);
369 restore_magic(INT2PTR(void*, (IV)mgs_ix));
376 return AvFILLp((const AV *) sv); /* Fallback to non-tied array */
380 Perl_croak(aTHX_ "Size magic not implemented");
389 Clear something magical that the SV represents. See C<sv_magic>.
395 Perl_mg_clear(pTHX_ SV *sv)
397 const I32 mgs_ix = SSNEW(sizeof(MGS));
401 PERL_ARGS_ASSERT_MG_CLEAR;
403 save_magic(mgs_ix, sv);
405 for (mg = SvMAGIC(sv); mg; mg = nextmg) {
406 const MGVTBL* const vtbl = mg->mg_virtual;
407 /* omit GSKIP -- never set here */
409 nextmg = mg->mg_moremagic; /* it may delete itself */
411 if (vtbl && vtbl->svt_clear)
412 vtbl->svt_clear(aTHX_ sv, mg);
415 restore_magic(INT2PTR(void*, (IV)mgs_ix));
420 S_mg_findext_flags(pTHX_ const SV *sv, int type, const MGVTBL *vtbl, U32 flags)
429 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
430 if (mg->mg_type == type && (!flags || mg->mg_virtual == vtbl)) {
442 Finds the magic pointer for type matching the SV. See C<sv_magic>.
448 Perl_mg_find(pTHX_ const SV *sv, int type)
450 return S_mg_findext_flags(aTHX_ sv, type, NULL, 0);
454 =for apidoc mg_findext
456 Finds the magic pointer of C<type> with the given C<vtbl> for the C<SV>. See
463 Perl_mg_findext(pTHX_ const SV *sv, int type, const MGVTBL *vtbl)
465 return S_mg_findext_flags(aTHX_ sv, type, vtbl, 1);
471 Copies the magic from one SV to another. See C<sv_magic>.
477 Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
482 PERL_ARGS_ASSERT_MG_COPY;
484 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
485 const MGVTBL* const vtbl = mg->mg_virtual;
486 if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){
487 count += vtbl->svt_copy(aTHX_ sv, mg, nsv, key, klen);
490 const char type = mg->mg_type;
491 if (isUPPER(type) && type != PERL_MAGIC_uvar) {
493 (type == PERL_MAGIC_tied)
495 : (type == PERL_MAGIC_regdata && mg->mg_obj)
498 toLOWER(type), key, klen);
507 =for apidoc mg_localize
509 Copy some of the magic from an existing SV to new localized version of that
510 SV. Container magic (eg %ENV, $1, tie) gets copied, value magic doesn't (eg
513 If setmagic is false then no set magic will be called on the new (empty) SV.
514 This typically means that assignment will soon follow (e.g. 'local $x = $y'),
515 and that will handle the magic.
521 Perl_mg_localize(pTHX_ SV *sv, SV *nsv, bool setmagic)
526 PERL_ARGS_ASSERT_MG_LOCALIZE;
528 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
529 const MGVTBL* const vtbl = mg->mg_virtual;
530 if (!S_is_container_magic(mg))
533 if ((mg->mg_flags & MGf_LOCAL) && vtbl->svt_local)
534 (void)vtbl->svt_local(aTHX_ nsv, mg);
536 sv_magicext(nsv, mg->mg_obj, mg->mg_type, vtbl,
537 mg->mg_ptr, mg->mg_len);
539 /* container types should remain read-only across localization */
540 SvFLAGS(nsv) |= SvREADONLY(sv);
543 if (SvTYPE(nsv) >= SVt_PVMG && SvMAGIC(nsv)) {
544 SvFLAGS(nsv) |= SvMAGICAL(sv);
553 #define mg_free_struct(sv, mg) S_mg_free_struct(aTHX_ sv, mg)
555 S_mg_free_struct(pTHX_ SV *sv, MAGIC *mg)
557 const MGVTBL* const vtbl = mg->mg_virtual;
558 if (vtbl && vtbl->svt_free)
559 vtbl->svt_free(aTHX_ sv, mg);
560 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
561 if (mg->mg_len > 0 || mg->mg_type == PERL_MAGIC_utf8)
562 Safefree(mg->mg_ptr);
563 else if (mg->mg_len == HEf_SVKEY)
564 SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr));
566 if (mg->mg_flags & MGf_REFCOUNTED)
567 SvREFCNT_dec(mg->mg_obj);
574 Free any magic storage used by the SV. See C<sv_magic>.
580 Perl_mg_free(pTHX_ SV *sv)
585 PERL_ARGS_ASSERT_MG_FREE;
587 for (mg = SvMAGIC(sv); mg; mg = moremagic) {
588 moremagic = mg->mg_moremagic;
589 mg_free_struct(sv, mg);
590 SvMAGIC_set(sv, moremagic);
592 SvMAGIC_set(sv, NULL);
598 =for apidoc Am|void|mg_free_type|SV *sv|int how
600 Remove any magic of type I<how> from the SV I<sv>. See L</sv_magic>.
606 Perl_mg_free_type(pTHX_ SV *sv, int how)
608 MAGIC *mg, *prevmg, *moremg;
609 PERL_ARGS_ASSERT_MG_FREE_TYPE;
610 for (prevmg = NULL, mg = SvMAGIC(sv); mg; prevmg = mg, mg = moremg) {
612 moremg = mg->mg_moremagic;
613 if (mg->mg_type == how) {
614 /* temporarily move to the head of the magic chain, in case
615 custom free code relies on this historical aspect of mg_free */
617 prevmg->mg_moremagic = moremg;
618 mg->mg_moremagic = SvMAGIC(sv);
621 newhead = mg->mg_moremagic;
622 mg_free_struct(sv, mg);
623 SvMAGIC_set(sv, newhead);
633 Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
638 PERL_ARGS_ASSERT_MAGIC_REGDATA_CNT;
641 register const REGEXP * const rx = PM_GETRE(PL_curpm);
643 if (mg->mg_obj) { /* @+ */
644 /* return the number possible */
645 return RX_NPARENS(rx);
647 I32 paren = RX_LASTPAREN(rx);
649 /* return the last filled */
651 && (RX_OFFS(rx)[paren].start == -1
652 || RX_OFFS(rx)[paren].end == -1) )
663 Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
667 PERL_ARGS_ASSERT_MAGIC_REGDATUM_GET;
670 register const REGEXP * const rx = PM_GETRE(PL_curpm);
672 register const I32 paren = mg->mg_len;
677 if (paren <= (I32)RX_NPARENS(rx) &&
678 (s = RX_OFFS(rx)[paren].start) != -1 &&
679 (t = RX_OFFS(rx)[paren].end) != -1)
682 if (mg->mg_obj) /* @+ */
687 if (i > 0 && RX_MATCH_UTF8(rx)) {
688 const char * const b = RX_SUBBEG(rx);
690 i = utf8_length((U8*)b, (U8*)(b+i));
701 Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
703 PERL_ARGS_ASSERT_MAGIC_REGDATUM_SET;
706 Perl_croak_no_modify(aTHX);
707 NORETURN_FUNCTION_END;
711 Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
716 register const REGEXP * rx;
717 const char * const remaining = mg->mg_ptr + 1;
719 PERL_ARGS_ASSERT_MAGIC_LEN;
721 switch (*mg->mg_ptr) {
723 if (*remaining == '\0') { /* ^P */
725 } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
727 } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
731 case '\015': /* $^MATCH */
732 if (strEQ(remaining, "ATCH")) {
739 paren = RX_BUFF_IDX_PREMATCH;
743 paren = RX_BUFF_IDX_POSTMATCH;
747 paren = RX_BUFF_IDX_FULLMATCH;
749 case '1': case '2': case '3': case '4':
750 case '5': case '6': case '7': case '8': case '9':
751 paren = atoi(mg->mg_ptr);
753 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
755 i = CALLREG_NUMBUF_LENGTH((REGEXP * const)rx, sv, paren);
758 Perl_croak(aTHX_ "panic: magic_len: %"IVdf, (IV)i);
761 if (ckWARN(WARN_UNINITIALIZED))
766 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
767 paren = RX_LASTPAREN(rx);
772 case '\016': /* ^N */
773 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
774 paren = RX_LASTCLOSEPAREN(rx);
781 if (!SvPOK(sv) && SvNIOK(sv)) {
789 #define SvRTRIM(sv) STMT_START { \
791 STRLEN len = SvCUR(sv); \
792 char * const p = SvPVX(sv); \
793 while (len > 0 && isSPACE(p[len-1])) \
795 SvCUR_set(sv, len); \
801 Perl_emulate_cop_io(pTHX_ const COP *const c, SV *const sv)
803 PERL_ARGS_ASSERT_EMULATE_COP_IO;
805 if (!(CopHINTS_get(c) & (HINT_LEXICAL_IO_IN|HINT_LEXICAL_IO_OUT)))
806 sv_setsv(sv, &PL_sv_undef);
810 if ((CopHINTS_get(c) & HINT_LEXICAL_IO_IN)) {
811 SV *const value = cop_hints_fetch_pvs(c, "open<", 0);
816 if ((CopHINTS_get(c) & HINT_LEXICAL_IO_OUT)) {
817 SV *const value = cop_hints_fetch_pvs(c, "open>", 0);
825 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
829 register const char *s = NULL;
831 const char * const remaining = mg->mg_ptr + 1;
832 const char nextchar = *remaining;
834 PERL_ARGS_ASSERT_MAGIC_GET;
836 switch (*mg->mg_ptr) {
837 case '\001': /* ^A */
838 sv_setsv(sv, PL_bodytarget);
839 if (SvTAINTED(PL_bodytarget))
842 case '\003': /* ^C, ^CHILD_ERROR_NATIVE */
843 if (nextchar == '\0') {
844 sv_setiv(sv, (IV)PL_minus_c);
846 else if (strEQ(remaining, "HILD_ERROR_NATIVE")) {
847 sv_setiv(sv, (IV)STATUS_NATIVE);
851 case '\004': /* ^D */
852 sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
854 case '\005': /* ^E */
855 if (nextchar == '\0') {
858 # include <descrip.h>
859 # include <starlet.h>
861 $DESCRIPTOR(msgdsc,msg);
862 sv_setnv(sv,(NV) vaxc$errno);
863 if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
864 sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
869 if (!(_emx_env & 0x200)) { /* Under DOS */
870 sv_setnv(sv, (NV)errno);
871 sv_setpv(sv, errno ? Strerror(errno) : "");
873 if (errno != errno_isOS2) {
874 const int tmp = _syserrno();
875 if (tmp) /* 2nd call to _syserrno() makes it 0 */
878 sv_setnv(sv, (NV)Perl_rc);
879 sv_setpv(sv, os2error(Perl_rc));
883 const DWORD dwErr = GetLastError();
884 sv_setnv(sv, (NV)dwErr);
886 PerlProc_GetOSError(sv, dwErr);
895 sv_setnv(sv, (NV)errno);
896 sv_setpv(sv, errno ? Strerror(errno) : "");
901 SvNOK_on(sv); /* what a wonderful hack! */
903 else if (strEQ(remaining, "NCODING"))
904 sv_setsv(sv, PL_encoding);
906 case '\006': /* ^F */
907 sv_setiv(sv, (IV)PL_maxsysfd);
909 case '\007': /* ^GLOBAL_PHASE */
910 if (strEQ(remaining, "LOBAL_PHASE")) {
911 sv_setpvn(sv, PL_phase_names[PL_phase],
912 strlen(PL_phase_names[PL_phase]));
915 case '\010': /* ^H */
916 sv_setiv(sv, (IV)PL_hints);
918 case '\011': /* ^I */ /* NOT \t in EBCDIC */
919 sv_setpv(sv, PL_inplace); /* Will undefine sv if PL_inplace is NULL */
921 case '\017': /* ^O & ^OPEN */
922 if (nextchar == '\0') {
923 sv_setpv(sv, PL_osname);
926 else if (strEQ(remaining, "PEN")) {
927 Perl_emulate_cop_io(aTHX_ &PL_compiling, sv);
931 if (nextchar == '\0') { /* ^P */
932 sv_setiv(sv, (IV)PL_perldb);
933 } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
934 goto do_prematch_fetch;
935 } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
936 goto do_postmatch_fetch;
939 case '\023': /* ^S */
940 if (nextchar == '\0') {
941 if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING)
944 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
949 case '\024': /* ^T */
950 if (nextchar == '\0') {
952 sv_setnv(sv, PL_basetime);
954 sv_setiv(sv, (IV)PL_basetime);
957 else if (strEQ(remaining, "AINT"))
958 sv_setiv(sv, PL_tainting
959 ? (PL_taint_warn || PL_unsafe ? -1 : 1)
962 case '\025': /* $^UNICODE, $^UTF8LOCALE, $^UTF8CACHE */
963 if (strEQ(remaining, "NICODE"))
964 sv_setuv(sv, (UV) PL_unicode);
965 else if (strEQ(remaining, "TF8LOCALE"))
966 sv_setuv(sv, (UV) PL_utf8locale);
967 else if (strEQ(remaining, "TF8CACHE"))
968 sv_setiv(sv, (IV) PL_utf8cache);
970 case '\027': /* ^W & $^WARNING_BITS */
971 if (nextchar == '\0')
972 sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
973 else if (strEQ(remaining, "ARNING_BITS")) {
974 if (PL_compiling.cop_warnings == pWARN_NONE) {
975 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
977 else if (PL_compiling.cop_warnings == pWARN_STD) {
980 (PL_dowarn & G_WARN_ON) ? WARN_ALLstring : WARN_NONEstring,
984 else if (PL_compiling.cop_warnings == pWARN_ALL) {
985 /* Get the bit mask for $warnings::Bits{all}, because
986 * it could have been extended by warnings::register */
987 HV * const bits=get_hv("warnings::Bits", 0);
989 SV ** const bits_all = hv_fetchs(bits, "all", FALSE);
991 sv_setsv(sv, *bits_all);
994 sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
998 sv_setpvn(sv, (char *) (PL_compiling.cop_warnings + 1),
999 *PL_compiling.cop_warnings);
1004 case '\015': /* $^MATCH */
1005 if (strEQ(remaining, "ATCH")) {
1006 case '1': case '2': case '3': case '4':
1007 case '5': case '6': case '7': case '8': case '9': case '&':
1008 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
1010 * Pre-threads, this was paren = atoi(GvENAME((const GV *)mg->mg_obj));
1011 * XXX Does the new way break anything?
1013 paren = atoi(mg->mg_ptr); /* $& is in [0] */
1014 CALLREG_NUMBUF_FETCH(rx,paren,sv);
1017 sv_setsv(sv,&PL_sv_undef);
1021 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
1022 if (RX_LASTPAREN(rx)) {
1023 CALLREG_NUMBUF_FETCH(rx,RX_LASTPAREN(rx),sv);
1027 sv_setsv(sv,&PL_sv_undef);
1029 case '\016': /* ^N */
1030 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
1031 if (RX_LASTCLOSEPAREN(rx)) {
1032 CALLREG_NUMBUF_FETCH(rx,RX_LASTCLOSEPAREN(rx),sv);
1037 sv_setsv(sv,&PL_sv_undef);
1041 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
1042 CALLREG_NUMBUF_FETCH(rx,-2,sv);
1045 sv_setsv(sv,&PL_sv_undef);
1049 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
1050 CALLREG_NUMBUF_FETCH(rx,-1,sv);
1053 sv_setsv(sv,&PL_sv_undef);
1056 if (GvIO(PL_last_in_gv)) {
1057 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
1062 sv_setiv(sv, (IV)STATUS_CURRENT);
1063 #ifdef COMPLEX_STATUS
1064 SvUPGRADE(sv, SVt_PVLV);
1065 LvTARGOFF(sv) = PL_statusvalue;
1066 LvTARGLEN(sv) = PL_statusvalue_vms;
1071 if (!isGV_with_GP(PL_defoutgv))
1073 else if (GvIOp(PL_defoutgv))
1074 s = IoTOP_NAME(GvIOp(PL_defoutgv));
1078 sv_setpv(sv,GvENAME(PL_defoutgv));
1079 sv_catpvs(sv,"_TOP");
1083 if (!isGV_with_GP(PL_defoutgv))
1085 else if (GvIOp(PL_defoutgv))
1086 s = IoFMT_NAME(GvIOp(PL_defoutgv));
1088 s = GvENAME(PL_defoutgv);
1092 if (GvIO(PL_defoutgv))
1093 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
1096 if (GvIO(PL_defoutgv))
1097 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
1100 if (GvIO(PL_defoutgv))
1101 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
1108 sv_setiv(sv, (IV)CopARYBASE_get(PL_curcop));
1111 if (GvIO(PL_defoutgv))
1112 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
1116 sv_copypv(sv, PL_ors_sv);
1122 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
1124 sv_setnv(sv, (NV)errno);
1127 if (errno == errno_isOS2 || errno == errno_isOS2_set)
1128 sv_setpv(sv, os2error(Perl_rc));
1131 sv_setpv(sv, errno ? Strerror(errno) : "");
1133 SvPOK_on(sv); /* may have got removed during taint processing */
1138 SvNOK_on(sv); /* what a wonderful hack! */
1141 sv_setiv(sv, (IV)PL_uid);
1144 sv_setiv(sv, (IV)PL_euid);
1147 sv_setiv(sv, (IV)PL_gid);
1150 sv_setiv(sv, (IV)PL_egid);
1152 #ifdef HAS_GETGROUPS
1154 Groups_t *gary = NULL;
1155 I32 i, num_groups = getgroups(0, gary);
1156 Newx(gary, num_groups, Groups_t);
1157 num_groups = getgroups(num_groups, gary);
1158 for (i = 0; i < num_groups; i++)
1159 Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]);
1162 (void)SvIOK_on(sv); /* what a wonderful hack! */
1172 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
1174 struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
1176 PERL_ARGS_ASSERT_MAGIC_GETUVAR;
1178 if (uf && uf->uf_val)
1179 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
1184 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
1187 STRLEN len = 0, klen;
1188 const char *s = SvOK(sv) ? SvPV_const(sv,len) : "";
1189 const char * const ptr = MgPV_const(mg,klen);
1192 PERL_ARGS_ASSERT_MAGIC_SETENV;
1194 #ifdef DYNAMIC_ENV_FETCH
1195 /* We just undefd an environment var. Is a replacement */
1196 /* waiting in the wings? */
1198 SV ** const valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE);
1200 s = SvOK(*valp) ? SvPV_const(*valp, len) : "";
1204 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
1205 /* And you'll never guess what the dog had */
1206 /* in its mouth... */
1208 MgTAINTEDDIR_off(mg);
1210 if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
1211 char pathbuf[256], eltbuf[256], *cp, *elt;
1214 my_strlcpy(eltbuf, s, sizeof(eltbuf));
1216 do { /* DCL$PATH may be a search list */
1217 while (1) { /* as may dev portion of any element */
1218 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1219 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1220 cando_by_name(S_IWUSR,0,elt) ) {
1221 MgTAINTEDDIR_on(mg);
1225 if ((cp = strchr(elt, ':')) != NULL)
1227 if (my_trnlnm(elt, eltbuf, j++))
1233 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1236 if (s && klen == 4 && strEQ(ptr,"PATH")) {
1237 const char * const strend = s + len;
1239 while (s < strend) {
1243 #ifdef VMS /* Hmm. How do we get $Config{path_sep} from C? */
1244 const char path_sep = '|';
1246 const char path_sep = ':';
1248 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
1249 s, strend, path_sep, &i);
1251 if (i >= (I32)sizeof tmpbuf /* too long -- assume the worst */
1253 || !strchr(tmpbuf, ':') /* no colon thus no device name -- assume relative path */
1255 || *tmpbuf != '/' /* no starting slash -- assume relative path */
1257 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1258 MgTAINTEDDIR_on(mg);
1264 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1270 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1272 PERL_ARGS_ASSERT_MAGIC_CLEARENV;
1273 PERL_UNUSED_ARG(sv);
1274 my_setenv(MgPV_nolen_const(mg),NULL);
1279 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1282 PERL_ARGS_ASSERT_MAGIC_SET_ALL_ENV;
1283 PERL_UNUSED_ARG(mg);
1285 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1287 if (PL_localizing) {
1290 hv_iterinit(MUTABLE_HV(sv));
1291 while ((entry = hv_iternext(MUTABLE_HV(sv)))) {
1293 my_setenv(hv_iterkey(entry, &keylen),
1294 SvPV_nolen_const(hv_iterval(MUTABLE_HV(sv), entry)));
1302 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1305 PERL_ARGS_ASSERT_MAGIC_CLEAR_ALL_ENV;
1306 PERL_UNUSED_ARG(sv);
1307 PERL_UNUSED_ARG(mg);
1309 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1317 #ifdef HAS_SIGPROCMASK
1319 restore_sigmask(pTHX_ SV *save_sv)
1321 const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1322 (void)sigprocmask(SIG_SETMASK, ossetp, NULL);
1326 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1329 /* Are we fetching a signal entry? */
1330 int i = (I16)mg->mg_private;
1332 PERL_ARGS_ASSERT_MAGIC_GETSIG;
1335 mg->mg_private = i = whichsig(MgPV_nolen_const(mg));
1340 sv_setsv(sv,PL_psig_ptr[i]);
1342 Sighandler_t sigstate = rsignal_state(i);
1343 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1344 if (PL_sig_handlers_initted && PL_sig_ignoring[i])
1347 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1348 if (PL_sig_handlers_initted && PL_sig_defaulting[i])
1351 /* cache state so we don't fetch it again */
1352 if(sigstate == (Sighandler_t) SIG_IGN)
1353 sv_setpvs(sv,"IGNORE");
1355 sv_setsv(sv,&PL_sv_undef);
1356 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1363 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1365 PERL_ARGS_ASSERT_MAGIC_CLEARSIG;
1366 PERL_UNUSED_ARG(sv);
1368 magic_setsig(NULL, mg);
1369 return sv_unmagic(sv, mg->mg_type);
1373 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1374 Perl_csighandler(int sig, siginfo_t *sip PERL_UNUSED_DECL, void *uap PERL_UNUSED_DECL)
1376 Perl_csighandler(int sig)
1379 #ifdef PERL_GET_SIG_CONTEXT
1380 dTHXa(PERL_GET_SIG_CONTEXT);
1384 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1385 (void) rsignal(sig, PL_csighandlerp);
1386 if (PL_sig_ignoring[sig]) return;
1388 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1389 if (PL_sig_defaulting[sig])
1390 #ifdef KILL_BY_SIGPRC
1391 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1406 (PL_signals & PERL_SIGNALS_UNSAFE_FLAG))
1407 /* Call the perl level handler now--
1408 * with risk we may be in malloc() or being destructed etc. */
1409 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1410 (*PL_sighandlerp)(sig, NULL, NULL);
1412 (*PL_sighandlerp)(sig);
1415 if (!PL_psig_pend) return;
1416 /* Set a flag to say this signal is pending, that is awaiting delivery after
1417 * the current Perl opcode completes */
1418 PL_psig_pend[sig]++;
1420 #ifndef SIG_PENDING_DIE_COUNT
1421 # define SIG_PENDING_DIE_COUNT 120
1423 /* Add one to say _a_ signal is pending */
1424 if (++PL_sig_pending >= SIG_PENDING_DIE_COUNT)
1425 Perl_croak(aTHX_ "Maximal count of pending signals (%lu) exceeded",
1426 (unsigned long)SIG_PENDING_DIE_COUNT);
1430 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1432 Perl_csighandler_init(void)
1435 if (PL_sig_handlers_initted) return;
1437 for (sig = 1; sig < SIG_SIZE; sig++) {
1438 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1440 PL_sig_defaulting[sig] = 1;
1441 (void) rsignal(sig, PL_csighandlerp);
1443 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1444 PL_sig_ignoring[sig] = 0;
1447 PL_sig_handlers_initted = 1;
1452 Perl_despatch_signals(pTHX)
1457 for (sig = 1; sig < SIG_SIZE; sig++) {
1458 if (PL_psig_pend[sig]) {
1460 PERL_BLOCKSIG_ADD(set, sig);
1461 PL_psig_pend[sig] = 0;
1462 PERL_BLOCKSIG_BLOCK(set);
1463 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1464 (*PL_sighandlerp)(sig, NULL, NULL);
1466 (*PL_sighandlerp)(sig);
1468 PERL_BLOCKSIG_UNBLOCK(set);
1474 /* sv of NULL signifies that we're acting as magic_clearsig. */
1476 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1481 /* Need to be careful with SvREFCNT_dec(), because that can have side
1482 * effects (due to closures). We must make sure that the new disposition
1483 * is in place before it is called.
1487 #ifdef HAS_SIGPROCMASK
1491 register const char *s = MgPV_const(mg,len);
1493 PERL_ARGS_ASSERT_MAGIC_SETSIG;
1496 if (strEQ(s,"__DIE__"))
1498 else if (strEQ(s,"__WARN__")
1499 && (sv ? 1 : PL_warnhook != PERL_WARNHOOK_FATAL)) {
1500 /* Merge the existing behaviours, which are as follows:
1501 magic_setsig, we always set svp to &PL_warnhook
1502 (hence we always change the warnings handler)
1503 For magic_clearsig, we don't change the warnings handler if it's
1504 set to the &PL_warnhook. */
1507 Perl_croak(aTHX_ "No such hook: %s", s);
1510 if (*svp != PERL_WARNHOOK_FATAL)
1516 i = (I16)mg->mg_private;
1518 i = whichsig(s); /* ...no, a brick */
1519 mg->mg_private = (U16)i;
1523 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
1526 #ifdef HAS_SIGPROCMASK
1527 /* Avoid having the signal arrive at a bad time, if possible. */
1530 sigprocmask(SIG_BLOCK, &set, &save);
1532 save_sv = newSVpvn((char *)(&save), sizeof(sigset_t));
1533 SAVEFREESV(save_sv);
1534 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1537 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1538 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1540 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1541 PL_sig_ignoring[i] = 0;
1543 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1544 PL_sig_defaulting[i] = 0;
1546 to_dec = PL_psig_ptr[i];
1548 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1549 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1551 /* Signals don't change name during the program's execution, so once
1552 they're cached in the appropriate slot of PL_psig_name, they can
1555 Ideally we'd find some way of making SVs at (C) compile time, or
1556 at least, doing most of the work. */
1557 if (!PL_psig_name[i]) {
1558 PL_psig_name[i] = newSVpvn(s, len);
1559 SvREADONLY_on(PL_psig_name[i]);
1562 SvREFCNT_dec(PL_psig_name[i]);
1563 PL_psig_name[i] = NULL;
1564 PL_psig_ptr[i] = NULL;
1567 if (sv && (isGV_with_GP(sv) || SvROK(sv))) {
1569 (void)rsignal(i, PL_csighandlerp);
1572 *svp = SvREFCNT_inc_simple_NN(sv);
1574 if (sv && SvOK(sv)) {
1575 s = SvPV_force(sv, len);
1579 if (sv && strEQ(s,"IGNORE")) {
1581 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1582 PL_sig_ignoring[i] = 1;
1583 (void)rsignal(i, PL_csighandlerp);
1585 (void)rsignal(i, (Sighandler_t) SIG_IGN);
1589 else if (!sv || strEQ(s,"DEFAULT") || !len) {
1591 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1592 PL_sig_defaulting[i] = 1;
1593 (void)rsignal(i, PL_csighandlerp);
1595 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1601 * We should warn if HINT_STRICT_REFS, but without
1602 * access to a known hint bit in a known OP, we can't
1603 * tell whether HINT_STRICT_REFS is in force or not.
1605 if (!strchr(s,':') && !strchr(s,'\''))
1606 Perl_sv_insert_flags(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"),
1609 (void)rsignal(i, PL_csighandlerp);
1611 *svp = SvREFCNT_inc_simple_NN(sv);
1615 #ifdef HAS_SIGPROCMASK
1619 SvREFCNT_dec(to_dec);
1622 #endif /* !PERL_MICRO */
1625 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1628 PERL_ARGS_ASSERT_MAGIC_SETISA;
1629 PERL_UNUSED_ARG(sv);
1631 /* Skip _isaelem because _isa will handle it shortly */
1632 if (PL_delaymagic & DM_ARRAY_ISA && mg->mg_type == PERL_MAGIC_isaelem)
1635 return magic_clearisa(NULL, mg);
1638 /* sv of NULL signifies that we're acting as magic_setisa. */
1640 Perl_magic_clearisa(pTHX_ SV *sv, MAGIC *mg)
1645 PERL_ARGS_ASSERT_MAGIC_CLEARISA;
1647 /* Bail out if destruction is going on */
1648 if(PL_phase == PERL_PHASE_DESTRUCT) return 0;
1651 av_clear(MUTABLE_AV(sv));
1653 if (SvTYPE(mg->mg_obj) != SVt_PVGV && SvSMAGICAL(mg->mg_obj))
1654 /* This occurs with setisa_elem magic, which calls this
1656 mg = mg_find(mg->mg_obj, PERL_MAGIC_isa);
1658 if (SvTYPE(mg->mg_obj) == SVt_PVAV) { /* multiple stashes */
1659 SV **svp = AvARRAY((AV *)mg->mg_obj);
1660 I32 items = AvFILLp((AV *)mg->mg_obj) + 1;
1662 stash = GvSTASH((GV *)*svp++);
1663 if (stash && HvENAME(stash)) mro_isa_changed_in(stash);
1670 (const GV *)mg->mg_obj
1673 /* The stash may have been detached from the symbol table, so check its
1674 name before doing anything. */
1675 if (stash && HvENAME_get(stash))
1676 mro_isa_changed_in(stash);
1682 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
1685 PERL_ARGS_ASSERT_MAGIC_SETAMAGIC;
1686 PERL_UNUSED_ARG(sv);
1687 PERL_UNUSED_ARG(mg);
1688 PL_amagic_generation++;
1694 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1696 HV * const hv = MUTABLE_HV(LvTARG(sv));
1699 PERL_ARGS_ASSERT_MAGIC_GETNKEYS;
1700 PERL_UNUSED_ARG(mg);
1703 (void) hv_iterinit(hv);
1704 if (! SvTIED_mg((const SV *)hv, PERL_MAGIC_tied))
1707 while (hv_iternext(hv))
1712 sv_setiv(sv, (IV)i);
1717 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1719 PERL_ARGS_ASSERT_MAGIC_SETNKEYS;
1720 PERL_UNUSED_ARG(mg);
1722 hv_ksplit(MUTABLE_HV(LvTARG(sv)), SvIV(sv));
1728 =for apidoc magic_methcall
1730 Invoke a magic method (like FETCH).
1732 * sv and mg are the tied thinggy and the tie magic;
1733 * meth is the name of the method to call;
1734 * argc is the number of args (in addition to $self) to pass to the method;
1735 the args themselves are any values following the argc argument.
1737 G_DISCARD: invoke method with G_DISCARD flag and don't return a value
1738 G_UNDEF_FILL: fill the stack with argc pointers to PL_sv_undef.
1740 Returns the SV (if any) returned by the method, or NULL on failure.
1747 Perl_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, U32 flags,
1754 PERL_ARGS_ASSERT_MAGIC_METHCALL;
1757 PUSHSTACKi(PERLSI_MAGIC);
1761 PUSHs(SvTIED_obj(sv, mg));
1762 if (flags & G_UNDEF_FILL) {
1764 PUSHs(&PL_sv_undef);
1766 } else if (argc > 0) {
1768 va_start(args, argc);
1771 SV *const sv = va_arg(args, SV *);
1778 if (flags & G_DISCARD) {
1779 call_method(meth, G_SCALAR|G_DISCARD);
1782 if (call_method(meth, G_SCALAR))
1783 ret = *PL_stack_sp--;
1791 /* wrapper for magic_methcall that creates the first arg */
1794 S_magic_methcall1(pTHX_ SV *sv, const MAGIC *mg, const char *meth, U32 flags,
1800 PERL_ARGS_ASSERT_MAGIC_METHCALL1;
1803 if (mg->mg_len >= 0) {
1804 arg1 = newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
1806 else if (mg->mg_len == HEf_SVKEY)
1807 arg1 = MUTABLE_SV(mg->mg_ptr);
1809 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1810 arg1 = newSViv((IV)(mg->mg_len));
1814 return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n - 1, val);
1816 return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n, arg1, val);
1820 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
1825 PERL_ARGS_ASSERT_MAGIC_METHPACK;
1827 ret = magic_methcall1(sv, mg, meth, 0, 1, NULL);
1834 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1836 PERL_ARGS_ASSERT_MAGIC_GETPACK;
1838 if (mg->mg_type == PERL_MAGIC_tiedelem)
1839 mg->mg_flags |= MGf_GSKIP;
1840 magic_methpack(sv,mg,"FETCH");
1845 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1851 PERL_ARGS_ASSERT_MAGIC_SETPACK;
1853 /* in the code C<$tied{foo} = $val>, the "thing" that gets passed to
1854 * STORE() is not $val, but rather a PVLV (the sv in this call), whose
1855 * public flags indicate its value based on copying from $val. Doing
1856 * mg_set() on the PVLV temporarily does SvMAGICAL_off(), then calls us.
1857 * So STORE()'s $_[2] arg is a temporarily disarmed PVLV. This goes
1858 * wrong if $val happened to be tainted, as sv hasn't got magic
1859 * enabled, even though taint magic is in the chain. In which case,
1860 * fake up a temporary tainted value (this is easier than temporarily
1861 * re-enabling magic on sv). */
1863 if (PL_tainting && (tmg = mg_find(sv, PERL_MAGIC_taint))
1864 && (tmg->mg_len & 1))
1866 val = sv_mortalcopy(sv);
1872 magic_methcall1(sv, mg, "STORE", G_DISCARD, 2, val);
1877 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1879 PERL_ARGS_ASSERT_MAGIC_CLEARPACK;
1881 return magic_methpack(sv,mg,"DELETE");
1886 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1892 PERL_ARGS_ASSERT_MAGIC_SIZEPACK;
1894 retsv = magic_methcall1(sv, mg, "FETCHSIZE", 0, 1, NULL);
1896 retval = SvIV(retsv)-1;
1898 Perl_croak(aTHX_ "FETCHSIZE returned a negative value");
1900 return (U32) retval;
1904 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1908 PERL_ARGS_ASSERT_MAGIC_WIPEPACK;
1910 Perl_magic_methcall(aTHX_ sv, mg, "CLEAR", G_DISCARD, 0);
1915 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1920 PERL_ARGS_ASSERT_MAGIC_NEXTPACK;
1922 ret = SvOK(key) ? Perl_magic_methcall(aTHX_ sv, mg, "NEXTKEY", 0, 1, key)
1923 : Perl_magic_methcall(aTHX_ sv, mg, "FIRSTKEY", 0, 0);
1930 Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg)
1932 PERL_ARGS_ASSERT_MAGIC_EXISTSPACK;
1934 return magic_methpack(sv,mg,"EXISTS");
1938 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1942 SV * const tied = SvTIED_obj(MUTABLE_SV(hv), mg);
1943 HV * const pkg = SvSTASH((const SV *)SvRV(tied));
1945 PERL_ARGS_ASSERT_MAGIC_SCALARPACK;
1947 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1949 if (HvEITER_get(hv))
1950 /* we are in an iteration so the hash cannot be empty */
1952 /* no xhv_eiter so now use FIRSTKEY */
1953 key = sv_newmortal();
1954 magic_nextpack(MUTABLE_SV(hv), mg, key);
1955 HvEITER_set(hv, NULL); /* need to reset iterator */
1956 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1959 /* there is a SCALAR method that we can call */
1960 retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(hv), mg, "SCALAR", 0, 0);
1962 retval = &PL_sv_undef;
1967 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1970 GV * const gv = PL_DBline;
1971 const I32 i = SvTRUE(sv);
1972 SV ** const svp = av_fetch(GvAV(gv),
1973 atoi(MgPV_nolen_const(mg)), FALSE);
1975 PERL_ARGS_ASSERT_MAGIC_SETDBLINE;
1977 if (svp && SvIOKp(*svp)) {
1978 OP * const o = INT2PTR(OP*,SvIVX(*svp));
1980 /* set or clear breakpoint in the relevant control op */
1982 o->op_flags |= OPf_SPECIAL;
1984 o->op_flags &= ~OPf_SPECIAL;
1991 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
1994 AV * const obj = MUTABLE_AV(mg->mg_obj);
1996 PERL_ARGS_ASSERT_MAGIC_GETARYLEN;
1999 sv_setiv(sv, AvFILL(obj) + CopARYBASE_get(PL_curcop));
2007 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
2010 AV * const obj = MUTABLE_AV(mg->mg_obj);
2012 PERL_ARGS_ASSERT_MAGIC_SETARYLEN;
2015 av_fill(obj, SvIV(sv) - CopARYBASE_get(PL_curcop));
2017 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
2018 "Attempt to set length of freed array");
2024 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
2028 PERL_ARGS_ASSERT_MAGIC_FREEARYLEN_P;
2029 PERL_UNUSED_ARG(sv);
2031 /* during global destruction, mg_obj may already have been freed */
2032 if (PL_in_clean_all)
2035 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
2038 /* arylen scalar holds a pointer back to the array, but doesn't own a
2039 reference. Hence the we (the array) are about to go away with it
2040 still pointing at us. Clear its pointer, else it would be pointing
2041 at free memory. See the comment in sv_magic about reference loops,
2042 and why it can't own a reference to us. */
2049 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
2052 SV* const lsv = LvTARG(sv);
2054 PERL_ARGS_ASSERT_MAGIC_GETPOS;
2055 PERL_UNUSED_ARG(mg);
2057 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
2058 MAGIC * const found = mg_find(lsv, PERL_MAGIC_regex_global);
2059 if (found && found->mg_len >= 0) {
2060 I32 i = found->mg_len;
2062 sv_pos_b2u(lsv, &i);
2063 sv_setiv(sv, i + CopARYBASE_get(PL_curcop));
2072 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
2075 SV* const lsv = LvTARG(sv);
2081 PERL_ARGS_ASSERT_MAGIC_SETPOS;
2082 PERL_UNUSED_ARG(mg);
2084 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
2085 found = mg_find(lsv, PERL_MAGIC_regex_global);
2091 #ifdef PERL_OLD_COPY_ON_WRITE
2093 sv_force_normal_flags(lsv, 0);
2095 found = sv_magicext(lsv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
2098 else if (!SvOK(sv)) {
2102 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
2104 pos = SvIV(sv) - CopARYBASE_get(PL_curcop);
2107 ulen = sv_len_utf8(lsv);
2117 else if (pos > (SSize_t)len)
2122 sv_pos_u2b(lsv, &p, 0);
2126 found->mg_len = pos;
2127 found->mg_flags &= ~MGf_MINMATCH;
2133 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
2136 SV * const lsv = LvTARG(sv);
2137 const char * const tmps = SvPV_const(lsv,len);
2138 STRLEN offs = LvTARGOFF(sv);
2139 STRLEN rem = LvTARGLEN(sv);
2141 PERL_ARGS_ASSERT_MAGIC_GETSUBSTR;
2142 PERL_UNUSED_ARG(mg);
2145 offs = sv_pos_u2b_flags(lsv, offs, &rem, SV_CONST_RETURN);
2148 if (rem > len - offs)
2150 sv_setpvn(sv, tmps + offs, rem);
2157 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
2161 const char * const tmps = SvPV_const(sv, len);
2162 SV * const lsv = LvTARG(sv);
2163 STRLEN lvoff = LvTARGOFF(sv);
2164 STRLEN lvlen = LvTARGLEN(sv);
2166 PERL_ARGS_ASSERT_MAGIC_SETSUBSTR;
2167 PERL_UNUSED_ARG(mg);
2170 sv_utf8_upgrade(lsv);
2171 lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
2172 sv_insert(lsv, lvoff, lvlen, tmps, len);
2173 LvTARGLEN(sv) = sv_len_utf8(sv);
2176 else if (lsv && SvUTF8(lsv)) {
2178 lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
2179 LvTARGLEN(sv) = len;
2180 utf8 = (char*)bytes_to_utf8((U8*)tmps, &len);
2181 sv_insert(lsv, lvoff, lvlen, utf8, len);
2185 sv_insert(lsv, lvoff, lvlen, tmps, len);
2186 LvTARGLEN(sv) = len;
2193 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
2197 PERL_ARGS_ASSERT_MAGIC_GETTAINT;
2198 PERL_UNUSED_ARG(sv);
2200 TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
2205 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
2209 PERL_ARGS_ASSERT_MAGIC_SETTAINT;
2210 PERL_UNUSED_ARG(sv);
2212 /* update taint status */
2221 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
2223 SV * const lsv = LvTARG(sv);
2225 PERL_ARGS_ASSERT_MAGIC_GETVEC;
2226 PERL_UNUSED_ARG(mg);
2229 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
2237 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
2239 PERL_ARGS_ASSERT_MAGIC_SETVEC;
2240 PERL_UNUSED_ARG(mg);
2241 do_vecset(sv); /* XXX slurp this routine */
2246 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
2251 PERL_ARGS_ASSERT_MAGIC_GETDEFELEM;
2253 if (LvTARGLEN(sv)) {
2255 SV * const ahv = LvTARG(sv);
2256 HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, FALSE, 0);
2261 AV *const av = MUTABLE_AV(LvTARG(sv));
2262 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
2263 targ = AvARRAY(av)[LvTARGOFF(sv)];
2265 if (targ && (targ != &PL_sv_undef)) {
2266 /* somebody else defined it for us */
2267 SvREFCNT_dec(LvTARG(sv));
2268 LvTARG(sv) = SvREFCNT_inc_simple_NN(targ);
2270 SvREFCNT_dec(mg->mg_obj);
2272 mg->mg_flags &= ~MGf_REFCOUNTED;
2277 sv_setsv(sv, targ ? targ : &PL_sv_undef);
2282 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
2284 PERL_ARGS_ASSERT_MAGIC_SETDEFELEM;
2285 PERL_UNUSED_ARG(mg);
2289 sv_setsv(LvTARG(sv), sv);
2290 SvSETMAGIC(LvTARG(sv));
2296 Perl_vivify_defelem(pTHX_ SV *sv)
2302 PERL_ARGS_ASSERT_VIVIFY_DEFELEM;
2304 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2307 SV * const ahv = LvTARG(sv);
2308 HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, TRUE, 0);
2311 if (!value || value == &PL_sv_undef)
2312 Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(mg->mg_obj));
2315 AV *const av = MUTABLE_AV(LvTARG(sv));
2316 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
2317 LvTARG(sv) = NULL; /* array can't be extended */
2319 SV* const * const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
2320 if (!svp || (value = *svp) == &PL_sv_undef)
2321 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
2324 SvREFCNT_inc_simple_void(value);
2325 SvREFCNT_dec(LvTARG(sv));
2328 SvREFCNT_dec(mg->mg_obj);
2330 mg->mg_flags &= ~MGf_REFCOUNTED;
2334 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2336 PERL_ARGS_ASSERT_MAGIC_KILLBACKREFS;
2337 Perl_sv_kill_backrefs(aTHX_ sv, MUTABLE_AV(mg->mg_obj));
2342 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2344 PERL_ARGS_ASSERT_MAGIC_SETMGLOB;
2345 PERL_UNUSED_CONTEXT;
2347 if (!isGV_with_GP(sv))
2353 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2355 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2357 PERL_ARGS_ASSERT_MAGIC_SETUVAR;
2359 if (uf && uf->uf_set)
2360 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2365 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2367 const char type = mg->mg_type;
2369 PERL_ARGS_ASSERT_MAGIC_SETREGEXP;
2371 if (type == PERL_MAGIC_qr) {
2372 } else if (type == PERL_MAGIC_bm) {
2376 assert(type == PERL_MAGIC_fm);
2379 return sv_unmagic(sv, type);
2382 #ifdef USE_LOCALE_COLLATE
2384 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2386 PERL_ARGS_ASSERT_MAGIC_SETCOLLXFRM;
2389 * RenE<eacute> Descartes said "I think not."
2390 * and vanished with a faint plop.
2392 PERL_UNUSED_CONTEXT;
2393 PERL_UNUSED_ARG(sv);
2395 Safefree(mg->mg_ptr);
2401 #endif /* USE_LOCALE_COLLATE */
2403 /* Just clear the UTF-8 cache data. */
2405 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2407 PERL_ARGS_ASSERT_MAGIC_SETUTF8;
2408 PERL_UNUSED_CONTEXT;
2409 PERL_UNUSED_ARG(sv);
2410 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2412 mg->mg_len = -1; /* The mg_len holds the len cache. */
2417 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2420 register const char *s;
2422 register const REGEXP * rx;
2423 const char * const remaining = mg->mg_ptr + 1;
2428 PERL_ARGS_ASSERT_MAGIC_SET;
2430 switch (*mg->mg_ptr) {
2431 case '\015': /* $^MATCH */
2432 if (strEQ(remaining, "ATCH"))
2434 case '`': /* ${^PREMATCH} caught below */
2436 paren = RX_BUFF_IDX_PREMATCH;
2438 case '\'': /* ${^POSTMATCH} caught below */
2440 paren = RX_BUFF_IDX_POSTMATCH;
2444 paren = RX_BUFF_IDX_FULLMATCH;
2446 case '1': case '2': case '3': case '4':
2447 case '5': case '6': case '7': case '8': case '9':
2448 paren = atoi(mg->mg_ptr);
2450 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
2451 CALLREG_NUMBUF_STORE((REGEXP * const)rx,paren,sv);
2453 /* Croak with a READONLY error when a numbered match var is
2454 * set without a previous pattern match. Unless it's C<local $1>
2456 if (!PL_localizing) {
2457 Perl_croak_no_modify(aTHX);
2461 case '\001': /* ^A */
2462 sv_setsv(PL_bodytarget, sv);
2463 /* mg_set() has temporarily made sv non-magical */
2465 if ((tmg = mg_find(sv,PERL_MAGIC_taint)) && tmg->mg_len & 1)
2466 SvTAINTED_on(PL_bodytarget);
2468 SvTAINTED_off(PL_bodytarget);
2471 case '\003': /* ^C */
2472 PL_minus_c = cBOOL(SvIV(sv));
2475 case '\004': /* ^D */
2477 s = SvPV_nolen_const(sv);
2478 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2479 if (DEBUG_x_TEST || DEBUG_B_TEST)
2480 dump_all_perl(!DEBUG_B_TEST);
2482 PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG;
2485 case '\005': /* ^E */
2486 if (*(mg->mg_ptr+1) == '\0') {
2488 set_vaxc_errno(SvIV(sv));
2491 SetLastError( SvIV(sv) );
2494 os2_setsyserrno(SvIV(sv));
2496 /* will anyone ever use this? */
2497 SETERRNO(SvIV(sv), 4);
2502 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2503 SvREFCNT_dec(PL_encoding);
2504 if (SvOK(sv) || SvGMAGICAL(sv)) {
2505 PL_encoding = newSVsv(sv);
2512 case '\006': /* ^F */
2513 PL_maxsysfd = SvIV(sv);
2515 case '\010': /* ^H */
2516 PL_hints = SvIV(sv);
2518 case '\011': /* ^I */ /* NOT \t in EBCDIC */
2519 Safefree(PL_inplace);
2520 PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
2522 case '\017': /* ^O */
2523 if (*(mg->mg_ptr+1) == '\0') {
2524 Safefree(PL_osname);
2527 TAINT_PROPER("assigning to $^O");
2528 PL_osname = savesvpv(sv);
2531 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2533 const char *const start = SvPV(sv, len);
2534 const char *out = (const char*)memchr(start, '\0', len);
2538 PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2539 PL_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2541 /* Opening for input is more common than opening for output, so
2542 ensure that hints for input are sooner on linked list. */
2543 tmp = out ? newSVpvn_flags(out + 1, start + len - out - 1,
2545 : newSVpvs_flags("", SvUTF8(sv));
2546 (void)hv_stores(GvHV(PL_hintgv), "open>", tmp);
2549 tmp = newSVpvn_flags(start, out ? (STRLEN)(out - start) : len,
2551 (void)hv_stores(GvHV(PL_hintgv), "open<", tmp);
2555 case '\020': /* ^P */
2556 if (*remaining == '\0') { /* ^P */
2557 PL_perldb = SvIV(sv);
2558 if (PL_perldb && !PL_DBsingle)
2561 } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
2563 } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
2567 case '\024': /* ^T */
2569 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2571 PL_basetime = (Time_t)SvIV(sv);
2574 case '\025': /* ^UTF8CACHE */
2575 if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
2576 PL_utf8cache = (signed char) sv_2iv(sv);
2579 case '\027': /* ^W & $^WARNING_BITS */
2580 if (*(mg->mg_ptr+1) == '\0') {
2581 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2583 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2584 | (i ? G_WARN_ON : G_WARN_OFF) ;
2587 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2588 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2589 if (!SvPOK(sv) && PL_localizing) {
2590 sv_setpvn(sv, WARN_NONEstring, WARNsize);
2591 PL_compiling.cop_warnings = pWARN_NONE;
2596 int accumulate = 0 ;
2597 int any_fatals = 0 ;
2598 const char * const ptr = SvPV_const(sv, len) ;
2599 for (i = 0 ; i < len ; ++i) {
2600 accumulate |= ptr[i] ;
2601 any_fatals |= (ptr[i] & 0xAA) ;
2604 if (!specialWARN(PL_compiling.cop_warnings))
2605 PerlMemShared_free(PL_compiling.cop_warnings);
2606 PL_compiling.cop_warnings = pWARN_NONE;
2608 /* Yuck. I can't see how to abstract this: */
2609 else if (isWARN_on(((STRLEN *)SvPV_nolen_const(sv)) - 1,
2610 WARN_ALL) && !any_fatals) {
2611 if (!specialWARN(PL_compiling.cop_warnings))
2612 PerlMemShared_free(PL_compiling.cop_warnings);
2613 PL_compiling.cop_warnings = pWARN_ALL;
2614 PL_dowarn |= G_WARN_ONCE ;
2618 const char *const p = SvPV_const(sv, len);
2620 PL_compiling.cop_warnings
2621 = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
2624 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2625 PL_dowarn |= G_WARN_ONCE ;
2633 if (PL_localizing) {
2634 if (PL_localizing == 1)
2635 SAVESPTR(PL_last_in_gv);
2637 else if (SvOK(sv) && GvIO(PL_last_in_gv))
2638 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2641 if (isGV_with_GP(PL_defoutgv)) {
2642 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2643 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2644 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2648 if (isGV_with_GP(PL_defoutgv)) {
2649 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2650 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2651 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2655 if (isGV_with_GP(PL_defoutgv))
2656 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
2659 if (isGV_with_GP(PL_defoutgv)) {
2660 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
2661 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2662 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2666 if (isGV_with_GP(PL_defoutgv))
2667 IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
2671 IO * const io = GvIO(PL_defoutgv);
2674 if ((SvIV(sv)) == 0)
2675 IoFLAGS(io) &= ~IOf_FLUSH;
2677 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2678 PerlIO *ofp = IoOFP(io);
2680 (void)PerlIO_flush(ofp);
2681 IoFLAGS(io) |= IOf_FLUSH;
2687 SvREFCNT_dec(PL_rs);
2688 PL_rs = newSVsv(sv);
2691 SvREFCNT_dec(PL_ors_sv);
2692 if (SvOK(sv) || SvGMAGICAL(sv)) {
2693 PL_ors_sv = newSVsv(sv);
2700 CopARYBASE_set(&PL_compiling, SvIV(sv));
2703 #ifdef COMPLEX_STATUS
2704 if (PL_localizing == 2) {
2705 SvUPGRADE(sv, SVt_PVLV);
2706 PL_statusvalue = LvTARGOFF(sv);
2707 PL_statusvalue_vms = LvTARGLEN(sv);
2711 #ifdef VMSISH_STATUS
2713 STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2716 STATUS_UNIX_EXIT_SET(SvIV(sv));
2721 # define PERL_VMS_BANG vaxc$errno
2723 # define PERL_VMS_BANG 0
2725 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2726 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2731 if (PL_delaymagic) {
2732 PL_delaymagic |= DM_RUID;
2733 break; /* don't do magic till later */
2736 (void)setruid((Uid_t)PL_uid);
2739 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2741 #ifdef HAS_SETRESUID
2742 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2744 if (PL_uid == PL_euid) { /* special case $< = $> */
2746 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2747 if (PL_uid != 0 && PerlProc_getuid() == 0)
2748 (void)PerlProc_setuid(0);
2750 (void)PerlProc_setuid(PL_uid);
2752 PL_uid = PerlProc_getuid();
2753 Perl_croak(aTHX_ "setruid() not implemented");
2758 PL_uid = PerlProc_getuid();
2762 if (PL_delaymagic) {
2763 PL_delaymagic |= DM_EUID;
2764 break; /* don't do magic till later */
2767 (void)seteuid((Uid_t)PL_euid);
2770 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2772 #ifdef HAS_SETRESUID
2773 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2775 if (PL_euid == PL_uid) /* special case $> = $< */
2776 PerlProc_setuid(PL_euid);
2778 PL_euid = PerlProc_geteuid();
2779 Perl_croak(aTHX_ "seteuid() not implemented");
2784 PL_euid = PerlProc_geteuid();
2788 if (PL_delaymagic) {
2789 PL_delaymagic |= DM_RGID;
2790 break; /* don't do magic till later */
2793 (void)setrgid((Gid_t)PL_gid);
2796 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2798 #ifdef HAS_SETRESGID
2799 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2801 if (PL_gid == PL_egid) /* special case $( = $) */
2802 (void)PerlProc_setgid(PL_gid);
2804 PL_gid = PerlProc_getgid();
2805 Perl_croak(aTHX_ "setrgid() not implemented");
2810 PL_gid = PerlProc_getgid();
2813 #ifdef HAS_SETGROUPS
2815 const char *p = SvPV_const(sv, len);
2816 Groups_t *gary = NULL;
2817 #ifdef _SC_NGROUPS_MAX
2818 int maxgrp = sysconf(_SC_NGROUPS_MAX);
2823 int maxgrp = NGROUPS;
2829 for (i = 0; i < maxgrp; ++i) {
2830 while (*p && !isSPACE(*p))
2837 Newx(gary, i + 1, Groups_t);
2839 Renew(gary, i + 1, Groups_t);
2843 (void)setgroups(i, gary);
2846 #else /* HAS_SETGROUPS */
2848 #endif /* HAS_SETGROUPS */
2849 if (PL_delaymagic) {
2850 PL_delaymagic |= DM_EGID;
2851 break; /* don't do magic till later */
2854 (void)setegid((Gid_t)PL_egid);
2857 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2859 #ifdef HAS_SETRESGID
2860 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2862 if (PL_egid == PL_gid) /* special case $) = $( */
2863 (void)PerlProc_setgid(PL_egid);
2865 PL_egid = PerlProc_getegid();
2866 Perl_croak(aTHX_ "setegid() not implemented");
2871 PL_egid = PerlProc_getegid();
2874 PL_chopset = SvPV_force(sv,len);
2877 LOCK_DOLLARZERO_MUTEX;
2878 #ifdef HAS_SETPROCTITLE
2879 /* The BSDs don't show the argv[] in ps(1) output, they
2880 * show a string from the process struct and provide
2881 * the setproctitle() routine to manipulate that. */
2882 if (PL_origalen != 1) {
2883 s = SvPV_const(sv, len);
2884 # if __FreeBSD_version > 410001
2885 /* The leading "-" removes the "perl: " prefix,
2886 * but not the "(perl) suffix from the ps(1)
2887 * output, because that's what ps(1) shows if the
2888 * argv[] is modified. */
2889 setproctitle("-%s", s);
2890 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2891 /* This doesn't really work if you assume that
2892 * $0 = 'foobar'; will wipe out 'perl' from the $0
2893 * because in ps(1) output the result will be like
2894 * sprintf("perl: %s (perl)", s)
2895 * I guess this is a security feature:
2896 * one (a user process) cannot get rid of the original name.
2898 setproctitle("%s", s);
2901 #elif defined(__hpux) && defined(PSTAT_SETCMD)
2902 if (PL_origalen != 1) {
2904 s = SvPV_const(sv, len);
2905 un.pst_command = (char *)s;
2906 pstat(PSTAT_SETCMD, un, len, 0, 0);
2909 if (PL_origalen > 1) {
2910 /* PL_origalen is set in perl_parse(). */
2911 s = SvPV_force(sv,len);
2912 if (len >= (STRLEN)PL_origalen-1) {
2913 /* Longer than original, will be truncated. We assume that
2914 * PL_origalen bytes are available. */
2915 Copy(s, PL_origargv[0], PL_origalen-1, char);
2918 /* Shorter than original, will be padded. */
2920 /* Special case for Mac OS X: see [perl #38868] */
2923 /* Is the space counterintuitive? Yes.
2924 * (You were expecting \0?)
2925 * Does it work? Seems to. (In Linux 2.4.20 at least.)
2927 const int pad = ' ';
2929 Copy(s, PL_origargv[0], len, char);
2930 PL_origargv[0][len] = 0;
2931 memset(PL_origargv[0] + len + 1,
2932 pad, PL_origalen - len - 1);
2934 PL_origargv[0][PL_origalen-1] = 0;
2935 for (i = 1; i < PL_origargc; i++)
2937 #ifdef HAS_PRCTL_SET_NAME
2938 /* Set the legacy process name in addition to the POSIX name on Linux */
2939 if (prctl(PR_SET_NAME, (unsigned long)s, 0, 0, 0) != 0) {
2940 /* diag_listed_as: SKIPME */
2941 Perl_croak(aTHX_ "Can't set $0 with prctl(): %s", Strerror(errno));
2946 UNLOCK_DOLLARZERO_MUTEX;
2953 Perl_whichsig(pTHX_ const char *sig)
2955 register char* const* sigv;
2957 PERL_ARGS_ASSERT_WHICHSIG;
2958 PERL_UNUSED_CONTEXT;
2960 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
2961 if (strEQ(sig,*sigv))
2962 return PL_sig_num[sigv - (char* const*)PL_sig_name];
2964 if (strEQ(sig,"CHLD"))
2968 if (strEQ(sig,"CLD"))
2975 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2976 Perl_sighandler(int sig, siginfo_t *sip, void *uap PERL_UNUSED_DECL)
2978 Perl_sighandler(int sig)
2981 #ifdef PERL_GET_SIG_CONTEXT
2982 dTHXa(PERL_GET_SIG_CONTEXT);
2989 SV * const tSv = PL_Sv;
2993 XPV * const tXpv = PL_Xpv;
2994 I32 old_ss_ix = PL_savestack_ix;
2997 if (!PL_psig_ptr[sig]) {
2998 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
3003 /* Max number of items pushed there is 3*n or 4. We cannot fix
3004 infinity, so we fix 4 (in fact 5): */
3005 if (PL_savestack_ix + 15 <= PL_savestack_max) {
3007 PL_savestack_ix += 5; /* Protect save in progress. */
3008 SAVEDESTRUCTOR_X(S_unwind_handler_stack, NULL);
3010 if (PL_markstack_ptr < PL_markstack_max - 2) {
3012 PL_markstack_ptr++; /* Protect mark. */
3014 if (PL_scopestack_ix < PL_scopestack_max - 3) {
3018 /* sv_2cv is too complicated, try a simpler variant first: */
3019 if (!SvROK(PL_psig_ptr[sig]) || !(cv = MUTABLE_CV(SvRV(PL_psig_ptr[sig])))
3020 || SvTYPE(cv) != SVt_PVCV) {
3022 cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
3025 if (!cv || !CvROOT(cv)) {
3026 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
3027 PL_sig_name[sig], (gv ? GvENAME(gv)
3034 sv = PL_psig_name[sig]
3035 ? SvREFCNT_inc_NN(PL_psig_name[sig])
3036 : newSVpv(PL_sig_name[sig],0);
3040 /* make sure our assumption about the size of the SAVEs are correct:
3041 * 3 for SAVEDESTRUCTOR_X, 2 for SAVEFREESV */
3042 assert(old_ss_ix + 2 + ((flags & 1) ? 3+5 : 0) == PL_savestack_ix);
3044 PUSHSTACKi(PERLSI_SIGNAL);
3047 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3049 struct sigaction oact;
3051 if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
3054 SV *rv = newRV_noinc(MUTABLE_SV(sih));
3055 /* The siginfo fields signo, code, errno, pid, uid,
3056 * addr, status, and band are defined by POSIX/SUSv3. */
3057 (void)hv_stores(sih, "signo", newSViv(sip->si_signo));
3058 (void)hv_stores(sih, "code", newSViv(sip->si_code));
3059 #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. */
3060 hv_stores(sih, "errno", newSViv(sip->si_errno));
3061 hv_stores(sih, "status", newSViv(sip->si_status));
3062 hv_stores(sih, "uid", newSViv(sip->si_uid));
3063 hv_stores(sih, "pid", newSViv(sip->si_pid));
3064 hv_stores(sih, "addr", newSVuv(PTR2UV(sip->si_addr)));
3065 hv_stores(sih, "band", newSViv(sip->si_band));
3069 mPUSHp((char *)sip, sizeof(*sip));
3077 call_sv(MUTABLE_SV(cv), G_DISCARD|G_EVAL);
3080 if (SvTRUE(ERRSV)) {
3082 #ifdef HAS_SIGPROCMASK
3083 /* Handler "died", for example to get out of a restart-able read().
3084 * Before we re-do that on its behalf re-enable the signal which was
3085 * blocked by the system when we entered.
3089 sigaddset(&set,sig);
3090 sigprocmask(SIG_UNBLOCK, &set, NULL);
3092 /* Not clear if this will work */
3093 (void)rsignal(sig, SIG_IGN);
3094 (void)rsignal(sig, PL_csighandlerp);
3096 #endif /* !PERL_MICRO */
3100 /* pop any of SAVEFREESV, SAVEDESTRUCTOR_X and "save in progress" */
3101 PL_savestack_ix = old_ss_ix;
3105 PL_scopestack_ix -= 1;
3108 PL_op = myop; /* Apparently not needed... */
3110 PL_Sv = tSv; /* Restore global temporaries. */
3117 S_restore_magic(pTHX_ const void *p)
3120 MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
3121 SV* const sv = mgs->mgs_sv;
3126 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
3128 #ifdef PERL_OLD_COPY_ON_WRITE
3129 /* While magic was saved (and off) sv_setsv may well have seen
3130 this SV as a prime candidate for COW. */
3132 sv_force_normal_flags(sv, 0);
3135 if (mgs->mgs_readonly)
3137 if (mgs->mgs_magical)
3138 SvFLAGS(sv) |= mgs->mgs_magical;
3141 if (SvGMAGICAL(sv)) {
3142 /* downgrade public flags to private,
3143 and discard any other private flags */
3145 const U32 pubflags = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
3147 SvFLAGS(sv) &= ~( pubflags | (SVp_IOK|SVp_NOK|SVp_POK) );
3148 SvFLAGS(sv) |= ( pubflags << PRIVSHIFT );
3153 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
3155 /* If we're still on top of the stack, pop us off. (That condition
3156 * will be satisfied if restore_magic was called explicitly, but *not*
3157 * if it's being called via leave_scope.)
3158 * The reason for doing this is that otherwise, things like sv_2cv()
3159 * may leave alloc gunk on the savestack, and some code
3160 * (e.g. sighandler) doesn't expect that...
3162 if (PL_savestack_ix == mgs->mgs_ss_ix)
3164 UV popval = SSPOPUV;
3165 assert(popval == SAVEt_DESTRUCTOR_X);
3166 PL_savestack_ix -= 2;
3168 assert((popval & SAVE_MASK) == SAVEt_ALLOC);
3169 PL_savestack_ix -= popval >> SAVE_TIGHT_SHIFT;
3174 /* clean up the mess created by Perl_sighandler().
3175 * Note that this is only called during an exit in a signal handler;
3176 * a die is trapped by the call_sv() and the SAVEDESTRUCTOR_X manually
3177 * skipped over. This is why we don't need to fix up the markstack and
3178 * scopestack - they're going to be set to 0 anyway */
3181 S_unwind_handler_stack(pTHX_ const void *p)
3186 PL_savestack_ix -= 5; /* Unprotect save in progress. */
3190 =for apidoc magic_sethint
3192 Triggered by a store to %^H, records the key/value pair to
3193 C<PL_compiling.cop_hints_hash>. It is assumed that hints aren't storing
3194 anything that would need a deep copy. Maybe we should warn if we find a
3200 Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
3203 SV *key = (mg->mg_len == HEf_SVKEY) ? MUTABLE_SV(mg->mg_ptr)
3204 : newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
3206 PERL_ARGS_ASSERT_MAGIC_SETHINT;
3208 /* mg->mg_obj isn't being used. If needed, it would be possible to store
3209 an alternative leaf in there, with PL_compiling.cop_hints being used if
3210 it's NULL. If needed for threads, the alternative could lock a mutex,
3211 or take other more complex action. */
3213 /* Something changed in %^H, so it will need to be restored on scope exit.
3214 Doing this here saves a lot of doing it manually in perl code (and
3215 forgetting to do it, and consequent subtle errors. */
3216 PL_hints |= HINT_LOCALIZE_HH;
3217 CopHINTHASH_set(&PL_compiling,
3218 cophh_store_sv(CopHINTHASH_get(&PL_compiling), key, 0, sv, 0));
3223 =for apidoc magic_clearhint
3225 Triggered by a delete from %^H, records the key to
3226 C<PL_compiling.cop_hints_hash>.
3231 Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
3235 PERL_ARGS_ASSERT_MAGIC_CLEARHINT;
3236 PERL_UNUSED_ARG(sv);
3238 assert(mg->mg_len == HEf_SVKEY);
3240 PERL_UNUSED_ARG(sv);
3242 PL_hints |= HINT_LOCALIZE_HH;
3243 CopHINTHASH_set(&PL_compiling,
3244 cophh_delete_sv(CopHINTHASH_get(&PL_compiling),
3245 MUTABLE_SV(mg->mg_ptr), 0, 0));
3250 =for apidoc magic_clearhints
3252 Triggered by clearing %^H, resets C<PL_compiling.cop_hints_hash>.
3257 Perl_magic_clearhints(pTHX_ SV *sv, MAGIC *mg)
3259 PERL_ARGS_ASSERT_MAGIC_CLEARHINTS;
3260 PERL_UNUSED_ARG(sv);
3261 PERL_UNUSED_ARG(mg);
3262 cophh_free(CopHINTHASH_get(&PL_compiling));
3263 CopHINTHASH_set(&PL_compiling, cophh_new_empty());
3269 * c-indentation-style: bsd
3271 * indent-tabs-mode: t
3274 * ex: set ts=8 sts=4 sw=4 noet: