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));
422 Finds the magic pointer for type matching the SV. See C<sv_magic>.
428 Perl_mg_find(pTHX_ const SV *sv, int type)
433 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
434 if (mg->mg_type == type)
444 Copies the magic from one SV to another. See C<sv_magic>.
450 Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
455 PERL_ARGS_ASSERT_MG_COPY;
457 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
458 const MGVTBL* const vtbl = mg->mg_virtual;
459 if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){
460 count += vtbl->svt_copy(aTHX_ sv, mg, nsv, key, klen);
463 const char type = mg->mg_type;
464 if (isUPPER(type) && type != PERL_MAGIC_uvar) {
466 (type == PERL_MAGIC_tied)
468 : (type == PERL_MAGIC_regdata && mg->mg_obj)
471 toLOWER(type), key, klen);
480 =for apidoc mg_localize
482 Copy some of the magic from an existing SV to new localized version of that
483 SV. Container magic (eg %ENV, $1, tie) gets copied, value magic doesn't (eg
486 If setmagic is false then no set magic will be called on the new (empty) SV.
487 This typically means that assignment will soon follow (e.g. 'local $x = $y'),
488 and that will handle the magic.
494 Perl_mg_localize(pTHX_ SV *sv, SV *nsv, bool setmagic)
499 PERL_ARGS_ASSERT_MG_LOCALIZE;
501 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
502 const MGVTBL* const vtbl = mg->mg_virtual;
503 if (!S_is_container_magic(mg))
506 if ((mg->mg_flags & MGf_LOCAL) && vtbl->svt_local)
507 (void)vtbl->svt_local(aTHX_ nsv, mg);
509 sv_magicext(nsv, mg->mg_obj, mg->mg_type, vtbl,
510 mg->mg_ptr, mg->mg_len);
512 /* container types should remain read-only across localization */
513 SvFLAGS(nsv) |= SvREADONLY(sv);
516 if (SvTYPE(nsv) >= SVt_PVMG && SvMAGIC(nsv)) {
517 SvFLAGS(nsv) |= SvMAGICAL(sv);
526 #define mg_free_struct(sv, mg) S_mg_free_struct(aTHX_ sv, mg)
528 S_mg_free_struct(pTHX_ SV *sv, MAGIC *mg)
530 const MGVTBL* const vtbl = mg->mg_virtual;
531 if (vtbl && vtbl->svt_free)
532 vtbl->svt_free(aTHX_ sv, mg);
533 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
534 if (mg->mg_len > 0 || mg->mg_type == PERL_MAGIC_utf8)
535 Safefree(mg->mg_ptr);
536 else if (mg->mg_len == HEf_SVKEY)
537 SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr));
539 if (mg->mg_flags & MGf_REFCOUNTED)
540 SvREFCNT_dec(mg->mg_obj);
547 Free any magic storage used by the SV. See C<sv_magic>.
553 Perl_mg_free(pTHX_ SV *sv)
558 PERL_ARGS_ASSERT_MG_FREE;
560 for (mg = SvMAGIC(sv); mg; mg = moremagic) {
561 moremagic = mg->mg_moremagic;
562 mg_free_struct(sv, mg);
563 SvMAGIC_set(sv, moremagic);
565 SvMAGIC_set(sv, NULL);
571 =for apidoc Am|void|mg_free_type|SV *sv|int how
573 Remove any magic of type I<how> from the SV I<sv>. See L</sv_magic>.
579 Perl_mg_free_type(pTHX_ SV *sv, int how)
581 MAGIC *mg, *prevmg, *moremg;
582 PERL_ARGS_ASSERT_MG_FREE_TYPE;
583 for (prevmg = NULL, mg = SvMAGIC(sv); mg; prevmg = mg, mg = moremg) {
585 moremg = mg->mg_moremagic;
586 if (mg->mg_type == how) {
587 /* temporarily move to the head of the magic chain, in case
588 custom free code relies on this historical aspect of mg_free */
590 prevmg->mg_moremagic = moremg;
591 mg->mg_moremagic = SvMAGIC(sv);
594 newhead = mg->mg_moremagic;
595 mg_free_struct(sv, mg);
596 SvMAGIC_set(sv, newhead);
606 Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
611 PERL_ARGS_ASSERT_MAGIC_REGDATA_CNT;
614 register const REGEXP * const rx = PM_GETRE(PL_curpm);
616 if (mg->mg_obj) { /* @+ */
617 /* return the number possible */
618 return RX_NPARENS(rx);
620 I32 paren = RX_LASTPAREN(rx);
622 /* return the last filled */
624 && (RX_OFFS(rx)[paren].start == -1
625 || RX_OFFS(rx)[paren].end == -1) )
636 Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
640 PERL_ARGS_ASSERT_MAGIC_REGDATUM_GET;
643 register const REGEXP * const rx = PM_GETRE(PL_curpm);
645 register const I32 paren = mg->mg_len;
650 if (paren <= (I32)RX_NPARENS(rx) &&
651 (s = RX_OFFS(rx)[paren].start) != -1 &&
652 (t = RX_OFFS(rx)[paren].end) != -1)
655 if (mg->mg_obj) /* @+ */
660 if (i > 0 && RX_MATCH_UTF8(rx)) {
661 const char * const b = RX_SUBBEG(rx);
663 i = utf8_length((U8*)b, (U8*)(b+i));
674 Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
676 PERL_ARGS_ASSERT_MAGIC_REGDATUM_SET;
679 Perl_croak_no_modify(aTHX);
680 NORETURN_FUNCTION_END;
684 Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
689 register const REGEXP * rx;
690 const char * const remaining = mg->mg_ptr + 1;
692 PERL_ARGS_ASSERT_MAGIC_LEN;
694 switch (*mg->mg_ptr) {
696 if (*remaining == '\0') { /* ^P */
698 } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
700 } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
704 case '\015': /* $^MATCH */
705 if (strEQ(remaining, "ATCH")) {
712 paren = RX_BUFF_IDX_PREMATCH;
716 paren = RX_BUFF_IDX_POSTMATCH;
720 paren = RX_BUFF_IDX_FULLMATCH;
722 case '1': case '2': case '3': case '4':
723 case '5': case '6': case '7': case '8': case '9':
724 paren = atoi(mg->mg_ptr);
726 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
728 i = CALLREG_NUMBUF_LENGTH((REGEXP * const)rx, sv, paren);
731 Perl_croak(aTHX_ "panic: magic_len: %"IVdf, (IV)i);
734 if (ckWARN(WARN_UNINITIALIZED))
739 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
740 paren = RX_LASTPAREN(rx);
745 case '\016': /* ^N */
746 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
747 paren = RX_LASTCLOSEPAREN(rx);
754 if (!SvPOK(sv) && SvNIOK(sv)) {
762 #define SvRTRIM(sv) STMT_START { \
764 STRLEN len = SvCUR(sv); \
765 char * const p = SvPVX(sv); \
766 while (len > 0 && isSPACE(p[len-1])) \
768 SvCUR_set(sv, len); \
774 Perl_emulate_cop_io(pTHX_ const COP *const c, SV *const sv)
776 PERL_ARGS_ASSERT_EMULATE_COP_IO;
778 if (!(CopHINTS_get(c) & (HINT_LEXICAL_IO_IN|HINT_LEXICAL_IO_OUT)))
779 sv_setsv(sv, &PL_sv_undef);
783 if ((CopHINTS_get(c) & HINT_LEXICAL_IO_IN)) {
784 SV *const value = cop_hints_fetch_pvs(c, "open<", 0);
789 if ((CopHINTS_get(c) & HINT_LEXICAL_IO_OUT)) {
790 SV *const value = cop_hints_fetch_pvs(c, "open>", 0);
798 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
802 register const char *s = NULL;
804 const char * const remaining = mg->mg_ptr + 1;
805 const char nextchar = *remaining;
807 PERL_ARGS_ASSERT_MAGIC_GET;
809 switch (*mg->mg_ptr) {
810 case '\001': /* ^A */
811 sv_setsv(sv, PL_bodytarget);
813 case '\003': /* ^C, ^CHILD_ERROR_NATIVE */
814 if (nextchar == '\0') {
815 sv_setiv(sv, (IV)PL_minus_c);
817 else if (strEQ(remaining, "HILD_ERROR_NATIVE")) {
818 sv_setiv(sv, (IV)STATUS_NATIVE);
822 case '\004': /* ^D */
823 sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
825 case '\005': /* ^E */
826 if (nextchar == '\0') {
829 # include <descrip.h>
830 # include <starlet.h>
832 $DESCRIPTOR(msgdsc,msg);
833 sv_setnv(sv,(NV) vaxc$errno);
834 if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
835 sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
840 if (!(_emx_env & 0x200)) { /* Under DOS */
841 sv_setnv(sv, (NV)errno);
842 sv_setpv(sv, errno ? Strerror(errno) : "");
844 if (errno != errno_isOS2) {
845 const int tmp = _syserrno();
846 if (tmp) /* 2nd call to _syserrno() makes it 0 */
849 sv_setnv(sv, (NV)Perl_rc);
850 sv_setpv(sv, os2error(Perl_rc));
854 const DWORD dwErr = GetLastError();
855 sv_setnv(sv, (NV)dwErr);
857 PerlProc_GetOSError(sv, dwErr);
866 sv_setnv(sv, (NV)errno);
867 sv_setpv(sv, errno ? Strerror(errno) : "");
872 SvNOK_on(sv); /* what a wonderful hack! */
874 else if (strEQ(remaining, "NCODING"))
875 sv_setsv(sv, PL_encoding);
877 case '\006': /* ^F */
878 sv_setiv(sv, (IV)PL_maxsysfd);
880 case '\010': /* ^H */
881 sv_setiv(sv, (IV)PL_hints);
883 case '\011': /* ^I */ /* NOT \t in EBCDIC */
884 sv_setpv(sv, PL_inplace); /* Will undefine sv if PL_inplace is NULL */
886 case '\017': /* ^O & ^OPEN */
887 if (nextchar == '\0') {
888 sv_setpv(sv, PL_osname);
891 else if (strEQ(remaining, "PEN")) {
892 Perl_emulate_cop_io(aTHX_ &PL_compiling, sv);
896 if (nextchar == '\0') { /* ^P */
897 sv_setiv(sv, (IV)PL_perldb);
898 } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
899 goto do_prematch_fetch;
900 } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
901 goto do_postmatch_fetch;
904 case '\023': /* ^S */
905 if (nextchar == '\0') {
906 if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING)
909 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
914 case '\024': /* ^T */
915 if (nextchar == '\0') {
917 sv_setnv(sv, PL_basetime);
919 sv_setiv(sv, (IV)PL_basetime);
922 else if (strEQ(remaining, "AINT"))
923 sv_setiv(sv, PL_tainting
924 ? (PL_taint_warn || PL_unsafe ? -1 : 1)
927 case '\025': /* $^UNICODE, $^UTF8LOCALE, $^UTF8CACHE */
928 if (strEQ(remaining, "NICODE"))
929 sv_setuv(sv, (UV) PL_unicode);
930 else if (strEQ(remaining, "TF8LOCALE"))
931 sv_setuv(sv, (UV) PL_utf8locale);
932 else if (strEQ(remaining, "TF8CACHE"))
933 sv_setiv(sv, (IV) PL_utf8cache);
935 case '\027': /* ^W & $^WARNING_BITS */
936 if (nextchar == '\0')
937 sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
938 else if (strEQ(remaining, "ARNING_BITS")) {
939 if (PL_compiling.cop_warnings == pWARN_NONE) {
940 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
942 else if (PL_compiling.cop_warnings == pWARN_STD) {
945 (PL_dowarn & G_WARN_ON) ? WARN_ALLstring : WARN_NONEstring,
949 else if (PL_compiling.cop_warnings == pWARN_ALL) {
950 /* Get the bit mask for $warnings::Bits{all}, because
951 * it could have been extended by warnings::register */
952 HV * const bits=get_hv("warnings::Bits", 0);
954 SV ** const bits_all = hv_fetchs(bits, "all", FALSE);
956 sv_setsv(sv, *bits_all);
959 sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
963 sv_setpvn(sv, (char *) (PL_compiling.cop_warnings + 1),
964 *PL_compiling.cop_warnings);
969 case '\015': /* $^MATCH */
970 if (strEQ(remaining, "ATCH")) {
971 case '1': case '2': case '3': case '4':
972 case '5': case '6': case '7': case '8': case '9': case '&':
973 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
975 * Pre-threads, this was paren = atoi(GvENAME((const GV *)mg->mg_obj));
976 * XXX Does the new way break anything?
978 paren = atoi(mg->mg_ptr); /* $& is in [0] */
979 CALLREG_NUMBUF_FETCH(rx,paren,sv);
982 sv_setsv(sv,&PL_sv_undef);
986 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
987 if (RX_LASTPAREN(rx)) {
988 CALLREG_NUMBUF_FETCH(rx,RX_LASTPAREN(rx),sv);
992 sv_setsv(sv,&PL_sv_undef);
994 case '\016': /* ^N */
995 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
996 if (RX_LASTCLOSEPAREN(rx)) {
997 CALLREG_NUMBUF_FETCH(rx,RX_LASTCLOSEPAREN(rx),sv);
1002 sv_setsv(sv,&PL_sv_undef);
1006 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
1007 CALLREG_NUMBUF_FETCH(rx,-2,sv);
1010 sv_setsv(sv,&PL_sv_undef);
1014 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
1015 CALLREG_NUMBUF_FETCH(rx,-1,sv);
1018 sv_setsv(sv,&PL_sv_undef);
1021 if (GvIO(PL_last_in_gv)) {
1022 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
1027 sv_setiv(sv, (IV)STATUS_CURRENT);
1028 #ifdef COMPLEX_STATUS
1029 SvUPGRADE(sv, SVt_PVLV);
1030 LvTARGOFF(sv) = PL_statusvalue;
1031 LvTARGLEN(sv) = PL_statusvalue_vms;
1036 if (!isGV_with_GP(PL_defoutgv))
1038 else if (GvIOp(PL_defoutgv))
1039 s = IoTOP_NAME(GvIOp(PL_defoutgv));
1043 sv_setpv(sv,GvENAME(PL_defoutgv));
1044 sv_catpvs(sv,"_TOP");
1048 if (!isGV_with_GP(PL_defoutgv))
1050 else if (GvIOp(PL_defoutgv))
1051 s = IoFMT_NAME(GvIOp(PL_defoutgv));
1053 s = GvENAME(PL_defoutgv);
1057 if (GvIO(PL_defoutgv))
1058 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
1061 if (GvIO(PL_defoutgv))
1062 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
1065 if (GvIO(PL_defoutgv))
1066 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
1073 sv_setiv(sv, (IV)CopARYBASE_get(PL_curcop));
1076 if (GvIO(PL_defoutgv))
1077 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
1081 sv_copypv(sv, PL_ors_sv);
1087 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
1089 sv_setnv(sv, (NV)errno);
1092 if (errno == errno_isOS2 || errno == errno_isOS2_set)
1093 sv_setpv(sv, os2error(Perl_rc));
1096 sv_setpv(sv, errno ? Strerror(errno) : "");
1098 SvPOK_on(sv); /* may have got removed during taint processing */
1103 SvNOK_on(sv); /* what a wonderful hack! */
1106 sv_setiv(sv, (IV)PL_uid);
1109 sv_setiv(sv, (IV)PL_euid);
1112 sv_setiv(sv, (IV)PL_gid);
1115 sv_setiv(sv, (IV)PL_egid);
1117 #ifdef HAS_GETGROUPS
1119 Groups_t *gary = NULL;
1120 I32 i, num_groups = getgroups(0, gary);
1121 Newx(gary, num_groups, Groups_t);
1122 num_groups = getgroups(num_groups, gary);
1123 for (i = 0; i < num_groups; i++)
1124 Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]);
1127 (void)SvIOK_on(sv); /* what a wonderful hack! */
1137 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
1139 struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
1141 PERL_ARGS_ASSERT_MAGIC_GETUVAR;
1143 if (uf && uf->uf_val)
1144 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
1149 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
1152 STRLEN len = 0, klen;
1153 const char *s = SvOK(sv) ? SvPV_const(sv,len) : "";
1154 const char * const ptr = MgPV_const(mg,klen);
1157 PERL_ARGS_ASSERT_MAGIC_SETENV;
1159 #ifdef DYNAMIC_ENV_FETCH
1160 /* We just undefd an environment var. Is a replacement */
1161 /* waiting in the wings? */
1163 SV ** const valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE);
1165 s = SvOK(*valp) ? SvPV_const(*valp, len) : "";
1169 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
1170 /* And you'll never guess what the dog had */
1171 /* in its mouth... */
1173 MgTAINTEDDIR_off(mg);
1175 if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
1176 char pathbuf[256], eltbuf[256], *cp, *elt;
1180 my_strlcpy(eltbuf, s, sizeof(eltbuf));
1182 do { /* DCL$PATH may be a search list */
1183 while (1) { /* as may dev portion of any element */
1184 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1185 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1186 cando_by_name(S_IWUSR,0,elt) ) {
1187 MgTAINTEDDIR_on(mg);
1191 if ((cp = strchr(elt, ':')) != NULL)
1193 if (my_trnlnm(elt, eltbuf, j++))
1199 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1202 if (s && klen == 4 && strEQ(ptr,"PATH")) {
1203 const char * const strend = s + len;
1205 while (s < strend) {
1209 #ifdef VMS /* Hmm. How do we get $Config{path_sep} from C? */
1210 const char path_sep = '|';
1212 const char path_sep = ':';
1214 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
1215 s, strend, path_sep, &i);
1217 if (i >= (I32)sizeof tmpbuf /* too long -- assume the worst */
1219 || !strchr(tmpbuf, ':') /* no colon thus no device name -- assume relative path */
1221 || *tmpbuf != '/' /* no starting slash -- assume relative path */
1223 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1224 MgTAINTEDDIR_on(mg);
1230 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1236 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1238 PERL_ARGS_ASSERT_MAGIC_CLEARENV;
1239 PERL_UNUSED_ARG(sv);
1240 my_setenv(MgPV_nolen_const(mg),NULL);
1245 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1248 PERL_ARGS_ASSERT_MAGIC_SET_ALL_ENV;
1249 PERL_UNUSED_ARG(mg);
1251 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1253 if (PL_localizing) {
1256 hv_iterinit(MUTABLE_HV(sv));
1257 while ((entry = hv_iternext(MUTABLE_HV(sv)))) {
1259 my_setenv(hv_iterkey(entry, &keylen),
1260 SvPV_nolen_const(hv_iterval(MUTABLE_HV(sv), entry)));
1268 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1271 PERL_ARGS_ASSERT_MAGIC_CLEAR_ALL_ENV;
1272 PERL_UNUSED_ARG(sv);
1273 PERL_UNUSED_ARG(mg);
1275 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1283 #ifdef HAS_SIGPROCMASK
1285 restore_sigmask(pTHX_ SV *save_sv)
1287 const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1288 (void)sigprocmask(SIG_SETMASK, ossetp, NULL);
1292 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1295 /* Are we fetching a signal entry? */
1296 int i = (I16)mg->mg_private;
1298 PERL_ARGS_ASSERT_MAGIC_GETSIG;
1301 mg->mg_private = i = whichsig(MgPV_nolen_const(mg));
1306 sv_setsv(sv,PL_psig_ptr[i]);
1308 Sighandler_t sigstate = rsignal_state(i);
1309 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1310 if (PL_sig_handlers_initted && PL_sig_ignoring[i])
1313 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1314 if (PL_sig_handlers_initted && PL_sig_defaulting[i])
1317 /* cache state so we don't fetch it again */
1318 if(sigstate == (Sighandler_t) SIG_IGN)
1319 sv_setpvs(sv,"IGNORE");
1321 sv_setsv(sv,&PL_sv_undef);
1322 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1329 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1331 PERL_ARGS_ASSERT_MAGIC_CLEARSIG;
1332 PERL_UNUSED_ARG(sv);
1334 magic_setsig(NULL, mg);
1335 return sv_unmagic(sv, mg->mg_type);
1339 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1340 Perl_csighandler(int sig, siginfo_t *sip PERL_UNUSED_DECL, void *uap PERL_UNUSED_DECL)
1342 Perl_csighandler(int sig)
1345 #ifdef PERL_GET_SIG_CONTEXT
1346 dTHXa(PERL_GET_SIG_CONTEXT);
1350 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1351 (void) rsignal(sig, PL_csighandlerp);
1352 if (PL_sig_ignoring[sig]) return;
1354 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1355 if (PL_sig_defaulting[sig])
1356 #ifdef KILL_BY_SIGPRC
1357 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1372 (PL_signals & PERL_SIGNALS_UNSAFE_FLAG))
1373 /* Call the perl level handler now--
1374 * with risk we may be in malloc() or being destructed etc. */
1375 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1376 (*PL_sighandlerp)(sig, NULL, NULL);
1378 (*PL_sighandlerp)(sig);
1381 if (!PL_psig_pend) return;
1382 /* Set a flag to say this signal is pending, that is awaiting delivery after
1383 * the current Perl opcode completes */
1384 PL_psig_pend[sig]++;
1386 #ifndef SIG_PENDING_DIE_COUNT
1387 # define SIG_PENDING_DIE_COUNT 120
1389 /* Add one to say _a_ signal is pending */
1390 if (++PL_sig_pending >= SIG_PENDING_DIE_COUNT)
1391 Perl_croak(aTHX_ "Maximal count of pending signals (%lu) exceeded",
1392 (unsigned long)SIG_PENDING_DIE_COUNT);
1396 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1398 Perl_csighandler_init(void)
1401 if (PL_sig_handlers_initted) return;
1403 for (sig = 1; sig < SIG_SIZE; sig++) {
1404 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1406 PL_sig_defaulting[sig] = 1;
1407 (void) rsignal(sig, PL_csighandlerp);
1409 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1410 PL_sig_ignoring[sig] = 0;
1413 PL_sig_handlers_initted = 1;
1418 Perl_despatch_signals(pTHX)
1423 for (sig = 1; sig < SIG_SIZE; sig++) {
1424 if (PL_psig_pend[sig]) {
1426 PERL_BLOCKSIG_ADD(set, sig);
1427 PL_psig_pend[sig] = 0;
1428 PERL_BLOCKSIG_BLOCK(set);
1429 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1430 (*PL_sighandlerp)(sig, NULL, NULL);
1432 (*PL_sighandlerp)(sig);
1434 PERL_BLOCKSIG_UNBLOCK(set);
1440 /* sv of NULL signifies that we're acting as magic_clearsig. */
1442 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1447 /* Need to be careful with SvREFCNT_dec(), because that can have side
1448 * effects (due to closures). We must make sure that the new disposition
1449 * is in place before it is called.
1453 #ifdef HAS_SIGPROCMASK
1457 register const char *s = MgPV_const(mg,len);
1459 PERL_ARGS_ASSERT_MAGIC_SETSIG;
1462 if (strEQ(s,"__DIE__"))
1464 else if (strEQ(s,"__WARN__")
1465 && (sv ? 1 : PL_warnhook != PERL_WARNHOOK_FATAL)) {
1466 /* Merge the existing behaviours, which are as follows:
1467 magic_setsig, we always set svp to &PL_warnhook
1468 (hence we always change the warnings handler)
1469 For magic_clearsig, we don't change the warnings handler if it's
1470 set to the &PL_warnhook. */
1473 Perl_croak(aTHX_ "No such hook: %s", s);
1476 if (*svp != PERL_WARNHOOK_FATAL)
1482 i = (I16)mg->mg_private;
1484 i = whichsig(s); /* ...no, a brick */
1485 mg->mg_private = (U16)i;
1489 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
1492 #ifdef HAS_SIGPROCMASK
1493 /* Avoid having the signal arrive at a bad time, if possible. */
1496 sigprocmask(SIG_BLOCK, &set, &save);
1498 save_sv = newSVpvn((char *)(&save), sizeof(sigset_t));
1499 SAVEFREESV(save_sv);
1500 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1503 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1504 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1506 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1507 PL_sig_ignoring[i] = 0;
1509 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1510 PL_sig_defaulting[i] = 0;
1512 to_dec = PL_psig_ptr[i];
1514 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1515 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1517 /* Signals don't change name during the program's execution, so once
1518 they're cached in the appropriate slot of PL_psig_name, they can
1521 Ideally we'd find some way of making SVs at (C) compile time, or
1522 at least, doing most of the work. */
1523 if (!PL_psig_name[i]) {
1524 PL_psig_name[i] = newSVpvn(s, len);
1525 SvREADONLY_on(PL_psig_name[i]);
1528 SvREFCNT_dec(PL_psig_name[i]);
1529 PL_psig_name[i] = NULL;
1530 PL_psig_ptr[i] = NULL;
1533 if (sv && (isGV_with_GP(sv) || SvROK(sv))) {
1535 (void)rsignal(i, PL_csighandlerp);
1538 *svp = SvREFCNT_inc_simple_NN(sv);
1540 if (sv && SvOK(sv)) {
1541 s = SvPV_force(sv, len);
1545 if (sv && strEQ(s,"IGNORE")) {
1547 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1548 PL_sig_ignoring[i] = 1;
1549 (void)rsignal(i, PL_csighandlerp);
1551 (void)rsignal(i, (Sighandler_t) SIG_IGN);
1555 else if (!sv || strEQ(s,"DEFAULT") || !len) {
1557 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1558 PL_sig_defaulting[i] = 1;
1559 (void)rsignal(i, PL_csighandlerp);
1561 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1567 * We should warn if HINT_STRICT_REFS, but without
1568 * access to a known hint bit in a known OP, we can't
1569 * tell whether HINT_STRICT_REFS is in force or not.
1571 if (!strchr(s,':') && !strchr(s,'\''))
1572 Perl_sv_insert_flags(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"),
1575 (void)rsignal(i, PL_csighandlerp);
1577 *svp = SvREFCNT_inc_simple_NN(sv);
1581 #ifdef HAS_SIGPROCMASK
1585 SvREFCNT_dec(to_dec);
1588 #endif /* !PERL_MICRO */
1591 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1594 PERL_ARGS_ASSERT_MAGIC_SETISA;
1595 PERL_UNUSED_ARG(sv);
1597 /* Skip _isaelem because _isa will handle it shortly */
1598 if (PL_delaymagic & DM_ARRAY_ISA && mg->mg_type == PERL_MAGIC_isaelem)
1601 return magic_clearisa(NULL, mg);
1604 /* sv of NULL signifies that we're acting as magic_setisa. */
1606 Perl_magic_clearisa(pTHX_ SV *sv, MAGIC *mg)
1611 PERL_ARGS_ASSERT_MAGIC_CLEARISA;
1613 /* Bail out if destruction is going on */
1614 if(PL_dirty) return 0;
1617 av_clear(MUTABLE_AV(sv));
1619 /* XXX Once it's possible, we need to
1620 detect that our @ISA is aliased in
1621 other stashes, and act on the stashes
1622 of all of the aliases */
1624 /* The first case occurs via setisa,
1625 the second via setisa_elem, which
1626 calls this same magic */
1628 SvTYPE(mg->mg_obj) == SVt_PVGV
1629 ? (const GV *)mg->mg_obj
1630 : (const GV *)mg_find(mg->mg_obj, PERL_MAGIC_isa)->mg_obj
1633 /* The stash may have been detached from the symbol table, so check its
1634 name before doing anything. */
1635 if (stash && HvENAME_get(stash))
1636 mro_isa_changed_in(stash);
1642 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
1645 PERL_ARGS_ASSERT_MAGIC_SETAMAGIC;
1646 PERL_UNUSED_ARG(sv);
1647 PERL_UNUSED_ARG(mg);
1648 PL_amagic_generation++;
1654 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1656 HV * const hv = MUTABLE_HV(LvTARG(sv));
1659 PERL_ARGS_ASSERT_MAGIC_GETNKEYS;
1660 PERL_UNUSED_ARG(mg);
1663 (void) hv_iterinit(hv);
1664 if (! SvTIED_mg((const SV *)hv, PERL_MAGIC_tied))
1667 while (hv_iternext(hv))
1672 sv_setiv(sv, (IV)i);
1677 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1679 PERL_ARGS_ASSERT_MAGIC_SETNKEYS;
1680 PERL_UNUSED_ARG(mg);
1682 hv_ksplit(MUTABLE_HV(LvTARG(sv)), SvIV(sv));
1688 =for apidoc magic_methcall
1690 Invoke a magic method (like FETCH).
1692 * sv and mg are the tied thinggy and the tie magic;
1693 * meth is the name of the method to call;
1694 * argc is the number of args (in addition to $self) to pass to the method;
1695 the args themselves are any values following the argc argument.
1697 G_DISCARD: invoke method with G_DISCARD flag and don't return a value
1698 G_UNDEF_FILL: fill the stack with argc pointers to PL_sv_undef.
1700 Returns the SV (if any) returned by the method, or NULL on failure.
1707 Perl_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, U32 flags,
1714 PERL_ARGS_ASSERT_MAGIC_METHCALL;
1717 PUSHSTACKi(PERLSI_MAGIC);
1721 PUSHs(SvTIED_obj(sv, mg));
1722 if (flags & G_UNDEF_FILL) {
1724 PUSHs(&PL_sv_undef);
1726 } else if (argc > 0) {
1728 va_start(args, argc);
1731 SV *const sv = va_arg(args, SV *);
1738 if (flags & G_DISCARD) {
1739 call_method(meth, G_SCALAR|G_DISCARD);
1742 if (call_method(meth, G_SCALAR))
1743 ret = *PL_stack_sp--;
1751 /* wrapper for magic_methcall that creates the first arg */
1754 S_magic_methcall1(pTHX_ SV *sv, const MAGIC *mg, const char *meth, U32 flags,
1760 PERL_ARGS_ASSERT_MAGIC_METHCALL1;
1763 if (mg->mg_len >= 0) {
1764 arg1 = newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
1766 else if (mg->mg_len == HEf_SVKEY)
1767 arg1 = MUTABLE_SV(mg->mg_ptr);
1769 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1770 arg1 = newSViv((IV)(mg->mg_len));
1774 return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n - 1, val);
1776 return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n, arg1, val);
1780 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
1785 PERL_ARGS_ASSERT_MAGIC_METHPACK;
1787 ret = magic_methcall1(sv, mg, meth, 0, 1, NULL);
1794 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1796 PERL_ARGS_ASSERT_MAGIC_GETPACK;
1798 if (mg->mg_type == PERL_MAGIC_tiedelem)
1799 mg->mg_flags |= MGf_GSKIP;
1800 magic_methpack(sv,mg,"FETCH");
1805 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1811 PERL_ARGS_ASSERT_MAGIC_SETPACK;
1813 /* in the code C<$tied{foo} = $val>, the "thing" that gets passed to
1814 * STORE() is not $val, but rather a PVLV (the sv in this call), whose
1815 * public flags indicate its value based on copying from $val. Doing
1816 * mg_set() on the PVLV temporarily does SvMAGICAL_off(), then calls us.
1817 * So STORE()'s $_[2] arg is a temporarily disarmed PVLV. This goes
1818 * wrong if $val happened to be tainted, as sv hasn't got magic
1819 * enabled, even though taint magic is in the chain. In which case,
1820 * fake up a temporary tainted value (this is easier than temporarily
1821 * re-enabling magic on sv). */
1823 if (PL_tainting && (tmg = mg_find(sv, PERL_MAGIC_taint))
1824 && (tmg->mg_len & 1))
1826 val = sv_mortalcopy(sv);
1832 magic_methcall1(sv, mg, "STORE", G_DISCARD, 2, val);
1837 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1839 PERL_ARGS_ASSERT_MAGIC_CLEARPACK;
1841 return magic_methpack(sv,mg,"DELETE");
1846 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1852 PERL_ARGS_ASSERT_MAGIC_SIZEPACK;
1854 retsv = magic_methcall1(sv, mg, "FETCHSIZE", 0, 1, NULL);
1856 retval = SvIV(retsv)-1;
1858 Perl_croak(aTHX_ "FETCHSIZE returned a negative value");
1860 return (U32) retval;
1864 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1868 PERL_ARGS_ASSERT_MAGIC_WIPEPACK;
1870 Perl_magic_methcall(aTHX_ sv, mg, "CLEAR", G_DISCARD, 0);
1875 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1880 PERL_ARGS_ASSERT_MAGIC_NEXTPACK;
1882 ret = SvOK(key) ? Perl_magic_methcall(aTHX_ sv, mg, "NEXTKEY", 0, 1, key)
1883 : Perl_magic_methcall(aTHX_ sv, mg, "FIRSTKEY", 0, 0);
1890 Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg)
1892 PERL_ARGS_ASSERT_MAGIC_EXISTSPACK;
1894 return magic_methpack(sv,mg,"EXISTS");
1898 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1902 SV * const tied = SvTIED_obj(MUTABLE_SV(hv), mg);
1903 HV * const pkg = SvSTASH((const SV *)SvRV(tied));
1905 PERL_ARGS_ASSERT_MAGIC_SCALARPACK;
1907 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1909 if (HvEITER_get(hv))
1910 /* we are in an iteration so the hash cannot be empty */
1912 /* no xhv_eiter so now use FIRSTKEY */
1913 key = sv_newmortal();
1914 magic_nextpack(MUTABLE_SV(hv), mg, key);
1915 HvEITER_set(hv, NULL); /* need to reset iterator */
1916 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1919 /* there is a SCALAR method that we can call */
1920 retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(hv), mg, "SCALAR", 0, 0);
1922 retval = &PL_sv_undef;
1927 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1930 GV * const gv = PL_DBline;
1931 const I32 i = SvTRUE(sv);
1932 SV ** const svp = av_fetch(GvAV(gv),
1933 atoi(MgPV_nolen_const(mg)), FALSE);
1935 PERL_ARGS_ASSERT_MAGIC_SETDBLINE;
1937 if (svp && SvIOKp(*svp)) {
1938 OP * const o = INT2PTR(OP*,SvIVX(*svp));
1940 /* set or clear breakpoint in the relevant control op */
1942 o->op_flags |= OPf_SPECIAL;
1944 o->op_flags &= ~OPf_SPECIAL;
1951 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
1954 AV * const obj = MUTABLE_AV(mg->mg_obj);
1956 PERL_ARGS_ASSERT_MAGIC_GETARYLEN;
1959 sv_setiv(sv, AvFILL(obj) + CopARYBASE_get(PL_curcop));
1967 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
1970 AV * const obj = MUTABLE_AV(mg->mg_obj);
1972 PERL_ARGS_ASSERT_MAGIC_SETARYLEN;
1975 av_fill(obj, SvIV(sv) - CopARYBASE_get(PL_curcop));
1977 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
1978 "Attempt to set length of freed array");
1984 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
1988 PERL_ARGS_ASSERT_MAGIC_FREEARYLEN_P;
1989 PERL_UNUSED_ARG(sv);
1991 /* during global destruction, mg_obj may already have been freed */
1992 if (PL_in_clean_all)
1995 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
1998 /* arylen scalar holds a pointer back to the array, but doesn't own a
1999 reference. Hence the we (the array) are about to go away with it
2000 still pointing at us. Clear its pointer, else it would be pointing
2001 at free memory. See the comment in sv_magic about reference loops,
2002 and why it can't own a reference to us. */
2009 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
2012 SV* const lsv = LvTARG(sv);
2014 PERL_ARGS_ASSERT_MAGIC_GETPOS;
2015 PERL_UNUSED_ARG(mg);
2017 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
2018 MAGIC * const found = mg_find(lsv, PERL_MAGIC_regex_global);
2019 if (found && found->mg_len >= 0) {
2020 I32 i = found->mg_len;
2022 sv_pos_b2u(lsv, &i);
2023 sv_setiv(sv, i + CopARYBASE_get(PL_curcop));
2032 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
2035 SV* const lsv = LvTARG(sv);
2041 PERL_ARGS_ASSERT_MAGIC_SETPOS;
2042 PERL_UNUSED_ARG(mg);
2044 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
2045 found = mg_find(lsv, PERL_MAGIC_regex_global);
2051 #ifdef PERL_OLD_COPY_ON_WRITE
2053 sv_force_normal_flags(lsv, 0);
2055 found = sv_magicext(lsv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
2058 else if (!SvOK(sv)) {
2062 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
2064 pos = SvIV(sv) - CopARYBASE_get(PL_curcop);
2067 ulen = sv_len_utf8(lsv);
2077 else if (pos > (SSize_t)len)
2082 sv_pos_u2b(lsv, &p, 0);
2086 found->mg_len = pos;
2087 found->mg_flags &= ~MGf_MINMATCH;
2093 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
2096 SV * const lsv = LvTARG(sv);
2097 const char * const tmps = SvPV_const(lsv,len);
2098 STRLEN offs = LvTARGOFF(sv);
2099 STRLEN rem = LvTARGLEN(sv);
2101 PERL_ARGS_ASSERT_MAGIC_GETSUBSTR;
2102 PERL_UNUSED_ARG(mg);
2105 offs = sv_pos_u2b_flags(lsv, offs, &rem, SV_CONST_RETURN);
2108 if (rem > len - offs)
2110 sv_setpvn(sv, tmps + offs, rem);
2117 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
2121 const char * const tmps = SvPV_const(sv, len);
2122 SV * const lsv = LvTARG(sv);
2123 STRLEN lvoff = LvTARGOFF(sv);
2124 STRLEN lvlen = LvTARGLEN(sv);
2126 PERL_ARGS_ASSERT_MAGIC_SETSUBSTR;
2127 PERL_UNUSED_ARG(mg);
2130 sv_utf8_upgrade(lsv);
2131 lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
2132 sv_insert(lsv, lvoff, lvlen, tmps, len);
2133 LvTARGLEN(sv) = sv_len_utf8(sv);
2136 else if (lsv && SvUTF8(lsv)) {
2138 lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
2139 LvTARGLEN(sv) = len;
2140 utf8 = (char*)bytes_to_utf8((U8*)tmps, &len);
2141 sv_insert(lsv, lvoff, lvlen, utf8, len);
2145 sv_insert(lsv, lvoff, lvlen, tmps, len);
2146 LvTARGLEN(sv) = len;
2153 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
2157 PERL_ARGS_ASSERT_MAGIC_GETTAINT;
2158 PERL_UNUSED_ARG(sv);
2160 TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
2165 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
2169 PERL_ARGS_ASSERT_MAGIC_SETTAINT;
2170 PERL_UNUSED_ARG(sv);
2172 /* update taint status */
2181 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
2183 SV * const lsv = LvTARG(sv);
2185 PERL_ARGS_ASSERT_MAGIC_GETVEC;
2186 PERL_UNUSED_ARG(mg);
2189 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
2197 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
2199 PERL_ARGS_ASSERT_MAGIC_SETVEC;
2200 PERL_UNUSED_ARG(mg);
2201 do_vecset(sv); /* XXX slurp this routine */
2206 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
2211 PERL_ARGS_ASSERT_MAGIC_GETDEFELEM;
2213 if (LvTARGLEN(sv)) {
2215 SV * const ahv = LvTARG(sv);
2216 HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, FALSE, 0);
2221 AV *const av = MUTABLE_AV(LvTARG(sv));
2222 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
2223 targ = AvARRAY(av)[LvTARGOFF(sv)];
2225 if (targ && (targ != &PL_sv_undef)) {
2226 /* somebody else defined it for us */
2227 SvREFCNT_dec(LvTARG(sv));
2228 LvTARG(sv) = SvREFCNT_inc_simple_NN(targ);
2230 SvREFCNT_dec(mg->mg_obj);
2232 mg->mg_flags &= ~MGf_REFCOUNTED;
2237 sv_setsv(sv, targ ? targ : &PL_sv_undef);
2242 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
2244 PERL_ARGS_ASSERT_MAGIC_SETDEFELEM;
2245 PERL_UNUSED_ARG(mg);
2249 sv_setsv(LvTARG(sv), sv);
2250 SvSETMAGIC(LvTARG(sv));
2256 Perl_vivify_defelem(pTHX_ SV *sv)
2262 PERL_ARGS_ASSERT_VIVIFY_DEFELEM;
2264 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2267 SV * const ahv = LvTARG(sv);
2268 HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, TRUE, 0);
2271 if (!value || value == &PL_sv_undef)
2272 Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(mg->mg_obj));
2275 AV *const av = MUTABLE_AV(LvTARG(sv));
2276 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
2277 LvTARG(sv) = NULL; /* array can't be extended */
2279 SV* const * const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
2280 if (!svp || (value = *svp) == &PL_sv_undef)
2281 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
2284 SvREFCNT_inc_simple_void(value);
2285 SvREFCNT_dec(LvTARG(sv));
2288 SvREFCNT_dec(mg->mg_obj);
2290 mg->mg_flags &= ~MGf_REFCOUNTED;
2294 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2296 PERL_ARGS_ASSERT_MAGIC_KILLBACKREFS;
2297 Perl_sv_kill_backrefs(aTHX_ sv, MUTABLE_AV(mg->mg_obj));
2302 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2304 PERL_ARGS_ASSERT_MAGIC_SETMGLOB;
2305 PERL_UNUSED_CONTEXT;
2307 if (!isGV_with_GP(sv))
2313 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2315 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2317 PERL_ARGS_ASSERT_MAGIC_SETUVAR;
2319 if (uf && uf->uf_set)
2320 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2325 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2327 const char type = mg->mg_type;
2329 PERL_ARGS_ASSERT_MAGIC_SETREGEXP;
2331 if (type == PERL_MAGIC_qr) {
2332 } else if (type == PERL_MAGIC_bm) {
2336 assert(type == PERL_MAGIC_fm);
2339 return sv_unmagic(sv, type);
2342 #ifdef USE_LOCALE_COLLATE
2344 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2346 PERL_ARGS_ASSERT_MAGIC_SETCOLLXFRM;
2349 * RenE<eacute> Descartes said "I think not."
2350 * and vanished with a faint plop.
2352 PERL_UNUSED_CONTEXT;
2353 PERL_UNUSED_ARG(sv);
2355 Safefree(mg->mg_ptr);
2361 #endif /* USE_LOCALE_COLLATE */
2363 /* Just clear the UTF-8 cache data. */
2365 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2367 PERL_ARGS_ASSERT_MAGIC_SETUTF8;
2368 PERL_UNUSED_CONTEXT;
2369 PERL_UNUSED_ARG(sv);
2370 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2372 mg->mg_len = -1; /* The mg_len holds the len cache. */
2377 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2380 register const char *s;
2382 register const REGEXP * rx;
2383 const char * const remaining = mg->mg_ptr + 1;
2387 PERL_ARGS_ASSERT_MAGIC_SET;
2389 switch (*mg->mg_ptr) {
2390 case '\015': /* $^MATCH */
2391 if (strEQ(remaining, "ATCH"))
2393 case '`': /* ${^PREMATCH} caught below */
2395 paren = RX_BUFF_IDX_PREMATCH;
2397 case '\'': /* ${^POSTMATCH} caught below */
2399 paren = RX_BUFF_IDX_POSTMATCH;
2403 paren = RX_BUFF_IDX_FULLMATCH;
2405 case '1': case '2': case '3': case '4':
2406 case '5': case '6': case '7': case '8': case '9':
2407 paren = atoi(mg->mg_ptr);
2409 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
2410 CALLREG_NUMBUF_STORE((REGEXP * const)rx,paren,sv);
2412 /* Croak with a READONLY error when a numbered match var is
2413 * set without a previous pattern match. Unless it's C<local $1>
2415 if (!PL_localizing) {
2416 Perl_croak_no_modify(aTHX);
2420 case '\001': /* ^A */
2421 sv_setsv(PL_bodytarget, sv);
2423 case '\003': /* ^C */
2424 PL_minus_c = cBOOL(SvIV(sv));
2427 case '\004': /* ^D */
2429 s = SvPV_nolen_const(sv);
2430 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2431 if (DEBUG_x_TEST || DEBUG_B_TEST)
2432 dump_all_perl(!DEBUG_B_TEST);
2434 PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG;
2437 case '\005': /* ^E */
2438 if (*(mg->mg_ptr+1) == '\0') {
2440 set_vaxc_errno(SvIV(sv));
2443 SetLastError( SvIV(sv) );
2446 os2_setsyserrno(SvIV(sv));
2448 /* will anyone ever use this? */
2449 SETERRNO(SvIV(sv), 4);
2454 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2455 SvREFCNT_dec(PL_encoding);
2456 if (SvOK(sv) || SvGMAGICAL(sv)) {
2457 PL_encoding = newSVsv(sv);
2464 case '\006': /* ^F */
2465 PL_maxsysfd = SvIV(sv);
2467 case '\010': /* ^H */
2468 PL_hints = SvIV(sv);
2470 case '\011': /* ^I */ /* NOT \t in EBCDIC */
2471 Safefree(PL_inplace);
2472 PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
2474 case '\017': /* ^O */
2475 if (*(mg->mg_ptr+1) == '\0') {
2476 Safefree(PL_osname);
2479 TAINT_PROPER("assigning to $^O");
2480 PL_osname = savesvpv(sv);
2483 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2485 const char *const start = SvPV(sv, len);
2486 const char *out = (const char*)memchr(start, '\0', len);
2490 PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2491 PL_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2493 /* Opening for input is more common than opening for output, so
2494 ensure that hints for input are sooner on linked list. */
2495 tmp = out ? newSVpvn_flags(out + 1, start + len - out - 1,
2497 : newSVpvs_flags("", SvUTF8(sv));
2498 (void)hv_stores(GvHV(PL_hintgv), "open>", tmp);
2501 tmp = newSVpvn_flags(start, out ? (STRLEN)(out - start) : len,
2503 (void)hv_stores(GvHV(PL_hintgv), "open<", tmp);
2507 case '\020': /* ^P */
2508 if (*remaining == '\0') { /* ^P */
2509 PL_perldb = SvIV(sv);
2510 if (PL_perldb && !PL_DBsingle)
2513 } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
2515 } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
2519 case '\024': /* ^T */
2521 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2523 PL_basetime = (Time_t)SvIV(sv);
2526 case '\025': /* ^UTF8CACHE */
2527 if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
2528 PL_utf8cache = (signed char) sv_2iv(sv);
2531 case '\027': /* ^W & $^WARNING_BITS */
2532 if (*(mg->mg_ptr+1) == '\0') {
2533 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2535 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2536 | (i ? G_WARN_ON : G_WARN_OFF) ;
2539 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2540 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2541 if (!SvPOK(sv) && PL_localizing) {
2542 sv_setpvn(sv, WARN_NONEstring, WARNsize);
2543 PL_compiling.cop_warnings = pWARN_NONE;
2548 int accumulate = 0 ;
2549 int any_fatals = 0 ;
2550 const char * const ptr = SvPV_const(sv, len) ;
2551 for (i = 0 ; i < len ; ++i) {
2552 accumulate |= ptr[i] ;
2553 any_fatals |= (ptr[i] & 0xAA) ;
2556 if (!specialWARN(PL_compiling.cop_warnings))
2557 PerlMemShared_free(PL_compiling.cop_warnings);
2558 PL_compiling.cop_warnings = pWARN_NONE;
2560 /* Yuck. I can't see how to abstract this: */
2561 else if (isWARN_on(((STRLEN *)SvPV_nolen_const(sv)) - 1,
2562 WARN_ALL) && !any_fatals) {
2563 if (!specialWARN(PL_compiling.cop_warnings))
2564 PerlMemShared_free(PL_compiling.cop_warnings);
2565 PL_compiling.cop_warnings = pWARN_ALL;
2566 PL_dowarn |= G_WARN_ONCE ;
2570 const char *const p = SvPV_const(sv, len);
2572 PL_compiling.cop_warnings
2573 = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
2576 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2577 PL_dowarn |= G_WARN_ONCE ;
2585 if (PL_localizing) {
2586 if (PL_localizing == 1)
2587 SAVESPTR(PL_last_in_gv);
2589 else if (SvOK(sv) && GvIO(PL_last_in_gv))
2590 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2593 if (isGV_with_GP(PL_defoutgv)) {
2594 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2595 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2596 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2600 if (isGV_with_GP(PL_defoutgv)) {
2601 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2602 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2603 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2607 if (isGV_with_GP(PL_defoutgv))
2608 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
2611 if (isGV_with_GP(PL_defoutgv)) {
2612 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
2613 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2614 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2618 if (isGV_with_GP(PL_defoutgv))
2619 IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
2623 IO * const io = GvIO(PL_defoutgv);
2626 if ((SvIV(sv)) == 0)
2627 IoFLAGS(io) &= ~IOf_FLUSH;
2629 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2630 PerlIO *ofp = IoOFP(io);
2632 (void)PerlIO_flush(ofp);
2633 IoFLAGS(io) |= IOf_FLUSH;
2639 SvREFCNT_dec(PL_rs);
2640 PL_rs = newSVsv(sv);
2643 SvREFCNT_dec(PL_ors_sv);
2644 if (SvOK(sv) || SvGMAGICAL(sv)) {
2645 PL_ors_sv = newSVsv(sv);
2652 CopARYBASE_set(&PL_compiling, SvIV(sv));
2655 #ifdef COMPLEX_STATUS
2656 if (PL_localizing == 2) {
2657 SvUPGRADE(sv, SVt_PVLV);
2658 PL_statusvalue = LvTARGOFF(sv);
2659 PL_statusvalue_vms = LvTARGLEN(sv);
2663 #ifdef VMSISH_STATUS
2665 STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2668 STATUS_UNIX_EXIT_SET(SvIV(sv));
2673 # define PERL_VMS_BANG vaxc$errno
2675 # define PERL_VMS_BANG 0
2677 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2678 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2683 if (PL_delaymagic) {
2684 PL_delaymagic |= DM_RUID;
2685 break; /* don't do magic till later */
2688 (void)setruid((Uid_t)PL_uid);
2691 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2693 #ifdef HAS_SETRESUID
2694 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2696 if (PL_uid == PL_euid) { /* special case $< = $> */
2698 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2699 if (PL_uid != 0 && PerlProc_getuid() == 0)
2700 (void)PerlProc_setuid(0);
2702 (void)PerlProc_setuid(PL_uid);
2704 PL_uid = PerlProc_getuid();
2705 Perl_croak(aTHX_ "setruid() not implemented");
2710 PL_uid = PerlProc_getuid();
2714 if (PL_delaymagic) {
2715 PL_delaymagic |= DM_EUID;
2716 break; /* don't do magic till later */
2719 (void)seteuid((Uid_t)PL_euid);
2722 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2724 #ifdef HAS_SETRESUID
2725 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2727 if (PL_euid == PL_uid) /* special case $> = $< */
2728 PerlProc_setuid(PL_euid);
2730 PL_euid = PerlProc_geteuid();
2731 Perl_croak(aTHX_ "seteuid() not implemented");
2736 PL_euid = PerlProc_geteuid();
2740 if (PL_delaymagic) {
2741 PL_delaymagic |= DM_RGID;
2742 break; /* don't do magic till later */
2745 (void)setrgid((Gid_t)PL_gid);
2748 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2750 #ifdef HAS_SETRESGID
2751 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2753 if (PL_gid == PL_egid) /* special case $( = $) */
2754 (void)PerlProc_setgid(PL_gid);
2756 PL_gid = PerlProc_getgid();
2757 Perl_croak(aTHX_ "setrgid() not implemented");
2762 PL_gid = PerlProc_getgid();
2765 #ifdef HAS_SETGROUPS
2767 const char *p = SvPV_const(sv, len);
2768 Groups_t *gary = NULL;
2769 #ifdef _SC_NGROUPS_MAX
2770 int maxgrp = sysconf(_SC_NGROUPS_MAX);
2775 int maxgrp = NGROUPS;
2781 for (i = 0; i < maxgrp; ++i) {
2782 while (*p && !isSPACE(*p))
2789 Newx(gary, i + 1, Groups_t);
2791 Renew(gary, i + 1, Groups_t);
2795 (void)setgroups(i, gary);
2798 #else /* HAS_SETGROUPS */
2800 #endif /* HAS_SETGROUPS */
2801 if (PL_delaymagic) {
2802 PL_delaymagic |= DM_EGID;
2803 break; /* don't do magic till later */
2806 (void)setegid((Gid_t)PL_egid);
2809 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2811 #ifdef HAS_SETRESGID
2812 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2814 if (PL_egid == PL_gid) /* special case $) = $( */
2815 (void)PerlProc_setgid(PL_egid);
2817 PL_egid = PerlProc_getegid();
2818 Perl_croak(aTHX_ "setegid() not implemented");
2823 PL_egid = PerlProc_getegid();
2826 PL_chopset = SvPV_force(sv,len);
2829 LOCK_DOLLARZERO_MUTEX;
2830 #ifdef HAS_SETPROCTITLE
2831 /* The BSDs don't show the argv[] in ps(1) output, they
2832 * show a string from the process struct and provide
2833 * the setproctitle() routine to manipulate that. */
2834 if (PL_origalen != 1) {
2835 s = SvPV_const(sv, len);
2836 # if __FreeBSD_version > 410001
2837 /* The leading "-" removes the "perl: " prefix,
2838 * but not the "(perl) suffix from the ps(1)
2839 * output, because that's what ps(1) shows if the
2840 * argv[] is modified. */
2841 setproctitle("-%s", s);
2842 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2843 /* This doesn't really work if you assume that
2844 * $0 = 'foobar'; will wipe out 'perl' from the $0
2845 * because in ps(1) output the result will be like
2846 * sprintf("perl: %s (perl)", s)
2847 * I guess this is a security feature:
2848 * one (a user process) cannot get rid of the original name.
2850 setproctitle("%s", s);
2853 #elif defined(__hpux) && defined(PSTAT_SETCMD)
2854 if (PL_origalen != 1) {
2856 s = SvPV_const(sv, len);
2857 un.pst_command = (char *)s;
2858 pstat(PSTAT_SETCMD, un, len, 0, 0);
2861 if (PL_origalen > 1) {
2862 /* PL_origalen is set in perl_parse(). */
2863 s = SvPV_force(sv,len);
2864 if (len >= (STRLEN)PL_origalen-1) {
2865 /* Longer than original, will be truncated. We assume that
2866 * PL_origalen bytes are available. */
2867 Copy(s, PL_origargv[0], PL_origalen-1, char);
2870 /* Shorter than original, will be padded. */
2872 /* Special case for Mac OS X: see [perl #38868] */
2875 /* Is the space counterintuitive? Yes.
2876 * (You were expecting \0?)
2877 * Does it work? Seems to. (In Linux 2.4.20 at least.)
2879 const int pad = ' ';
2881 Copy(s, PL_origargv[0], len, char);
2882 PL_origargv[0][len] = 0;
2883 memset(PL_origargv[0] + len + 1,
2884 pad, PL_origalen - len - 1);
2886 PL_origargv[0][PL_origalen-1] = 0;
2887 for (i = 1; i < PL_origargc; i++)
2889 #ifdef HAS_PRCTL_SET_NAME
2890 /* Set the legacy process name in addition to the POSIX name on Linux */
2891 if (prctl(PR_SET_NAME, (unsigned long)s, 0, 0, 0) != 0) {
2892 /* diag_listed_as: SKIPME */
2893 Perl_croak(aTHX_ "Can't set $0 with prctl(): %s", Strerror(errno));
2898 UNLOCK_DOLLARZERO_MUTEX;
2905 Perl_whichsig(pTHX_ const char *sig)
2907 register char* const* sigv;
2909 PERL_ARGS_ASSERT_WHICHSIG;
2910 PERL_UNUSED_CONTEXT;
2912 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
2913 if (strEQ(sig,*sigv))
2914 return PL_sig_num[sigv - (char* const*)PL_sig_name];
2916 if (strEQ(sig,"CHLD"))
2920 if (strEQ(sig,"CLD"))
2927 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2928 Perl_sighandler(int sig, siginfo_t *sip, void *uap PERL_UNUSED_DECL)
2930 Perl_sighandler(int sig)
2933 #ifdef PERL_GET_SIG_CONTEXT
2934 dTHXa(PERL_GET_SIG_CONTEXT);
2941 SV * const tSv = PL_Sv;
2945 XPV * const tXpv = PL_Xpv;
2947 if (PL_savestack_ix + 15 <= PL_savestack_max)
2949 if (PL_markstack_ptr < PL_markstack_max - 2)
2951 if (PL_scopestack_ix < PL_scopestack_max - 3)
2954 if (!PL_psig_ptr[sig]) {
2955 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2960 /* Max number of items pushed there is 3*n or 4. We cannot fix
2961 infinity, so we fix 4 (in fact 5): */
2963 PL_savestack_ix += 5; /* Protect save in progress. */
2964 SAVEDESTRUCTOR_X(S_unwind_handler_stack, (void*)&flags);
2967 PL_markstack_ptr++; /* Protect mark. */
2969 PL_scopestack_ix += 1;
2970 /* sv_2cv is too complicated, try a simpler variant first: */
2971 if (!SvROK(PL_psig_ptr[sig]) || !(cv = MUTABLE_CV(SvRV(PL_psig_ptr[sig])))
2972 || SvTYPE(cv) != SVt_PVCV) {
2974 cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
2977 if (!cv || !CvROOT(cv)) {
2978 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2979 PL_sig_name[sig], (gv ? GvENAME(gv)
2986 if(PL_psig_name[sig]) {
2987 sv = SvREFCNT_inc_NN(PL_psig_name[sig]);
2989 #if !defined(PERL_IMPLICIT_CONTEXT)
2993 sv = sv_newmortal();
2994 sv_setpv(sv,PL_sig_name[sig]);
2997 PUSHSTACKi(PERLSI_SIGNAL);
3000 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3002 struct sigaction oact;
3004 if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
3007 SV *rv = newRV_noinc(MUTABLE_SV(sih));
3008 /* The siginfo fields signo, code, errno, pid, uid,
3009 * addr, status, and band are defined by POSIX/SUSv3. */
3010 (void)hv_stores(sih, "signo", newSViv(sip->si_signo));
3011 (void)hv_stores(sih, "code", newSViv(sip->si_code));
3012 #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. */
3013 hv_stores(sih, "errno", newSViv(sip->si_errno));
3014 hv_stores(sih, "status", newSViv(sip->si_status));
3015 hv_stores(sih, "uid", newSViv(sip->si_uid));
3016 hv_stores(sih, "pid", newSViv(sip->si_pid));
3017 hv_stores(sih, "addr", newSVuv(PTR2UV(sip->si_addr)));
3018 hv_stores(sih, "band", newSViv(sip->si_band));
3022 mPUSHp((char *)sip, sizeof(*sip));
3030 call_sv(MUTABLE_SV(cv), G_DISCARD|G_EVAL);
3033 if (SvTRUE(ERRSV)) {
3035 #ifdef HAS_SIGPROCMASK
3036 /* Handler "died", for example to get out of a restart-able read().
3037 * Before we re-do that on its behalf re-enable the signal which was
3038 * blocked by the system when we entered.
3042 sigaddset(&set,sig);
3043 sigprocmask(SIG_UNBLOCK, &set, NULL);
3045 /* Not clear if this will work */
3046 (void)rsignal(sig, SIG_IGN);
3047 (void)rsignal(sig, PL_csighandlerp);
3049 #endif /* !PERL_MICRO */
3054 PL_savestack_ix -= 8; /* Unprotect save in progress. */
3058 PL_scopestack_ix -= 1;
3061 PL_op = myop; /* Apparently not needed... */
3063 PL_Sv = tSv; /* Restore global temporaries. */
3070 S_restore_magic(pTHX_ const void *p)
3073 MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
3074 SV* const sv = mgs->mgs_sv;
3079 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
3081 #ifdef PERL_OLD_COPY_ON_WRITE
3082 /* While magic was saved (and off) sv_setsv may well have seen
3083 this SV as a prime candidate for COW. */
3085 sv_force_normal_flags(sv, 0);
3088 if (mgs->mgs_readonly)
3090 if (mgs->mgs_magical)
3091 SvFLAGS(sv) |= mgs->mgs_magical;
3094 if (SvGMAGICAL(sv)) {
3095 /* downgrade public flags to private,
3096 and discard any other private flags */
3098 const U32 pubflags = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
3100 SvFLAGS(sv) &= ~( pubflags | (SVp_IOK|SVp_NOK|SVp_POK) );
3101 SvFLAGS(sv) |= ( pubflags << PRIVSHIFT );
3106 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
3108 /* If we're still on top of the stack, pop us off. (That condition
3109 * will be satisfied if restore_magic was called explicitly, but *not*
3110 * if it's being called via leave_scope.)
3111 * The reason for doing this is that otherwise, things like sv_2cv()
3112 * may leave alloc gunk on the savestack, and some code
3113 * (e.g. sighandler) doesn't expect that...
3115 if (PL_savestack_ix == mgs->mgs_ss_ix)
3117 UV popval = SSPOPUV;
3118 assert(popval == SAVEt_DESTRUCTOR_X);
3119 PL_savestack_ix -= 2;
3121 assert((popval & SAVE_MASK) == SAVEt_ALLOC);
3122 PL_savestack_ix -= popval >> SAVE_TIGHT_SHIFT;
3128 S_unwind_handler_stack(pTHX_ const void *p)
3131 const U32 flags = *(const U32*)p;
3133 PERL_ARGS_ASSERT_UNWIND_HANDLER_STACK;
3136 PL_savestack_ix -= 5; /* Unprotect save in progress. */
3137 #if !defined(PERL_IMPLICIT_CONTEXT)
3139 SvREFCNT_dec(PL_sig_sv);
3144 =for apidoc magic_sethint
3146 Triggered by a store to %^H, records the key/value pair to
3147 C<PL_compiling.cop_hints_hash>. It is assumed that hints aren't storing
3148 anything that would need a deep copy. Maybe we should warn if we find a
3154 Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
3157 SV *key = (mg->mg_len == HEf_SVKEY) ? MUTABLE_SV(mg->mg_ptr)
3158 : newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
3160 PERL_ARGS_ASSERT_MAGIC_SETHINT;
3162 /* mg->mg_obj isn't being used. If needed, it would be possible to store
3163 an alternative leaf in there, with PL_compiling.cop_hints being used if
3164 it's NULL. If needed for threads, the alternative could lock a mutex,
3165 or take other more complex action. */
3167 /* Something changed in %^H, so it will need to be restored on scope exit.
3168 Doing this here saves a lot of doing it manually in perl code (and
3169 forgetting to do it, and consequent subtle errors. */
3170 PL_hints |= HINT_LOCALIZE_HH;
3171 CopHINTHASH_set(&PL_compiling,
3172 cophh_store_sv(CopHINTHASH_get(&PL_compiling), key, 0, sv, 0));
3177 =for apidoc magic_clearhint
3179 Triggered by a delete from %^H, records the key to
3180 C<PL_compiling.cop_hints_hash>.
3185 Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
3189 PERL_ARGS_ASSERT_MAGIC_CLEARHINT;
3190 PERL_UNUSED_ARG(sv);
3192 assert(mg->mg_len == HEf_SVKEY);
3194 PERL_UNUSED_ARG(sv);
3196 PL_hints |= HINT_LOCALIZE_HH;
3197 CopHINTHASH_set(&PL_compiling,
3198 cophh_delete_sv(CopHINTHASH_get(&PL_compiling),
3199 MUTABLE_SV(mg->mg_ptr), 0, 0));
3204 =for apidoc magic_clearhints
3206 Triggered by clearing %^H, resets C<PL_compiling.cop_hints_hash>.
3211 Perl_magic_clearhints(pTHX_ SV *sv, MAGIC *mg)
3213 PERL_ARGS_ASSERT_MAGIC_CLEARHINTS;
3214 PERL_UNUSED_ARG(sv);
3215 PERL_UNUSED_ARG(mg);
3216 cophh_free(CopHINTHASH_get(&PL_compiling));
3217 CopHINTHASH_set(&PL_compiling, cophh_new_empty());
3223 * c-indentation-style: bsd
3225 * indent-tabs-mode: t
3228 * ex: set ts=8 sts=4 sw=4 noet: