3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * Sam sat on the ground and put his head in his hands. 'I wish I had never
13 * come here, and I don't want to see no more magic,' he said, and fell silent.
15 * [p.363 of _The Lord of the Rings_, II/vii: "The Mirror of Galadriel"]
19 =head1 Magical Functions
21 "Magic" is special data attached to SV structures in order to give them
22 "magical" properties. When any Perl code tries to read from, or assign to,
23 an SV marked as magical, it calls the 'get' or 'set' function associated
24 with that SV's magic. A get is called prior to reading an SV, in order to
25 give it a chance to update its internal value (get on $. writes the line
26 number of the last read filehandle into to the SV's IV slot), while
27 set is called after an SV has been written to, in order to allow it to make
28 use of its changed value (set on $/ copies the SV's new value to the
29 PL_rs global variable).
31 Magic is implemented as a linked list of MAGIC structures attached to the
32 SV. Each MAGIC struct holds the type of the magic, a pointer to an array
33 of functions that implement the get(), set(), length() etc functions,
34 plus space for some flags and pointers. For example, a tied variable has
35 a MAGIC structure that contains a pointer to the object associated with the
44 #if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS)
50 #if defined(HAS_SETGROUPS)
57 # include <sys/pstat.h>
60 #ifdef HAS_PRCTL_SET_NAME
61 # include <sys/prctl.h>
64 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
65 Signal_t Perl_csighandler(int sig, siginfo_t *, void *);
67 Signal_t Perl_csighandler(int sig);
71 /* Missing protos on LynxOS */
72 void setruid(uid_t id);
73 void seteuid(uid_t id);
74 void setrgid(uid_t id);
75 void setegid(uid_t id);
79 * Use the "DESTRUCTOR" scope cleanup to reinstate magic.
88 /* MGS is typedef'ed to struct magic_state in perl.h */
91 S_save_magic(pTHX_ I32 mgs_ix, SV *sv)
96 PERL_ARGS_ASSERT_SAVE_MAGIC;
98 /* guard against sv having being freed midway by holding a private
100 SvREFCNT_inc_simple_void_NN(sv);
102 assert(SvMAGICAL(sv));
103 /* Turning READONLY off for a copy-on-write scalar (including shared
104 hash keys) is a bad idea. */
106 sv_force_normal_flags(sv, 0);
108 SAVEDESTRUCTOR_X(S_restore_magic, INT2PTR(void*, (IV)mgs_ix));
110 mgs = SSPTR(mgs_ix, MGS*);
112 mgs->mgs_magical = SvMAGICAL(sv);
113 mgs->mgs_readonly = SvREADONLY(sv) != 0;
114 mgs->mgs_ss_ix = PL_savestack_ix; /* points after the saved destructor */
118 if (!(SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK))) {
119 /* No public flags are set, so promote any private flags to public. */
120 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
125 =for apidoc mg_magical
127 Turns on the magical status of an SV. See C<sv_magic>.
133 Perl_mg_magical(pTHX_ SV *sv)
136 PERL_ARGS_ASSERT_MG_MAGICAL;
140 if ((mg = SvMAGIC(sv))) {
142 const MGVTBL* const vtbl = mg->mg_virtual;
144 if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
151 } while ((mg = mg->mg_moremagic));
152 if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)))
158 /* is this container magic (%ENV, $1 etc), or value magic (pos, taint etc)? */
161 S_is_container_magic(const MAGIC *mg)
164 switch (mg->mg_type) {
167 case PERL_MAGIC_regex_global:
168 case PERL_MAGIC_nkeys:
169 #ifdef USE_LOCALE_COLLATE
170 case PERL_MAGIC_collxfrm:
173 case PERL_MAGIC_taint:
175 case PERL_MAGIC_vstring:
176 case PERL_MAGIC_utf8:
177 case PERL_MAGIC_substr:
178 case PERL_MAGIC_defelem:
179 case PERL_MAGIC_arylen:
181 case PERL_MAGIC_backref:
182 case PERL_MAGIC_arylen_p:
183 case PERL_MAGIC_rhash:
184 case PERL_MAGIC_symtab:
185 case PERL_MAGIC_tied: /* treat as value, so 'local @tied' isn't tied */
186 case PERL_MAGIC_checkcall:
196 Do magic after a value is retrieved from the SV. See C<sv_magic>.
202 Perl_mg_get(pTHX_ SV *sv)
205 const I32 mgs_ix = SSNEW(sizeof(MGS));
207 MAGIC *newmg, *head, *cur, *mg;
209 PERL_ARGS_ASSERT_MG_GET;
211 save_magic(mgs_ix, sv);
213 /* We must call svt_get(sv, mg) for each valid entry in the linked
214 list of magic. svt_get() may delete the current entry, add new
215 magic to the head of the list, or upgrade the SV. AMS 20010810 */
217 newmg = cur = head = mg = SvMAGIC(sv);
219 const MGVTBL * const vtbl = mg->mg_virtual;
220 MAGIC * const nextmg = mg->mg_moremagic; /* it may delete itself */
222 if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
223 vtbl->svt_get(aTHX_ sv, mg);
225 /* guard against magic having been deleted - eg FETCH calling
228 (SSPTR(mgs_ix, MGS *))->mgs_magical = 0; /* recalculate flags */
232 /* recalculate flags if this entry was deleted. */
233 if (mg->mg_flags & MGf_GSKIP)
234 (SSPTR(mgs_ix, MGS *))->mgs_magical = 0;
240 /* Have we finished with the new entries we saw? Start again
241 where we left off (unless there are more new entries). */
249 /* Were any new entries added? */
250 if (!have_new && (newmg = SvMAGIC(sv)) != head) {
254 (SSPTR(mgs_ix, MGS *))->mgs_magical = 0; /* recalculate flags */
258 restore_magic(INT2PTR(void *, (IV)mgs_ix));
265 Do magic after a value is assigned to the SV. See C<sv_magic>.
271 Perl_mg_set(pTHX_ SV *sv)
274 const I32 mgs_ix = SSNEW(sizeof(MGS));
278 PERL_ARGS_ASSERT_MG_SET;
280 save_magic(mgs_ix, sv);
282 for (mg = SvMAGIC(sv); mg; mg = nextmg) {
283 const MGVTBL* vtbl = mg->mg_virtual;
284 nextmg = mg->mg_moremagic; /* it may delete itself */
285 if (mg->mg_flags & MGf_GSKIP) {
286 mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */
287 (SSPTR(mgs_ix, MGS*))->mgs_magical = 0;
289 if (PL_localizing == 2 && !S_is_container_magic(mg))
291 if (vtbl && vtbl->svt_set)
292 vtbl->svt_set(aTHX_ sv, mg);
295 restore_magic(INT2PTR(void*, (IV)mgs_ix));
300 =for apidoc mg_length
302 Report on the SV's length. See C<sv_magic>.
308 Perl_mg_length(pTHX_ SV *sv)
314 PERL_ARGS_ASSERT_MG_LENGTH;
316 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
317 const MGVTBL * const vtbl = mg->mg_virtual;
318 if (vtbl && vtbl->svt_len) {
319 const I32 mgs_ix = SSNEW(sizeof(MGS));
320 save_magic(mgs_ix, sv);
321 /* omit MGf_GSKIP -- not changed here */
322 len = vtbl->svt_len(aTHX_ sv, mg);
323 restore_magic(INT2PTR(void*, (IV)mgs_ix));
329 /* You can't know whether it's UTF-8 until you get the string again...
331 const U8 *s = (U8*)SvPV_const(sv, len);
334 len = utf8_length(s, s + len);
341 Perl_mg_size(pTHX_ SV *sv)
345 PERL_ARGS_ASSERT_MG_SIZE;
347 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
348 const MGVTBL* const vtbl = mg->mg_virtual;
349 if (vtbl && vtbl->svt_len) {
350 const I32 mgs_ix = SSNEW(sizeof(MGS));
352 save_magic(mgs_ix, sv);
353 /* omit MGf_GSKIP -- not changed here */
354 len = vtbl->svt_len(aTHX_ sv, mg);
355 restore_magic(INT2PTR(void*, (IV)mgs_ix));
362 return AvFILLp((const AV *) sv); /* Fallback to non-tied array */
366 Perl_croak(aTHX_ "Size magic not implemented");
375 Clear something magical that the SV represents. See C<sv_magic>.
381 Perl_mg_clear(pTHX_ SV *sv)
383 const I32 mgs_ix = SSNEW(sizeof(MGS));
387 PERL_ARGS_ASSERT_MG_CLEAR;
389 save_magic(mgs_ix, sv);
391 for (mg = SvMAGIC(sv); mg; mg = nextmg) {
392 const MGVTBL* const vtbl = mg->mg_virtual;
393 /* omit GSKIP -- never set here */
395 nextmg = mg->mg_moremagic; /* it may delete itself */
397 if (vtbl && vtbl->svt_clear)
398 vtbl->svt_clear(aTHX_ sv, mg);
401 restore_magic(INT2PTR(void*, (IV)mgs_ix));
406 S_mg_findext_flags(pTHX_ const SV *sv, int type, const MGVTBL *vtbl, U32 flags)
415 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
416 if (mg->mg_type == type && (!flags || mg->mg_virtual == vtbl)) {
428 Finds the magic pointer for type matching the SV. See C<sv_magic>.
434 Perl_mg_find(pTHX_ const SV *sv, int type)
436 return S_mg_findext_flags(aTHX_ sv, type, NULL, 0);
440 =for apidoc mg_findext
442 Finds the magic pointer of C<type> with the given C<vtbl> for the C<SV>. See
449 Perl_mg_findext(pTHX_ const SV *sv, int type, const MGVTBL *vtbl)
451 return S_mg_findext_flags(aTHX_ sv, type, vtbl, 1);
457 Copies the magic from one SV to another. See C<sv_magic>.
463 Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
468 PERL_ARGS_ASSERT_MG_COPY;
470 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
471 const MGVTBL* const vtbl = mg->mg_virtual;
472 if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){
473 count += vtbl->svt_copy(aTHX_ sv, mg, nsv, key, klen);
476 const char type = mg->mg_type;
477 if (isUPPER(type) && type != PERL_MAGIC_uvar) {
479 (type == PERL_MAGIC_tied)
481 : (type == PERL_MAGIC_regdata && mg->mg_obj)
484 toLOWER(type), key, klen);
493 =for apidoc mg_localize
495 Copy some of the magic from an existing SV to new localized version of that
496 SV. Container magic (eg %ENV, $1, tie) gets copied, value magic doesn't (eg
499 If setmagic is false then no set magic will be called on the new (empty) SV.
500 This typically means that assignment will soon follow (e.g. 'local $x = $y'),
501 and that will handle the magic.
507 Perl_mg_localize(pTHX_ SV *sv, SV *nsv, bool setmagic)
512 PERL_ARGS_ASSERT_MG_LOCALIZE;
514 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
515 const MGVTBL* const vtbl = mg->mg_virtual;
516 if (!S_is_container_magic(mg))
519 if ((mg->mg_flags & MGf_LOCAL) && vtbl->svt_local)
520 (void)vtbl->svt_local(aTHX_ nsv, mg);
522 sv_magicext(nsv, mg->mg_obj, mg->mg_type, vtbl,
523 mg->mg_ptr, mg->mg_len);
525 /* container types should remain read-only across localization */
526 SvFLAGS(nsv) |= SvREADONLY(sv);
529 if (SvTYPE(nsv) >= SVt_PVMG && SvMAGIC(nsv)) {
530 SvFLAGS(nsv) |= SvMAGICAL(sv);
539 #define mg_free_struct(sv, mg) S_mg_free_struct(aTHX_ sv, mg)
541 S_mg_free_struct(pTHX_ SV *sv, MAGIC *mg)
543 const MGVTBL* const vtbl = mg->mg_virtual;
544 if (vtbl && vtbl->svt_free)
545 vtbl->svt_free(aTHX_ sv, mg);
546 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
547 if (mg->mg_len > 0 || mg->mg_type == PERL_MAGIC_utf8)
548 Safefree(mg->mg_ptr);
549 else if (mg->mg_len == HEf_SVKEY)
550 SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr));
552 if (mg->mg_flags & MGf_REFCOUNTED)
553 SvREFCNT_dec(mg->mg_obj);
560 Free any magic storage used by the SV. See C<sv_magic>.
566 Perl_mg_free(pTHX_ SV *sv)
571 PERL_ARGS_ASSERT_MG_FREE;
573 for (mg = SvMAGIC(sv); mg; mg = moremagic) {
574 moremagic = mg->mg_moremagic;
575 mg_free_struct(sv, mg);
576 SvMAGIC_set(sv, moremagic);
578 SvMAGIC_set(sv, NULL);
584 =for apidoc Am|void|mg_free_type|SV *sv|int how
586 Remove any magic of type I<how> from the SV I<sv>. See L</sv_magic>.
592 Perl_mg_free_type(pTHX_ SV *sv, int how)
594 MAGIC *mg, *prevmg, *moremg;
595 PERL_ARGS_ASSERT_MG_FREE_TYPE;
596 for (prevmg = NULL, mg = SvMAGIC(sv); mg; prevmg = mg, mg = moremg) {
598 moremg = mg->mg_moremagic;
599 if (mg->mg_type == how) {
600 /* temporarily move to the head of the magic chain, in case
601 custom free code relies on this historical aspect of mg_free */
603 prevmg->mg_moremagic = moremg;
604 mg->mg_moremagic = SvMAGIC(sv);
607 newhead = mg->mg_moremagic;
608 mg_free_struct(sv, mg);
609 SvMAGIC_set(sv, newhead);
619 Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
624 PERL_ARGS_ASSERT_MAGIC_REGDATA_CNT;
627 register const REGEXP * const rx = PM_GETRE(PL_curpm);
629 if (mg->mg_obj) { /* @+ */
630 /* return the number possible */
631 return RX_NPARENS(rx);
633 I32 paren = RX_LASTPAREN(rx);
635 /* return the last filled */
637 && (RX_OFFS(rx)[paren].start == -1
638 || RX_OFFS(rx)[paren].end == -1) )
649 Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
653 PERL_ARGS_ASSERT_MAGIC_REGDATUM_GET;
656 register const REGEXP * const rx = PM_GETRE(PL_curpm);
658 register const I32 paren = mg->mg_len;
663 if (paren <= (I32)RX_NPARENS(rx) &&
664 (s = RX_OFFS(rx)[paren].start) != -1 &&
665 (t = RX_OFFS(rx)[paren].end) != -1)
668 if (mg->mg_obj) /* @+ */
673 if (i > 0 && RX_MATCH_UTF8(rx)) {
674 const char * const b = RX_SUBBEG(rx);
676 i = utf8_length((U8*)b, (U8*)(b+i));
687 Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
689 PERL_ARGS_ASSERT_MAGIC_REGDATUM_SET;
692 Perl_croak_no_modify(aTHX);
693 NORETURN_FUNCTION_END;
697 Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
702 register const REGEXP * rx;
703 const char * const remaining = mg->mg_ptr + 1;
705 PERL_ARGS_ASSERT_MAGIC_LEN;
707 switch (*mg->mg_ptr) {
709 if (*remaining == '\0') { /* ^P */
711 } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
713 } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
717 case '\015': /* $^MATCH */
718 if (strEQ(remaining, "ATCH")) {
725 paren = RX_BUFF_IDX_PREMATCH;
729 paren = RX_BUFF_IDX_POSTMATCH;
733 paren = RX_BUFF_IDX_FULLMATCH;
735 case '1': case '2': case '3': case '4':
736 case '5': case '6': case '7': case '8': case '9':
737 paren = atoi(mg->mg_ptr);
739 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
741 i = CALLREG_NUMBUF_LENGTH((REGEXP * const)rx, sv, paren);
744 Perl_croak(aTHX_ "panic: magic_len: %"IVdf, (IV)i);
747 if (ckWARN(WARN_UNINITIALIZED))
752 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
753 paren = RX_LASTPAREN(rx);
758 case '\016': /* ^N */
759 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
760 paren = RX_LASTCLOSEPAREN(rx);
767 if (!SvPOK(sv) && SvNIOK(sv)) {
775 #define SvRTRIM(sv) STMT_START { \
777 STRLEN len = SvCUR(sv); \
778 char * const p = SvPVX(sv); \
779 while (len > 0 && isSPACE(p[len-1])) \
781 SvCUR_set(sv, len); \
787 Perl_emulate_cop_io(pTHX_ const COP *const c, SV *const sv)
789 PERL_ARGS_ASSERT_EMULATE_COP_IO;
791 if (!(CopHINTS_get(c) & (HINT_LEXICAL_IO_IN|HINT_LEXICAL_IO_OUT)))
792 sv_setsv(sv, &PL_sv_undef);
796 if ((CopHINTS_get(c) & HINT_LEXICAL_IO_IN)) {
797 SV *const value = cop_hints_fetch_pvs(c, "open<", 0);
802 if ((CopHINTS_get(c) & HINT_LEXICAL_IO_OUT)) {
803 SV *const value = cop_hints_fetch_pvs(c, "open>", 0);
811 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
815 register const char *s = NULL;
817 const char * const remaining = mg->mg_ptr + 1;
818 const char nextchar = *remaining;
820 PERL_ARGS_ASSERT_MAGIC_GET;
822 switch (*mg->mg_ptr) {
823 case '\001': /* ^A */
824 sv_setsv(sv, PL_bodytarget);
825 if (SvTAINTED(PL_bodytarget))
828 case '\003': /* ^C, ^CHILD_ERROR_NATIVE */
829 if (nextchar == '\0') {
830 sv_setiv(sv, (IV)PL_minus_c);
832 else if (strEQ(remaining, "HILD_ERROR_NATIVE")) {
833 sv_setiv(sv, (IV)STATUS_NATIVE);
837 case '\004': /* ^D */
838 sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
840 case '\005': /* ^E */
841 if (nextchar == '\0') {
844 # include <descrip.h>
845 # include <starlet.h>
847 $DESCRIPTOR(msgdsc,msg);
848 sv_setnv(sv,(NV) vaxc$errno);
849 if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
850 sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
855 if (!(_emx_env & 0x200)) { /* Under DOS */
856 sv_setnv(sv, (NV)errno);
857 sv_setpv(sv, errno ? Strerror(errno) : "");
859 if (errno != errno_isOS2) {
860 const int tmp = _syserrno();
861 if (tmp) /* 2nd call to _syserrno() makes it 0 */
864 sv_setnv(sv, (NV)Perl_rc);
865 sv_setpv(sv, os2error(Perl_rc));
869 const DWORD dwErr = GetLastError();
870 sv_setnv(sv, (NV)dwErr);
872 PerlProc_GetOSError(sv, dwErr);
881 sv_setnv(sv, (NV)errno);
882 sv_setpv(sv, errno ? Strerror(errno) : "");
887 SvNOK_on(sv); /* what a wonderful hack! */
889 else if (strEQ(remaining, "NCODING"))
890 sv_setsv(sv, PL_encoding);
892 case '\006': /* ^F */
893 sv_setiv(sv, (IV)PL_maxsysfd);
895 case '\007': /* ^GLOBAL_PHASE */
896 if (strEQ(remaining, "LOBAL_PHASE")) {
897 sv_setpvn(sv, PL_phase_names[PL_phase],
898 strlen(PL_phase_names[PL_phase]));
901 case '\010': /* ^H */
902 sv_setiv(sv, (IV)PL_hints);
904 case '\011': /* ^I */ /* NOT \t in EBCDIC */
905 sv_setpv(sv, PL_inplace); /* Will undefine sv if PL_inplace is NULL */
907 case '\017': /* ^O & ^OPEN */
908 if (nextchar == '\0') {
909 sv_setpv(sv, PL_osname);
912 else if (strEQ(remaining, "PEN")) {
913 Perl_emulate_cop_io(aTHX_ &PL_compiling, sv);
917 if (nextchar == '\0') { /* ^P */
918 sv_setiv(sv, (IV)PL_perldb);
919 } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
920 goto do_prematch_fetch;
921 } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
922 goto do_postmatch_fetch;
925 case '\023': /* ^S */
926 if (nextchar == '\0') {
927 if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING)
930 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
935 case '\024': /* ^T */
936 if (nextchar == '\0') {
938 sv_setnv(sv, PL_basetime);
940 sv_setiv(sv, (IV)PL_basetime);
943 else if (strEQ(remaining, "AINT"))
944 sv_setiv(sv, PL_tainting
945 ? (PL_taint_warn || PL_unsafe ? -1 : 1)
948 case '\025': /* $^UNICODE, $^UTF8LOCALE, $^UTF8CACHE */
949 if (strEQ(remaining, "NICODE"))
950 sv_setuv(sv, (UV) PL_unicode);
951 else if (strEQ(remaining, "TF8LOCALE"))
952 sv_setuv(sv, (UV) PL_utf8locale);
953 else if (strEQ(remaining, "TF8CACHE"))
954 sv_setiv(sv, (IV) PL_utf8cache);
956 case '\027': /* ^W & $^WARNING_BITS */
957 if (nextchar == '\0')
958 sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
959 else if (strEQ(remaining, "ARNING_BITS")) {
960 if (PL_compiling.cop_warnings == pWARN_NONE) {
961 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
963 else if (PL_compiling.cop_warnings == pWARN_STD) {
966 (PL_dowarn & G_WARN_ON) ? WARN_ALLstring : WARN_NONEstring,
970 else if (PL_compiling.cop_warnings == pWARN_ALL) {
971 /* Get the bit mask for $warnings::Bits{all}, because
972 * it could have been extended by warnings::register */
973 HV * const bits=get_hv("warnings::Bits", 0);
975 SV ** const bits_all = hv_fetchs(bits, "all", FALSE);
977 sv_setsv(sv, *bits_all);
980 sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
984 sv_setpvn(sv, (char *) (PL_compiling.cop_warnings + 1),
985 *PL_compiling.cop_warnings);
990 case '\015': /* $^MATCH */
991 if (strEQ(remaining, "ATCH")) {
992 case '1': case '2': case '3': case '4':
993 case '5': case '6': case '7': case '8': case '9': case '&':
994 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
996 * Pre-threads, this was paren = atoi(GvENAME((const GV *)mg->mg_obj));
997 * XXX Does the new way break anything?
999 paren = atoi(mg->mg_ptr); /* $& is in [0] */
1000 CALLREG_NUMBUF_FETCH(rx,paren,sv);
1003 sv_setsv(sv,&PL_sv_undef);
1007 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
1008 if (RX_LASTPAREN(rx)) {
1009 CALLREG_NUMBUF_FETCH(rx,RX_LASTPAREN(rx),sv);
1013 sv_setsv(sv,&PL_sv_undef);
1015 case '\016': /* ^N */
1016 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
1017 if (RX_LASTCLOSEPAREN(rx)) {
1018 CALLREG_NUMBUF_FETCH(rx,RX_LASTCLOSEPAREN(rx),sv);
1023 sv_setsv(sv,&PL_sv_undef);
1027 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
1028 CALLREG_NUMBUF_FETCH(rx,-2,sv);
1031 sv_setsv(sv,&PL_sv_undef);
1035 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
1036 CALLREG_NUMBUF_FETCH(rx,-1,sv);
1039 sv_setsv(sv,&PL_sv_undef);
1042 if (GvIO(PL_last_in_gv)) {
1043 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
1048 sv_setiv(sv, (IV)STATUS_CURRENT);
1049 #ifdef COMPLEX_STATUS
1050 SvUPGRADE(sv, SVt_PVLV);
1051 LvTARGOFF(sv) = PL_statusvalue;
1052 LvTARGLEN(sv) = PL_statusvalue_vms;
1057 if (!isGV_with_GP(PL_defoutgv))
1059 else if (GvIOp(PL_defoutgv))
1060 s = IoTOP_NAME(GvIOp(PL_defoutgv));
1064 sv_setpv(sv,GvENAME(PL_defoutgv));
1065 sv_catpvs(sv,"_TOP");
1069 if (!isGV_with_GP(PL_defoutgv))
1071 else if (GvIOp(PL_defoutgv))
1072 s = IoFMT_NAME(GvIOp(PL_defoutgv));
1074 s = GvENAME(PL_defoutgv);
1078 if (GvIO(PL_defoutgv))
1079 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
1082 if (GvIO(PL_defoutgv))
1083 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
1086 if (GvIO(PL_defoutgv))
1087 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
1094 sv_setiv(sv, (IV)CopARYBASE_get(PL_curcop));
1097 if (GvIO(PL_defoutgv))
1098 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
1102 sv_copypv(sv, PL_ors_sv);
1108 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
1110 sv_setnv(sv, (NV)errno);
1113 if (errno == errno_isOS2 || errno == errno_isOS2_set)
1114 sv_setpv(sv, os2error(Perl_rc));
1117 sv_setpv(sv, errno ? Strerror(errno) : "");
1119 SvPOK_on(sv); /* may have got removed during taint processing */
1124 SvNOK_on(sv); /* what a wonderful hack! */
1127 sv_setiv(sv, (IV)PL_uid);
1130 sv_setiv(sv, (IV)PL_euid);
1133 sv_setiv(sv, (IV)PL_gid);
1136 sv_setiv(sv, (IV)PL_egid);
1138 #ifdef HAS_GETGROUPS
1140 Groups_t *gary = NULL;
1141 I32 i, num_groups = getgroups(0, gary);
1142 Newx(gary, num_groups, Groups_t);
1143 num_groups = getgroups(num_groups, gary);
1144 for (i = 0; i < num_groups; i++)
1145 Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]);
1148 (void)SvIOK_on(sv); /* what a wonderful hack! */
1158 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
1160 struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
1162 PERL_ARGS_ASSERT_MAGIC_GETUVAR;
1164 if (uf && uf->uf_val)
1165 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
1170 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
1173 STRLEN len = 0, klen;
1174 const char *s = SvOK(sv) ? SvPV_const(sv,len) : "";
1175 const char * const ptr = MgPV_const(mg,klen);
1178 PERL_ARGS_ASSERT_MAGIC_SETENV;
1180 #ifdef DYNAMIC_ENV_FETCH
1181 /* We just undefd an environment var. Is a replacement */
1182 /* waiting in the wings? */
1184 SV ** const valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE);
1186 s = SvOK(*valp) ? SvPV_const(*valp, len) : "";
1190 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
1191 /* And you'll never guess what the dog had */
1192 /* in its mouth... */
1194 MgTAINTEDDIR_off(mg);
1196 if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
1197 char pathbuf[256], eltbuf[256], *cp, *elt;
1200 my_strlcpy(eltbuf, s, sizeof(eltbuf));
1202 do { /* DCL$PATH may be a search list */
1203 while (1) { /* as may dev portion of any element */
1204 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1205 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1206 cando_by_name(S_IWUSR,0,elt) ) {
1207 MgTAINTEDDIR_on(mg);
1211 if ((cp = strchr(elt, ':')) != NULL)
1213 if (my_trnlnm(elt, eltbuf, j++))
1219 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1222 if (s && klen == 4 && strEQ(ptr,"PATH")) {
1223 const char * const strend = s + len;
1225 while (s < strend) {
1229 #ifdef VMS /* Hmm. How do we get $Config{path_sep} from C? */
1230 const char path_sep = '|';
1232 const char path_sep = ':';
1234 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
1235 s, strend, path_sep, &i);
1237 if (i >= (I32)sizeof tmpbuf /* too long -- assume the worst */
1239 || !strchr(tmpbuf, ':') /* no colon thus no device name -- assume relative path */
1241 || *tmpbuf != '/' /* no starting slash -- assume relative path */
1243 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1244 MgTAINTEDDIR_on(mg);
1250 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1256 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1258 PERL_ARGS_ASSERT_MAGIC_CLEARENV;
1259 PERL_UNUSED_ARG(sv);
1260 my_setenv(MgPV_nolen_const(mg),NULL);
1265 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1268 PERL_ARGS_ASSERT_MAGIC_SET_ALL_ENV;
1269 PERL_UNUSED_ARG(mg);
1271 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1273 if (PL_localizing) {
1276 hv_iterinit(MUTABLE_HV(sv));
1277 while ((entry = hv_iternext(MUTABLE_HV(sv)))) {
1279 my_setenv(hv_iterkey(entry, &keylen),
1280 SvPV_nolen_const(hv_iterval(MUTABLE_HV(sv), entry)));
1288 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1291 PERL_ARGS_ASSERT_MAGIC_CLEAR_ALL_ENV;
1292 PERL_UNUSED_ARG(sv);
1293 PERL_UNUSED_ARG(mg);
1295 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1303 #ifdef HAS_SIGPROCMASK
1305 restore_sigmask(pTHX_ SV *save_sv)
1307 const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1308 (void)sigprocmask(SIG_SETMASK, ossetp, NULL);
1312 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1315 /* Are we fetching a signal entry? */
1316 int i = (I16)mg->mg_private;
1318 PERL_ARGS_ASSERT_MAGIC_GETSIG;
1321 mg->mg_private = i = whichsig(MgPV_nolen_const(mg));
1326 sv_setsv(sv,PL_psig_ptr[i]);
1328 Sighandler_t sigstate = rsignal_state(i);
1329 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1330 if (PL_sig_handlers_initted && PL_sig_ignoring[i])
1333 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1334 if (PL_sig_handlers_initted && PL_sig_defaulting[i])
1337 /* cache state so we don't fetch it again */
1338 if(sigstate == (Sighandler_t) SIG_IGN)
1339 sv_setpvs(sv,"IGNORE");
1341 sv_setsv(sv,&PL_sv_undef);
1342 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1349 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1351 PERL_ARGS_ASSERT_MAGIC_CLEARSIG;
1352 PERL_UNUSED_ARG(sv);
1354 magic_setsig(NULL, mg);
1355 return sv_unmagic(sv, mg->mg_type);
1359 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1360 Perl_csighandler(int sig, siginfo_t *sip PERL_UNUSED_DECL, void *uap PERL_UNUSED_DECL)
1362 Perl_csighandler(int sig)
1365 #ifdef PERL_GET_SIG_CONTEXT
1366 dTHXa(PERL_GET_SIG_CONTEXT);
1370 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1371 (void) rsignal(sig, PL_csighandlerp);
1372 if (PL_sig_ignoring[sig]) return;
1374 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1375 if (PL_sig_defaulting[sig])
1376 #ifdef KILL_BY_SIGPRC
1377 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1392 (PL_signals & PERL_SIGNALS_UNSAFE_FLAG))
1393 /* Call the perl level handler now--
1394 * with risk we may be in malloc() or being destructed etc. */
1395 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1396 (*PL_sighandlerp)(sig, NULL, NULL);
1398 (*PL_sighandlerp)(sig);
1401 if (!PL_psig_pend) return;
1402 /* Set a flag to say this signal is pending, that is awaiting delivery after
1403 * the current Perl opcode completes */
1404 PL_psig_pend[sig]++;
1406 #ifndef SIG_PENDING_DIE_COUNT
1407 # define SIG_PENDING_DIE_COUNT 120
1409 /* Add one to say _a_ signal is pending */
1410 if (++PL_sig_pending >= SIG_PENDING_DIE_COUNT)
1411 Perl_croak(aTHX_ "Maximal count of pending signals (%lu) exceeded",
1412 (unsigned long)SIG_PENDING_DIE_COUNT);
1416 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1418 Perl_csighandler_init(void)
1421 if (PL_sig_handlers_initted) return;
1423 for (sig = 1; sig < SIG_SIZE; sig++) {
1424 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1426 PL_sig_defaulting[sig] = 1;
1427 (void) rsignal(sig, PL_csighandlerp);
1429 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1430 PL_sig_ignoring[sig] = 0;
1433 PL_sig_handlers_initted = 1;
1437 #if defined HAS_SIGPROCMASK
1439 unblock_sigmask(pTHX_ void* newset)
1441 sigprocmask(SIG_UNBLOCK, (sigset_t*)newset, NULL);
1446 Perl_despatch_signals(pTHX)
1451 for (sig = 1; sig < SIG_SIZE; sig++) {
1452 if (PL_psig_pend[sig]) {
1454 #ifdef HAS_SIGPROCMASK
1455 /* From sigaction(2) (FreeBSD man page):
1456 * | Signal routines normally execute with the signal that
1457 * | caused their invocation blocked, but other signals may
1459 * Emulation of this behavior (from within Perl) is enabled
1463 sigset_t newset, oldset;
1465 sigemptyset(&newset);
1466 sigaddset(&newset, sig);
1467 sigprocmask(SIG_BLOCK, &newset, &oldset);
1468 was_blocked = sigismember(&oldset, sig);
1470 SV* save_sv = newSVpvn((char *)(&newset), sizeof(sigset_t));
1472 SAVEFREESV(save_sv);
1473 SAVEDESTRUCTOR_X(unblock_sigmask, SvPV_nolen(save_sv));
1476 PL_psig_pend[sig] = 0;
1477 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1478 (*PL_sighandlerp)(sig, NULL, NULL);
1480 (*PL_sighandlerp)(sig);
1482 #ifdef HAS_SIGPROCMASK
1491 /* sv of NULL signifies that we're acting as magic_clearsig. */
1493 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1498 /* Need to be careful with SvREFCNT_dec(), because that can have side
1499 * effects (due to closures). We must make sure that the new disposition
1500 * is in place before it is called.
1504 #ifdef HAS_SIGPROCMASK
1508 register const char *s = MgPV_const(mg,len);
1510 PERL_ARGS_ASSERT_MAGIC_SETSIG;
1513 if (strEQ(s,"__DIE__"))
1515 else if (strEQ(s,"__WARN__")
1516 && (sv ? 1 : PL_warnhook != PERL_WARNHOOK_FATAL)) {
1517 /* Merge the existing behaviours, which are as follows:
1518 magic_setsig, we always set svp to &PL_warnhook
1519 (hence we always change the warnings handler)
1520 For magic_clearsig, we don't change the warnings handler if it's
1521 set to the &PL_warnhook. */
1524 Perl_croak(aTHX_ "No such hook: %s", s);
1527 if (*svp != PERL_WARNHOOK_FATAL)
1533 i = (I16)mg->mg_private;
1535 i = whichsig(s); /* ...no, a brick */
1536 mg->mg_private = (U16)i;
1540 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
1543 #ifdef HAS_SIGPROCMASK
1544 /* Avoid having the signal arrive at a bad time, if possible. */
1547 sigprocmask(SIG_BLOCK, &set, &save);
1549 save_sv = newSVpvn((char *)(&save), sizeof(sigset_t));
1550 SAVEFREESV(save_sv);
1551 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1554 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1555 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1557 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1558 PL_sig_ignoring[i] = 0;
1560 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1561 PL_sig_defaulting[i] = 0;
1563 to_dec = PL_psig_ptr[i];
1565 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1566 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1568 /* Signals don't change name during the program's execution, so once
1569 they're cached in the appropriate slot of PL_psig_name, they can
1572 Ideally we'd find some way of making SVs at (C) compile time, or
1573 at least, doing most of the work. */
1574 if (!PL_psig_name[i]) {
1575 PL_psig_name[i] = newSVpvn(s, len);
1576 SvREADONLY_on(PL_psig_name[i]);
1579 SvREFCNT_dec(PL_psig_name[i]);
1580 PL_psig_name[i] = NULL;
1581 PL_psig_ptr[i] = NULL;
1584 if (sv && (isGV_with_GP(sv) || SvROK(sv))) {
1586 (void)rsignal(i, PL_csighandlerp);
1589 *svp = SvREFCNT_inc_simple_NN(sv);
1591 if (sv && SvOK(sv)) {
1592 s = SvPV_force(sv, len);
1596 if (sv && strEQ(s,"IGNORE")) {
1598 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1599 PL_sig_ignoring[i] = 1;
1600 (void)rsignal(i, PL_csighandlerp);
1602 (void)rsignal(i, (Sighandler_t) SIG_IGN);
1606 else if (!sv || strEQ(s,"DEFAULT") || !len) {
1608 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1609 PL_sig_defaulting[i] = 1;
1610 (void)rsignal(i, PL_csighandlerp);
1612 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1618 * We should warn if HINT_STRICT_REFS, but without
1619 * access to a known hint bit in a known OP, we can't
1620 * tell whether HINT_STRICT_REFS is in force or not.
1622 if (!strchr(s,':') && !strchr(s,'\''))
1623 Perl_sv_insert_flags(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"),
1626 (void)rsignal(i, PL_csighandlerp);
1628 *svp = SvREFCNT_inc_simple_NN(sv);
1632 #ifdef HAS_SIGPROCMASK
1636 SvREFCNT_dec(to_dec);
1639 #endif /* !PERL_MICRO */
1642 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1645 PERL_ARGS_ASSERT_MAGIC_SETISA;
1646 PERL_UNUSED_ARG(sv);
1648 /* Skip _isaelem because _isa will handle it shortly */
1649 if (PL_delaymagic & DM_ARRAY_ISA && mg->mg_type == PERL_MAGIC_isaelem)
1652 return magic_clearisa(NULL, mg);
1655 /* sv of NULL signifies that we're acting as magic_setisa. */
1657 Perl_magic_clearisa(pTHX_ SV *sv, MAGIC *mg)
1662 PERL_ARGS_ASSERT_MAGIC_CLEARISA;
1664 /* Bail out if destruction is going on */
1665 if(PL_phase == PERL_PHASE_DESTRUCT) return 0;
1668 av_clear(MUTABLE_AV(sv));
1670 if (SvTYPE(mg->mg_obj) != SVt_PVGV && SvSMAGICAL(mg->mg_obj))
1671 /* This occurs with setisa_elem magic, which calls this
1673 mg = mg_find(mg->mg_obj, PERL_MAGIC_isa);
1675 if (SvTYPE(mg->mg_obj) == SVt_PVAV) { /* multiple stashes */
1676 SV **svp = AvARRAY((AV *)mg->mg_obj);
1677 I32 items = AvFILLp((AV *)mg->mg_obj) + 1;
1679 stash = GvSTASH((GV *)*svp++);
1680 if (stash && HvENAME(stash)) mro_isa_changed_in(stash);
1687 (const GV *)mg->mg_obj
1690 /* The stash may have been detached from the symbol table, so check its
1691 name before doing anything. */
1692 if (stash && HvENAME_get(stash))
1693 mro_isa_changed_in(stash);
1699 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
1702 PERL_ARGS_ASSERT_MAGIC_SETAMAGIC;
1703 PERL_UNUSED_ARG(sv);
1704 PERL_UNUSED_ARG(mg);
1705 PL_amagic_generation++;
1711 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1713 HV * const hv = MUTABLE_HV(LvTARG(sv));
1716 PERL_ARGS_ASSERT_MAGIC_GETNKEYS;
1717 PERL_UNUSED_ARG(mg);
1720 (void) hv_iterinit(hv);
1721 if (! SvTIED_mg((const SV *)hv, PERL_MAGIC_tied))
1724 while (hv_iternext(hv))
1729 sv_setiv(sv, (IV)i);
1734 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1736 PERL_ARGS_ASSERT_MAGIC_SETNKEYS;
1737 PERL_UNUSED_ARG(mg);
1739 hv_ksplit(MUTABLE_HV(LvTARG(sv)), SvIV(sv));
1745 =for apidoc magic_methcall
1747 Invoke a magic method (like FETCH).
1749 * sv and mg are the tied thinggy and the tie magic;
1750 * meth is the name of the method to call;
1751 * argc is the number of args (in addition to $self) to pass to the method;
1752 the args themselves are any values following the argc argument.
1754 G_DISCARD: invoke method with G_DISCARD flag and don't return a value
1755 G_UNDEF_FILL: fill the stack with argc pointers to PL_sv_undef.
1757 Returns the SV (if any) returned by the method, or NULL on failure.
1764 Perl_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, U32 flags,
1771 PERL_ARGS_ASSERT_MAGIC_METHCALL;
1775 if (flags & G_WRITING_TO_STDERR) {
1779 SAVESPTR(PL_stderrgv);
1783 PUSHSTACKi(PERLSI_MAGIC);
1787 PUSHs(SvTIED_obj(sv, mg));
1788 if (flags & G_UNDEF_FILL) {
1790 PUSHs(&PL_sv_undef);
1792 } else if (argc > 0) {
1794 va_start(args, argc);
1797 SV *const sv = va_arg(args, SV *);
1804 if (flags & G_DISCARD) {
1805 call_method(meth, G_SCALAR|G_DISCARD);
1808 if (call_method(meth, G_SCALAR))
1809 ret = *PL_stack_sp--;
1812 if (flags & G_WRITING_TO_STDERR)
1819 /* wrapper for magic_methcall that creates the first arg */
1822 S_magic_methcall1(pTHX_ SV *sv, const MAGIC *mg, const char *meth, U32 flags,
1828 PERL_ARGS_ASSERT_MAGIC_METHCALL1;
1831 if (mg->mg_len >= 0) {
1832 arg1 = newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
1834 else if (mg->mg_len == HEf_SVKEY)
1835 arg1 = MUTABLE_SV(mg->mg_ptr);
1837 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1838 arg1 = newSViv((IV)(mg->mg_len));
1842 return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n - 1, val);
1844 return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n, arg1, val);
1848 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
1853 PERL_ARGS_ASSERT_MAGIC_METHPACK;
1855 ret = magic_methcall1(sv, mg, meth, 0, 1, NULL);
1862 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1864 PERL_ARGS_ASSERT_MAGIC_GETPACK;
1866 if (mg->mg_type == PERL_MAGIC_tiedelem)
1867 mg->mg_flags |= MGf_GSKIP;
1868 magic_methpack(sv,mg,"FETCH");
1873 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1879 PERL_ARGS_ASSERT_MAGIC_SETPACK;
1881 /* in the code C<$tied{foo} = $val>, the "thing" that gets passed to
1882 * STORE() is not $val, but rather a PVLV (the sv in this call), whose
1883 * public flags indicate its value based on copying from $val. Doing
1884 * mg_set() on the PVLV temporarily does SvMAGICAL_off(), then calls us.
1885 * So STORE()'s $_[2] arg is a temporarily disarmed PVLV. This goes
1886 * wrong if $val happened to be tainted, as sv hasn't got magic
1887 * enabled, even though taint magic is in the chain. In which case,
1888 * fake up a temporary tainted value (this is easier than temporarily
1889 * re-enabling magic on sv). */
1891 if (PL_tainting && (tmg = mg_find(sv, PERL_MAGIC_taint))
1892 && (tmg->mg_len & 1))
1894 val = sv_mortalcopy(sv);
1900 magic_methcall1(sv, mg, "STORE", G_DISCARD, 2, val);
1905 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1907 PERL_ARGS_ASSERT_MAGIC_CLEARPACK;
1909 return magic_methpack(sv,mg,"DELETE");
1914 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1920 PERL_ARGS_ASSERT_MAGIC_SIZEPACK;
1922 retsv = magic_methcall1(sv, mg, "FETCHSIZE", 0, 1, NULL);
1924 retval = SvIV(retsv)-1;
1926 Perl_croak(aTHX_ "FETCHSIZE returned a negative value");
1928 return (U32) retval;
1932 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1936 PERL_ARGS_ASSERT_MAGIC_WIPEPACK;
1938 Perl_magic_methcall(aTHX_ sv, mg, "CLEAR", G_DISCARD, 0);
1943 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1948 PERL_ARGS_ASSERT_MAGIC_NEXTPACK;
1950 ret = SvOK(key) ? Perl_magic_methcall(aTHX_ sv, mg, "NEXTKEY", 0, 1, key)
1951 : Perl_magic_methcall(aTHX_ sv, mg, "FIRSTKEY", 0, 0);
1958 Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg)
1960 PERL_ARGS_ASSERT_MAGIC_EXISTSPACK;
1962 return magic_methpack(sv,mg,"EXISTS");
1966 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1970 SV * const tied = SvTIED_obj(MUTABLE_SV(hv), mg);
1971 HV * const pkg = SvSTASH((const SV *)SvRV(tied));
1973 PERL_ARGS_ASSERT_MAGIC_SCALARPACK;
1975 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1977 if (HvEITER_get(hv))
1978 /* we are in an iteration so the hash cannot be empty */
1980 /* no xhv_eiter so now use FIRSTKEY */
1981 key = sv_newmortal();
1982 magic_nextpack(MUTABLE_SV(hv), mg, key);
1983 HvEITER_set(hv, NULL); /* need to reset iterator */
1984 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1987 /* there is a SCALAR method that we can call */
1988 retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(hv), mg, "SCALAR", 0, 0);
1990 retval = &PL_sv_undef;
1995 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1998 GV * const gv = PL_DBline;
1999 const I32 i = SvTRUE(sv);
2000 SV ** const svp = av_fetch(GvAV(gv),
2001 atoi(MgPV_nolen_const(mg)), FALSE);
2003 PERL_ARGS_ASSERT_MAGIC_SETDBLINE;
2005 if (svp && SvIOKp(*svp)) {
2006 OP * const o = INT2PTR(OP*,SvIVX(*svp));
2008 /* set or clear breakpoint in the relevant control op */
2010 o->op_flags |= OPf_SPECIAL;
2012 o->op_flags &= ~OPf_SPECIAL;
2019 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
2022 AV * const obj = MUTABLE_AV(mg->mg_obj);
2024 PERL_ARGS_ASSERT_MAGIC_GETARYLEN;
2027 sv_setiv(sv, AvFILL(obj) + CopARYBASE_get(PL_curcop));
2035 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
2038 AV * const obj = MUTABLE_AV(mg->mg_obj);
2040 PERL_ARGS_ASSERT_MAGIC_SETARYLEN;
2043 av_fill(obj, SvIV(sv) - CopARYBASE_get(PL_curcop));
2045 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
2046 "Attempt to set length of freed array");
2052 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
2056 PERL_ARGS_ASSERT_MAGIC_FREEARYLEN_P;
2057 PERL_UNUSED_ARG(sv);
2059 /* during global destruction, mg_obj may already have been freed */
2060 if (PL_in_clean_all)
2063 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
2066 /* arylen scalar holds a pointer back to the array, but doesn't own a
2067 reference. Hence the we (the array) are about to go away with it
2068 still pointing at us. Clear its pointer, else it would be pointing
2069 at free memory. See the comment in sv_magic about reference loops,
2070 and why it can't own a reference to us. */
2077 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
2080 SV* const lsv = LvTARG(sv);
2082 PERL_ARGS_ASSERT_MAGIC_GETPOS;
2083 PERL_UNUSED_ARG(mg);
2085 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
2086 MAGIC * const found = mg_find(lsv, PERL_MAGIC_regex_global);
2087 if (found && found->mg_len >= 0) {
2088 I32 i = found->mg_len;
2090 sv_pos_b2u(lsv, &i);
2091 sv_setiv(sv, i + CopARYBASE_get(PL_curcop));
2100 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
2103 SV* const lsv = LvTARG(sv);
2109 PERL_ARGS_ASSERT_MAGIC_SETPOS;
2110 PERL_UNUSED_ARG(mg);
2112 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
2113 found = mg_find(lsv, PERL_MAGIC_regex_global);
2119 #ifdef PERL_OLD_COPY_ON_WRITE
2121 sv_force_normal_flags(lsv, 0);
2123 found = sv_magicext(lsv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
2126 else if (!SvOK(sv)) {
2130 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
2132 pos = SvIV(sv) - CopARYBASE_get(PL_curcop);
2135 ulen = sv_len_utf8(lsv);
2145 else if (pos > (SSize_t)len)
2150 sv_pos_u2b(lsv, &p, 0);
2154 found->mg_len = pos;
2155 found->mg_flags &= ~MGf_MINMATCH;
2161 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
2164 SV * const lsv = LvTARG(sv);
2165 const char * const tmps = SvPV_const(lsv,len);
2166 STRLEN offs = LvTARGOFF(sv);
2167 STRLEN rem = LvTARGLEN(sv);
2169 PERL_ARGS_ASSERT_MAGIC_GETSUBSTR;
2170 PERL_UNUSED_ARG(mg);
2173 offs = sv_pos_u2b_flags(lsv, offs, &rem, SV_CONST_RETURN);
2176 if (rem > len - offs)
2178 sv_setpvn(sv, tmps + offs, rem);
2185 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
2189 const char * const tmps = SvPV_const(sv, len);
2190 SV * const lsv = LvTARG(sv);
2191 STRLEN lvoff = LvTARGOFF(sv);
2192 STRLEN lvlen = LvTARGLEN(sv);
2194 PERL_ARGS_ASSERT_MAGIC_SETSUBSTR;
2195 PERL_UNUSED_ARG(mg);
2198 sv_utf8_upgrade(lsv);
2199 lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
2200 sv_insert(lsv, lvoff, lvlen, tmps, len);
2201 LvTARGLEN(sv) = sv_len_utf8(sv);
2204 else if (lsv && SvUTF8(lsv)) {
2206 lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
2207 LvTARGLEN(sv) = len;
2208 utf8 = (char*)bytes_to_utf8((U8*)tmps, &len);
2209 sv_insert(lsv, lvoff, lvlen, utf8, len);
2213 sv_insert(lsv, lvoff, lvlen, tmps, len);
2214 LvTARGLEN(sv) = len;
2221 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
2225 PERL_ARGS_ASSERT_MAGIC_GETTAINT;
2226 PERL_UNUSED_ARG(sv);
2228 TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
2233 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
2237 PERL_ARGS_ASSERT_MAGIC_SETTAINT;
2238 PERL_UNUSED_ARG(sv);
2240 /* update taint status */
2249 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
2251 SV * const lsv = LvTARG(sv);
2253 PERL_ARGS_ASSERT_MAGIC_GETVEC;
2254 PERL_UNUSED_ARG(mg);
2257 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
2265 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
2267 PERL_ARGS_ASSERT_MAGIC_SETVEC;
2268 PERL_UNUSED_ARG(mg);
2269 do_vecset(sv); /* XXX slurp this routine */
2274 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
2279 PERL_ARGS_ASSERT_MAGIC_GETDEFELEM;
2281 if (LvTARGLEN(sv)) {
2283 SV * const ahv = LvTARG(sv);
2284 HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, FALSE, 0);
2289 AV *const av = MUTABLE_AV(LvTARG(sv));
2290 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
2291 targ = AvARRAY(av)[LvTARGOFF(sv)];
2293 if (targ && (targ != &PL_sv_undef)) {
2294 /* somebody else defined it for us */
2295 SvREFCNT_dec(LvTARG(sv));
2296 LvTARG(sv) = SvREFCNT_inc_simple_NN(targ);
2298 SvREFCNT_dec(mg->mg_obj);
2300 mg->mg_flags &= ~MGf_REFCOUNTED;
2305 sv_setsv(sv, targ ? targ : &PL_sv_undef);
2310 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
2312 PERL_ARGS_ASSERT_MAGIC_SETDEFELEM;
2313 PERL_UNUSED_ARG(mg);
2317 sv_setsv(LvTARG(sv), sv);
2318 SvSETMAGIC(LvTARG(sv));
2324 Perl_vivify_defelem(pTHX_ SV *sv)
2330 PERL_ARGS_ASSERT_VIVIFY_DEFELEM;
2332 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2335 SV * const ahv = LvTARG(sv);
2336 HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, TRUE, 0);
2339 if (!value || value == &PL_sv_undef)
2340 Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(mg->mg_obj));
2343 AV *const av = MUTABLE_AV(LvTARG(sv));
2344 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
2345 LvTARG(sv) = NULL; /* array can't be extended */
2347 SV* const * const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
2348 if (!svp || (value = *svp) == &PL_sv_undef)
2349 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
2352 SvREFCNT_inc_simple_void(value);
2353 SvREFCNT_dec(LvTARG(sv));
2356 SvREFCNT_dec(mg->mg_obj);
2358 mg->mg_flags &= ~MGf_REFCOUNTED;
2362 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2364 PERL_ARGS_ASSERT_MAGIC_KILLBACKREFS;
2365 Perl_sv_kill_backrefs(aTHX_ sv, MUTABLE_AV(mg->mg_obj));
2370 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2372 PERL_ARGS_ASSERT_MAGIC_SETMGLOB;
2373 PERL_UNUSED_CONTEXT;
2375 if (!isGV_with_GP(sv))
2381 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2383 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2385 PERL_ARGS_ASSERT_MAGIC_SETUVAR;
2387 if (uf && uf->uf_set)
2388 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2393 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2395 const char type = mg->mg_type;
2397 PERL_ARGS_ASSERT_MAGIC_SETREGEXP;
2399 if (type == PERL_MAGIC_qr) {
2400 } else if (type == PERL_MAGIC_bm) {
2404 assert(type == PERL_MAGIC_fm);
2407 return sv_unmagic(sv, type);
2410 #ifdef USE_LOCALE_COLLATE
2412 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2414 PERL_ARGS_ASSERT_MAGIC_SETCOLLXFRM;
2417 * RenE<eacute> Descartes said "I think not."
2418 * and vanished with a faint plop.
2420 PERL_UNUSED_CONTEXT;
2421 PERL_UNUSED_ARG(sv);
2423 Safefree(mg->mg_ptr);
2429 #endif /* USE_LOCALE_COLLATE */
2431 /* Just clear the UTF-8 cache data. */
2433 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2435 PERL_ARGS_ASSERT_MAGIC_SETUTF8;
2436 PERL_UNUSED_CONTEXT;
2437 PERL_UNUSED_ARG(sv);
2438 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2440 mg->mg_len = -1; /* The mg_len holds the len cache. */
2445 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2448 register const char *s;
2450 register const REGEXP * rx;
2451 const char * const remaining = mg->mg_ptr + 1;
2456 PERL_ARGS_ASSERT_MAGIC_SET;
2458 switch (*mg->mg_ptr) {
2459 case '\015': /* $^MATCH */
2460 if (strEQ(remaining, "ATCH"))
2462 case '`': /* ${^PREMATCH} caught below */
2464 paren = RX_BUFF_IDX_PREMATCH;
2466 case '\'': /* ${^POSTMATCH} caught below */
2468 paren = RX_BUFF_IDX_POSTMATCH;
2472 paren = RX_BUFF_IDX_FULLMATCH;
2474 case '1': case '2': case '3': case '4':
2475 case '5': case '6': case '7': case '8': case '9':
2476 paren = atoi(mg->mg_ptr);
2478 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
2479 CALLREG_NUMBUF_STORE((REGEXP * const)rx,paren,sv);
2481 /* Croak with a READONLY error when a numbered match var is
2482 * set without a previous pattern match. Unless it's C<local $1>
2484 if (!PL_localizing) {
2485 Perl_croak_no_modify(aTHX);
2489 case '\001': /* ^A */
2490 sv_setsv(PL_bodytarget, sv);
2491 /* mg_set() has temporarily made sv non-magical */
2493 if ((tmg = mg_find(sv,PERL_MAGIC_taint)) && tmg->mg_len & 1)
2494 SvTAINTED_on(PL_bodytarget);
2496 SvTAINTED_off(PL_bodytarget);
2499 case '\003': /* ^C */
2500 PL_minus_c = cBOOL(SvIV(sv));
2503 case '\004': /* ^D */
2505 s = SvPV_nolen_const(sv);
2506 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2507 if (DEBUG_x_TEST || DEBUG_B_TEST)
2508 dump_all_perl(!DEBUG_B_TEST);
2510 PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG;
2513 case '\005': /* ^E */
2514 if (*(mg->mg_ptr+1) == '\0') {
2516 set_vaxc_errno(SvIV(sv));
2519 SetLastError( SvIV(sv) );
2522 os2_setsyserrno(SvIV(sv));
2524 /* will anyone ever use this? */
2525 SETERRNO(SvIV(sv), 4);
2530 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2531 SvREFCNT_dec(PL_encoding);
2532 if (SvOK(sv) || SvGMAGICAL(sv)) {
2533 PL_encoding = newSVsv(sv);
2540 case '\006': /* ^F */
2541 PL_maxsysfd = SvIV(sv);
2543 case '\010': /* ^H */
2544 PL_hints = SvIV(sv);
2546 case '\011': /* ^I */ /* NOT \t in EBCDIC */
2547 Safefree(PL_inplace);
2548 PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
2550 case '\017': /* ^O */
2551 if (*(mg->mg_ptr+1) == '\0') {
2552 Safefree(PL_osname);
2555 TAINT_PROPER("assigning to $^O");
2556 PL_osname = savesvpv(sv);
2559 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2561 const char *const start = SvPV(sv, len);
2562 const char *out = (const char*)memchr(start, '\0', len);
2566 PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2567 PL_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2569 /* Opening for input is more common than opening for output, so
2570 ensure that hints for input are sooner on linked list. */
2571 tmp = out ? newSVpvn_flags(out + 1, start + len - out - 1,
2573 : newSVpvs_flags("", SvUTF8(sv));
2574 (void)hv_stores(GvHV(PL_hintgv), "open>", tmp);
2577 tmp = newSVpvn_flags(start, out ? (STRLEN)(out - start) : len,
2579 (void)hv_stores(GvHV(PL_hintgv), "open<", tmp);
2583 case '\020': /* ^P */
2584 if (*remaining == '\0') { /* ^P */
2585 PL_perldb = SvIV(sv);
2586 if (PL_perldb && !PL_DBsingle)
2589 } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
2591 } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
2595 case '\024': /* ^T */
2597 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2599 PL_basetime = (Time_t)SvIV(sv);
2602 case '\025': /* ^UTF8CACHE */
2603 if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
2604 PL_utf8cache = (signed char) sv_2iv(sv);
2607 case '\027': /* ^W & $^WARNING_BITS */
2608 if (*(mg->mg_ptr+1) == '\0') {
2609 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2611 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2612 | (i ? G_WARN_ON : G_WARN_OFF) ;
2615 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2616 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2617 if (!SvPOK(sv) && PL_localizing) {
2618 sv_setpvn(sv, WARN_NONEstring, WARNsize);
2619 PL_compiling.cop_warnings = pWARN_NONE;
2624 int accumulate = 0 ;
2625 int any_fatals = 0 ;
2626 const char * const ptr = SvPV_const(sv, len) ;
2627 for (i = 0 ; i < len ; ++i) {
2628 accumulate |= ptr[i] ;
2629 any_fatals |= (ptr[i] & 0xAA) ;
2632 if (!specialWARN(PL_compiling.cop_warnings))
2633 PerlMemShared_free(PL_compiling.cop_warnings);
2634 PL_compiling.cop_warnings = pWARN_NONE;
2636 /* Yuck. I can't see how to abstract this: */
2637 else if (isWARN_on(((STRLEN *)SvPV_nolen_const(sv)) - 1,
2638 WARN_ALL) && !any_fatals) {
2639 if (!specialWARN(PL_compiling.cop_warnings))
2640 PerlMemShared_free(PL_compiling.cop_warnings);
2641 PL_compiling.cop_warnings = pWARN_ALL;
2642 PL_dowarn |= G_WARN_ONCE ;
2646 const char *const p = SvPV_const(sv, len);
2648 PL_compiling.cop_warnings
2649 = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
2652 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2653 PL_dowarn |= G_WARN_ONCE ;
2661 if (PL_localizing) {
2662 if (PL_localizing == 1)
2663 SAVESPTR(PL_last_in_gv);
2665 else if (SvOK(sv) && GvIO(PL_last_in_gv))
2666 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2669 if (isGV_with_GP(PL_defoutgv)) {
2670 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2671 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2672 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2676 if (isGV_with_GP(PL_defoutgv)) {
2677 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2678 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2679 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2683 if (isGV_with_GP(PL_defoutgv))
2684 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
2687 if (isGV_with_GP(PL_defoutgv)) {
2688 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
2689 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2690 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2694 if (isGV_with_GP(PL_defoutgv))
2695 IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
2699 IO * const io = GvIO(PL_defoutgv);
2702 if ((SvIV(sv)) == 0)
2703 IoFLAGS(io) &= ~IOf_FLUSH;
2705 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2706 PerlIO *ofp = IoOFP(io);
2708 (void)PerlIO_flush(ofp);
2709 IoFLAGS(io) |= IOf_FLUSH;
2715 SvREFCNT_dec(PL_rs);
2716 PL_rs = newSVsv(sv);
2719 SvREFCNT_dec(PL_ors_sv);
2720 if (SvOK(sv) || SvGMAGICAL(sv)) {
2721 PL_ors_sv = newSVsv(sv);
2728 CopARYBASE_set(&PL_compiling, SvIV(sv));
2731 #ifdef COMPLEX_STATUS
2732 if (PL_localizing == 2) {
2733 SvUPGRADE(sv, SVt_PVLV);
2734 PL_statusvalue = LvTARGOFF(sv);
2735 PL_statusvalue_vms = LvTARGLEN(sv);
2739 #ifdef VMSISH_STATUS
2741 STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2744 STATUS_UNIX_EXIT_SET(SvIV(sv));
2749 # define PERL_VMS_BANG vaxc$errno
2751 # define PERL_VMS_BANG 0
2753 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2754 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2759 if (PL_delaymagic) {
2760 PL_delaymagic |= DM_RUID;
2761 break; /* don't do magic till later */
2764 (void)setruid((Uid_t)PL_uid);
2767 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2769 #ifdef HAS_SETRESUID
2770 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2772 if (PL_uid == PL_euid) { /* special case $< = $> */
2774 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2775 if (PL_uid != 0 && PerlProc_getuid() == 0)
2776 (void)PerlProc_setuid(0);
2778 (void)PerlProc_setuid(PL_uid);
2780 PL_uid = PerlProc_getuid();
2781 Perl_croak(aTHX_ "setruid() not implemented");
2786 PL_uid = PerlProc_getuid();
2790 if (PL_delaymagic) {
2791 PL_delaymagic |= DM_EUID;
2792 break; /* don't do magic till later */
2795 (void)seteuid((Uid_t)PL_euid);
2798 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2800 #ifdef HAS_SETRESUID
2801 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2803 if (PL_euid == PL_uid) /* special case $> = $< */
2804 PerlProc_setuid(PL_euid);
2806 PL_euid = PerlProc_geteuid();
2807 Perl_croak(aTHX_ "seteuid() not implemented");
2812 PL_euid = PerlProc_geteuid();
2816 if (PL_delaymagic) {
2817 PL_delaymagic |= DM_RGID;
2818 break; /* don't do magic till later */
2821 (void)setrgid((Gid_t)PL_gid);
2824 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2826 #ifdef HAS_SETRESGID
2827 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2829 if (PL_gid == PL_egid) /* special case $( = $) */
2830 (void)PerlProc_setgid(PL_gid);
2832 PL_gid = PerlProc_getgid();
2833 Perl_croak(aTHX_ "setrgid() not implemented");
2838 PL_gid = PerlProc_getgid();
2841 #ifdef HAS_SETGROUPS
2843 const char *p = SvPV_const(sv, len);
2844 Groups_t *gary = NULL;
2845 #ifdef _SC_NGROUPS_MAX
2846 int maxgrp = sysconf(_SC_NGROUPS_MAX);
2851 int maxgrp = NGROUPS;
2857 for (i = 0; i < maxgrp; ++i) {
2858 while (*p && !isSPACE(*p))
2865 Newx(gary, i + 1, Groups_t);
2867 Renew(gary, i + 1, Groups_t);
2871 (void)setgroups(i, gary);
2874 #else /* HAS_SETGROUPS */
2876 #endif /* HAS_SETGROUPS */
2877 if (PL_delaymagic) {
2878 PL_delaymagic |= DM_EGID;
2879 break; /* don't do magic till later */
2882 (void)setegid((Gid_t)PL_egid);
2885 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2887 #ifdef HAS_SETRESGID
2888 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2890 if (PL_egid == PL_gid) /* special case $) = $( */
2891 (void)PerlProc_setgid(PL_egid);
2893 PL_egid = PerlProc_getegid();
2894 Perl_croak(aTHX_ "setegid() not implemented");
2899 PL_egid = PerlProc_getegid();
2902 PL_chopset = SvPV_force(sv,len);
2905 LOCK_DOLLARZERO_MUTEX;
2906 #ifdef HAS_SETPROCTITLE
2907 /* The BSDs don't show the argv[] in ps(1) output, they
2908 * show a string from the process struct and provide
2909 * the setproctitle() routine to manipulate that. */
2910 if (PL_origalen != 1) {
2911 s = SvPV_const(sv, len);
2912 # if __FreeBSD_version > 410001
2913 /* The leading "-" removes the "perl: " prefix,
2914 * but not the "(perl) suffix from the ps(1)
2915 * output, because that's what ps(1) shows if the
2916 * argv[] is modified. */
2917 setproctitle("-%s", s);
2918 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2919 /* This doesn't really work if you assume that
2920 * $0 = 'foobar'; will wipe out 'perl' from the $0
2921 * because in ps(1) output the result will be like
2922 * sprintf("perl: %s (perl)", s)
2923 * I guess this is a security feature:
2924 * one (a user process) cannot get rid of the original name.
2926 setproctitle("%s", s);
2929 #elif defined(__hpux) && defined(PSTAT_SETCMD)
2930 if (PL_origalen != 1) {
2932 s = SvPV_const(sv, len);
2933 un.pst_command = (char *)s;
2934 pstat(PSTAT_SETCMD, un, len, 0, 0);
2937 if (PL_origalen > 1) {
2938 /* PL_origalen is set in perl_parse(). */
2939 s = SvPV_force(sv,len);
2940 if (len >= (STRLEN)PL_origalen-1) {
2941 /* Longer than original, will be truncated. We assume that
2942 * PL_origalen bytes are available. */
2943 Copy(s, PL_origargv[0], PL_origalen-1, char);
2946 /* Shorter than original, will be padded. */
2948 /* Special case for Mac OS X: see [perl #38868] */
2951 /* Is the space counterintuitive? Yes.
2952 * (You were expecting \0?)
2953 * Does it work? Seems to. (In Linux 2.4.20 at least.)
2955 const int pad = ' ';
2957 Copy(s, PL_origargv[0], len, char);
2958 PL_origargv[0][len] = 0;
2959 memset(PL_origargv[0] + len + 1,
2960 pad, PL_origalen - len - 1);
2962 PL_origargv[0][PL_origalen-1] = 0;
2963 for (i = 1; i < PL_origargc; i++)
2965 #ifdef HAS_PRCTL_SET_NAME
2966 /* Set the legacy process name in addition to the POSIX name on Linux */
2967 if (prctl(PR_SET_NAME, (unsigned long)s, 0, 0, 0) != 0) {
2968 /* diag_listed_as: SKIPME */
2969 Perl_croak(aTHX_ "Can't set $0 with prctl(): %s", Strerror(errno));
2974 UNLOCK_DOLLARZERO_MUTEX;
2981 Perl_whichsig(pTHX_ const char *sig)
2983 register char* const* sigv;
2985 PERL_ARGS_ASSERT_WHICHSIG;
2986 PERL_UNUSED_CONTEXT;
2988 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
2989 if (strEQ(sig,*sigv))
2990 return PL_sig_num[sigv - (char* const*)PL_sig_name];
2992 if (strEQ(sig,"CHLD"))
2996 if (strEQ(sig,"CLD"))
3003 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3004 Perl_sighandler(int sig, siginfo_t *sip, void *uap PERL_UNUSED_DECL)
3006 Perl_sighandler(int sig)
3009 #ifdef PERL_GET_SIG_CONTEXT
3010 dTHXa(PERL_GET_SIG_CONTEXT);
3017 SV * const tSv = PL_Sv;
3021 XPV * const tXpv = PL_Xpv;
3022 I32 old_ss_ix = PL_savestack_ix;
3025 if (!PL_psig_ptr[sig]) {
3026 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
3031 /* Max number of items pushed there is 3*n or 4. We cannot fix
3032 infinity, so we fix 4 (in fact 5): */
3033 if (PL_savestack_ix + 15 <= PL_savestack_max) {
3035 PL_savestack_ix += 5; /* Protect save in progress. */
3036 SAVEDESTRUCTOR_X(S_unwind_handler_stack, NULL);
3038 if (PL_markstack_ptr < PL_markstack_max - 2) {
3040 PL_markstack_ptr++; /* Protect mark. */
3042 if (PL_scopestack_ix < PL_scopestack_max - 3) {
3046 /* sv_2cv is too complicated, try a simpler variant first: */
3047 if (!SvROK(PL_psig_ptr[sig]) || !(cv = MUTABLE_CV(SvRV(PL_psig_ptr[sig])))
3048 || SvTYPE(cv) != SVt_PVCV) {
3050 cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
3053 if (!cv || !CvROOT(cv)) {
3054 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
3055 PL_sig_name[sig], (gv ? GvENAME(gv)
3062 sv = PL_psig_name[sig]
3063 ? SvREFCNT_inc_NN(PL_psig_name[sig])
3064 : newSVpv(PL_sig_name[sig],0);
3068 /* make sure our assumption about the size of the SAVEs are correct:
3069 * 3 for SAVEDESTRUCTOR_X, 2 for SAVEFREESV */
3070 assert(old_ss_ix + 2 + ((flags & 1) ? 3+5 : 0) == PL_savestack_ix);
3072 PUSHSTACKi(PERLSI_SIGNAL);
3075 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3077 struct sigaction oact;
3079 if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
3082 SV *rv = newRV_noinc(MUTABLE_SV(sih));
3083 /* The siginfo fields signo, code, errno, pid, uid,
3084 * addr, status, and band are defined by POSIX/SUSv3. */
3085 (void)hv_stores(sih, "signo", newSViv(sip->si_signo));
3086 (void)hv_stores(sih, "code", newSViv(sip->si_code));
3087 #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. */
3088 hv_stores(sih, "errno", newSViv(sip->si_errno));
3089 hv_stores(sih, "status", newSViv(sip->si_status));
3090 hv_stores(sih, "uid", newSViv(sip->si_uid));
3091 hv_stores(sih, "pid", newSViv(sip->si_pid));
3092 hv_stores(sih, "addr", newSVuv(PTR2UV(sip->si_addr)));
3093 hv_stores(sih, "band", newSViv(sip->si_band));
3097 mPUSHp((char *)sip, sizeof(*sip));
3105 call_sv(MUTABLE_SV(cv), G_DISCARD|G_EVAL);
3108 if (SvTRUE(ERRSV)) {
3109 #if !defined(PERL_MICRO) && !defined(HAS_SIGPROCMASK)
3110 /* Handler "died", for example to get out of a restart-able read().
3111 * Before we re-do that on its behalf re-enable the signal which was
3112 * blocked by the system when we entered.
3114 /* Not clear if this will work */
3115 (void)rsignal(sig, SIG_IGN);
3116 (void)rsignal(sig, PL_csighandlerp);
3117 #endif /* !PERL_MICRO && !HAS_SIGPROCMASK*/
3121 /* pop any of SAVEFREESV, SAVEDESTRUCTOR_X and "save in progress" */
3122 PL_savestack_ix = old_ss_ix;
3126 PL_scopestack_ix -= 1;
3129 PL_op = myop; /* Apparently not needed... */
3131 PL_Sv = tSv; /* Restore global temporaries. */
3138 S_restore_magic(pTHX_ const void *p)
3141 MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
3142 SV* const sv = mgs->mgs_sv;
3147 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
3149 #ifdef PERL_OLD_COPY_ON_WRITE
3150 /* While magic was saved (and off) sv_setsv may well have seen
3151 this SV as a prime candidate for COW. */
3153 sv_force_normal_flags(sv, 0);
3156 if (mgs->mgs_readonly)
3158 if (mgs->mgs_magical)
3159 SvFLAGS(sv) |= mgs->mgs_magical;
3162 if (SvGMAGICAL(sv)) {
3163 /* downgrade public flags to private,
3164 and discard any other private flags */
3166 const U32 pubflags = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
3168 SvFLAGS(sv) &= ~( pubflags | (SVp_IOK|SVp_NOK|SVp_POK) );
3169 SvFLAGS(sv) |= ( pubflags << PRIVSHIFT );
3174 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
3176 /* If we're still on top of the stack, pop us off. (That condition
3177 * will be satisfied if restore_magic was called explicitly, but *not*
3178 * if it's being called via leave_scope.)
3179 * The reason for doing this is that otherwise, things like sv_2cv()
3180 * may leave alloc gunk on the savestack, and some code
3181 * (e.g. sighandler) doesn't expect that...
3183 if (PL_savestack_ix == mgs->mgs_ss_ix)
3185 UV popval = SSPOPUV;
3186 assert(popval == SAVEt_DESTRUCTOR_X);
3187 PL_savestack_ix -= 2;
3189 assert((popval & SAVE_MASK) == SAVEt_ALLOC);
3190 PL_savestack_ix -= popval >> SAVE_TIGHT_SHIFT;
3192 if (SvREFCNT(sv) == 1) {
3193 /* We hold the last reference to this SV, which implies that the
3194 SV was deleted as a side effect of the routines we called.
3195 So artificially keep it alive a bit longer.
3196 We avoid turning on the TEMP flag, which can cause the SV's
3197 buffer to get stolen (and maybe other stuff). */
3198 int was_temp = SvTEMP(sv);
3206 SvREFCNT_dec(sv); /* undo the inc in S_save_magic() */
3209 /* clean up the mess created by Perl_sighandler().
3210 * Note that this is only called during an exit in a signal handler;
3211 * a die is trapped by the call_sv() and the SAVEDESTRUCTOR_X manually
3212 * skipped over. This is why we don't need to fix up the markstack and
3213 * scopestack - they're going to be set to 0 anyway */
3216 S_unwind_handler_stack(pTHX_ const void *p)
3221 PL_savestack_ix -= 5; /* Unprotect save in progress. */
3225 =for apidoc magic_sethint
3227 Triggered by a store to %^H, records the key/value pair to
3228 C<PL_compiling.cop_hints_hash>. It is assumed that hints aren't storing
3229 anything that would need a deep copy. Maybe we should warn if we find a
3235 Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
3238 SV *key = (mg->mg_len == HEf_SVKEY) ? MUTABLE_SV(mg->mg_ptr)
3239 : newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
3241 PERL_ARGS_ASSERT_MAGIC_SETHINT;
3243 /* mg->mg_obj isn't being used. If needed, it would be possible to store
3244 an alternative leaf in there, with PL_compiling.cop_hints being used if
3245 it's NULL. If needed for threads, the alternative could lock a mutex,
3246 or take other more complex action. */
3248 /* Something changed in %^H, so it will need to be restored on scope exit.
3249 Doing this here saves a lot of doing it manually in perl code (and
3250 forgetting to do it, and consequent subtle errors. */
3251 PL_hints |= HINT_LOCALIZE_HH;
3252 CopHINTHASH_set(&PL_compiling,
3253 cophh_store_sv(CopHINTHASH_get(&PL_compiling), key, 0, sv, 0));
3258 =for apidoc magic_clearhint
3260 Triggered by a delete from %^H, records the key to
3261 C<PL_compiling.cop_hints_hash>.
3266 Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
3270 PERL_ARGS_ASSERT_MAGIC_CLEARHINT;
3271 PERL_UNUSED_ARG(sv);
3273 assert(mg->mg_len == HEf_SVKEY);
3275 PERL_UNUSED_ARG(sv);
3277 PL_hints |= HINT_LOCALIZE_HH;
3278 CopHINTHASH_set(&PL_compiling,
3279 cophh_delete_sv(CopHINTHASH_get(&PL_compiling),
3280 MUTABLE_SV(mg->mg_ptr), 0, 0));
3285 =for apidoc magic_clearhints
3287 Triggered by clearing %^H, resets C<PL_compiling.cop_hints_hash>.
3292 Perl_magic_clearhints(pTHX_ SV *sv, MAGIC *mg)
3294 PERL_ARGS_ASSERT_MAGIC_CLEARHINTS;
3295 PERL_UNUSED_ARG(sv);
3296 PERL_UNUSED_ARG(mg);
3297 cophh_free(CopHINTHASH_get(&PL_compiling));
3298 CopHINTHASH_set(&PL_compiling, cophh_new_empty());
3304 * c-indentation-style: bsd
3306 * indent-tabs-mode: t
3309 * ex: set ts=8 sts=4 sw=4 noet: