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 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
61 Signal_t Perl_csighandler(int sig, siginfo_t *, void *);
63 Signal_t Perl_csighandler(int sig);
67 /* Missing protos on LynxOS */
68 void setruid(uid_t id);
69 void seteuid(uid_t id);
70 void setrgid(uid_t id);
71 void setegid(uid_t id);
75 * Use the "DESTRUCTOR" scope cleanup to reinstate magic.
84 /* MGS is typedef'ed to struct magic_state in perl.h */
87 S_save_magic(pTHX_ I32 mgs_ix, SV *sv)
92 PERL_ARGS_ASSERT_SAVE_MAGIC;
94 assert(SvMAGICAL(sv));
95 /* Turning READONLY off for a copy-on-write scalar (including shared
96 hash keys) is a bad idea. */
98 sv_force_normal_flags(sv, 0);
100 SAVEDESTRUCTOR_X(S_restore_magic, INT2PTR(void*, (IV)mgs_ix));
102 mgs = SSPTR(mgs_ix, MGS*);
104 mgs->mgs_magical = SvMAGICAL(sv);
105 mgs->mgs_readonly = SvREADONLY(sv) != 0;
106 mgs->mgs_ss_ix = PL_savestack_ix; /* points after the saved destructor */
110 if (!(SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK))) {
111 /* No public flags are set, so promote any private flags to public. */
112 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
117 =for apidoc mg_magical
119 Turns on the magical status of an SV. See C<sv_magic>.
125 Perl_mg_magical(pTHX_ SV *sv)
128 PERL_ARGS_ASSERT_MG_MAGICAL;
132 if ((mg = SvMAGIC(sv))) {
134 const MGVTBL* const vtbl = mg->mg_virtual;
136 if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
143 } while ((mg = mg->mg_moremagic));
144 if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)))
150 /* is this container magic (%ENV, $1 etc), or value magic (pos, taint etc)? */
153 S_is_container_magic(const MAGIC *mg)
156 switch (mg->mg_type) {
159 case PERL_MAGIC_regex_global:
160 case PERL_MAGIC_nkeys:
161 #ifdef USE_LOCALE_COLLATE
162 case PERL_MAGIC_collxfrm:
165 case PERL_MAGIC_taint:
167 case PERL_MAGIC_vstring:
168 case PERL_MAGIC_utf8:
169 case PERL_MAGIC_substr:
170 case PERL_MAGIC_defelem:
171 case PERL_MAGIC_arylen:
173 case PERL_MAGIC_backref:
174 case PERL_MAGIC_arylen_p:
175 case PERL_MAGIC_rhash:
176 case PERL_MAGIC_symtab:
186 Do magic after a value is retrieved from the SV. See C<sv_magic>.
192 Perl_mg_get(pTHX_ SV *sv)
195 const I32 mgs_ix = SSNEW(sizeof(MGS));
196 const bool was_temp = (bool)SvTEMP(sv);
198 MAGIC *newmg, *head, *cur, *mg;
199 /* guard against sv having being freed midway by holding a private
202 PERL_ARGS_ASSERT_MG_GET;
204 /* sv_2mortal has this side effect of turning on the TEMP flag, which can
205 cause the SV's buffer to get stolen (and maybe other stuff).
208 sv_2mortal(SvREFCNT_inc_simple_NN(sv));
213 save_magic(mgs_ix, sv);
215 /* We must call svt_get(sv, mg) for each valid entry in the linked
216 list of magic. svt_get() may delete the current entry, add new
217 magic to the head of the list, or upgrade the SV. AMS 20010810 */
219 newmg = cur = head = mg = SvMAGIC(sv);
221 const MGVTBL * const vtbl = mg->mg_virtual;
222 MAGIC * const nextmg = mg->mg_moremagic; /* it may delete itself */
224 if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
225 CALL_FPTR(vtbl->svt_get)(aTHX_ sv, mg);
227 /* guard against magic having been deleted - eg FETCH calling
230 (SSPTR(mgs_ix, MGS *))->mgs_magical = 0; /* recalculate flags */
234 /* recalculate flags if this entry was deleted. */
235 if (mg->mg_flags & MGf_GSKIP)
236 (SSPTR(mgs_ix, MGS *))->mgs_magical = 0;
242 /* Have we finished with the new entries we saw? Start again
243 where we left off (unless there are more new entries). */
251 /* Were any new entries added? */
252 if (!have_new && (newmg = SvMAGIC(sv)) != head) {
256 (SSPTR(mgs_ix, MGS *))->mgs_magical = 0; /* recalculate flags */
260 restore_magic(INT2PTR(void *, (IV)mgs_ix));
262 if (SvREFCNT(sv) == 1) {
263 /* We hold the last reference to this SV, which implies that the
264 SV was deleted as a side effect of the routines we called. */
273 Do magic after a value is assigned to the SV. See C<sv_magic>.
279 Perl_mg_set(pTHX_ SV *sv)
282 const I32 mgs_ix = SSNEW(sizeof(MGS));
286 PERL_ARGS_ASSERT_MG_SET;
288 save_magic(mgs_ix, sv);
290 for (mg = SvMAGIC(sv); mg; mg = nextmg) {
291 const MGVTBL* vtbl = mg->mg_virtual;
292 nextmg = mg->mg_moremagic; /* it may delete itself */
293 if (mg->mg_flags & MGf_GSKIP) {
294 mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */
295 (SSPTR(mgs_ix, MGS*))->mgs_magical = 0;
297 if (PL_localizing == 2 && !S_is_container_magic(mg))
299 if (vtbl && vtbl->svt_set)
300 CALL_FPTR(vtbl->svt_set)(aTHX_ sv, mg);
303 restore_magic(INT2PTR(void*, (IV)mgs_ix));
308 =for apidoc mg_length
310 Report on the SV's length. See C<sv_magic>.
316 Perl_mg_length(pTHX_ SV *sv)
322 PERL_ARGS_ASSERT_MG_LENGTH;
324 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
325 const MGVTBL * const vtbl = mg->mg_virtual;
326 if (vtbl && vtbl->svt_len) {
327 const I32 mgs_ix = SSNEW(sizeof(MGS));
328 save_magic(mgs_ix, sv);
329 /* omit MGf_GSKIP -- not changed here */
330 len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
331 restore_magic(INT2PTR(void*, (IV)mgs_ix));
337 /* You can't know whether it's UTF-8 until you get the string again...
339 const U8 *s = (U8*)SvPV_const(sv, len);
342 len = utf8_length(s, s + len);
349 Perl_mg_size(pTHX_ SV *sv)
353 PERL_ARGS_ASSERT_MG_SIZE;
355 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
356 const MGVTBL* const vtbl = mg->mg_virtual;
357 if (vtbl && vtbl->svt_len) {
358 const I32 mgs_ix = SSNEW(sizeof(MGS));
360 save_magic(mgs_ix, sv);
361 /* omit MGf_GSKIP -- not changed here */
362 len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
363 restore_magic(INT2PTR(void*, (IV)mgs_ix));
370 return AvFILLp((const AV *) sv); /* Fallback to non-tied array */
374 Perl_croak(aTHX_ "Size magic not implemented");
383 Clear something magical that the SV represents. See C<sv_magic>.
389 Perl_mg_clear(pTHX_ SV *sv)
391 const I32 mgs_ix = SSNEW(sizeof(MGS));
395 PERL_ARGS_ASSERT_MG_CLEAR;
397 save_magic(mgs_ix, sv);
399 for (mg = SvMAGIC(sv); mg; mg = nextmg) {
400 const MGVTBL* const vtbl = mg->mg_virtual;
401 /* omit GSKIP -- never set here */
403 nextmg = mg->mg_moremagic; /* it may delete itself */
405 if (vtbl && vtbl->svt_clear)
406 CALL_FPTR(vtbl->svt_clear)(aTHX_ sv, mg);
409 restore_magic(INT2PTR(void*, (IV)mgs_ix));
416 Finds the magic pointer for type matching the SV. See C<sv_magic>.
422 Perl_mg_find(pTHX_ const SV *sv, int type)
427 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
428 if (mg->mg_type == type)
438 Copies the magic from one SV to another. See C<sv_magic>.
444 Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
449 PERL_ARGS_ASSERT_MG_COPY;
451 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
452 const MGVTBL* const vtbl = mg->mg_virtual;
453 if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){
454 count += CALL_FPTR(vtbl->svt_copy)(aTHX_ sv, mg, nsv, key, klen);
457 const char type = mg->mg_type;
458 if (isUPPER(type) && type != PERL_MAGIC_uvar) {
460 (type == PERL_MAGIC_tied)
462 : (type == PERL_MAGIC_regdata && mg->mg_obj)
465 toLOWER(type), key, klen);
474 =for apidoc mg_localize
476 Copy some of the magic from an existing SV to new localized version of that
477 SV. Container magic (eg %ENV, $1, tie) gets copied, value magic doesn't (eg
480 If setmagic is false then no set magic will be called on the new (empty) SV.
481 This typically means that assignment will soon follow (e.g. 'local $x = $y'),
482 and that will handle the magic.
488 Perl_mg_localize(pTHX_ SV *sv, SV *nsv, bool setmagic)
493 PERL_ARGS_ASSERT_MG_LOCALIZE;
495 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
496 const MGVTBL* const vtbl = mg->mg_virtual;
497 if (!S_is_container_magic(mg))
500 if ((mg->mg_flags & MGf_LOCAL) && vtbl->svt_local)
501 (void)CALL_FPTR(vtbl->svt_local)(aTHX_ nsv, mg);
503 sv_magicext(nsv, mg->mg_obj, mg->mg_type, vtbl,
504 mg->mg_ptr, mg->mg_len);
506 /* container types should remain read-only across localization */
507 SvFLAGS(nsv) |= SvREADONLY(sv);
510 if (SvTYPE(nsv) >= SVt_PVMG && SvMAGIC(nsv)) {
511 SvFLAGS(nsv) |= SvMAGICAL(sv);
523 Free any magic storage used by the SV. See C<sv_magic>.
529 Perl_mg_free(pTHX_ SV *sv)
534 PERL_ARGS_ASSERT_MG_FREE;
536 for (mg = SvMAGIC(sv); mg; mg = moremagic) {
537 const MGVTBL* const vtbl = mg->mg_virtual;
538 moremagic = mg->mg_moremagic;
539 if (vtbl && vtbl->svt_free)
540 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
541 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
542 if (mg->mg_len > 0 || mg->mg_type == PERL_MAGIC_utf8)
543 Safefree(mg->mg_ptr);
544 else if (mg->mg_len == HEf_SVKEY)
545 SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr));
547 if (mg->mg_flags & MGf_REFCOUNTED)
548 SvREFCNT_dec(mg->mg_obj);
550 SvMAGIC_set(sv, moremagic);
552 SvMAGIC_set(sv, NULL);
560 Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
565 PERL_ARGS_ASSERT_MAGIC_REGDATA_CNT;
568 register const REGEXP * const rx = PM_GETRE(PL_curpm);
570 if (mg->mg_obj) { /* @+ */
571 /* return the number possible */
572 return RX_NPARENS(rx);
574 I32 paren = RX_LASTPAREN(rx);
576 /* return the last filled */
578 && (RX_OFFS(rx)[paren].start == -1
579 || RX_OFFS(rx)[paren].end == -1) )
590 Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
594 PERL_ARGS_ASSERT_MAGIC_REGDATUM_GET;
597 register const REGEXP * const rx = PM_GETRE(PL_curpm);
599 register const I32 paren = mg->mg_len;
604 if (paren <= (I32)RX_NPARENS(rx) &&
605 (s = RX_OFFS(rx)[paren].start) != -1 &&
606 (t = RX_OFFS(rx)[paren].end) != -1)
609 if (mg->mg_obj) /* @+ */
614 if (i > 0 && RX_MATCH_UTF8(rx)) {
615 const char * const b = RX_SUBBEG(rx);
617 i = utf8_length((U8*)b, (U8*)(b+i));
628 Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
630 PERL_ARGS_ASSERT_MAGIC_REGDATUM_SET;
633 Perl_croak(aTHX_ "%s", PL_no_modify);
634 NORETURN_FUNCTION_END;
638 Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
643 register const REGEXP * rx;
644 const char * const remaining = mg->mg_ptr + 1;
646 PERL_ARGS_ASSERT_MAGIC_LEN;
648 switch (*mg->mg_ptr) {
650 if (*remaining == '\0') { /* ^P */
652 } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
654 } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
658 case '\015': /* $^MATCH */
659 if (strEQ(remaining, "ATCH")) {
666 paren = RX_BUFF_IDX_PREMATCH;
670 paren = RX_BUFF_IDX_POSTMATCH;
674 paren = RX_BUFF_IDX_FULLMATCH;
676 case '1': case '2': case '3': case '4':
677 case '5': case '6': case '7': case '8': case '9':
678 paren = atoi(mg->mg_ptr);
680 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
682 i = CALLREG_NUMBUF_LENGTH((REGEXP * const)rx, sv, paren);
685 Perl_croak(aTHX_ "panic: magic_len: %"IVdf, (IV)i);
688 if (ckWARN(WARN_UNINITIALIZED))
693 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
694 paren = RX_LASTPAREN(rx);
699 case '\016': /* ^N */
700 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
701 paren = RX_LASTCLOSEPAREN(rx);
708 if (!SvPOK(sv) && SvNIOK(sv)) {
716 #define SvRTRIM(sv) STMT_START { \
718 STRLEN len = SvCUR(sv); \
719 char * const p = SvPVX(sv); \
720 while (len > 0 && isSPACE(p[len-1])) \
722 SvCUR_set(sv, len); \
728 Perl_emulate_cop_io(pTHX_ const COP *const c, SV *const sv)
730 PERL_ARGS_ASSERT_EMULATE_COP_IO;
732 if (!(CopHINTS_get(c) & (HINT_LEXICAL_IO_IN|HINT_LEXICAL_IO_OUT)))
733 sv_setsv(sv, &PL_sv_undef);
737 if ((CopHINTS_get(c) & HINT_LEXICAL_IO_IN)) {
738 SV *const value = Perl_refcounted_he_fetch(aTHX_
740 0, "open<", 5, 0, 0);
745 if ((CopHINTS_get(c) & HINT_LEXICAL_IO_OUT)) {
746 SV *const value = Perl_refcounted_he_fetch(aTHX_
748 0, "open>", 5, 0, 0);
756 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
760 register char *s = NULL;
762 const char * const remaining = mg->mg_ptr + 1;
763 const char nextchar = *remaining;
765 PERL_ARGS_ASSERT_MAGIC_GET;
767 switch (*mg->mg_ptr) {
768 case '\001': /* ^A */
769 sv_setsv(sv, PL_bodytarget);
771 case '\003': /* ^C, ^CHILD_ERROR_NATIVE */
772 if (nextchar == '\0') {
773 sv_setiv(sv, (IV)PL_minus_c);
775 else if (strEQ(remaining, "HILD_ERROR_NATIVE")) {
776 sv_setiv(sv, (IV)STATUS_NATIVE);
780 case '\004': /* ^D */
781 sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
783 case '\005': /* ^E */
784 if (nextchar == '\0') {
787 # include <descrip.h>
788 # include <starlet.h>
790 $DESCRIPTOR(msgdsc,msg);
791 sv_setnv(sv,(NV) vaxc$errno);
792 if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
793 sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
798 if (!(_emx_env & 0x200)) { /* Under DOS */
799 sv_setnv(sv, (NV)errno);
800 sv_setpv(sv, errno ? Strerror(errno) : "");
802 if (errno != errno_isOS2) {
803 const int tmp = _syserrno();
804 if (tmp) /* 2nd call to _syserrno() makes it 0 */
807 sv_setnv(sv, (NV)Perl_rc);
808 sv_setpv(sv, os2error(Perl_rc));
812 const DWORD dwErr = GetLastError();
813 sv_setnv(sv, (NV)dwErr);
815 PerlProc_GetOSError(sv, dwErr);
824 sv_setnv(sv, (NV)errno);
825 sv_setpv(sv, errno ? Strerror(errno) : "");
830 SvNOK_on(sv); /* what a wonderful hack! */
832 else if (strEQ(remaining, "NCODING"))
833 sv_setsv(sv, PL_encoding);
835 case '\006': /* ^F */
836 sv_setiv(sv, (IV)PL_maxsysfd);
838 case '\010': /* ^H */
839 sv_setiv(sv, (IV)PL_hints);
841 case '\011': /* ^I */ /* NOT \t in EBCDIC */
842 sv_setpv(sv, PL_inplace); /* Will undefine sv if PL_inplace is NULL */
844 case '\017': /* ^O & ^OPEN */
845 if (nextchar == '\0') {
846 sv_setpv(sv, PL_osname);
849 else if (strEQ(remaining, "PEN")) {
850 Perl_emulate_cop_io(aTHX_ &PL_compiling, sv);
854 if (nextchar == '\0') { /* ^P */
855 sv_setiv(sv, (IV)PL_perldb);
856 } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
857 goto do_prematch_fetch;
858 } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
859 goto do_postmatch_fetch;
862 case '\023': /* ^S */
863 if (nextchar == '\0') {
864 if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING)
867 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
872 case '\024': /* ^T */
873 if (nextchar == '\0') {
875 sv_setnv(sv, PL_basetime);
877 sv_setiv(sv, (IV)PL_basetime);
880 else if (strEQ(remaining, "AINT"))
881 sv_setiv(sv, PL_tainting
882 ? (PL_taint_warn || PL_unsafe ? -1 : 1)
885 case '\025': /* $^UNICODE, $^UTF8LOCALE, $^UTF8CACHE */
886 if (strEQ(remaining, "NICODE"))
887 sv_setuv(sv, (UV) PL_unicode);
888 else if (strEQ(remaining, "TF8LOCALE"))
889 sv_setuv(sv, (UV) PL_utf8locale);
890 else if (strEQ(remaining, "TF8CACHE"))
891 sv_setiv(sv, (IV) PL_utf8cache);
893 case '\027': /* ^W & $^WARNING_BITS */
894 if (nextchar == '\0')
895 sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
896 else if (strEQ(remaining, "ARNING_BITS")) {
897 if (PL_compiling.cop_warnings == pWARN_NONE) {
898 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
900 else if (PL_compiling.cop_warnings == pWARN_STD) {
903 (PL_dowarn & G_WARN_ON) ? WARN_ALLstring : WARN_NONEstring,
907 else if (PL_compiling.cop_warnings == pWARN_ALL) {
908 /* Get the bit mask for $warnings::Bits{all}, because
909 * it could have been extended by warnings::register */
910 HV * const bits=get_hv("warnings::Bits", 0);
912 SV ** const bits_all = hv_fetchs(bits, "all", FALSE);
914 sv_setsv(sv, *bits_all);
917 sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
921 sv_setpvn(sv, (char *) (PL_compiling.cop_warnings + 1),
922 *PL_compiling.cop_warnings);
927 case '\015': /* $^MATCH */
928 if (strEQ(remaining, "ATCH")) {
929 case '1': case '2': case '3': case '4':
930 case '5': case '6': case '7': case '8': case '9': case '&':
931 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
933 * Pre-threads, this was paren = atoi(GvENAME((const GV *)mg->mg_obj));
934 * XXX Does the new way break anything?
936 paren = atoi(mg->mg_ptr); /* $& is in [0] */
937 CALLREG_NUMBUF_FETCH(rx,paren,sv);
940 sv_setsv(sv,&PL_sv_undef);
944 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
945 if (RX_LASTPAREN(rx)) {
946 CALLREG_NUMBUF_FETCH(rx,RX_LASTPAREN(rx),sv);
950 sv_setsv(sv,&PL_sv_undef);
952 case '\016': /* ^N */
953 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
954 if (RX_LASTCLOSEPAREN(rx)) {
955 CALLREG_NUMBUF_FETCH(rx,RX_LASTCLOSEPAREN(rx),sv);
960 sv_setsv(sv,&PL_sv_undef);
964 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
965 CALLREG_NUMBUF_FETCH(rx,-2,sv);
968 sv_setsv(sv,&PL_sv_undef);
972 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
973 CALLREG_NUMBUF_FETCH(rx,-1,sv);
976 sv_setsv(sv,&PL_sv_undef);
979 if (GvIO(PL_last_in_gv)) {
980 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
985 sv_setiv(sv, (IV)STATUS_CURRENT);
986 #ifdef COMPLEX_STATUS
987 SvUPGRADE(sv, SVt_PVLV);
988 LvTARGOFF(sv) = PL_statusvalue;
989 LvTARGLEN(sv) = PL_statusvalue_vms;
994 if (GvIOp(PL_defoutgv))
995 s = IoTOP_NAME(GvIOp(PL_defoutgv));
999 sv_setpv(sv,GvENAME(PL_defoutgv));
1000 sv_catpvs(sv,"_TOP");
1004 if (GvIOp(PL_defoutgv))
1005 s = IoFMT_NAME(GvIOp(PL_defoutgv));
1007 s = GvENAME(PL_defoutgv);
1011 if (GvIOp(PL_defoutgv))
1012 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
1015 if (GvIOp(PL_defoutgv))
1016 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
1019 if (GvIOp(PL_defoutgv))
1020 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
1027 sv_setiv(sv, (IV)CopARYBASE_get(PL_curcop));
1030 if (GvIOp(PL_defoutgv))
1031 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
1035 sv_copypv(sv, PL_ors_sv);
1039 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
1040 sv_setpv(sv, errno ? Strerror(errno) : "");
1044 sv_setnv(sv, (NV)errno);
1046 if (errno == errno_isOS2 || errno == errno_isOS2_set)
1047 sv_setpv(sv, os2error(Perl_rc));
1050 sv_setpv(sv, errno ? Strerror(errno) : "");
1055 SvNOK_on(sv); /* what a wonderful hack! */
1058 sv_setiv(sv, (IV)PL_uid);
1061 sv_setiv(sv, (IV)PL_euid);
1064 sv_setiv(sv, (IV)PL_gid);
1067 sv_setiv(sv, (IV)PL_egid);
1069 #ifdef HAS_GETGROUPS
1071 Groups_t *gary = NULL;
1072 I32 i, num_groups = getgroups(0, gary);
1073 Newx(gary, num_groups, Groups_t);
1074 num_groups = getgroups(num_groups, gary);
1075 for (i = 0; i < num_groups; i++)
1076 Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]);
1079 (void)SvIOK_on(sv); /* what a wonderful hack! */
1089 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
1091 struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
1093 PERL_ARGS_ASSERT_MAGIC_GETUVAR;
1095 if (uf && uf->uf_val)
1096 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
1101 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
1104 STRLEN len = 0, klen;
1105 const char *s = SvOK(sv) ? SvPV_const(sv,len) : "";
1106 const char * const ptr = MgPV_const(mg,klen);
1109 PERL_ARGS_ASSERT_MAGIC_SETENV;
1111 #ifdef DYNAMIC_ENV_FETCH
1112 /* We just undefd an environment var. Is a replacement */
1113 /* waiting in the wings? */
1115 SV ** const valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE);
1117 s = SvOK(*valp) ? SvPV_const(*valp, len) : "";
1121 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
1122 /* And you'll never guess what the dog had */
1123 /* in its mouth... */
1125 MgTAINTEDDIR_off(mg);
1127 if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
1128 char pathbuf[256], eltbuf[256], *cp, *elt;
1132 my_strlcpy(eltbuf, s, sizeof(eltbuf));
1134 do { /* DCL$PATH may be a search list */
1135 while (1) { /* as may dev portion of any element */
1136 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1137 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1138 cando_by_name(S_IWUSR,0,elt) ) {
1139 MgTAINTEDDIR_on(mg);
1143 if ((cp = strchr(elt, ':')) != NULL)
1145 if (my_trnlnm(elt, eltbuf, j++))
1151 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1154 if (s && klen == 4 && strEQ(ptr,"PATH")) {
1155 const char * const strend = s + len;
1157 while (s < strend) {
1161 #ifdef VMS /* Hmm. How do we get $Config{path_sep} from C? */
1162 const char path_sep = '|';
1164 const char path_sep = ':';
1166 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
1167 s, strend, path_sep, &i);
1169 if (i >= (I32)sizeof tmpbuf /* too long -- assume the worst */
1171 || !strchr(tmpbuf, ':') /* no colon thus no device name -- assume relative path */
1173 || *tmpbuf != '/' /* no starting slash -- assume relative path */
1175 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1176 MgTAINTEDDIR_on(mg);
1182 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1188 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1190 PERL_ARGS_ASSERT_MAGIC_CLEARENV;
1191 PERL_UNUSED_ARG(sv);
1192 my_setenv(MgPV_nolen_const(mg),NULL);
1197 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1200 PERL_ARGS_ASSERT_MAGIC_SET_ALL_ENV;
1201 PERL_UNUSED_ARG(mg);
1203 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1205 if (PL_localizing) {
1208 hv_iterinit(MUTABLE_HV(sv));
1209 while ((entry = hv_iternext(MUTABLE_HV(sv)))) {
1211 my_setenv(hv_iterkey(entry, &keylen),
1212 SvPV_nolen_const(hv_iterval(MUTABLE_HV(sv), entry)));
1220 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1223 PERL_ARGS_ASSERT_MAGIC_CLEAR_ALL_ENV;
1224 PERL_UNUSED_ARG(sv);
1225 PERL_UNUSED_ARG(mg);
1227 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1235 #ifdef HAS_SIGPROCMASK
1237 restore_sigmask(pTHX_ SV *save_sv)
1239 const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1240 (void)sigprocmask(SIG_SETMASK, ossetp, NULL);
1244 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1247 /* Are we fetching a signal entry? */
1248 int i = (I16)mg->mg_private;
1250 PERL_ARGS_ASSERT_MAGIC_GETSIG;
1253 mg->mg_private = i = whichsig(MgPV_nolen_const(mg));
1258 sv_setsv(sv,PL_psig_ptr[i]);
1260 Sighandler_t sigstate = rsignal_state(i);
1261 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1262 if (PL_sig_handlers_initted && PL_sig_ignoring[i])
1265 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1266 if (PL_sig_handlers_initted && PL_sig_defaulting[i])
1269 /* cache state so we don't fetch it again */
1270 if(sigstate == (Sighandler_t) SIG_IGN)
1271 sv_setpvs(sv,"IGNORE");
1273 sv_setsv(sv,&PL_sv_undef);
1274 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1281 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1283 PERL_ARGS_ASSERT_MAGIC_CLEARSIG;
1284 PERL_UNUSED_ARG(sv);
1286 magic_setsig(NULL, mg);
1287 return sv_unmagic(sv, mg->mg_type);
1291 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1292 Perl_csighandler(int sig, siginfo_t *sip PERL_UNUSED_DECL, void *uap PERL_UNUSED_DECL)
1294 Perl_csighandler(int sig)
1297 #ifdef PERL_GET_SIG_CONTEXT
1298 dTHXa(PERL_GET_SIG_CONTEXT);
1302 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1303 (void) rsignal(sig, PL_csighandlerp);
1304 if (PL_sig_ignoring[sig]) return;
1306 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1307 if (PL_sig_defaulting[sig])
1308 #ifdef KILL_BY_SIGPRC
1309 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1324 (PL_signals & PERL_SIGNALS_UNSAFE_FLAG))
1325 /* Call the perl level handler now--
1326 * with risk we may be in malloc() or being destructed etc. */
1327 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1328 (*PL_sighandlerp)(sig, NULL, NULL);
1330 (*PL_sighandlerp)(sig);
1333 if (!PL_psig_pend) return;
1334 /* Set a flag to say this signal is pending, that is awaiting delivery after
1335 * the current Perl opcode completes */
1336 PL_psig_pend[sig]++;
1338 #ifndef SIG_PENDING_DIE_COUNT
1339 # define SIG_PENDING_DIE_COUNT 120
1341 /* Add one to say _a_ signal is pending */
1342 if (++PL_sig_pending >= SIG_PENDING_DIE_COUNT)
1343 Perl_croak(aTHX_ "Maximal count of pending signals (%lu) exceeded",
1344 (unsigned long)SIG_PENDING_DIE_COUNT);
1348 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1350 Perl_csighandler_init(void)
1353 if (PL_sig_handlers_initted) return;
1355 for (sig = 1; sig < SIG_SIZE; sig++) {
1356 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1358 PL_sig_defaulting[sig] = 1;
1359 (void) rsignal(sig, PL_csighandlerp);
1361 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1362 PL_sig_ignoring[sig] = 0;
1365 PL_sig_handlers_initted = 1;
1370 Perl_despatch_signals(pTHX)
1375 for (sig = 1; sig < SIG_SIZE; sig++) {
1376 if (PL_psig_pend[sig]) {
1377 PERL_BLOCKSIG_ADD(set, sig);
1378 PL_psig_pend[sig] = 0;
1379 PERL_BLOCKSIG_BLOCK(set);
1380 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1381 (*PL_sighandlerp)(sig, NULL, NULL);
1383 (*PL_sighandlerp)(sig);
1385 PERL_BLOCKSIG_UNBLOCK(set);
1390 /* sv of NULL signifies that we're acting as magic_clearsig. */
1392 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1397 /* Need to be careful with SvREFCNT_dec(), because that can have side
1398 * effects (due to closures). We must make sure that the new disposition
1399 * is in place before it is called.
1403 #ifdef HAS_SIGPROCMASK
1407 register const char *s = MgPV_const(mg,len);
1409 PERL_ARGS_ASSERT_MAGIC_SETSIG;
1412 if (strEQ(s,"__DIE__"))
1414 else if (strEQ(s,"__WARN__")
1415 && (sv ? 1 : PL_warnhook != PERL_WARNHOOK_FATAL)) {
1416 /* Merge the existing behaviours, which are as follows:
1417 magic_setsig, we always set svp to &PL_warnhook
1418 (hence we always change the warnings handler)
1419 For magic_clearsig, we don't change the warnings handler if it's
1420 set to the &PL_warnhook. */
1423 Perl_croak(aTHX_ "No such hook: %s", s);
1426 if (*svp != PERL_WARNHOOK_FATAL)
1432 i = (I16)mg->mg_private;
1434 i = whichsig(s); /* ...no, a brick */
1435 mg->mg_private = (U16)i;
1439 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
1442 #ifdef HAS_SIGPROCMASK
1443 /* Avoid having the signal arrive at a bad time, if possible. */
1446 sigprocmask(SIG_BLOCK, &set, &save);
1448 save_sv = newSVpvn((char *)(&save), sizeof(sigset_t));
1449 SAVEFREESV(save_sv);
1450 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1453 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1454 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1456 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1457 PL_sig_ignoring[i] = 0;
1459 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1460 PL_sig_defaulting[i] = 0;
1462 to_dec = PL_psig_ptr[i];
1464 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1465 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1467 /* Signals don't change name during the program's execution, so once
1468 they're cached in the appropriate slot of PL_psig_name, they can
1471 Ideally we'd find some way of making SVs at (C) compile time, or
1472 at least, doing most of the work. */
1473 if (!PL_psig_name[i]) {
1474 PL_psig_name[i] = newSVpvn(s, len);
1475 SvREADONLY_on(PL_psig_name[i]);
1478 SvREFCNT_dec(PL_psig_name[i]);
1479 PL_psig_name[i] = NULL;
1480 PL_psig_ptr[i] = NULL;
1483 if (sv && (isGV_with_GP(sv) || SvROK(sv))) {
1485 (void)rsignal(i, PL_csighandlerp);
1488 *svp = SvREFCNT_inc_simple_NN(sv);
1490 if (sv && SvOK(sv)) {
1491 s = SvPV_force(sv, len);
1495 if (sv && strEQ(s,"IGNORE")) {
1497 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1498 PL_sig_ignoring[i] = 1;
1499 (void)rsignal(i, PL_csighandlerp);
1501 (void)rsignal(i, (Sighandler_t) SIG_IGN);
1505 else if (!sv || strEQ(s,"DEFAULT") || !len) {
1507 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1508 PL_sig_defaulting[i] = 1;
1509 (void)rsignal(i, PL_csighandlerp);
1511 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1517 * We should warn if HINT_STRICT_REFS, but without
1518 * access to a known hint bit in a known OP, we can't
1519 * tell whether HINT_STRICT_REFS is in force or not.
1521 if (!strchr(s,':') && !strchr(s,'\''))
1522 Perl_sv_insert_flags(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"),
1525 (void)rsignal(i, PL_csighandlerp);
1527 *svp = SvREFCNT_inc_simple_NN(sv);
1531 #ifdef HAS_SIGPROCMASK
1535 SvREFCNT_dec(to_dec);
1538 #endif /* !PERL_MICRO */
1541 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1544 PERL_ARGS_ASSERT_MAGIC_SETISA;
1545 PERL_UNUSED_ARG(sv);
1547 /* Skip _isaelem because _isa will handle it shortly */
1548 if (PL_delaymagic & DM_ARRAY && mg->mg_type == PERL_MAGIC_isaelem)
1551 return magic_clearisa(NULL, mg);
1554 /* sv of NULL signifies that we're acting as magic_setisa. */
1556 Perl_magic_clearisa(pTHX_ SV *sv, MAGIC *mg)
1561 PERL_ARGS_ASSERT_MAGIC_CLEARISA;
1563 /* Bail out if destruction is going on */
1564 if(PL_dirty) return 0;
1567 av_clear(MUTABLE_AV(sv));
1569 /* XXX Once it's possible, we need to
1570 detect that our @ISA is aliased in
1571 other stashes, and act on the stashes
1572 of all of the aliases */
1574 /* The first case occurs via setisa,
1575 the second via setisa_elem, which
1576 calls this same magic */
1578 SvTYPE(mg->mg_obj) == SVt_PVGV
1579 ? (const GV *)mg->mg_obj
1580 : (const GV *)mg_find(mg->mg_obj, PERL_MAGIC_isa)->mg_obj
1584 mro_isa_changed_in(stash);
1590 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
1593 PERL_ARGS_ASSERT_MAGIC_SETAMAGIC;
1594 PERL_UNUSED_ARG(sv);
1595 PERL_UNUSED_ARG(mg);
1596 PL_amagic_generation++;
1602 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1604 HV * const hv = MUTABLE_HV(LvTARG(sv));
1607 PERL_ARGS_ASSERT_MAGIC_GETNKEYS;
1608 PERL_UNUSED_ARG(mg);
1611 (void) hv_iterinit(hv);
1612 if (! SvTIED_mg((const SV *)hv, PERL_MAGIC_tied))
1615 while (hv_iternext(hv))
1620 sv_setiv(sv, (IV)i);
1625 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1627 PERL_ARGS_ASSERT_MAGIC_SETNKEYS;
1628 PERL_UNUSED_ARG(mg);
1630 hv_ksplit(MUTABLE_HV(LvTARG(sv)), SvIV(sv));
1635 /* caller is responsible for stack switching/cleanup */
1637 S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV *val)
1642 PERL_ARGS_ASSERT_MAGIC_METHCALL;
1646 PUSHs(SvTIED_obj(sv, mg));
1649 if (mg->mg_len >= 0)
1650 mPUSHp(mg->mg_ptr, mg->mg_len);
1651 else if (mg->mg_len == HEf_SVKEY)
1652 PUSHs(MUTABLE_SV(mg->mg_ptr));
1654 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1663 return call_method(meth, flags);
1667 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
1671 PERL_ARGS_ASSERT_MAGIC_METHPACK;
1675 PUSHSTACKi(PERLSI_MAGIC);
1677 if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
1678 sv_setsv(sv, *PL_stack_sp--);
1688 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1690 PERL_ARGS_ASSERT_MAGIC_GETPACK;
1693 mg->mg_flags |= MGf_GSKIP;
1694 magic_methpack(sv,mg,"FETCH");
1699 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1703 PERL_ARGS_ASSERT_MAGIC_SETPACK;
1706 PUSHSTACKi(PERLSI_MAGIC);
1707 magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
1714 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1716 PERL_ARGS_ASSERT_MAGIC_CLEARPACK;
1718 return magic_methpack(sv,mg,"DELETE");
1723 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1728 PERL_ARGS_ASSERT_MAGIC_SIZEPACK;
1732 PUSHSTACKi(PERLSI_MAGIC);
1733 if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
1734 sv = *PL_stack_sp--;
1735 retval = SvIV(sv)-1;
1737 Perl_croak(aTHX_ "FETCHSIZE returned a negative value");
1742 return (U32) retval;
1746 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1750 PERL_ARGS_ASSERT_MAGIC_WIPEPACK;
1753 PUSHSTACKi(PERLSI_MAGIC);
1755 XPUSHs(SvTIED_obj(sv, mg));
1757 call_method("CLEAR", G_SCALAR|G_DISCARD);
1765 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1768 const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
1770 PERL_ARGS_ASSERT_MAGIC_NEXTPACK;
1774 PUSHSTACKi(PERLSI_MAGIC);
1777 PUSHs(SvTIED_obj(sv, mg));
1782 if (call_method(meth, G_SCALAR))
1783 sv_setsv(key, *PL_stack_sp--);
1792 Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg)
1794 PERL_ARGS_ASSERT_MAGIC_EXISTSPACK;
1796 return magic_methpack(sv,mg,"EXISTS");
1800 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1804 SV * const tied = SvTIED_obj(MUTABLE_SV(hv), mg);
1805 HV * const pkg = SvSTASH((const SV *)SvRV(tied));
1807 PERL_ARGS_ASSERT_MAGIC_SCALARPACK;
1809 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1811 if (HvEITER_get(hv))
1812 /* we are in an iteration so the hash cannot be empty */
1814 /* no xhv_eiter so now use FIRSTKEY */
1815 key = sv_newmortal();
1816 magic_nextpack(MUTABLE_SV(hv), mg, key);
1817 HvEITER_set(hv, NULL); /* need to reset iterator */
1818 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1821 /* there is a SCALAR method that we can call */
1823 PUSHSTACKi(PERLSI_MAGIC);
1829 if (call_method("SCALAR", G_SCALAR))
1830 retval = *PL_stack_sp--;
1832 retval = &PL_sv_undef;
1839 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1842 GV * const gv = PL_DBline;
1843 const I32 i = SvTRUE(sv);
1844 SV ** const svp = av_fetch(GvAV(gv),
1845 atoi(MgPV_nolen_const(mg)), FALSE);
1847 PERL_ARGS_ASSERT_MAGIC_SETDBLINE;
1849 if (svp && SvIOKp(*svp)) {
1850 OP * const o = INT2PTR(OP*,SvIVX(*svp));
1852 /* set or clear breakpoint in the relevant control op */
1854 o->op_flags |= OPf_SPECIAL;
1856 o->op_flags &= ~OPf_SPECIAL;
1863 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
1866 AV * const obj = MUTABLE_AV(mg->mg_obj);
1868 PERL_ARGS_ASSERT_MAGIC_GETARYLEN;
1871 sv_setiv(sv, AvFILL(obj) + CopARYBASE_get(PL_curcop));
1879 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
1882 AV * const obj = MUTABLE_AV(mg->mg_obj);
1884 PERL_ARGS_ASSERT_MAGIC_SETARYLEN;
1887 av_fill(obj, SvIV(sv) - CopARYBASE_get(PL_curcop));
1889 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
1890 "Attempt to set length of freed array");
1896 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
1900 PERL_ARGS_ASSERT_MAGIC_FREEARYLEN_P;
1901 PERL_UNUSED_ARG(sv);
1903 /* during global destruction, mg_obj may already have been freed */
1904 if (PL_in_clean_all)
1907 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
1910 /* arylen scalar holds a pointer back to the array, but doesn't own a
1911 reference. Hence the we (the array) are about to go away with it
1912 still pointing at us. Clear its pointer, else it would be pointing
1913 at free memory. See the comment in sv_magic about reference loops,
1914 and why it can't own a reference to us. */
1921 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
1924 SV* const lsv = LvTARG(sv);
1926 PERL_ARGS_ASSERT_MAGIC_GETPOS;
1927 PERL_UNUSED_ARG(mg);
1929 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1930 MAGIC * const found = mg_find(lsv, PERL_MAGIC_regex_global);
1931 if (found && found->mg_len >= 0) {
1932 I32 i = found->mg_len;
1934 sv_pos_b2u(lsv, &i);
1935 sv_setiv(sv, i + CopARYBASE_get(PL_curcop));
1944 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
1947 SV* const lsv = LvTARG(sv);
1953 PERL_ARGS_ASSERT_MAGIC_SETPOS;
1954 PERL_UNUSED_ARG(mg);
1956 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
1957 found = mg_find(lsv, PERL_MAGIC_regex_global);
1963 #ifdef PERL_OLD_COPY_ON_WRITE
1965 sv_force_normal_flags(lsv, 0);
1967 found = sv_magicext(lsv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
1970 else if (!SvOK(sv)) {
1974 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1976 pos = SvIV(sv) - CopARYBASE_get(PL_curcop);
1979 ulen = sv_len_utf8(lsv);
1989 else if (pos > (SSize_t)len)
1994 sv_pos_u2b(lsv, &p, 0);
1998 found->mg_len = pos;
1999 found->mg_flags &= ~MGf_MINMATCH;
2005 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
2008 SV * const lsv = LvTARG(sv);
2009 const char * const tmps = SvPV_const(lsv,len);
2010 I32 offs = LvTARGOFF(sv);
2011 I32 rem = LvTARGLEN(sv);
2013 PERL_ARGS_ASSERT_MAGIC_GETSUBSTR;
2014 PERL_UNUSED_ARG(mg);
2017 sv_pos_u2b(lsv, &offs, &rem);
2018 if (offs > (I32)len)
2020 if (rem + offs > (I32)len)
2022 sv_setpvn(sv, tmps + offs, (STRLEN)rem);
2029 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
2033 const char * const tmps = SvPV_const(sv, len);
2034 SV * const lsv = LvTARG(sv);
2035 I32 lvoff = LvTARGOFF(sv);
2036 I32 lvlen = LvTARGLEN(sv);
2038 PERL_ARGS_ASSERT_MAGIC_SETSUBSTR;
2039 PERL_UNUSED_ARG(mg);
2042 sv_utf8_upgrade(lsv);
2043 sv_pos_u2b(lsv, &lvoff, &lvlen);
2044 sv_insert(lsv, lvoff, lvlen, tmps, len);
2045 LvTARGLEN(sv) = sv_len_utf8(sv);
2048 else if (lsv && SvUTF8(lsv)) {
2050 sv_pos_u2b(lsv, &lvoff, &lvlen);
2051 LvTARGLEN(sv) = len;
2052 utf8 = (char*)bytes_to_utf8((U8*)tmps, &len);
2053 sv_insert(lsv, lvoff, lvlen, utf8, len);
2057 sv_insert(lsv, lvoff, lvlen, tmps, len);
2058 LvTARGLEN(sv) = len;
2066 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
2070 PERL_ARGS_ASSERT_MAGIC_GETTAINT;
2071 PERL_UNUSED_ARG(sv);
2073 TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
2078 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
2082 PERL_ARGS_ASSERT_MAGIC_SETTAINT;
2083 PERL_UNUSED_ARG(sv);
2085 /* update taint status */
2094 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
2096 SV * const lsv = LvTARG(sv);
2098 PERL_ARGS_ASSERT_MAGIC_GETVEC;
2099 PERL_UNUSED_ARG(mg);
2102 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
2110 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
2112 PERL_ARGS_ASSERT_MAGIC_SETVEC;
2113 PERL_UNUSED_ARG(mg);
2114 do_vecset(sv); /* XXX slurp this routine */
2119 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
2124 PERL_ARGS_ASSERT_MAGIC_GETDEFELEM;
2126 if (LvTARGLEN(sv)) {
2128 SV * const ahv = LvTARG(sv);
2129 HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, FALSE, 0);
2134 AV *const av = MUTABLE_AV(LvTARG(sv));
2135 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
2136 targ = AvARRAY(av)[LvTARGOFF(sv)];
2138 if (targ && (targ != &PL_sv_undef)) {
2139 /* somebody else defined it for us */
2140 SvREFCNT_dec(LvTARG(sv));
2141 LvTARG(sv) = SvREFCNT_inc_simple_NN(targ);
2143 SvREFCNT_dec(mg->mg_obj);
2145 mg->mg_flags &= ~MGf_REFCOUNTED;
2150 sv_setsv(sv, targ ? targ : &PL_sv_undef);
2155 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
2157 PERL_ARGS_ASSERT_MAGIC_SETDEFELEM;
2158 PERL_UNUSED_ARG(mg);
2162 sv_setsv(LvTARG(sv), sv);
2163 SvSETMAGIC(LvTARG(sv));
2169 Perl_vivify_defelem(pTHX_ SV *sv)
2175 PERL_ARGS_ASSERT_VIVIFY_DEFELEM;
2177 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2180 SV * const ahv = LvTARG(sv);
2181 HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, TRUE, 0);
2184 if (!value || value == &PL_sv_undef)
2185 Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(mg->mg_obj));
2188 AV *const av = MUTABLE_AV(LvTARG(sv));
2189 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
2190 LvTARG(sv) = NULL; /* array can't be extended */
2192 SV* const * const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
2193 if (!svp || (value = *svp) == &PL_sv_undef)
2194 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
2197 SvREFCNT_inc_simple_void(value);
2198 SvREFCNT_dec(LvTARG(sv));
2201 SvREFCNT_dec(mg->mg_obj);
2203 mg->mg_flags &= ~MGf_REFCOUNTED;
2207 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2209 PERL_ARGS_ASSERT_MAGIC_KILLBACKREFS;
2210 return Perl_sv_kill_backrefs(aTHX_ sv, MUTABLE_AV(mg->mg_obj));
2214 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2216 PERL_ARGS_ASSERT_MAGIC_SETMGLOB;
2217 PERL_UNUSED_CONTEXT;
2224 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2226 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2228 PERL_ARGS_ASSERT_MAGIC_SETUVAR;
2230 if (uf && uf->uf_set)
2231 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2236 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2238 const char type = mg->mg_type;
2240 PERL_ARGS_ASSERT_MAGIC_SETREGEXP;
2242 if (type == PERL_MAGIC_qr) {
2243 } else if (type == PERL_MAGIC_bm) {
2247 assert(type == PERL_MAGIC_fm);
2250 return sv_unmagic(sv, type);
2253 #ifdef USE_LOCALE_COLLATE
2255 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2257 PERL_ARGS_ASSERT_MAGIC_SETCOLLXFRM;
2260 * RenE<eacute> Descartes said "I think not."
2261 * and vanished with a faint plop.
2263 PERL_UNUSED_CONTEXT;
2264 PERL_UNUSED_ARG(sv);
2266 Safefree(mg->mg_ptr);
2272 #endif /* USE_LOCALE_COLLATE */
2274 /* Just clear the UTF-8 cache data. */
2276 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2278 PERL_ARGS_ASSERT_MAGIC_SETUTF8;
2279 PERL_UNUSED_CONTEXT;
2280 PERL_UNUSED_ARG(sv);
2281 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2283 mg->mg_len = -1; /* The mg_len holds the len cache. */
2288 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2291 register const char *s;
2293 register const REGEXP * rx;
2294 const char * const remaining = mg->mg_ptr + 1;
2298 PERL_ARGS_ASSERT_MAGIC_SET;
2300 switch (*mg->mg_ptr) {
2301 case '\015': /* $^MATCH */
2302 if (strEQ(remaining, "ATCH"))
2304 case '`': /* ${^PREMATCH} caught below */
2306 paren = RX_BUFF_IDX_PREMATCH;
2308 case '\'': /* ${^POSTMATCH} caught below */
2310 paren = RX_BUFF_IDX_POSTMATCH;
2314 paren = RX_BUFF_IDX_FULLMATCH;
2316 case '1': case '2': case '3': case '4':
2317 case '5': case '6': case '7': case '8': case '9':
2318 paren = atoi(mg->mg_ptr);
2320 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
2321 CALLREG_NUMBUF_STORE((REGEXP * const)rx,paren,sv);
2324 /* Croak with a READONLY error when a numbered match var is
2325 * set without a previous pattern match. Unless it's C<local $1>
2327 if (!PL_localizing) {
2328 Perl_croak(aTHX_ "%s", PL_no_modify);
2331 case '\001': /* ^A */
2332 sv_setsv(PL_bodytarget, sv);
2334 case '\003': /* ^C */
2335 PL_minus_c = (bool)SvIV(sv);
2338 case '\004': /* ^D */
2340 s = SvPV_nolen_const(sv);
2341 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2342 if (DEBUG_x_TEST || DEBUG_B_TEST)
2343 dump_all_perl(!DEBUG_B_TEST);
2345 PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG;
2348 case '\005': /* ^E */
2349 if (*(mg->mg_ptr+1) == '\0') {
2351 set_vaxc_errno(SvIV(sv));
2354 SetLastError( SvIV(sv) );
2357 os2_setsyserrno(SvIV(sv));
2359 /* will anyone ever use this? */
2360 SETERRNO(SvIV(sv), 4);
2365 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2366 SvREFCNT_dec(PL_encoding);
2367 if (SvOK(sv) || SvGMAGICAL(sv)) {
2368 PL_encoding = newSVsv(sv);
2375 case '\006': /* ^F */
2376 PL_maxsysfd = SvIV(sv);
2378 case '\010': /* ^H */
2379 PL_hints = SvIV(sv);
2381 case '\011': /* ^I */ /* NOT \t in EBCDIC */
2382 Safefree(PL_inplace);
2383 PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
2385 case '\017': /* ^O */
2386 if (*(mg->mg_ptr+1) == '\0') {
2387 Safefree(PL_osname);
2390 TAINT_PROPER("assigning to $^O");
2391 PL_osname = savesvpv(sv);
2394 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2396 const char *const start = SvPV(sv, len);
2397 const char *out = (const char*)memchr(start, '\0', len);
2401 PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2402 PL_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2404 /* Opening for input is more common than opening for output, so
2405 ensure that hints for input are sooner on linked list. */
2406 tmp = out ? newSVpvn_flags(out + 1, start + len - out - 1,
2408 : newSVpvs_flags("", SvUTF8(sv));
2409 (void)hv_stores(GvHV(PL_hintgv), "open>", tmp);
2412 tmp = newSVpvn_flags(start, out ? (STRLEN)(out - start) : len,
2414 (void)hv_stores(GvHV(PL_hintgv), "open<", tmp);
2418 case '\020': /* ^P */
2419 if (*remaining == '\0') { /* ^P */
2420 PL_perldb = SvIV(sv);
2421 if (PL_perldb && !PL_DBsingle)
2424 } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
2426 } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
2429 case '\024': /* ^T */
2431 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2433 PL_basetime = (Time_t)SvIV(sv);
2436 case '\025': /* ^UTF8CACHE */
2437 if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
2438 PL_utf8cache = (signed char) sv_2iv(sv);
2441 case '\027': /* ^W & $^WARNING_BITS */
2442 if (*(mg->mg_ptr+1) == '\0') {
2443 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2445 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2446 | (i ? G_WARN_ON : G_WARN_OFF) ;
2449 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2450 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2451 if (!SvPOK(sv) && PL_localizing) {
2452 sv_setpvn(sv, WARN_NONEstring, WARNsize);
2453 PL_compiling.cop_warnings = pWARN_NONE;
2458 int accumulate = 0 ;
2459 int any_fatals = 0 ;
2460 const char * const ptr = SvPV_const(sv, len) ;
2461 for (i = 0 ; i < len ; ++i) {
2462 accumulate |= ptr[i] ;
2463 any_fatals |= (ptr[i] & 0xAA) ;
2466 if (!specialWARN(PL_compiling.cop_warnings))
2467 PerlMemShared_free(PL_compiling.cop_warnings);
2468 PL_compiling.cop_warnings = pWARN_NONE;
2470 /* Yuck. I can't see how to abstract this: */
2471 else if (isWARN_on(((STRLEN *)SvPV_nolen_const(sv)) - 1,
2472 WARN_ALL) && !any_fatals) {
2473 if (!specialWARN(PL_compiling.cop_warnings))
2474 PerlMemShared_free(PL_compiling.cop_warnings);
2475 PL_compiling.cop_warnings = pWARN_ALL;
2476 PL_dowarn |= G_WARN_ONCE ;
2480 const char *const p = SvPV_const(sv, len);
2482 PL_compiling.cop_warnings
2483 = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
2486 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2487 PL_dowarn |= G_WARN_ONCE ;
2495 if (PL_localizing) {
2496 if (PL_localizing == 1)
2497 SAVESPTR(PL_last_in_gv);
2499 else if (SvOK(sv) && GvIO(PL_last_in_gv))
2500 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2503 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2504 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2505 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2508 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2509 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2510 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2513 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
2516 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
2517 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2518 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2521 IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
2525 IO * const io = GvIOp(PL_defoutgv);
2528 if ((SvIV(sv)) == 0)
2529 IoFLAGS(io) &= ~IOf_FLUSH;
2531 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2532 PerlIO *ofp = IoOFP(io);
2534 (void)PerlIO_flush(ofp);
2535 IoFLAGS(io) |= IOf_FLUSH;
2541 SvREFCNT_dec(PL_rs);
2542 PL_rs = newSVsv(sv);
2545 SvREFCNT_dec(PL_ors_sv);
2546 if (SvOK(sv) || SvGMAGICAL(sv)) {
2547 PL_ors_sv = newSVsv(sv);
2554 CopARYBASE_set(&PL_compiling, SvIV(sv));
2557 #ifdef COMPLEX_STATUS
2558 if (PL_localizing == 2) {
2559 SvUPGRADE(sv, SVt_PVLV);
2560 PL_statusvalue = LvTARGOFF(sv);
2561 PL_statusvalue_vms = LvTARGLEN(sv);
2565 #ifdef VMSISH_STATUS
2567 STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2570 STATUS_UNIX_EXIT_SET(SvIV(sv));
2575 # define PERL_VMS_BANG vaxc$errno
2577 # define PERL_VMS_BANG 0
2579 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2580 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2585 if (PL_delaymagic) {
2586 PL_delaymagic |= DM_RUID;
2587 break; /* don't do magic till later */
2590 (void)setruid((Uid_t)PL_uid);
2593 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2595 #ifdef HAS_SETRESUID
2596 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2598 if (PL_uid == PL_euid) { /* special case $< = $> */
2600 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2601 if (PL_uid != 0 && PerlProc_getuid() == 0)
2602 (void)PerlProc_setuid(0);
2604 (void)PerlProc_setuid(PL_uid);
2606 PL_uid = PerlProc_getuid();
2607 Perl_croak(aTHX_ "setruid() not implemented");
2612 PL_uid = PerlProc_getuid();
2613 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2617 if (PL_delaymagic) {
2618 PL_delaymagic |= DM_EUID;
2619 break; /* don't do magic till later */
2622 (void)seteuid((Uid_t)PL_euid);
2625 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2627 #ifdef HAS_SETRESUID
2628 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2630 if (PL_euid == PL_uid) /* special case $> = $< */
2631 PerlProc_setuid(PL_euid);
2633 PL_euid = PerlProc_geteuid();
2634 Perl_croak(aTHX_ "seteuid() not implemented");
2639 PL_euid = PerlProc_geteuid();
2640 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2644 if (PL_delaymagic) {
2645 PL_delaymagic |= DM_RGID;
2646 break; /* don't do magic till later */
2649 (void)setrgid((Gid_t)PL_gid);
2652 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2654 #ifdef HAS_SETRESGID
2655 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2657 if (PL_gid == PL_egid) /* special case $( = $) */
2658 (void)PerlProc_setgid(PL_gid);
2660 PL_gid = PerlProc_getgid();
2661 Perl_croak(aTHX_ "setrgid() not implemented");
2666 PL_gid = PerlProc_getgid();
2667 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2670 #ifdef HAS_SETGROUPS
2672 const char *p = SvPV_const(sv, len);
2673 Groups_t *gary = NULL;
2674 #ifdef _SC_NGROUPS_MAX
2675 int maxgrp = sysconf(_SC_NGROUPS_MAX);
2680 int maxgrp = NGROUPS;
2686 for (i = 0; i < maxgrp; ++i) {
2687 while (*p && !isSPACE(*p))
2694 Newx(gary, i + 1, Groups_t);
2696 Renew(gary, i + 1, Groups_t);
2700 (void)setgroups(i, gary);
2703 #else /* HAS_SETGROUPS */
2705 #endif /* HAS_SETGROUPS */
2706 if (PL_delaymagic) {
2707 PL_delaymagic |= DM_EGID;
2708 break; /* don't do magic till later */
2711 (void)setegid((Gid_t)PL_egid);
2714 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2716 #ifdef HAS_SETRESGID
2717 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2719 if (PL_egid == PL_gid) /* special case $) = $( */
2720 (void)PerlProc_setgid(PL_egid);
2722 PL_egid = PerlProc_getegid();
2723 Perl_croak(aTHX_ "setegid() not implemented");
2728 PL_egid = PerlProc_getegid();
2729 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2732 PL_chopset = SvPV_force(sv,len);
2735 LOCK_DOLLARZERO_MUTEX;
2736 #ifdef HAS_SETPROCTITLE
2737 /* The BSDs don't show the argv[] in ps(1) output, they
2738 * show a string from the process struct and provide
2739 * the setproctitle() routine to manipulate that. */
2740 if (PL_origalen != 1) {
2741 s = SvPV_const(sv, len);
2742 # if __FreeBSD_version > 410001
2743 /* The leading "-" removes the "perl: " prefix,
2744 * but not the "(perl) suffix from the ps(1)
2745 * output, because that's what ps(1) shows if the
2746 * argv[] is modified. */
2747 setproctitle("-%s", s);
2748 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2749 /* This doesn't really work if you assume that
2750 * $0 = 'foobar'; will wipe out 'perl' from the $0
2751 * because in ps(1) output the result will be like
2752 * sprintf("perl: %s (perl)", s)
2753 * I guess this is a security feature:
2754 * one (a user process) cannot get rid of the original name.
2756 setproctitle("%s", s);
2759 #elif defined(__hpux) && defined(PSTAT_SETCMD)
2760 if (PL_origalen != 1) {
2762 s = SvPV_const(sv, len);
2763 un.pst_command = (char *)s;
2764 pstat(PSTAT_SETCMD, un, len, 0, 0);
2767 if (PL_origalen > 1) {
2768 /* PL_origalen is set in perl_parse(). */
2769 s = SvPV_force(sv,len);
2770 if (len >= (STRLEN)PL_origalen-1) {
2771 /* Longer than original, will be truncated. We assume that
2772 * PL_origalen bytes are available. */
2773 Copy(s, PL_origargv[0], PL_origalen-1, char);
2776 /* Shorter than original, will be padded. */
2778 /* Special case for Mac OS X: see [perl #38868] */
2781 /* Is the space counterintuitive? Yes.
2782 * (You were expecting \0?)
2783 * Does it work? Seems to. (In Linux 2.4.20 at least.)
2785 const int pad = ' ';
2787 Copy(s, PL_origargv[0], len, char);
2788 PL_origargv[0][len] = 0;
2789 memset(PL_origargv[0] + len + 1,
2790 pad, PL_origalen - len - 1);
2792 PL_origargv[0][PL_origalen-1] = 0;
2793 for (i = 1; i < PL_origargc; i++)
2797 UNLOCK_DOLLARZERO_MUTEX;
2804 Perl_whichsig(pTHX_ const char *sig)
2806 register char* const* sigv;
2808 PERL_ARGS_ASSERT_WHICHSIG;
2809 PERL_UNUSED_CONTEXT;
2811 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
2812 if (strEQ(sig,*sigv))
2813 return PL_sig_num[sigv - (char* const*)PL_sig_name];
2815 if (strEQ(sig,"CHLD"))
2819 if (strEQ(sig,"CLD"))
2826 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2827 Perl_sighandler(int sig, siginfo_t *sip, void *uap PERL_UNUSED_DECL)
2829 Perl_sighandler(int sig)
2832 #ifdef PERL_GET_SIG_CONTEXT
2833 dTHXa(PERL_GET_SIG_CONTEXT);
2840 SV * const tSv = PL_Sv;
2844 XPV * const tXpv = PL_Xpv;
2846 if (PL_savestack_ix + 15 <= PL_savestack_max)
2848 if (PL_markstack_ptr < PL_markstack_max - 2)
2850 if (PL_scopestack_ix < PL_scopestack_max - 3)
2853 if (!PL_psig_ptr[sig]) {
2854 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2859 /* Max number of items pushed there is 3*n or 4. We cannot fix
2860 infinity, so we fix 4 (in fact 5): */
2862 PL_savestack_ix += 5; /* Protect save in progress. */
2863 SAVEDESTRUCTOR_X(S_unwind_handler_stack, (void*)&flags);
2866 PL_markstack_ptr++; /* Protect mark. */
2868 PL_scopestack_ix += 1;
2869 /* sv_2cv is too complicated, try a simpler variant first: */
2870 if (!SvROK(PL_psig_ptr[sig]) || !(cv = MUTABLE_CV(SvRV(PL_psig_ptr[sig])))
2871 || SvTYPE(cv) != SVt_PVCV) {
2873 cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
2876 if (!cv || !CvROOT(cv)) {
2877 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2878 PL_sig_name[sig], (gv ? GvENAME(gv)
2885 if(PL_psig_name[sig]) {
2886 sv = SvREFCNT_inc_NN(PL_psig_name[sig]);
2888 #if !defined(PERL_IMPLICIT_CONTEXT)
2892 sv = sv_newmortal();
2893 sv_setpv(sv,PL_sig_name[sig]);
2896 PUSHSTACKi(PERLSI_SIGNAL);
2899 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2901 struct sigaction oact;
2903 if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
2906 SV *rv = newRV_noinc(MUTABLE_SV(sih));
2907 /* The siginfo fields signo, code, errno, pid, uid,
2908 * addr, status, and band are defined by POSIX/SUSv3. */
2909 (void)hv_stores(sih, "signo", newSViv(sip->si_signo));
2910 (void)hv_stores(sih, "code", newSViv(sip->si_code));
2911 #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. */
2912 hv_stores(sih, "errno", newSViv(sip->si_errno));
2913 hv_stores(sih, "status", newSViv(sip->si_status));
2914 hv_stores(sih, "uid", newSViv(sip->si_uid));
2915 hv_stores(sih, "pid", newSViv(sip->si_pid));
2916 hv_stores(sih, "addr", newSVuv(PTR2UV(sip->si_addr)));
2917 hv_stores(sih, "band", newSViv(sip->si_band));
2921 mPUSHp((char *)sip, sizeof(*sip));
2929 call_sv(MUTABLE_SV(cv), G_DISCARD|G_EVAL);
2932 if (SvTRUE(ERRSV)) {
2934 #ifdef HAS_SIGPROCMASK
2935 /* Handler "died", for example to get out of a restart-able read().
2936 * Before we re-do that on its behalf re-enable the signal which was
2937 * blocked by the system when we entered.
2941 sigaddset(&set,sig);
2942 sigprocmask(SIG_UNBLOCK, &set, NULL);
2944 /* Not clear if this will work */
2945 (void)rsignal(sig, SIG_IGN);
2946 (void)rsignal(sig, PL_csighandlerp);
2948 #endif /* !PERL_MICRO */
2949 Perl_die(aTHX_ NULL);
2953 PL_savestack_ix -= 8; /* Unprotect save in progress. */
2957 PL_scopestack_ix -= 1;
2960 PL_op = myop; /* Apparently not needed... */
2962 PL_Sv = tSv; /* Restore global temporaries. */
2969 S_restore_magic(pTHX_ const void *p)
2972 MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
2973 SV* const sv = mgs->mgs_sv;
2978 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2980 #ifdef PERL_OLD_COPY_ON_WRITE
2981 /* While magic was saved (and off) sv_setsv may well have seen
2982 this SV as a prime candidate for COW. */
2984 sv_force_normal_flags(sv, 0);
2987 if (mgs->mgs_readonly)
2989 if (mgs->mgs_magical)
2990 SvFLAGS(sv) |= mgs->mgs_magical;
2993 if (SvGMAGICAL(sv)) {
2994 /* downgrade public flags to private,
2995 and discard any other private flags */
2997 const U32 pubflags = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
2999 SvFLAGS(sv) &= ~( pubflags | (SVp_IOK|SVp_NOK|SVp_POK) );
3000 SvFLAGS(sv) |= ( pubflags << PRIVSHIFT );
3005 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
3007 /* If we're still on top of the stack, pop us off. (That condition
3008 * will be satisfied if restore_magic was called explicitly, but *not*
3009 * if it's being called via leave_scope.)
3010 * The reason for doing this is that otherwise, things like sv_2cv()
3011 * may leave alloc gunk on the savestack, and some code
3012 * (e.g. sighandler) doesn't expect that...
3014 if (PL_savestack_ix == mgs->mgs_ss_ix)
3016 I32 popval = SSPOPINT;
3017 assert(popval == SAVEt_DESTRUCTOR_X);
3018 PL_savestack_ix -= 2;
3020 assert(popval == SAVEt_ALLOC);
3022 PL_savestack_ix -= popval;
3028 S_unwind_handler_stack(pTHX_ const void *p)
3031 const U32 flags = *(const U32*)p;
3033 PERL_ARGS_ASSERT_UNWIND_HANDLER_STACK;
3036 PL_savestack_ix -= 5; /* Unprotect save in progress. */
3037 #if !defined(PERL_IMPLICIT_CONTEXT)
3039 SvREFCNT_dec(PL_sig_sv);
3044 =for apidoc magic_sethint
3046 Triggered by a store to %^H, records the key/value pair to
3047 C<PL_compiling.cop_hints_hash>. It is assumed that hints aren't storing
3048 anything that would need a deep copy. Maybe we should warn if we find a
3054 Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
3057 SV *key = (mg->mg_len == HEf_SVKEY) ? MUTABLE_SV(mg->mg_ptr)
3058 : newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
3060 PERL_ARGS_ASSERT_MAGIC_SETHINT;
3062 /* mg->mg_obj isn't being used. If needed, it would be possible to store
3063 an alternative leaf in there, with PL_compiling.cop_hints being used if
3064 it's NULL. If needed for threads, the alternative could lock a mutex,
3065 or take other more complex action. */
3067 /* Something changed in %^H, so it will need to be restored on scope exit.
3068 Doing this here saves a lot of doing it manually in perl code (and
3069 forgetting to do it, and consequent subtle errors. */
3070 PL_hints |= HINT_LOCALIZE_HH;
3071 PL_compiling.cop_hints_hash
3072 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash, key, sv);
3077 =for apidoc magic_clearhint
3079 Triggered by a delete from %^H, records the key to
3080 C<PL_compiling.cop_hints_hash>.
3085 Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
3089 PERL_ARGS_ASSERT_MAGIC_CLEARHINT;
3090 PERL_UNUSED_ARG(sv);
3092 assert(mg->mg_len == HEf_SVKEY);
3094 PERL_UNUSED_ARG(sv);
3096 PL_hints |= HINT_LOCALIZE_HH;
3097 PL_compiling.cop_hints_hash
3098 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
3099 MUTABLE_SV(mg->mg_ptr), &PL_sv_placeholder);
3104 =for apidoc magic_clearhints
3106 Triggered by clearing %^H, resets C<PL_compiling.cop_hints_hash>.
3111 Perl_magic_clearhints(pTHX_ SV *sv, MAGIC *mg)
3113 PERL_ARGS_ASSERT_MAGIC_CLEARHINTS;
3114 PERL_UNUSED_ARG(sv);
3115 PERL_UNUSED_ARG(mg);
3116 if (PL_compiling.cop_hints_hash) {
3117 Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
3118 PL_compiling.cop_hints_hash = NULL;
3125 * c-indentation-style: bsd
3127 * indent-tabs-mode: t
3130 * ex: set ts=8 sts=4 sw=4 noet: