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_ISA && 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 is the number of args (in addition to $self) to pass to the method;
1654 the args themselves are any values following the argc argument.
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.
1659 Returns the SV (if any) returned by the method, or NULL on failure.
1666 Perl_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, U32 flags,
1673 PERL_ARGS_ASSERT_MAGIC_METHCALL;
1676 PUSHSTACKi(PERLSI_MAGIC);
1680 PUSHs(SvTIED_obj(sv, mg));
1681 if (flags & G_UNDEF_FILL) {
1683 PUSHs(&PL_sv_undef);
1685 } else if (argc > 0) {
1687 va_start(args, argc);
1690 SV *const sv = va_arg(args, SV *);
1697 if (flags & G_DISCARD) {
1698 call_method(meth, G_SCALAR|G_DISCARD);
1701 if (call_method(meth, G_SCALAR))
1702 ret = *PL_stack_sp--;
1710 /* wrapper for magic_methcall that creates the first arg */
1713 S_magic_methcall1(pTHX_ SV *sv, const MAGIC *mg, const char *meth, U32 flags,
1719 PERL_ARGS_ASSERT_MAGIC_METHCALL1;
1722 if (mg->mg_len >= 0) {
1723 arg1 = newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
1725 else if (mg->mg_len == HEf_SVKEY)
1726 arg1 = MUTABLE_SV(mg->mg_ptr);
1728 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1729 arg1 = newSViv((IV)(mg->mg_len));
1733 return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n - 1, val);
1735 return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n, arg1, val);
1739 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
1744 PERL_ARGS_ASSERT_MAGIC_METHPACK;
1746 ret = magic_methcall1(sv, mg, meth, 0, 1, NULL);
1753 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1755 PERL_ARGS_ASSERT_MAGIC_GETPACK;
1757 if (mg->mg_type == PERL_MAGIC_tiedelem)
1758 mg->mg_flags |= MGf_GSKIP;
1759 magic_methpack(sv,mg,"FETCH");
1764 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1770 PERL_ARGS_ASSERT_MAGIC_SETPACK;
1772 /* in the code C<$tied{foo} = $val>, the "thing" that gets passed to
1773 * STORE() is not $val, but rather a PVLV (the sv in this call), whose
1774 * public flags indicate its value based on copying from $val. Doing
1775 * mg_set() on the PVLV temporarily does SvMAGICAL_off(), then calls us.
1776 * So STORE()'s $_[2] arg is a temporarily disarmed PVLV. This goes
1777 * wrong if $val happened to be tainted, as sv hasn't got magic
1778 * enabled, even though taint magic is in the chain. In which case,
1779 * fake up a temporary tainted value (this is easier than temporarily
1780 * re-enabling magic on sv). */
1782 if (PL_tainting && (tmg = mg_find(sv, PERL_MAGIC_taint))
1783 && (tmg->mg_len & 1))
1785 val = sv_mortalcopy(sv);
1791 magic_methcall1(sv, mg, "STORE", G_DISCARD, 2, val);
1796 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1798 PERL_ARGS_ASSERT_MAGIC_CLEARPACK;
1800 return magic_methpack(sv,mg,"DELETE");
1805 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1811 PERL_ARGS_ASSERT_MAGIC_SIZEPACK;
1813 retsv = magic_methcall1(sv, mg, "FETCHSIZE", 0, 1, NULL);
1815 retval = SvIV(retsv)-1;
1817 Perl_croak(aTHX_ "FETCHSIZE returned a negative value");
1819 return (U32) retval;
1823 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1827 PERL_ARGS_ASSERT_MAGIC_WIPEPACK;
1829 Perl_magic_methcall(aTHX_ sv, mg, "CLEAR", G_DISCARD, 0);
1834 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1839 PERL_ARGS_ASSERT_MAGIC_NEXTPACK;
1841 ret = SvOK(key) ? Perl_magic_methcall(aTHX_ sv, mg, "NEXTKEY", 0, 1, key)
1842 : Perl_magic_methcall(aTHX_ sv, mg, "FIRSTKEY", 0, 0);
1849 Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg)
1851 PERL_ARGS_ASSERT_MAGIC_EXISTSPACK;
1853 return magic_methpack(sv,mg,"EXISTS");
1857 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1861 SV * const tied = SvTIED_obj(MUTABLE_SV(hv), mg);
1862 HV * const pkg = SvSTASH((const SV *)SvRV(tied));
1864 PERL_ARGS_ASSERT_MAGIC_SCALARPACK;
1866 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1868 if (HvEITER_get(hv))
1869 /* we are in an iteration so the hash cannot be empty */
1871 /* no xhv_eiter so now use FIRSTKEY */
1872 key = sv_newmortal();
1873 magic_nextpack(MUTABLE_SV(hv), mg, key);
1874 HvEITER_set(hv, NULL); /* need to reset iterator */
1875 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1878 /* there is a SCALAR method that we can call */
1879 retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(hv), mg, "SCALAR", 0, 0);
1881 retval = &PL_sv_undef;
1886 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1889 GV * const gv = PL_DBline;
1890 const I32 i = SvTRUE(sv);
1891 SV ** const svp = av_fetch(GvAV(gv),
1892 atoi(MgPV_nolen_const(mg)), FALSE);
1894 PERL_ARGS_ASSERT_MAGIC_SETDBLINE;
1896 if (svp && SvIOKp(*svp)) {
1897 OP * const o = INT2PTR(OP*,SvIVX(*svp));
1899 /* set or clear breakpoint in the relevant control op */
1901 o->op_flags |= OPf_SPECIAL;
1903 o->op_flags &= ~OPf_SPECIAL;
1910 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
1913 AV * const obj = MUTABLE_AV(mg->mg_obj);
1915 PERL_ARGS_ASSERT_MAGIC_GETARYLEN;
1918 sv_setiv(sv, AvFILL(obj) + CopARYBASE_get(PL_curcop));
1926 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
1929 AV * const obj = MUTABLE_AV(mg->mg_obj);
1931 PERL_ARGS_ASSERT_MAGIC_SETARYLEN;
1934 av_fill(obj, SvIV(sv) - CopARYBASE_get(PL_curcop));
1936 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
1937 "Attempt to set length of freed array");
1943 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
1947 PERL_ARGS_ASSERT_MAGIC_FREEARYLEN_P;
1948 PERL_UNUSED_ARG(sv);
1950 /* during global destruction, mg_obj may already have been freed */
1951 if (PL_in_clean_all)
1954 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
1957 /* arylen scalar holds a pointer back to the array, but doesn't own a
1958 reference. Hence the we (the array) are about to go away with it
1959 still pointing at us. Clear its pointer, else it would be pointing
1960 at free memory. See the comment in sv_magic about reference loops,
1961 and why it can't own a reference to us. */
1968 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
1971 SV* const lsv = LvTARG(sv);
1973 PERL_ARGS_ASSERT_MAGIC_GETPOS;
1974 PERL_UNUSED_ARG(mg);
1976 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1977 MAGIC * const found = mg_find(lsv, PERL_MAGIC_regex_global);
1978 if (found && found->mg_len >= 0) {
1979 I32 i = found->mg_len;
1981 sv_pos_b2u(lsv, &i);
1982 sv_setiv(sv, i + CopARYBASE_get(PL_curcop));
1991 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
1994 SV* const lsv = LvTARG(sv);
2000 PERL_ARGS_ASSERT_MAGIC_SETPOS;
2001 PERL_UNUSED_ARG(mg);
2003 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
2004 found = mg_find(lsv, PERL_MAGIC_regex_global);
2010 #ifdef PERL_OLD_COPY_ON_WRITE
2012 sv_force_normal_flags(lsv, 0);
2014 found = sv_magicext(lsv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
2017 else if (!SvOK(sv)) {
2021 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
2023 pos = SvIV(sv) - CopARYBASE_get(PL_curcop);
2026 ulen = sv_len_utf8(lsv);
2036 else if (pos > (SSize_t)len)
2041 sv_pos_u2b(lsv, &p, 0);
2045 found->mg_len = pos;
2046 found->mg_flags &= ~MGf_MINMATCH;
2052 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
2055 SV * const lsv = LvTARG(sv);
2056 const char * const tmps = SvPV_const(lsv,len);
2057 STRLEN offs = LvTARGOFF(sv);
2058 STRLEN rem = LvTARGLEN(sv);
2060 PERL_ARGS_ASSERT_MAGIC_GETSUBSTR;
2061 PERL_UNUSED_ARG(mg);
2064 offs = sv_pos_u2b_flags(lsv, offs, &rem, SV_CONST_RETURN);
2067 if (rem > len - offs)
2069 sv_setpvn(sv, tmps + offs, rem);
2076 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
2080 const char * const tmps = SvPV_const(sv, len);
2081 SV * const lsv = LvTARG(sv);
2082 STRLEN lvoff = LvTARGOFF(sv);
2083 STRLEN lvlen = LvTARGLEN(sv);
2085 PERL_ARGS_ASSERT_MAGIC_SETSUBSTR;
2086 PERL_UNUSED_ARG(mg);
2089 sv_utf8_upgrade(lsv);
2090 lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
2091 sv_insert(lsv, lvoff, lvlen, tmps, len);
2092 LvTARGLEN(sv) = sv_len_utf8(sv);
2095 else if (lsv && SvUTF8(lsv)) {
2097 lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
2098 LvTARGLEN(sv) = len;
2099 utf8 = (char*)bytes_to_utf8((U8*)tmps, &len);
2100 sv_insert(lsv, lvoff, lvlen, utf8, len);
2104 sv_insert(lsv, lvoff, lvlen, tmps, len);
2105 LvTARGLEN(sv) = len;
2112 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
2116 PERL_ARGS_ASSERT_MAGIC_GETTAINT;
2117 PERL_UNUSED_ARG(sv);
2119 TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
2124 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
2128 PERL_ARGS_ASSERT_MAGIC_SETTAINT;
2129 PERL_UNUSED_ARG(sv);
2131 /* update taint status */
2140 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
2142 SV * const lsv = LvTARG(sv);
2144 PERL_ARGS_ASSERT_MAGIC_GETVEC;
2145 PERL_UNUSED_ARG(mg);
2148 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
2156 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
2158 PERL_ARGS_ASSERT_MAGIC_SETVEC;
2159 PERL_UNUSED_ARG(mg);
2160 do_vecset(sv); /* XXX slurp this routine */
2165 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
2170 PERL_ARGS_ASSERT_MAGIC_GETDEFELEM;
2172 if (LvTARGLEN(sv)) {
2174 SV * const ahv = LvTARG(sv);
2175 HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, FALSE, 0);
2180 AV *const av = MUTABLE_AV(LvTARG(sv));
2181 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
2182 targ = AvARRAY(av)[LvTARGOFF(sv)];
2184 if (targ && (targ != &PL_sv_undef)) {
2185 /* somebody else defined it for us */
2186 SvREFCNT_dec(LvTARG(sv));
2187 LvTARG(sv) = SvREFCNT_inc_simple_NN(targ);
2189 SvREFCNT_dec(mg->mg_obj);
2191 mg->mg_flags &= ~MGf_REFCOUNTED;
2196 sv_setsv(sv, targ ? targ : &PL_sv_undef);
2201 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
2203 PERL_ARGS_ASSERT_MAGIC_SETDEFELEM;
2204 PERL_UNUSED_ARG(mg);
2208 sv_setsv(LvTARG(sv), sv);
2209 SvSETMAGIC(LvTARG(sv));
2215 Perl_vivify_defelem(pTHX_ SV *sv)
2221 PERL_ARGS_ASSERT_VIVIFY_DEFELEM;
2223 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2226 SV * const ahv = LvTARG(sv);
2227 HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, TRUE, 0);
2230 if (!value || value == &PL_sv_undef)
2231 Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(mg->mg_obj));
2234 AV *const av = MUTABLE_AV(LvTARG(sv));
2235 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
2236 LvTARG(sv) = NULL; /* array can't be extended */
2238 SV* const * const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
2239 if (!svp || (value = *svp) == &PL_sv_undef)
2240 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
2243 SvREFCNT_inc_simple_void(value);
2244 SvREFCNT_dec(LvTARG(sv));
2247 SvREFCNT_dec(mg->mg_obj);
2249 mg->mg_flags &= ~MGf_REFCOUNTED;
2253 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2255 PERL_ARGS_ASSERT_MAGIC_KILLBACKREFS;
2256 return Perl_sv_kill_backrefs(aTHX_ sv, MUTABLE_AV(mg->mg_obj));
2260 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2262 PERL_ARGS_ASSERT_MAGIC_SETMGLOB;
2263 PERL_UNUSED_CONTEXT;
2265 if (!isGV_with_GP(sv))
2271 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2273 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2275 PERL_ARGS_ASSERT_MAGIC_SETUVAR;
2277 if (uf && uf->uf_set)
2278 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2283 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2285 const char type = mg->mg_type;
2287 PERL_ARGS_ASSERT_MAGIC_SETREGEXP;
2289 if (type == PERL_MAGIC_qr) {
2290 } else if (type == PERL_MAGIC_bm) {
2294 assert(type == PERL_MAGIC_fm);
2297 return sv_unmagic(sv, type);
2300 #ifdef USE_LOCALE_COLLATE
2302 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2304 PERL_ARGS_ASSERT_MAGIC_SETCOLLXFRM;
2307 * RenE<eacute> Descartes said "I think not."
2308 * and vanished with a faint plop.
2310 PERL_UNUSED_CONTEXT;
2311 PERL_UNUSED_ARG(sv);
2313 Safefree(mg->mg_ptr);
2319 #endif /* USE_LOCALE_COLLATE */
2321 /* Just clear the UTF-8 cache data. */
2323 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2325 PERL_ARGS_ASSERT_MAGIC_SETUTF8;
2326 PERL_UNUSED_CONTEXT;
2327 PERL_UNUSED_ARG(sv);
2328 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2330 mg->mg_len = -1; /* The mg_len holds the len cache. */
2335 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2338 register const char *s;
2340 register const REGEXP * rx;
2341 const char * const remaining = mg->mg_ptr + 1;
2345 PERL_ARGS_ASSERT_MAGIC_SET;
2347 switch (*mg->mg_ptr) {
2348 case '\015': /* $^MATCH */
2349 if (strEQ(remaining, "ATCH"))
2351 case '`': /* ${^PREMATCH} caught below */
2353 paren = RX_BUFF_IDX_PREMATCH;
2355 case '\'': /* ${^POSTMATCH} caught below */
2357 paren = RX_BUFF_IDX_POSTMATCH;
2361 paren = RX_BUFF_IDX_FULLMATCH;
2363 case '1': case '2': case '3': case '4':
2364 case '5': case '6': case '7': case '8': case '9':
2365 paren = atoi(mg->mg_ptr);
2367 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
2368 CALLREG_NUMBUF_STORE((REGEXP * const)rx,paren,sv);
2371 /* Croak with a READONLY error when a numbered match var is
2372 * set without a previous pattern match. Unless it's C<local $1>
2374 if (!PL_localizing) {
2375 Perl_croak(aTHX_ "%s", PL_no_modify);
2378 case '\001': /* ^A */
2379 sv_setsv(PL_bodytarget, sv);
2381 case '\003': /* ^C */
2382 PL_minus_c = cBOOL(SvIV(sv));
2385 case '\004': /* ^D */
2387 s = SvPV_nolen_const(sv);
2388 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2389 if (DEBUG_x_TEST || DEBUG_B_TEST)
2390 dump_all_perl(!DEBUG_B_TEST);
2392 PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG;
2395 case '\005': /* ^E */
2396 if (*(mg->mg_ptr+1) == '\0') {
2398 set_vaxc_errno(SvIV(sv));
2401 SetLastError( SvIV(sv) );
2404 os2_setsyserrno(SvIV(sv));
2406 /* will anyone ever use this? */
2407 SETERRNO(SvIV(sv), 4);
2412 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2413 SvREFCNT_dec(PL_encoding);
2414 if (SvOK(sv) || SvGMAGICAL(sv)) {
2415 PL_encoding = newSVsv(sv);
2422 case '\006': /* ^F */
2423 PL_maxsysfd = SvIV(sv);
2425 case '\010': /* ^H */
2426 PL_hints = SvIV(sv);
2428 case '\011': /* ^I */ /* NOT \t in EBCDIC */
2429 Safefree(PL_inplace);
2430 PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
2432 case '\017': /* ^O */
2433 if (*(mg->mg_ptr+1) == '\0') {
2434 Safefree(PL_osname);
2437 TAINT_PROPER("assigning to $^O");
2438 PL_osname = savesvpv(sv);
2441 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2443 const char *const start = SvPV(sv, len);
2444 const char *out = (const char*)memchr(start, '\0', len);
2448 PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2449 PL_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2451 /* Opening for input is more common than opening for output, so
2452 ensure that hints for input are sooner on linked list. */
2453 tmp = out ? newSVpvn_flags(out + 1, start + len - out - 1,
2455 : newSVpvs_flags("", SvUTF8(sv));
2456 (void)hv_stores(GvHV(PL_hintgv), "open>", tmp);
2459 tmp = newSVpvn_flags(start, out ? (STRLEN)(out - start) : len,
2461 (void)hv_stores(GvHV(PL_hintgv), "open<", tmp);
2465 case '\020': /* ^P */
2466 if (*remaining == '\0') { /* ^P */
2467 PL_perldb = SvIV(sv);
2468 if (PL_perldb && !PL_DBsingle)
2471 } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
2473 } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
2476 case '\024': /* ^T */
2478 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2480 PL_basetime = (Time_t)SvIV(sv);
2483 case '\025': /* ^UTF8CACHE */
2484 if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
2485 PL_utf8cache = (signed char) sv_2iv(sv);
2488 case '\027': /* ^W & $^WARNING_BITS */
2489 if (*(mg->mg_ptr+1) == '\0') {
2490 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2492 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2493 | (i ? G_WARN_ON : G_WARN_OFF) ;
2496 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2497 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2498 if (!SvPOK(sv) && PL_localizing) {
2499 sv_setpvn(sv, WARN_NONEstring, WARNsize);
2500 PL_compiling.cop_warnings = pWARN_NONE;
2505 int accumulate = 0 ;
2506 int any_fatals = 0 ;
2507 const char * const ptr = SvPV_const(sv, len) ;
2508 for (i = 0 ; i < len ; ++i) {
2509 accumulate |= ptr[i] ;
2510 any_fatals |= (ptr[i] & 0xAA) ;
2513 if (!specialWARN(PL_compiling.cop_warnings))
2514 PerlMemShared_free(PL_compiling.cop_warnings);
2515 PL_compiling.cop_warnings = pWARN_NONE;
2517 /* Yuck. I can't see how to abstract this: */
2518 else if (isWARN_on(((STRLEN *)SvPV_nolen_const(sv)) - 1,
2519 WARN_ALL) && !any_fatals) {
2520 if (!specialWARN(PL_compiling.cop_warnings))
2521 PerlMemShared_free(PL_compiling.cop_warnings);
2522 PL_compiling.cop_warnings = pWARN_ALL;
2523 PL_dowarn |= G_WARN_ONCE ;
2527 const char *const p = SvPV_const(sv, len);
2529 PL_compiling.cop_warnings
2530 = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
2533 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2534 PL_dowarn |= G_WARN_ONCE ;
2542 if (PL_localizing) {
2543 if (PL_localizing == 1)
2544 SAVESPTR(PL_last_in_gv);
2546 else if (SvOK(sv) && GvIO(PL_last_in_gv))
2547 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2550 if (isGV_with_GP(PL_defoutgv)) {
2551 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2552 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2553 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2557 if (isGV_with_GP(PL_defoutgv)) {
2558 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2559 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2560 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2564 if (isGV_with_GP(PL_defoutgv))
2565 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
2568 if (isGV_with_GP(PL_defoutgv)) {
2569 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
2570 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2571 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2575 if (isGV_with_GP(PL_defoutgv))
2576 IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
2580 IO * const io = GvIO(PL_defoutgv);
2583 if ((SvIV(sv)) == 0)
2584 IoFLAGS(io) &= ~IOf_FLUSH;
2586 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2587 PerlIO *ofp = IoOFP(io);
2589 (void)PerlIO_flush(ofp);
2590 IoFLAGS(io) |= IOf_FLUSH;
2596 SvREFCNT_dec(PL_rs);
2597 PL_rs = newSVsv(sv);
2600 SvREFCNT_dec(PL_ors_sv);
2601 if (SvOK(sv) || SvGMAGICAL(sv)) {
2602 PL_ors_sv = newSVsv(sv);
2609 CopARYBASE_set(&PL_compiling, SvIV(sv));
2612 #ifdef COMPLEX_STATUS
2613 if (PL_localizing == 2) {
2614 SvUPGRADE(sv, SVt_PVLV);
2615 PL_statusvalue = LvTARGOFF(sv);
2616 PL_statusvalue_vms = LvTARGLEN(sv);
2620 #ifdef VMSISH_STATUS
2622 STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2625 STATUS_UNIX_EXIT_SET(SvIV(sv));
2630 # define PERL_VMS_BANG vaxc$errno
2632 # define PERL_VMS_BANG 0
2634 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2635 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2640 if (PL_delaymagic) {
2641 PL_delaymagic |= DM_RUID;
2642 break; /* don't do magic till later */
2645 (void)setruid((Uid_t)PL_uid);
2648 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2650 #ifdef HAS_SETRESUID
2651 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2653 if (PL_uid == PL_euid) { /* special case $< = $> */
2655 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2656 if (PL_uid != 0 && PerlProc_getuid() == 0)
2657 (void)PerlProc_setuid(0);
2659 (void)PerlProc_setuid(PL_uid);
2661 PL_uid = PerlProc_getuid();
2662 Perl_croak(aTHX_ "setruid() not implemented");
2667 PL_uid = PerlProc_getuid();
2671 if (PL_delaymagic) {
2672 PL_delaymagic |= DM_EUID;
2673 break; /* don't do magic till later */
2676 (void)seteuid((Uid_t)PL_euid);
2679 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2681 #ifdef HAS_SETRESUID
2682 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2684 if (PL_euid == PL_uid) /* special case $> = $< */
2685 PerlProc_setuid(PL_euid);
2687 PL_euid = PerlProc_geteuid();
2688 Perl_croak(aTHX_ "seteuid() not implemented");
2693 PL_euid = PerlProc_geteuid();
2697 if (PL_delaymagic) {
2698 PL_delaymagic |= DM_RGID;
2699 break; /* don't do magic till later */
2702 (void)setrgid((Gid_t)PL_gid);
2705 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2707 #ifdef HAS_SETRESGID
2708 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2710 if (PL_gid == PL_egid) /* special case $( = $) */
2711 (void)PerlProc_setgid(PL_gid);
2713 PL_gid = PerlProc_getgid();
2714 Perl_croak(aTHX_ "setrgid() not implemented");
2719 PL_gid = PerlProc_getgid();
2722 #ifdef HAS_SETGROUPS
2724 const char *p = SvPV_const(sv, len);
2725 Groups_t *gary = NULL;
2726 #ifdef _SC_NGROUPS_MAX
2727 int maxgrp = sysconf(_SC_NGROUPS_MAX);
2732 int maxgrp = NGROUPS;
2738 for (i = 0; i < maxgrp; ++i) {
2739 while (*p && !isSPACE(*p))
2746 Newx(gary, i + 1, Groups_t);
2748 Renew(gary, i + 1, Groups_t);
2752 (void)setgroups(i, gary);
2755 #else /* HAS_SETGROUPS */
2757 #endif /* HAS_SETGROUPS */
2758 if (PL_delaymagic) {
2759 PL_delaymagic |= DM_EGID;
2760 break; /* don't do magic till later */
2763 (void)setegid((Gid_t)PL_egid);
2766 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2768 #ifdef HAS_SETRESGID
2769 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2771 if (PL_egid == PL_gid) /* special case $) = $( */
2772 (void)PerlProc_setgid(PL_egid);
2774 PL_egid = PerlProc_getegid();
2775 Perl_croak(aTHX_ "setegid() not implemented");
2780 PL_egid = PerlProc_getegid();
2783 PL_chopset = SvPV_force(sv,len);
2786 LOCK_DOLLARZERO_MUTEX;
2787 #ifdef HAS_SETPROCTITLE
2788 /* The BSDs don't show the argv[] in ps(1) output, they
2789 * show a string from the process struct and provide
2790 * the setproctitle() routine to manipulate that. */
2791 if (PL_origalen != 1) {
2792 s = SvPV_const(sv, len);
2793 # if __FreeBSD_version > 410001
2794 /* The leading "-" removes the "perl: " prefix,
2795 * but not the "(perl) suffix from the ps(1)
2796 * output, because that's what ps(1) shows if the
2797 * argv[] is modified. */
2798 setproctitle("-%s", s);
2799 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2800 /* This doesn't really work if you assume that
2801 * $0 = 'foobar'; will wipe out 'perl' from the $0
2802 * because in ps(1) output the result will be like
2803 * sprintf("perl: %s (perl)", s)
2804 * I guess this is a security feature:
2805 * one (a user process) cannot get rid of the original name.
2807 setproctitle("%s", s);
2810 #elif defined(__hpux) && defined(PSTAT_SETCMD)
2811 if (PL_origalen != 1) {
2813 s = SvPV_const(sv, len);
2814 un.pst_command = (char *)s;
2815 pstat(PSTAT_SETCMD, un, len, 0, 0);
2818 if (PL_origalen > 1) {
2819 /* PL_origalen is set in perl_parse(). */
2820 s = SvPV_force(sv,len);
2821 if (len >= (STRLEN)PL_origalen-1) {
2822 /* Longer than original, will be truncated. We assume that
2823 * PL_origalen bytes are available. */
2824 Copy(s, PL_origargv[0], PL_origalen-1, char);
2827 /* Shorter than original, will be padded. */
2829 /* Special case for Mac OS X: see [perl #38868] */
2832 /* Is the space counterintuitive? Yes.
2833 * (You were expecting \0?)
2834 * Does it work? Seems to. (In Linux 2.4.20 at least.)
2836 const int pad = ' ';
2838 Copy(s, PL_origargv[0], len, char);
2839 PL_origargv[0][len] = 0;
2840 memset(PL_origargv[0] + len + 1,
2841 pad, PL_origalen - len - 1);
2843 PL_origargv[0][PL_origalen-1] = 0;
2844 for (i = 1; i < PL_origargc; i++)
2846 #ifdef HAS_PRCTL_SET_NAME
2847 /* Set the legacy process name in addition to the POSIX name on Linux */
2848 if (prctl(PR_SET_NAME, (unsigned long)s, 0, 0, 0) != 0) {
2849 /* diag_listed_as: SKIPME */
2850 Perl_croak(aTHX_ "Can't set $0 with prctl(): %s", Strerror(errno));
2855 UNLOCK_DOLLARZERO_MUTEX;
2862 Perl_whichsig(pTHX_ const char *sig)
2864 register char* const* sigv;
2866 PERL_ARGS_ASSERT_WHICHSIG;
2867 PERL_UNUSED_CONTEXT;
2869 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
2870 if (strEQ(sig,*sigv))
2871 return PL_sig_num[sigv - (char* const*)PL_sig_name];
2873 if (strEQ(sig,"CHLD"))
2877 if (strEQ(sig,"CLD"))
2884 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2885 Perl_sighandler(int sig, siginfo_t *sip, void *uap PERL_UNUSED_DECL)
2887 Perl_sighandler(int sig)
2890 #ifdef PERL_GET_SIG_CONTEXT
2891 dTHXa(PERL_GET_SIG_CONTEXT);
2898 SV * const tSv = PL_Sv;
2902 XPV * const tXpv = PL_Xpv;
2904 if (PL_savestack_ix + 15 <= PL_savestack_max)
2906 if (PL_markstack_ptr < PL_markstack_max - 2)
2908 if (PL_scopestack_ix < PL_scopestack_max - 3)
2911 if (!PL_psig_ptr[sig]) {
2912 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2917 /* Max number of items pushed there is 3*n or 4. We cannot fix
2918 infinity, so we fix 4 (in fact 5): */
2920 PL_savestack_ix += 5; /* Protect save in progress. */
2921 SAVEDESTRUCTOR_X(S_unwind_handler_stack, (void*)&flags);
2924 PL_markstack_ptr++; /* Protect mark. */
2926 PL_scopestack_ix += 1;
2927 /* sv_2cv is too complicated, try a simpler variant first: */
2928 if (!SvROK(PL_psig_ptr[sig]) || !(cv = MUTABLE_CV(SvRV(PL_psig_ptr[sig])))
2929 || SvTYPE(cv) != SVt_PVCV) {
2931 cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
2934 if (!cv || !CvROOT(cv)) {
2935 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2936 PL_sig_name[sig], (gv ? GvENAME(gv)
2943 if(PL_psig_name[sig]) {
2944 sv = SvREFCNT_inc_NN(PL_psig_name[sig]);
2946 #if !defined(PERL_IMPLICIT_CONTEXT)
2950 sv = sv_newmortal();
2951 sv_setpv(sv,PL_sig_name[sig]);
2954 PUSHSTACKi(PERLSI_SIGNAL);
2957 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2959 struct sigaction oact;
2961 if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
2964 SV *rv = newRV_noinc(MUTABLE_SV(sih));
2965 /* The siginfo fields signo, code, errno, pid, uid,
2966 * addr, status, and band are defined by POSIX/SUSv3. */
2967 (void)hv_stores(sih, "signo", newSViv(sip->si_signo));
2968 (void)hv_stores(sih, "code", newSViv(sip->si_code));
2969 #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. */
2970 hv_stores(sih, "errno", newSViv(sip->si_errno));
2971 hv_stores(sih, "status", newSViv(sip->si_status));
2972 hv_stores(sih, "uid", newSViv(sip->si_uid));
2973 hv_stores(sih, "pid", newSViv(sip->si_pid));
2974 hv_stores(sih, "addr", newSVuv(PTR2UV(sip->si_addr)));
2975 hv_stores(sih, "band", newSViv(sip->si_band));
2979 mPUSHp((char *)sip, sizeof(*sip));
2987 call_sv(MUTABLE_SV(cv), G_DISCARD|G_EVAL);
2990 if (SvTRUE(ERRSV)) {
2992 #ifdef HAS_SIGPROCMASK
2993 /* Handler "died", for example to get out of a restart-able read().
2994 * Before we re-do that on its behalf re-enable the signal which was
2995 * blocked by the system when we entered.
2999 sigaddset(&set,sig);
3000 sigprocmask(SIG_UNBLOCK, &set, NULL);
3002 /* Not clear if this will work */
3003 (void)rsignal(sig, SIG_IGN);
3004 (void)rsignal(sig, PL_csighandlerp);
3006 #endif /* !PERL_MICRO */
3011 PL_savestack_ix -= 8; /* Unprotect save in progress. */
3015 PL_scopestack_ix -= 1;
3018 PL_op = myop; /* Apparently not needed... */
3020 PL_Sv = tSv; /* Restore global temporaries. */
3027 S_restore_magic(pTHX_ const void *p)
3030 MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
3031 SV* const sv = mgs->mgs_sv;
3036 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
3038 #ifdef PERL_OLD_COPY_ON_WRITE
3039 /* While magic was saved (and off) sv_setsv may well have seen
3040 this SV as a prime candidate for COW. */
3042 sv_force_normal_flags(sv, 0);
3045 if (mgs->mgs_readonly)
3047 if (mgs->mgs_magical)
3048 SvFLAGS(sv) |= mgs->mgs_magical;
3051 if (SvGMAGICAL(sv)) {
3052 /* downgrade public flags to private,
3053 and discard any other private flags */
3055 const U32 pubflags = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
3057 SvFLAGS(sv) &= ~( pubflags | (SVp_IOK|SVp_NOK|SVp_POK) );
3058 SvFLAGS(sv) |= ( pubflags << PRIVSHIFT );
3063 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
3065 /* If we're still on top of the stack, pop us off. (That condition
3066 * will be satisfied if restore_magic was called explicitly, but *not*
3067 * if it's being called via leave_scope.)
3068 * The reason for doing this is that otherwise, things like sv_2cv()
3069 * may leave alloc gunk on the savestack, and some code
3070 * (e.g. sighandler) doesn't expect that...
3072 if (PL_savestack_ix == mgs->mgs_ss_ix)
3074 UV popval = SSPOPUV;
3075 assert(popval == SAVEt_DESTRUCTOR_X);
3076 PL_savestack_ix -= 2;
3078 assert((popval & SAVE_MASK) == SAVEt_ALLOC);
3079 PL_savestack_ix -= popval >> SAVE_TIGHT_SHIFT;
3085 S_unwind_handler_stack(pTHX_ const void *p)
3088 const U32 flags = *(const U32*)p;
3090 PERL_ARGS_ASSERT_UNWIND_HANDLER_STACK;
3093 PL_savestack_ix -= 5; /* Unprotect save in progress. */
3094 #if !defined(PERL_IMPLICIT_CONTEXT)
3096 SvREFCNT_dec(PL_sig_sv);
3101 =for apidoc magic_sethint
3103 Triggered by a store to %^H, records the key/value pair to
3104 C<PL_compiling.cop_hints_hash>. It is assumed that hints aren't storing
3105 anything that would need a deep copy. Maybe we should warn if we find a
3111 Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
3114 SV *key = (mg->mg_len == HEf_SVKEY) ? MUTABLE_SV(mg->mg_ptr)
3115 : newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
3117 PERL_ARGS_ASSERT_MAGIC_SETHINT;
3119 /* mg->mg_obj isn't being used. If needed, it would be possible to store
3120 an alternative leaf in there, with PL_compiling.cop_hints being used if
3121 it's NULL. If needed for threads, the alternative could lock a mutex,
3122 or take other more complex action. */
3124 /* Something changed in %^H, so it will need to be restored on scope exit.
3125 Doing this here saves a lot of doing it manually in perl code (and
3126 forgetting to do it, and consequent subtle errors. */
3127 PL_hints |= HINT_LOCALIZE_HH;
3128 PL_compiling.cop_hints_hash
3129 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash, key, sv);
3134 =for apidoc magic_clearhint
3136 Triggered by a delete from %^H, records the key to
3137 C<PL_compiling.cop_hints_hash>.
3142 Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
3146 PERL_ARGS_ASSERT_MAGIC_CLEARHINT;
3147 PERL_UNUSED_ARG(sv);
3149 assert(mg->mg_len == HEf_SVKEY);
3151 PERL_UNUSED_ARG(sv);
3153 PL_hints |= HINT_LOCALIZE_HH;
3154 PL_compiling.cop_hints_hash
3155 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
3156 MUTABLE_SV(mg->mg_ptr), &PL_sv_placeholder);
3161 =for apidoc magic_clearhints
3163 Triggered by clearing %^H, resets C<PL_compiling.cop_hints_hash>.
3168 Perl_magic_clearhints(pTHX_ SV *sv, MAGIC *mg)
3170 PERL_ARGS_ASSERT_MAGIC_CLEARHINTS;
3171 PERL_UNUSED_ARG(sv);
3172 PERL_UNUSED_ARG(mg);
3173 if (PL_compiling.cop_hints_hash) {
3174 Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
3175 PL_compiling.cop_hints_hash = NULL;
3182 * c-indentation-style: bsd
3184 * indent-tabs-mode: t
3187 * ex: set ts=8 sts=4 sw=4 noet: