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 */
191 Do magic after a value is retrieved from the SV. See C<sv_magic>.
197 Perl_mg_get(pTHX_ SV *sv)
200 const I32 mgs_ix = SSNEW(sizeof(MGS));
201 const bool was_temp = cBOOL(SvTEMP(sv));
203 MAGIC *newmg, *head, *cur, *mg;
204 /* guard against sv having being freed midway by holding a private
207 PERL_ARGS_ASSERT_MG_GET;
209 /* sv_2mortal has this side effect of turning on the TEMP flag, which can
210 cause the SV's buffer to get stolen (and maybe other stuff).
213 sv_2mortal(SvREFCNT_inc_simple_NN(sv));
218 save_magic(mgs_ix, sv);
220 /* We must call svt_get(sv, mg) for each valid entry in the linked
221 list of magic. svt_get() may delete the current entry, add new
222 magic to the head of the list, or upgrade the SV. AMS 20010810 */
224 newmg = cur = head = mg = SvMAGIC(sv);
226 const MGVTBL * const vtbl = mg->mg_virtual;
227 MAGIC * const nextmg = mg->mg_moremagic; /* it may delete itself */
229 if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
230 CALL_FPTR(vtbl->svt_get)(aTHX_ sv, mg);
232 /* guard against magic having been deleted - eg FETCH calling
235 (SSPTR(mgs_ix, MGS *))->mgs_magical = 0; /* recalculate flags */
239 /* recalculate flags if this entry was deleted. */
240 if (mg->mg_flags & MGf_GSKIP)
241 (SSPTR(mgs_ix, MGS *))->mgs_magical = 0;
247 /* Have we finished with the new entries we saw? Start again
248 where we left off (unless there are more new entries). */
256 /* Were any new entries added? */
257 if (!have_new && (newmg = SvMAGIC(sv)) != head) {
261 (SSPTR(mgs_ix, MGS *))->mgs_magical = 0; /* recalculate flags */
265 restore_magic(INT2PTR(void *, (IV)mgs_ix));
267 if (SvREFCNT(sv) == 1) {
268 /* We hold the last reference to this SV, which implies that the
269 SV was deleted as a side effect of the routines we called. */
278 Do magic after a value is assigned to the SV. See C<sv_magic>.
284 Perl_mg_set(pTHX_ SV *sv)
287 const I32 mgs_ix = SSNEW(sizeof(MGS));
291 PERL_ARGS_ASSERT_MG_SET;
293 save_magic(mgs_ix, sv);
295 for (mg = SvMAGIC(sv); mg; mg = nextmg) {
296 const MGVTBL* vtbl = mg->mg_virtual;
297 nextmg = mg->mg_moremagic; /* it may delete itself */
298 if (mg->mg_flags & MGf_GSKIP) {
299 mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */
300 (SSPTR(mgs_ix, MGS*))->mgs_magical = 0;
302 if (PL_localizing == 2 && !S_is_container_magic(mg))
304 if (vtbl && vtbl->svt_set)
305 CALL_FPTR(vtbl->svt_set)(aTHX_ sv, mg);
308 restore_magic(INT2PTR(void*, (IV)mgs_ix));
313 =for apidoc mg_length
315 Report on the SV's length. See C<sv_magic>.
321 Perl_mg_length(pTHX_ SV *sv)
327 PERL_ARGS_ASSERT_MG_LENGTH;
329 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
330 const MGVTBL * const vtbl = mg->mg_virtual;
331 if (vtbl && vtbl->svt_len) {
332 const I32 mgs_ix = SSNEW(sizeof(MGS));
333 save_magic(mgs_ix, sv);
334 /* omit MGf_GSKIP -- not changed here */
335 len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
336 restore_magic(INT2PTR(void*, (IV)mgs_ix));
342 /* You can't know whether it's UTF-8 until you get the string again...
344 const U8 *s = (U8*)SvPV_const(sv, len);
347 len = utf8_length(s, s + len);
354 Perl_mg_size(pTHX_ SV *sv)
358 PERL_ARGS_ASSERT_MG_SIZE;
360 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
361 const MGVTBL* const vtbl = mg->mg_virtual;
362 if (vtbl && vtbl->svt_len) {
363 const I32 mgs_ix = SSNEW(sizeof(MGS));
365 save_magic(mgs_ix, sv);
366 /* omit MGf_GSKIP -- not changed here */
367 len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
368 restore_magic(INT2PTR(void*, (IV)mgs_ix));
375 return AvFILLp((const AV *) sv); /* Fallback to non-tied array */
379 Perl_croak(aTHX_ "Size magic not implemented");
388 Clear something magical that the SV represents. See C<sv_magic>.
394 Perl_mg_clear(pTHX_ SV *sv)
396 const I32 mgs_ix = SSNEW(sizeof(MGS));
400 PERL_ARGS_ASSERT_MG_CLEAR;
402 save_magic(mgs_ix, sv);
404 for (mg = SvMAGIC(sv); mg; mg = nextmg) {
405 const MGVTBL* const vtbl = mg->mg_virtual;
406 /* omit GSKIP -- never set here */
408 nextmg = mg->mg_moremagic; /* it may delete itself */
410 if (vtbl && vtbl->svt_clear)
411 CALL_FPTR(vtbl->svt_clear)(aTHX_ sv, mg);
414 restore_magic(INT2PTR(void*, (IV)mgs_ix));
421 Finds the magic pointer for type matching the SV. See C<sv_magic>.
427 Perl_mg_find(pTHX_ const SV *sv, int type)
432 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
433 if (mg->mg_type == type)
443 Copies the magic from one SV to another. See C<sv_magic>.
449 Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
454 PERL_ARGS_ASSERT_MG_COPY;
456 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
457 const MGVTBL* const vtbl = mg->mg_virtual;
458 if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){
459 count += CALL_FPTR(vtbl->svt_copy)(aTHX_ sv, mg, nsv, key, klen);
462 const char type = mg->mg_type;
463 if (isUPPER(type) && type != PERL_MAGIC_uvar) {
465 (type == PERL_MAGIC_tied)
467 : (type == PERL_MAGIC_regdata && mg->mg_obj)
470 toLOWER(type), key, klen);
479 =for apidoc mg_localize
481 Copy some of the magic from an existing SV to new localized version of that
482 SV. Container magic (eg %ENV, $1, tie) gets copied, value magic doesn't (eg
485 If setmagic is false then no set magic will be called on the new (empty) SV.
486 This typically means that assignment will soon follow (e.g. 'local $x = $y'),
487 and that will handle the magic.
493 Perl_mg_localize(pTHX_ SV *sv, SV *nsv, bool setmagic)
498 PERL_ARGS_ASSERT_MG_LOCALIZE;
500 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
501 const MGVTBL* const vtbl = mg->mg_virtual;
502 if (!S_is_container_magic(mg))
505 if ((mg->mg_flags & MGf_LOCAL) && vtbl->svt_local)
506 (void)CALL_FPTR(vtbl->svt_local)(aTHX_ nsv, mg);
508 sv_magicext(nsv, mg->mg_obj, mg->mg_type, vtbl,
509 mg->mg_ptr, mg->mg_len);
511 /* container types should remain read-only across localization */
512 SvFLAGS(nsv) |= SvREADONLY(sv);
515 if (SvTYPE(nsv) >= SVt_PVMG && SvMAGIC(nsv)) {
516 SvFLAGS(nsv) |= SvMAGICAL(sv);
528 Free any magic storage used by the SV. See C<sv_magic>.
534 Perl_mg_free(pTHX_ SV *sv)
539 PERL_ARGS_ASSERT_MG_FREE;
541 for (mg = SvMAGIC(sv); mg; mg = moremagic) {
542 const MGVTBL* const vtbl = mg->mg_virtual;
543 moremagic = mg->mg_moremagic;
544 if (vtbl && vtbl->svt_free)
545 CALL_FPTR(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);
555 SvMAGIC_set(sv, moremagic);
557 SvMAGIC_set(sv, NULL);
565 Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
570 PERL_ARGS_ASSERT_MAGIC_REGDATA_CNT;
573 register const REGEXP * const rx = PM_GETRE(PL_curpm);
575 if (mg->mg_obj) { /* @+ */
576 /* return the number possible */
577 return RX_NPARENS(rx);
579 I32 paren = RX_LASTPAREN(rx);
581 /* return the last filled */
583 && (RX_OFFS(rx)[paren].start == -1
584 || RX_OFFS(rx)[paren].end == -1) )
595 Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
599 PERL_ARGS_ASSERT_MAGIC_REGDATUM_GET;
602 register const REGEXP * const rx = PM_GETRE(PL_curpm);
604 register const I32 paren = mg->mg_len;
609 if (paren <= (I32)RX_NPARENS(rx) &&
610 (s = RX_OFFS(rx)[paren].start) != -1 &&
611 (t = RX_OFFS(rx)[paren].end) != -1)
614 if (mg->mg_obj) /* @+ */
619 if (i > 0 && RX_MATCH_UTF8(rx)) {
620 const char * const b = RX_SUBBEG(rx);
622 i = utf8_length((U8*)b, (U8*)(b+i));
633 Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
635 PERL_ARGS_ASSERT_MAGIC_REGDATUM_SET;
638 Perl_croak(aTHX_ "%s", PL_no_modify);
639 NORETURN_FUNCTION_END;
643 Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
648 register const REGEXP * rx;
649 const char * const remaining = mg->mg_ptr + 1;
651 PERL_ARGS_ASSERT_MAGIC_LEN;
653 switch (*mg->mg_ptr) {
655 if (*remaining == '\0') { /* ^P */
657 } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
659 } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
663 case '\015': /* $^MATCH */
664 if (strEQ(remaining, "ATCH")) {
671 paren = RX_BUFF_IDX_PREMATCH;
675 paren = RX_BUFF_IDX_POSTMATCH;
679 paren = RX_BUFF_IDX_FULLMATCH;
681 case '1': case '2': case '3': case '4':
682 case '5': case '6': case '7': case '8': case '9':
683 paren = atoi(mg->mg_ptr);
685 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
687 i = CALLREG_NUMBUF_LENGTH((REGEXP * const)rx, sv, paren);
690 Perl_croak(aTHX_ "panic: magic_len: %"IVdf, (IV)i);
693 if (ckWARN(WARN_UNINITIALIZED))
698 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
699 paren = RX_LASTPAREN(rx);
704 case '\016': /* ^N */
705 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
706 paren = RX_LASTCLOSEPAREN(rx);
713 if (!SvPOK(sv) && SvNIOK(sv)) {
721 #define SvRTRIM(sv) STMT_START { \
723 STRLEN len = SvCUR(sv); \
724 char * const p = SvPVX(sv); \
725 while (len > 0 && isSPACE(p[len-1])) \
727 SvCUR_set(sv, len); \
733 Perl_emulate_cop_io(pTHX_ const COP *const c, SV *const sv)
735 PERL_ARGS_ASSERT_EMULATE_COP_IO;
737 if (!(CopHINTS_get(c) & (HINT_LEXICAL_IO_IN|HINT_LEXICAL_IO_OUT)))
738 sv_setsv(sv, &PL_sv_undef);
742 if ((CopHINTS_get(c) & HINT_LEXICAL_IO_IN)) {
743 SV *const value = Perl_refcounted_he_fetch(aTHX_
745 0, "open<", 5, 0, 0);
750 if ((CopHINTS_get(c) & HINT_LEXICAL_IO_OUT)) {
751 SV *const value = Perl_refcounted_he_fetch(aTHX_
753 0, "open>", 5, 0, 0);
761 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
765 register char *s = NULL;
767 const char * const remaining = mg->mg_ptr + 1;
768 const char nextchar = *remaining;
770 PERL_ARGS_ASSERT_MAGIC_GET;
772 switch (*mg->mg_ptr) {
773 case '\001': /* ^A */
774 sv_setsv(sv, PL_bodytarget);
776 case '\003': /* ^C, ^CHILD_ERROR_NATIVE */
777 if (nextchar == '\0') {
778 sv_setiv(sv, (IV)PL_minus_c);
780 else if (strEQ(remaining, "HILD_ERROR_NATIVE")) {
781 sv_setiv(sv, (IV)STATUS_NATIVE);
785 case '\004': /* ^D */
786 sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
788 case '\005': /* ^E */
789 if (nextchar == '\0') {
792 # include <descrip.h>
793 # include <starlet.h>
795 $DESCRIPTOR(msgdsc,msg);
796 sv_setnv(sv,(NV) vaxc$errno);
797 if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
798 sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
803 if (!(_emx_env & 0x200)) { /* Under DOS */
804 sv_setnv(sv, (NV)errno);
805 sv_setpv(sv, errno ? Strerror(errno) : "");
807 if (errno != errno_isOS2) {
808 const int tmp = _syserrno();
809 if (tmp) /* 2nd call to _syserrno() makes it 0 */
812 sv_setnv(sv, (NV)Perl_rc);
813 sv_setpv(sv, os2error(Perl_rc));
817 const DWORD dwErr = GetLastError();
818 sv_setnv(sv, (NV)dwErr);
820 PerlProc_GetOSError(sv, dwErr);
829 sv_setnv(sv, (NV)errno);
830 sv_setpv(sv, errno ? Strerror(errno) : "");
835 SvNOK_on(sv); /* what a wonderful hack! */
837 else if (strEQ(remaining, "NCODING"))
838 sv_setsv(sv, PL_encoding);
840 case '\006': /* ^F */
841 sv_setiv(sv, (IV)PL_maxsysfd);
843 case '\010': /* ^H */
844 sv_setiv(sv, (IV)PL_hints);
846 case '\011': /* ^I */ /* NOT \t in EBCDIC */
847 sv_setpv(sv, PL_inplace); /* Will undefine sv if PL_inplace is NULL */
849 case '\017': /* ^O & ^OPEN */
850 if (nextchar == '\0') {
851 sv_setpv(sv, PL_osname);
854 else if (strEQ(remaining, "PEN")) {
855 Perl_emulate_cop_io(aTHX_ &PL_compiling, sv);
859 if (nextchar == '\0') { /* ^P */
860 sv_setiv(sv, (IV)PL_perldb);
861 } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
862 goto do_prematch_fetch;
863 } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
864 goto do_postmatch_fetch;
867 case '\023': /* ^S */
868 if (nextchar == '\0') {
869 if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING)
872 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
877 case '\024': /* ^T */
878 if (nextchar == '\0') {
880 sv_setnv(sv, PL_basetime);
882 sv_setiv(sv, (IV)PL_basetime);
885 else if (strEQ(remaining, "AINT"))
886 sv_setiv(sv, PL_tainting
887 ? (PL_taint_warn || PL_unsafe ? -1 : 1)
890 case '\025': /* $^UNICODE, $^UTF8LOCALE, $^UTF8CACHE */
891 if (strEQ(remaining, "NICODE"))
892 sv_setuv(sv, (UV) PL_unicode);
893 else if (strEQ(remaining, "TF8LOCALE"))
894 sv_setuv(sv, (UV) PL_utf8locale);
895 else if (strEQ(remaining, "TF8CACHE"))
896 sv_setiv(sv, (IV) PL_utf8cache);
898 case '\027': /* ^W & $^WARNING_BITS */
899 if (nextchar == '\0')
900 sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
901 else if (strEQ(remaining, "ARNING_BITS")) {
902 if (PL_compiling.cop_warnings == pWARN_NONE) {
903 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
905 else if (PL_compiling.cop_warnings == pWARN_STD) {
908 (PL_dowarn & G_WARN_ON) ? WARN_ALLstring : WARN_NONEstring,
912 else if (PL_compiling.cop_warnings == pWARN_ALL) {
913 /* Get the bit mask for $warnings::Bits{all}, because
914 * it could have been extended by warnings::register */
915 HV * const bits=get_hv("warnings::Bits", 0);
917 SV ** const bits_all = hv_fetchs(bits, "all", FALSE);
919 sv_setsv(sv, *bits_all);
922 sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
926 sv_setpvn(sv, (char *) (PL_compiling.cop_warnings + 1),
927 *PL_compiling.cop_warnings);
932 case '\015': /* $^MATCH */
933 if (strEQ(remaining, "ATCH")) {
934 case '1': case '2': case '3': case '4':
935 case '5': case '6': case '7': case '8': case '9': case '&':
936 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
938 * Pre-threads, this was paren = atoi(GvENAME((const GV *)mg->mg_obj));
939 * XXX Does the new way break anything?
941 paren = atoi(mg->mg_ptr); /* $& is in [0] */
942 CALLREG_NUMBUF_FETCH(rx,paren,sv);
945 sv_setsv(sv,&PL_sv_undef);
949 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
950 if (RX_LASTPAREN(rx)) {
951 CALLREG_NUMBUF_FETCH(rx,RX_LASTPAREN(rx),sv);
955 sv_setsv(sv,&PL_sv_undef);
957 case '\016': /* ^N */
958 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
959 if (RX_LASTCLOSEPAREN(rx)) {
960 CALLREG_NUMBUF_FETCH(rx,RX_LASTCLOSEPAREN(rx),sv);
965 sv_setsv(sv,&PL_sv_undef);
969 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
970 CALLREG_NUMBUF_FETCH(rx,-2,sv);
973 sv_setsv(sv,&PL_sv_undef);
977 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
978 CALLREG_NUMBUF_FETCH(rx,-1,sv);
981 sv_setsv(sv,&PL_sv_undef);
984 if (GvIO(PL_last_in_gv)) {
985 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
990 sv_setiv(sv, (IV)STATUS_CURRENT);
991 #ifdef COMPLEX_STATUS
992 SvUPGRADE(sv, SVt_PVLV);
993 LvTARGOFF(sv) = PL_statusvalue;
994 LvTARGLEN(sv) = PL_statusvalue_vms;
999 if (!isGV_with_GP(PL_defoutgv))
1001 else if (GvIOp(PL_defoutgv))
1002 s = IoTOP_NAME(GvIOp(PL_defoutgv));
1006 sv_setpv(sv,GvENAME(PL_defoutgv));
1007 sv_catpvs(sv,"_TOP");
1011 if (!isGV_with_GP(PL_defoutgv))
1013 else if (GvIOp(PL_defoutgv))
1014 s = IoFMT_NAME(GvIOp(PL_defoutgv));
1016 s = GvENAME(PL_defoutgv);
1020 if (GvIO(PL_defoutgv))
1021 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
1024 if (GvIO(PL_defoutgv))
1025 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
1028 if (GvIO(PL_defoutgv))
1029 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
1036 sv_setiv(sv, (IV)CopARYBASE_get(PL_curcop));
1039 if (GvIO(PL_defoutgv))
1040 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
1044 sv_copypv(sv, PL_ors_sv);
1050 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
1052 sv_setnv(sv, (NV)errno);
1055 if (errno == errno_isOS2 || errno == errno_isOS2_set)
1056 sv_setpv(sv, os2error(Perl_rc));
1059 sv_setpv(sv, errno ? Strerror(errno) : "");
1061 SvPOK_on(sv); /* may have got removed during taint processing */
1066 SvNOK_on(sv); /* what a wonderful hack! */
1069 sv_setiv(sv, (IV)PL_uid);
1072 sv_setiv(sv, (IV)PL_euid);
1075 sv_setiv(sv, (IV)PL_gid);
1078 sv_setiv(sv, (IV)PL_egid);
1080 #ifdef HAS_GETGROUPS
1082 Groups_t *gary = NULL;
1083 I32 i, num_groups = getgroups(0, gary);
1084 Newx(gary, num_groups, Groups_t);
1085 num_groups = getgroups(num_groups, gary);
1086 for (i = 0; i < num_groups; i++)
1087 Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]);
1090 (void)SvIOK_on(sv); /* what a wonderful hack! */
1100 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
1102 struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
1104 PERL_ARGS_ASSERT_MAGIC_GETUVAR;
1106 if (uf && uf->uf_val)
1107 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
1112 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
1115 STRLEN len = 0, klen;
1116 const char *s = SvOK(sv) ? SvPV_const(sv,len) : "";
1117 const char * const ptr = MgPV_const(mg,klen);
1120 PERL_ARGS_ASSERT_MAGIC_SETENV;
1122 #ifdef DYNAMIC_ENV_FETCH
1123 /* We just undefd an environment var. Is a replacement */
1124 /* waiting in the wings? */
1126 SV ** const valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE);
1128 s = SvOK(*valp) ? SvPV_const(*valp, len) : "";
1132 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
1133 /* And you'll never guess what the dog had */
1134 /* in its mouth... */
1136 MgTAINTEDDIR_off(mg);
1138 if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
1139 char pathbuf[256], eltbuf[256], *cp, *elt;
1143 my_strlcpy(eltbuf, s, sizeof(eltbuf));
1145 do { /* DCL$PATH may be a search list */
1146 while (1) { /* as may dev portion of any element */
1147 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1148 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1149 cando_by_name(S_IWUSR,0,elt) ) {
1150 MgTAINTEDDIR_on(mg);
1154 if ((cp = strchr(elt, ':')) != NULL)
1156 if (my_trnlnm(elt, eltbuf, j++))
1162 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1165 if (s && klen == 4 && strEQ(ptr,"PATH")) {
1166 const char * const strend = s + len;
1168 while (s < strend) {
1172 #ifdef VMS /* Hmm. How do we get $Config{path_sep} from C? */
1173 const char path_sep = '|';
1175 const char path_sep = ':';
1177 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
1178 s, strend, path_sep, &i);
1180 if (i >= (I32)sizeof tmpbuf /* too long -- assume the worst */
1182 || !strchr(tmpbuf, ':') /* no colon thus no device name -- assume relative path */
1184 || *tmpbuf != '/' /* no starting slash -- assume relative path */
1186 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1187 MgTAINTEDDIR_on(mg);
1193 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1199 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1201 PERL_ARGS_ASSERT_MAGIC_CLEARENV;
1202 PERL_UNUSED_ARG(sv);
1203 my_setenv(MgPV_nolen_const(mg),NULL);
1208 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1211 PERL_ARGS_ASSERT_MAGIC_SET_ALL_ENV;
1212 PERL_UNUSED_ARG(mg);
1214 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1216 if (PL_localizing) {
1219 hv_iterinit(MUTABLE_HV(sv));
1220 while ((entry = hv_iternext(MUTABLE_HV(sv)))) {
1222 my_setenv(hv_iterkey(entry, &keylen),
1223 SvPV_nolen_const(hv_iterval(MUTABLE_HV(sv), entry)));
1231 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1234 PERL_ARGS_ASSERT_MAGIC_CLEAR_ALL_ENV;
1235 PERL_UNUSED_ARG(sv);
1236 PERL_UNUSED_ARG(mg);
1238 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1246 #ifdef HAS_SIGPROCMASK
1248 restore_sigmask(pTHX_ SV *save_sv)
1250 const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1251 (void)sigprocmask(SIG_SETMASK, ossetp, NULL);
1255 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1258 /* Are we fetching a signal entry? */
1259 int i = (I16)mg->mg_private;
1261 PERL_ARGS_ASSERT_MAGIC_GETSIG;
1264 mg->mg_private = i = whichsig(MgPV_nolen_const(mg));
1269 sv_setsv(sv,PL_psig_ptr[i]);
1271 Sighandler_t sigstate = rsignal_state(i);
1272 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1273 if (PL_sig_handlers_initted && PL_sig_ignoring[i])
1276 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1277 if (PL_sig_handlers_initted && PL_sig_defaulting[i])
1280 /* cache state so we don't fetch it again */
1281 if(sigstate == (Sighandler_t) SIG_IGN)
1282 sv_setpvs(sv,"IGNORE");
1284 sv_setsv(sv,&PL_sv_undef);
1285 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1292 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1294 PERL_ARGS_ASSERT_MAGIC_CLEARSIG;
1295 PERL_UNUSED_ARG(sv);
1297 magic_setsig(NULL, mg);
1298 return sv_unmagic(sv, mg->mg_type);
1302 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1303 Perl_csighandler(int sig, siginfo_t *sip PERL_UNUSED_DECL, void *uap PERL_UNUSED_DECL)
1305 Perl_csighandler(int sig)
1308 #ifdef PERL_GET_SIG_CONTEXT
1309 dTHXa(PERL_GET_SIG_CONTEXT);
1313 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1314 (void) rsignal(sig, PL_csighandlerp);
1315 if (PL_sig_ignoring[sig]) return;
1317 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1318 if (PL_sig_defaulting[sig])
1319 #ifdef KILL_BY_SIGPRC
1320 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1335 (PL_signals & PERL_SIGNALS_UNSAFE_FLAG))
1336 /* Call the perl level handler now--
1337 * with risk we may be in malloc() or being destructed etc. */
1338 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1339 (*PL_sighandlerp)(sig, NULL, NULL);
1341 (*PL_sighandlerp)(sig);
1344 if (!PL_psig_pend) return;
1345 /* Set a flag to say this signal is pending, that is awaiting delivery after
1346 * the current Perl opcode completes */
1347 PL_psig_pend[sig]++;
1349 #ifndef SIG_PENDING_DIE_COUNT
1350 # define SIG_PENDING_DIE_COUNT 120
1352 /* Add one to say _a_ signal is pending */
1353 if (++PL_sig_pending >= SIG_PENDING_DIE_COUNT)
1354 Perl_croak(aTHX_ "Maximal count of pending signals (%lu) exceeded",
1355 (unsigned long)SIG_PENDING_DIE_COUNT);
1359 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1361 Perl_csighandler_init(void)
1364 if (PL_sig_handlers_initted) return;
1366 for (sig = 1; sig < SIG_SIZE; sig++) {
1367 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1369 PL_sig_defaulting[sig] = 1;
1370 (void) rsignal(sig, PL_csighandlerp);
1372 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1373 PL_sig_ignoring[sig] = 0;
1376 PL_sig_handlers_initted = 1;
1381 Perl_despatch_signals(pTHX)
1386 for (sig = 1; sig < SIG_SIZE; sig++) {
1387 if (PL_psig_pend[sig]) {
1388 PERL_BLOCKSIG_ADD(set, sig);
1389 PL_psig_pend[sig] = 0;
1390 PERL_BLOCKSIG_BLOCK(set);
1391 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1392 (*PL_sighandlerp)(sig, NULL, NULL);
1394 (*PL_sighandlerp)(sig);
1396 PERL_BLOCKSIG_UNBLOCK(set);
1401 /* sv of NULL signifies that we're acting as magic_clearsig. */
1403 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1408 /* Need to be careful with SvREFCNT_dec(), because that can have side
1409 * effects (due to closures). We must make sure that the new disposition
1410 * is in place before it is called.
1414 #ifdef HAS_SIGPROCMASK
1418 register const char *s = MgPV_const(mg,len);
1420 PERL_ARGS_ASSERT_MAGIC_SETSIG;
1423 if (strEQ(s,"__DIE__"))
1425 else if (strEQ(s,"__WARN__")
1426 && (sv ? 1 : PL_warnhook != PERL_WARNHOOK_FATAL)) {
1427 /* Merge the existing behaviours, which are as follows:
1428 magic_setsig, we always set svp to &PL_warnhook
1429 (hence we always change the warnings handler)
1430 For magic_clearsig, we don't change the warnings handler if it's
1431 set to the &PL_warnhook. */
1434 Perl_croak(aTHX_ "No such hook: %s", s);
1437 if (*svp != PERL_WARNHOOK_FATAL)
1443 i = (I16)mg->mg_private;
1445 i = whichsig(s); /* ...no, a brick */
1446 mg->mg_private = (U16)i;
1450 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
1453 #ifdef HAS_SIGPROCMASK
1454 /* Avoid having the signal arrive at a bad time, if possible. */
1457 sigprocmask(SIG_BLOCK, &set, &save);
1459 save_sv = newSVpvn((char *)(&save), sizeof(sigset_t));
1460 SAVEFREESV(save_sv);
1461 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1464 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1465 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1467 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1468 PL_sig_ignoring[i] = 0;
1470 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1471 PL_sig_defaulting[i] = 0;
1473 to_dec = PL_psig_ptr[i];
1475 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1476 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1478 /* Signals don't change name during the program's execution, so once
1479 they're cached in the appropriate slot of PL_psig_name, they can
1482 Ideally we'd find some way of making SVs at (C) compile time, or
1483 at least, doing most of the work. */
1484 if (!PL_psig_name[i]) {
1485 PL_psig_name[i] = newSVpvn(s, len);
1486 SvREADONLY_on(PL_psig_name[i]);
1489 SvREFCNT_dec(PL_psig_name[i]);
1490 PL_psig_name[i] = NULL;
1491 PL_psig_ptr[i] = NULL;
1494 if (sv && (isGV_with_GP(sv) || SvROK(sv))) {
1496 (void)rsignal(i, PL_csighandlerp);
1499 *svp = SvREFCNT_inc_simple_NN(sv);
1501 if (sv && SvOK(sv)) {
1502 s = SvPV_force(sv, len);
1506 if (sv && strEQ(s,"IGNORE")) {
1508 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1509 PL_sig_ignoring[i] = 1;
1510 (void)rsignal(i, PL_csighandlerp);
1512 (void)rsignal(i, (Sighandler_t) SIG_IGN);
1516 else if (!sv || strEQ(s,"DEFAULT") || !len) {
1518 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1519 PL_sig_defaulting[i] = 1;
1520 (void)rsignal(i, PL_csighandlerp);
1522 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1528 * We should warn if HINT_STRICT_REFS, but without
1529 * access to a known hint bit in a known OP, we can't
1530 * tell whether HINT_STRICT_REFS is in force or not.
1532 if (!strchr(s,':') && !strchr(s,'\''))
1533 Perl_sv_insert_flags(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"),
1536 (void)rsignal(i, PL_csighandlerp);
1538 *svp = SvREFCNT_inc_simple_NN(sv);
1542 #ifdef HAS_SIGPROCMASK
1546 SvREFCNT_dec(to_dec);
1549 #endif /* !PERL_MICRO */
1552 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1555 PERL_ARGS_ASSERT_MAGIC_SETISA;
1556 PERL_UNUSED_ARG(sv);
1558 /* Skip _isaelem because _isa will handle it shortly */
1559 if (PL_delaymagic & DM_ARRAY && mg->mg_type == PERL_MAGIC_isaelem)
1562 return magic_clearisa(NULL, mg);
1565 /* sv of NULL signifies that we're acting as magic_setisa. */
1567 Perl_magic_clearisa(pTHX_ SV *sv, MAGIC *mg)
1572 PERL_ARGS_ASSERT_MAGIC_CLEARISA;
1574 /* Bail out if destruction is going on */
1575 if(PL_dirty) return 0;
1578 av_clear(MUTABLE_AV(sv));
1580 /* XXX Once it's possible, we need to
1581 detect that our @ISA is aliased in
1582 other stashes, and act on the stashes
1583 of all of the aliases */
1585 /* The first case occurs via setisa,
1586 the second via setisa_elem, which
1587 calls this same magic */
1589 SvTYPE(mg->mg_obj) == SVt_PVGV
1590 ? (const GV *)mg->mg_obj
1591 : (const GV *)mg_find(mg->mg_obj, PERL_MAGIC_isa)->mg_obj
1595 mro_isa_changed_in(stash);
1601 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
1604 PERL_ARGS_ASSERT_MAGIC_SETAMAGIC;
1605 PERL_UNUSED_ARG(sv);
1606 PERL_UNUSED_ARG(mg);
1607 PL_amagic_generation++;
1613 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1615 HV * const hv = MUTABLE_HV(LvTARG(sv));
1618 PERL_ARGS_ASSERT_MAGIC_GETNKEYS;
1619 PERL_UNUSED_ARG(mg);
1622 (void) hv_iterinit(hv);
1623 if (! SvTIED_mg((const SV *)hv, PERL_MAGIC_tied))
1626 while (hv_iternext(hv))
1631 sv_setiv(sv, (IV)i);
1636 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1638 PERL_ARGS_ASSERT_MAGIC_SETNKEYS;
1639 PERL_UNUSED_ARG(mg);
1641 hv_ksplit(MUTABLE_HV(LvTARG(sv)), SvIV(sv));
1647 =for apidoc magic_methcall
1649 Invoke a magic method (like FETCH).
1651 * sv and mg are the tied thinggy and the tie magic;
1652 * meth is the name of the method to call;
1653 * argc, arg1, arg2 are the number of args (in addition to $self) to pass to
1654 the method, and the args themselves
1656 G_DISCARD: invoke method with G_DISCARD flag and don't return a value
1657 G_UNDEF_FILL: fill the stack with argc pointers to PL_sv_undef;
1658 ignore arg1 and arg2.
1660 Returns the SV (if any) returned by the method, or NULL on failure.
1667 Perl_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, U32 flags,
1674 PERL_ARGS_ASSERT_MAGIC_METHCALL;
1677 PUSHSTACKi(PERLSI_MAGIC);
1681 PUSHs(SvTIED_obj(sv, mg));
1682 if (flags & G_UNDEF_FILL) {
1684 PUSHs(&PL_sv_undef);
1686 } else if (argc > 0) {
1688 va_start(args, argc);
1691 SV *const sv = va_arg(args, SV *);
1698 if (flags & G_DISCARD) {
1699 call_method(meth, G_SCALAR|G_DISCARD);
1702 if (call_method(meth, G_SCALAR))
1703 ret = *PL_stack_sp--;
1711 /* wrapper for magic_methcall that creates the first arg */
1714 S_magic_methcall1(pTHX_ SV *sv, const MAGIC *mg, const char *meth, U32 flags,
1720 PERL_ARGS_ASSERT_MAGIC_METHCALL1;
1723 if (mg->mg_len >= 0) {
1724 arg1 = newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
1726 else if (mg->mg_len == HEf_SVKEY)
1727 arg1 = MUTABLE_SV(mg->mg_ptr);
1729 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1730 arg1 = newSViv((IV)(mg->mg_len));
1734 return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n - 1, val);
1736 return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n, arg1, val);
1740 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
1745 PERL_ARGS_ASSERT_MAGIC_METHPACK;
1747 ret = magic_methcall1(sv, mg, meth, 0, 1, NULL);
1754 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1756 PERL_ARGS_ASSERT_MAGIC_GETPACK;
1758 if (mg->mg_type == PERL_MAGIC_tiedelem)
1759 mg->mg_flags |= MGf_GSKIP;
1760 magic_methpack(sv,mg,"FETCH");
1765 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1771 PERL_ARGS_ASSERT_MAGIC_SETPACK;
1773 /* in the code C<$tied{foo} = $val>, the "thing" that gets passed to
1774 * STORE() is not $val, but rather a PVLV (the sv in this call), whose
1775 * public flags indicate its value based on copying from $val. Doing
1776 * mg_set() on the PVLV temporarily does SvMAGICAL_off(), then calls us.
1777 * So STORE()'s $_[2] arg is a temporarily disarmed PVLV. This goes
1778 * wrong if $val happened to be tainted, as sv hasn't got magic
1779 * enabled, even though taint magic is in the chain. In which case,
1780 * fake up a temporary tainted value (this is easier than temporarily
1781 * re-enabling magic on sv). */
1783 if (PL_tainting && (tmg = mg_find(sv, PERL_MAGIC_taint))
1784 && (tmg->mg_len & 1))
1786 val = sv_mortalcopy(sv);
1792 magic_methcall1(sv, mg, "STORE", G_DISCARD, 2, val);
1797 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1799 PERL_ARGS_ASSERT_MAGIC_CLEARPACK;
1801 return magic_methpack(sv,mg,"DELETE");
1806 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1812 PERL_ARGS_ASSERT_MAGIC_SIZEPACK;
1814 retsv = magic_methcall1(sv, mg, "FETCHSIZE", 0, 1, NULL);
1816 retval = SvIV(retsv)-1;
1818 Perl_croak(aTHX_ "FETCHSIZE returned a negative value");
1820 return (U32) retval;
1824 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1828 PERL_ARGS_ASSERT_MAGIC_WIPEPACK;
1830 Perl_magic_methcall(aTHX_ sv, mg, "CLEAR", G_DISCARD, 0);
1835 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1840 PERL_ARGS_ASSERT_MAGIC_NEXTPACK;
1842 ret = SvOK(key) ? Perl_magic_methcall(aTHX_ sv, mg, "NEXTKEY", 0, 1, key)
1843 : Perl_magic_methcall(aTHX_ sv, mg, "FIRSTKEY", 0, 0);
1850 Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg)
1852 PERL_ARGS_ASSERT_MAGIC_EXISTSPACK;
1854 return magic_methpack(sv,mg,"EXISTS");
1858 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1862 SV * const tied = SvTIED_obj(MUTABLE_SV(hv), mg);
1863 HV * const pkg = SvSTASH((const SV *)SvRV(tied));
1865 PERL_ARGS_ASSERT_MAGIC_SCALARPACK;
1867 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1869 if (HvEITER_get(hv))
1870 /* we are in an iteration so the hash cannot be empty */
1872 /* no xhv_eiter so now use FIRSTKEY */
1873 key = sv_newmortal();
1874 magic_nextpack(MUTABLE_SV(hv), mg, key);
1875 HvEITER_set(hv, NULL); /* need to reset iterator */
1876 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1879 /* there is a SCALAR method that we can call */
1880 retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(hv), mg, "SCALAR", 0, 0);
1882 retval = &PL_sv_undef;
1887 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1890 GV * const gv = PL_DBline;
1891 const I32 i = SvTRUE(sv);
1892 SV ** const svp = av_fetch(GvAV(gv),
1893 atoi(MgPV_nolen_const(mg)), FALSE);
1895 PERL_ARGS_ASSERT_MAGIC_SETDBLINE;
1897 if (svp && SvIOKp(*svp)) {
1898 OP * const o = INT2PTR(OP*,SvIVX(*svp));
1900 /* set or clear breakpoint in the relevant control op */
1902 o->op_flags |= OPf_SPECIAL;
1904 o->op_flags &= ~OPf_SPECIAL;
1911 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
1914 AV * const obj = MUTABLE_AV(mg->mg_obj);
1916 PERL_ARGS_ASSERT_MAGIC_GETARYLEN;
1919 sv_setiv(sv, AvFILL(obj) + CopARYBASE_get(PL_curcop));
1927 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
1930 AV * const obj = MUTABLE_AV(mg->mg_obj);
1932 PERL_ARGS_ASSERT_MAGIC_SETARYLEN;
1935 av_fill(obj, SvIV(sv) - CopARYBASE_get(PL_curcop));
1937 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
1938 "Attempt to set length of freed array");
1944 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
1948 PERL_ARGS_ASSERT_MAGIC_FREEARYLEN_P;
1949 PERL_UNUSED_ARG(sv);
1951 /* during global destruction, mg_obj may already have been freed */
1952 if (PL_in_clean_all)
1955 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
1958 /* arylen scalar holds a pointer back to the array, but doesn't own a
1959 reference. Hence the we (the array) are about to go away with it
1960 still pointing at us. Clear its pointer, else it would be pointing
1961 at free memory. See the comment in sv_magic about reference loops,
1962 and why it can't own a reference to us. */
1969 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
1972 SV* const lsv = LvTARG(sv);
1974 PERL_ARGS_ASSERT_MAGIC_GETPOS;
1975 PERL_UNUSED_ARG(mg);
1977 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1978 MAGIC * const found = mg_find(lsv, PERL_MAGIC_regex_global);
1979 if (found && found->mg_len >= 0) {
1980 I32 i = found->mg_len;
1982 sv_pos_b2u(lsv, &i);
1983 sv_setiv(sv, i + CopARYBASE_get(PL_curcop));
1992 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
1995 SV* const lsv = LvTARG(sv);
2001 PERL_ARGS_ASSERT_MAGIC_SETPOS;
2002 PERL_UNUSED_ARG(mg);
2004 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
2005 found = mg_find(lsv, PERL_MAGIC_regex_global);
2011 #ifdef PERL_OLD_COPY_ON_WRITE
2013 sv_force_normal_flags(lsv, 0);
2015 found = sv_magicext(lsv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
2018 else if (!SvOK(sv)) {
2022 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
2024 pos = SvIV(sv) - CopARYBASE_get(PL_curcop);
2027 ulen = sv_len_utf8(lsv);
2037 else if (pos > (SSize_t)len)
2042 sv_pos_u2b(lsv, &p, 0);
2046 found->mg_len = pos;
2047 found->mg_flags &= ~MGf_MINMATCH;
2053 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
2056 SV * const lsv = LvTARG(sv);
2057 const char * const tmps = SvPV_const(lsv,len);
2058 STRLEN offs = LvTARGOFF(sv);
2059 STRLEN rem = LvTARGLEN(sv);
2061 PERL_ARGS_ASSERT_MAGIC_GETSUBSTR;
2062 PERL_UNUSED_ARG(mg);
2065 offs = sv_pos_u2b_flags(lsv, offs, &rem, SV_CONST_RETURN);
2068 if (rem > len - offs)
2070 sv_setpvn(sv, tmps + offs, rem);
2077 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
2081 const char * const tmps = SvPV_const(sv, len);
2082 SV * const lsv = LvTARG(sv);
2083 STRLEN lvoff = LvTARGOFF(sv);
2084 STRLEN lvlen = LvTARGLEN(sv);
2086 PERL_ARGS_ASSERT_MAGIC_SETSUBSTR;
2087 PERL_UNUSED_ARG(mg);
2090 sv_utf8_upgrade(lsv);
2091 lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
2092 sv_insert(lsv, lvoff, lvlen, tmps, len);
2093 LvTARGLEN(sv) = sv_len_utf8(sv);
2096 else if (lsv && SvUTF8(lsv)) {
2098 lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
2099 LvTARGLEN(sv) = len;
2100 utf8 = (char*)bytes_to_utf8((U8*)tmps, &len);
2101 sv_insert(lsv, lvoff, lvlen, utf8, len);
2105 sv_insert(lsv, lvoff, lvlen, tmps, len);
2106 LvTARGLEN(sv) = len;
2113 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
2117 PERL_ARGS_ASSERT_MAGIC_GETTAINT;
2118 PERL_UNUSED_ARG(sv);
2120 TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
2125 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
2129 PERL_ARGS_ASSERT_MAGIC_SETTAINT;
2130 PERL_UNUSED_ARG(sv);
2132 /* update taint status */
2141 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
2143 SV * const lsv = LvTARG(sv);
2145 PERL_ARGS_ASSERT_MAGIC_GETVEC;
2146 PERL_UNUSED_ARG(mg);
2149 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
2157 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
2159 PERL_ARGS_ASSERT_MAGIC_SETVEC;
2160 PERL_UNUSED_ARG(mg);
2161 do_vecset(sv); /* XXX slurp this routine */
2166 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
2171 PERL_ARGS_ASSERT_MAGIC_GETDEFELEM;
2173 if (LvTARGLEN(sv)) {
2175 SV * const ahv = LvTARG(sv);
2176 HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, FALSE, 0);
2181 AV *const av = MUTABLE_AV(LvTARG(sv));
2182 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
2183 targ = AvARRAY(av)[LvTARGOFF(sv)];
2185 if (targ && (targ != &PL_sv_undef)) {
2186 /* somebody else defined it for us */
2187 SvREFCNT_dec(LvTARG(sv));
2188 LvTARG(sv) = SvREFCNT_inc_simple_NN(targ);
2190 SvREFCNT_dec(mg->mg_obj);
2192 mg->mg_flags &= ~MGf_REFCOUNTED;
2197 sv_setsv(sv, targ ? targ : &PL_sv_undef);
2202 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
2204 PERL_ARGS_ASSERT_MAGIC_SETDEFELEM;
2205 PERL_UNUSED_ARG(mg);
2209 sv_setsv(LvTARG(sv), sv);
2210 SvSETMAGIC(LvTARG(sv));
2216 Perl_vivify_defelem(pTHX_ SV *sv)
2222 PERL_ARGS_ASSERT_VIVIFY_DEFELEM;
2224 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2227 SV * const ahv = LvTARG(sv);
2228 HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, TRUE, 0);
2231 if (!value || value == &PL_sv_undef)
2232 Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(mg->mg_obj));
2235 AV *const av = MUTABLE_AV(LvTARG(sv));
2236 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
2237 LvTARG(sv) = NULL; /* array can't be extended */
2239 SV* const * const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
2240 if (!svp || (value = *svp) == &PL_sv_undef)
2241 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
2244 SvREFCNT_inc_simple_void(value);
2245 SvREFCNT_dec(LvTARG(sv));
2248 SvREFCNT_dec(mg->mg_obj);
2250 mg->mg_flags &= ~MGf_REFCOUNTED;
2254 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2256 PERL_ARGS_ASSERT_MAGIC_KILLBACKREFS;
2257 return Perl_sv_kill_backrefs(aTHX_ sv, MUTABLE_AV(mg->mg_obj));
2261 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2263 PERL_ARGS_ASSERT_MAGIC_SETMGLOB;
2264 PERL_UNUSED_CONTEXT;
2266 if (!isGV_with_GP(sv))
2272 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2274 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2276 PERL_ARGS_ASSERT_MAGIC_SETUVAR;
2278 if (uf && uf->uf_set)
2279 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2284 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2286 const char type = mg->mg_type;
2288 PERL_ARGS_ASSERT_MAGIC_SETREGEXP;
2290 if (type == PERL_MAGIC_qr) {
2291 } else if (type == PERL_MAGIC_bm) {
2295 assert(type == PERL_MAGIC_fm);
2298 return sv_unmagic(sv, type);
2301 #ifdef USE_LOCALE_COLLATE
2303 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2305 PERL_ARGS_ASSERT_MAGIC_SETCOLLXFRM;
2308 * RenE<eacute> Descartes said "I think not."
2309 * and vanished with a faint plop.
2311 PERL_UNUSED_CONTEXT;
2312 PERL_UNUSED_ARG(sv);
2314 Safefree(mg->mg_ptr);
2320 #endif /* USE_LOCALE_COLLATE */
2322 /* Just clear the UTF-8 cache data. */
2324 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2326 PERL_ARGS_ASSERT_MAGIC_SETUTF8;
2327 PERL_UNUSED_CONTEXT;
2328 PERL_UNUSED_ARG(sv);
2329 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2331 mg->mg_len = -1; /* The mg_len holds the len cache. */
2336 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2339 register const char *s;
2341 register const REGEXP * rx;
2342 const char * const remaining = mg->mg_ptr + 1;
2346 PERL_ARGS_ASSERT_MAGIC_SET;
2348 switch (*mg->mg_ptr) {
2349 case '\015': /* $^MATCH */
2350 if (strEQ(remaining, "ATCH"))
2352 case '`': /* ${^PREMATCH} caught below */
2354 paren = RX_BUFF_IDX_PREMATCH;
2356 case '\'': /* ${^POSTMATCH} caught below */
2358 paren = RX_BUFF_IDX_POSTMATCH;
2362 paren = RX_BUFF_IDX_FULLMATCH;
2364 case '1': case '2': case '3': case '4':
2365 case '5': case '6': case '7': case '8': case '9':
2366 paren = atoi(mg->mg_ptr);
2368 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
2369 CALLREG_NUMBUF_STORE((REGEXP * const)rx,paren,sv);
2372 /* Croak with a READONLY error when a numbered match var is
2373 * set without a previous pattern match. Unless it's C<local $1>
2375 if (!PL_localizing) {
2376 Perl_croak(aTHX_ "%s", PL_no_modify);
2379 case '\001': /* ^A */
2380 sv_setsv(PL_bodytarget, sv);
2382 case '\003': /* ^C */
2383 PL_minus_c = cBOOL(SvIV(sv));
2386 case '\004': /* ^D */
2388 s = SvPV_nolen_const(sv);
2389 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2390 if (DEBUG_x_TEST || DEBUG_B_TEST)
2391 dump_all_perl(!DEBUG_B_TEST);
2393 PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG;
2396 case '\005': /* ^E */
2397 if (*(mg->mg_ptr+1) == '\0') {
2399 set_vaxc_errno(SvIV(sv));
2402 SetLastError( SvIV(sv) );
2405 os2_setsyserrno(SvIV(sv));
2407 /* will anyone ever use this? */
2408 SETERRNO(SvIV(sv), 4);
2413 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2414 SvREFCNT_dec(PL_encoding);
2415 if (SvOK(sv) || SvGMAGICAL(sv)) {
2416 PL_encoding = newSVsv(sv);
2423 case '\006': /* ^F */
2424 PL_maxsysfd = SvIV(sv);
2426 case '\010': /* ^H */
2427 PL_hints = SvIV(sv);
2429 case '\011': /* ^I */ /* NOT \t in EBCDIC */
2430 Safefree(PL_inplace);
2431 PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
2433 case '\017': /* ^O */
2434 if (*(mg->mg_ptr+1) == '\0') {
2435 Safefree(PL_osname);
2438 TAINT_PROPER("assigning to $^O");
2439 PL_osname = savesvpv(sv);
2442 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2444 const char *const start = SvPV(sv, len);
2445 const char *out = (const char*)memchr(start, '\0', len);
2449 PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2450 PL_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2452 /* Opening for input is more common than opening for output, so
2453 ensure that hints for input are sooner on linked list. */
2454 tmp = out ? newSVpvn_flags(out + 1, start + len - out - 1,
2456 : newSVpvs_flags("", SvUTF8(sv));
2457 (void)hv_stores(GvHV(PL_hintgv), "open>", tmp);
2460 tmp = newSVpvn_flags(start, out ? (STRLEN)(out - start) : len,
2462 (void)hv_stores(GvHV(PL_hintgv), "open<", tmp);
2466 case '\020': /* ^P */
2467 if (*remaining == '\0') { /* ^P */
2468 PL_perldb = SvIV(sv);
2469 if (PL_perldb && !PL_DBsingle)
2472 } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
2474 } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
2477 case '\024': /* ^T */
2479 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2481 PL_basetime = (Time_t)SvIV(sv);
2484 case '\025': /* ^UTF8CACHE */
2485 if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
2486 PL_utf8cache = (signed char) sv_2iv(sv);
2489 case '\027': /* ^W & $^WARNING_BITS */
2490 if (*(mg->mg_ptr+1) == '\0') {
2491 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2493 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2494 | (i ? G_WARN_ON : G_WARN_OFF) ;
2497 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2498 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2499 if (!SvPOK(sv) && PL_localizing) {
2500 sv_setpvn(sv, WARN_NONEstring, WARNsize);
2501 PL_compiling.cop_warnings = pWARN_NONE;
2506 int accumulate = 0 ;
2507 int any_fatals = 0 ;
2508 const char * const ptr = SvPV_const(sv, len) ;
2509 for (i = 0 ; i < len ; ++i) {
2510 accumulate |= ptr[i] ;
2511 any_fatals |= (ptr[i] & 0xAA) ;
2514 if (!specialWARN(PL_compiling.cop_warnings))
2515 PerlMemShared_free(PL_compiling.cop_warnings);
2516 PL_compiling.cop_warnings = pWARN_NONE;
2518 /* Yuck. I can't see how to abstract this: */
2519 else if (isWARN_on(((STRLEN *)SvPV_nolen_const(sv)) - 1,
2520 WARN_ALL) && !any_fatals) {
2521 if (!specialWARN(PL_compiling.cop_warnings))
2522 PerlMemShared_free(PL_compiling.cop_warnings);
2523 PL_compiling.cop_warnings = pWARN_ALL;
2524 PL_dowarn |= G_WARN_ONCE ;
2528 const char *const p = SvPV_const(sv, len);
2530 PL_compiling.cop_warnings
2531 = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
2534 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2535 PL_dowarn |= G_WARN_ONCE ;
2543 if (PL_localizing) {
2544 if (PL_localizing == 1)
2545 SAVESPTR(PL_last_in_gv);
2547 else if (SvOK(sv) && GvIO(PL_last_in_gv))
2548 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2551 if (isGV_with_GP(PL_defoutgv)) {
2552 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2553 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2554 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2558 if (isGV_with_GP(PL_defoutgv)) {
2559 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2560 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2561 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2565 if (isGV_with_GP(PL_defoutgv))
2566 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
2569 if (isGV_with_GP(PL_defoutgv)) {
2570 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
2571 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2572 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2576 if (isGV_with_GP(PL_defoutgv))
2577 IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
2581 IO * const io = GvIO(PL_defoutgv);
2584 if ((SvIV(sv)) == 0)
2585 IoFLAGS(io) &= ~IOf_FLUSH;
2587 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2588 PerlIO *ofp = IoOFP(io);
2590 (void)PerlIO_flush(ofp);
2591 IoFLAGS(io) |= IOf_FLUSH;
2597 SvREFCNT_dec(PL_rs);
2598 PL_rs = newSVsv(sv);
2601 SvREFCNT_dec(PL_ors_sv);
2602 if (SvOK(sv) || SvGMAGICAL(sv)) {
2603 PL_ors_sv = newSVsv(sv);
2610 CopARYBASE_set(&PL_compiling, SvIV(sv));
2613 #ifdef COMPLEX_STATUS
2614 if (PL_localizing == 2) {
2615 SvUPGRADE(sv, SVt_PVLV);
2616 PL_statusvalue = LvTARGOFF(sv);
2617 PL_statusvalue_vms = LvTARGLEN(sv);
2621 #ifdef VMSISH_STATUS
2623 STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2626 STATUS_UNIX_EXIT_SET(SvIV(sv));
2631 # define PERL_VMS_BANG vaxc$errno
2633 # define PERL_VMS_BANG 0
2635 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2636 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2641 if (PL_delaymagic) {
2642 PL_delaymagic |= DM_RUID;
2643 break; /* don't do magic till later */
2646 (void)setruid((Uid_t)PL_uid);
2649 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2651 #ifdef HAS_SETRESUID
2652 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2654 if (PL_uid == PL_euid) { /* special case $< = $> */
2656 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2657 if (PL_uid != 0 && PerlProc_getuid() == 0)
2658 (void)PerlProc_setuid(0);
2660 (void)PerlProc_setuid(PL_uid);
2662 PL_uid = PerlProc_getuid();
2663 Perl_croak(aTHX_ "setruid() not implemented");
2668 PL_uid = PerlProc_getuid();
2672 if (PL_delaymagic) {
2673 PL_delaymagic |= DM_EUID;
2674 break; /* don't do magic till later */
2677 (void)seteuid((Uid_t)PL_euid);
2680 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2682 #ifdef HAS_SETRESUID
2683 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2685 if (PL_euid == PL_uid) /* special case $> = $< */
2686 PerlProc_setuid(PL_euid);
2688 PL_euid = PerlProc_geteuid();
2689 Perl_croak(aTHX_ "seteuid() not implemented");
2694 PL_euid = PerlProc_geteuid();
2698 if (PL_delaymagic) {
2699 PL_delaymagic |= DM_RGID;
2700 break; /* don't do magic till later */
2703 (void)setrgid((Gid_t)PL_gid);
2706 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2708 #ifdef HAS_SETRESGID
2709 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2711 if (PL_gid == PL_egid) /* special case $( = $) */
2712 (void)PerlProc_setgid(PL_gid);
2714 PL_gid = PerlProc_getgid();
2715 Perl_croak(aTHX_ "setrgid() not implemented");
2720 PL_gid = PerlProc_getgid();
2723 #ifdef HAS_SETGROUPS
2725 const char *p = SvPV_const(sv, len);
2726 Groups_t *gary = NULL;
2727 #ifdef _SC_NGROUPS_MAX
2728 int maxgrp = sysconf(_SC_NGROUPS_MAX);
2733 int maxgrp = NGROUPS;
2739 for (i = 0; i < maxgrp; ++i) {
2740 while (*p && !isSPACE(*p))
2747 Newx(gary, i + 1, Groups_t);
2749 Renew(gary, i + 1, Groups_t);
2753 (void)setgroups(i, gary);
2756 #else /* HAS_SETGROUPS */
2758 #endif /* HAS_SETGROUPS */
2759 if (PL_delaymagic) {
2760 PL_delaymagic |= DM_EGID;
2761 break; /* don't do magic till later */
2764 (void)setegid((Gid_t)PL_egid);
2767 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2769 #ifdef HAS_SETRESGID
2770 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2772 if (PL_egid == PL_gid) /* special case $) = $( */
2773 (void)PerlProc_setgid(PL_egid);
2775 PL_egid = PerlProc_getegid();
2776 Perl_croak(aTHX_ "setegid() not implemented");
2781 PL_egid = PerlProc_getegid();
2784 PL_chopset = SvPV_force(sv,len);
2787 LOCK_DOLLARZERO_MUTEX;
2788 #ifdef HAS_SETPROCTITLE
2789 /* The BSDs don't show the argv[] in ps(1) output, they
2790 * show a string from the process struct and provide
2791 * the setproctitle() routine to manipulate that. */
2792 if (PL_origalen != 1) {
2793 s = SvPV_const(sv, len);
2794 # if __FreeBSD_version > 410001
2795 /* The leading "-" removes the "perl: " prefix,
2796 * but not the "(perl) suffix from the ps(1)
2797 * output, because that's what ps(1) shows if the
2798 * argv[] is modified. */
2799 setproctitle("-%s", s);
2800 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2801 /* This doesn't really work if you assume that
2802 * $0 = 'foobar'; will wipe out 'perl' from the $0
2803 * because in ps(1) output the result will be like
2804 * sprintf("perl: %s (perl)", s)
2805 * I guess this is a security feature:
2806 * one (a user process) cannot get rid of the original name.
2808 setproctitle("%s", s);
2811 #elif defined(__hpux) && defined(PSTAT_SETCMD)
2812 if (PL_origalen != 1) {
2814 s = SvPV_const(sv, len);
2815 un.pst_command = (char *)s;
2816 pstat(PSTAT_SETCMD, un, len, 0, 0);
2819 if (PL_origalen > 1) {
2820 /* PL_origalen is set in perl_parse(). */
2821 s = SvPV_force(sv,len);
2822 if (len >= (STRLEN)PL_origalen-1) {
2823 /* Longer than original, will be truncated. We assume that
2824 * PL_origalen bytes are available. */
2825 Copy(s, PL_origargv[0], PL_origalen-1, char);
2828 /* Shorter than original, will be padded. */
2830 /* Special case for Mac OS X: see [perl #38868] */
2833 /* Is the space counterintuitive? Yes.
2834 * (You were expecting \0?)
2835 * Does it work? Seems to. (In Linux 2.4.20 at least.)
2837 const int pad = ' ';
2839 Copy(s, PL_origargv[0], len, char);
2840 PL_origargv[0][len] = 0;
2841 memset(PL_origargv[0] + len + 1,
2842 pad, PL_origalen - len - 1);
2844 PL_origargv[0][PL_origalen-1] = 0;
2845 for (i = 1; i < PL_origargc; i++)
2847 #ifdef HAS_PRCTL_SET_NAME
2848 /* Set the legacy process name in addition to the POSIX name on Linux */
2849 if (prctl(PR_SET_NAME, (unsigned long)s, 0, 0, 0) != 0) {
2850 /* diag_listed_as: SKIPME */
2851 Perl_croak(aTHX_ "Can't set $0 with prctl(): %s", Strerror(errno));
2856 UNLOCK_DOLLARZERO_MUTEX;
2863 Perl_whichsig(pTHX_ const char *sig)
2865 register char* const* sigv;
2867 PERL_ARGS_ASSERT_WHICHSIG;
2868 PERL_UNUSED_CONTEXT;
2870 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
2871 if (strEQ(sig,*sigv))
2872 return PL_sig_num[sigv - (char* const*)PL_sig_name];
2874 if (strEQ(sig,"CHLD"))
2878 if (strEQ(sig,"CLD"))
2885 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2886 Perl_sighandler(int sig, siginfo_t *sip, void *uap PERL_UNUSED_DECL)
2888 Perl_sighandler(int sig)
2891 #ifdef PERL_GET_SIG_CONTEXT
2892 dTHXa(PERL_GET_SIG_CONTEXT);
2899 SV * const tSv = PL_Sv;
2903 XPV * const tXpv = PL_Xpv;
2905 if (PL_savestack_ix + 15 <= PL_savestack_max)
2907 if (PL_markstack_ptr < PL_markstack_max - 2)
2909 if (PL_scopestack_ix < PL_scopestack_max - 3)
2912 if (!PL_psig_ptr[sig]) {
2913 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2918 /* Max number of items pushed there is 3*n or 4. We cannot fix
2919 infinity, so we fix 4 (in fact 5): */
2921 PL_savestack_ix += 5; /* Protect save in progress. */
2922 SAVEDESTRUCTOR_X(S_unwind_handler_stack, (void*)&flags);
2925 PL_markstack_ptr++; /* Protect mark. */
2927 PL_scopestack_ix += 1;
2928 /* sv_2cv is too complicated, try a simpler variant first: */
2929 if (!SvROK(PL_psig_ptr[sig]) || !(cv = MUTABLE_CV(SvRV(PL_psig_ptr[sig])))
2930 || SvTYPE(cv) != SVt_PVCV) {
2932 cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
2935 if (!cv || !CvROOT(cv)) {
2936 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2937 PL_sig_name[sig], (gv ? GvENAME(gv)
2944 if(PL_psig_name[sig]) {
2945 sv = SvREFCNT_inc_NN(PL_psig_name[sig]);
2947 #if !defined(PERL_IMPLICIT_CONTEXT)
2951 sv = sv_newmortal();
2952 sv_setpv(sv,PL_sig_name[sig]);
2955 PUSHSTACKi(PERLSI_SIGNAL);
2958 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2960 struct sigaction oact;
2962 if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
2965 SV *rv = newRV_noinc(MUTABLE_SV(sih));
2966 /* The siginfo fields signo, code, errno, pid, uid,
2967 * addr, status, and band are defined by POSIX/SUSv3. */
2968 (void)hv_stores(sih, "signo", newSViv(sip->si_signo));
2969 (void)hv_stores(sih, "code", newSViv(sip->si_code));
2970 #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. */
2971 hv_stores(sih, "errno", newSViv(sip->si_errno));
2972 hv_stores(sih, "status", newSViv(sip->si_status));
2973 hv_stores(sih, "uid", newSViv(sip->si_uid));
2974 hv_stores(sih, "pid", newSViv(sip->si_pid));
2975 hv_stores(sih, "addr", newSVuv(PTR2UV(sip->si_addr)));
2976 hv_stores(sih, "band", newSViv(sip->si_band));
2980 mPUSHp((char *)sip, sizeof(*sip));
2988 call_sv(MUTABLE_SV(cv), G_DISCARD|G_EVAL);
2991 if (SvTRUE(ERRSV)) {
2993 #ifdef HAS_SIGPROCMASK
2994 /* Handler "died", for example to get out of a restart-able read().
2995 * Before we re-do that on its behalf re-enable the signal which was
2996 * blocked by the system when we entered.
3000 sigaddset(&set,sig);
3001 sigprocmask(SIG_UNBLOCK, &set, NULL);
3003 /* Not clear if this will work */
3004 (void)rsignal(sig, SIG_IGN);
3005 (void)rsignal(sig, PL_csighandlerp);
3007 #endif /* !PERL_MICRO */
3012 PL_savestack_ix -= 8; /* Unprotect save in progress. */
3016 PL_scopestack_ix -= 1;
3019 PL_op = myop; /* Apparently not needed... */
3021 PL_Sv = tSv; /* Restore global temporaries. */
3028 S_restore_magic(pTHX_ const void *p)
3031 MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
3032 SV* const sv = mgs->mgs_sv;
3037 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
3039 #ifdef PERL_OLD_COPY_ON_WRITE
3040 /* While magic was saved (and off) sv_setsv may well have seen
3041 this SV as a prime candidate for COW. */
3043 sv_force_normal_flags(sv, 0);
3046 if (mgs->mgs_readonly)
3048 if (mgs->mgs_magical)
3049 SvFLAGS(sv) |= mgs->mgs_magical;
3052 if (SvGMAGICAL(sv)) {
3053 /* downgrade public flags to private,
3054 and discard any other private flags */
3056 const U32 pubflags = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
3058 SvFLAGS(sv) &= ~( pubflags | (SVp_IOK|SVp_NOK|SVp_POK) );
3059 SvFLAGS(sv) |= ( pubflags << PRIVSHIFT );
3064 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
3066 /* If we're still on top of the stack, pop us off. (That condition
3067 * will be satisfied if restore_magic was called explicitly, but *not*
3068 * if it's being called via leave_scope.)
3069 * The reason for doing this is that otherwise, things like sv_2cv()
3070 * may leave alloc gunk on the savestack, and some code
3071 * (e.g. sighandler) doesn't expect that...
3073 if (PL_savestack_ix == mgs->mgs_ss_ix)
3075 UV popval = SSPOPUV;
3076 assert(popval == SAVEt_DESTRUCTOR_X);
3077 PL_savestack_ix -= 2;
3079 assert((popval & SAVE_MASK) == SAVEt_ALLOC);
3080 PL_savestack_ix -= popval >> SAVE_TIGHT_SHIFT;
3086 S_unwind_handler_stack(pTHX_ const void *p)
3089 const U32 flags = *(const U32*)p;
3091 PERL_ARGS_ASSERT_UNWIND_HANDLER_STACK;
3094 PL_savestack_ix -= 5; /* Unprotect save in progress. */
3095 #if !defined(PERL_IMPLICIT_CONTEXT)
3097 SvREFCNT_dec(PL_sig_sv);
3102 =for apidoc magic_sethint
3104 Triggered by a store to %^H, records the key/value pair to
3105 C<PL_compiling.cop_hints_hash>. It is assumed that hints aren't storing
3106 anything that would need a deep copy. Maybe we should warn if we find a
3112 Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
3115 SV *key = (mg->mg_len == HEf_SVKEY) ? MUTABLE_SV(mg->mg_ptr)
3116 : newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
3118 PERL_ARGS_ASSERT_MAGIC_SETHINT;
3120 /* mg->mg_obj isn't being used. If needed, it would be possible to store
3121 an alternative leaf in there, with PL_compiling.cop_hints being used if
3122 it's NULL. If needed for threads, the alternative could lock a mutex,
3123 or take other more complex action. */
3125 /* Something changed in %^H, so it will need to be restored on scope exit.
3126 Doing this here saves a lot of doing it manually in perl code (and
3127 forgetting to do it, and consequent subtle errors. */
3128 PL_hints |= HINT_LOCALIZE_HH;
3129 PL_compiling.cop_hints_hash
3130 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash, key, sv);
3135 =for apidoc magic_clearhint
3137 Triggered by a delete from %^H, records the key to
3138 C<PL_compiling.cop_hints_hash>.
3143 Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
3147 PERL_ARGS_ASSERT_MAGIC_CLEARHINT;
3148 PERL_UNUSED_ARG(sv);
3150 assert(mg->mg_len == HEf_SVKEY);
3152 PERL_UNUSED_ARG(sv);
3154 PL_hints |= HINT_LOCALIZE_HH;
3155 PL_compiling.cop_hints_hash
3156 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
3157 MUTABLE_SV(mg->mg_ptr), &PL_sv_placeholder);
3162 =for apidoc magic_clearhints
3164 Triggered by clearing %^H, resets C<PL_compiling.cop_hints_hash>.
3169 Perl_magic_clearhints(pTHX_ SV *sv, MAGIC *mg)
3171 PERL_ARGS_ASSERT_MAGIC_CLEARHINTS;
3172 PERL_UNUSED_ARG(sv);
3173 PERL_UNUSED_ARG(mg);
3174 if (PL_compiling.cop_hints_hash) {
3175 Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
3176 PL_compiling.cop_hints_hash = NULL;
3183 * c-indentation-style: bsd
3185 * indent-tabs-mode: t
3188 * ex: set ts=8 sts=4 sw=4 noet: