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 (!isGV_with_GP(PL_defoutgv))
996 else if (GvIOp(PL_defoutgv))
997 s = IoTOP_NAME(GvIOp(PL_defoutgv));
1001 sv_setpv(sv,GvENAME(PL_defoutgv));
1002 sv_catpvs(sv,"_TOP");
1006 if (!isGV_with_GP(PL_defoutgv))
1008 else if (GvIOp(PL_defoutgv))
1009 s = IoFMT_NAME(GvIOp(PL_defoutgv));
1011 s = GvENAME(PL_defoutgv);
1015 if (GvIO(PL_defoutgv))
1016 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
1019 if (GvIO(PL_defoutgv))
1020 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
1023 if (GvIO(PL_defoutgv))
1024 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
1031 sv_setiv(sv, (IV)CopARYBASE_get(PL_curcop));
1034 if (GvIO(PL_defoutgv))
1035 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
1039 sv_copypv(sv, PL_ors_sv);
1045 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
1047 sv_setnv(sv, (NV)errno);
1050 if (errno == errno_isOS2 || errno == errno_isOS2_set)
1051 sv_setpv(sv, os2error(Perl_rc));
1054 sv_setpv(sv, errno ? Strerror(errno) : "");
1056 SvPOK_on(sv); /* may have got removed during taint processing */
1061 SvNOK_on(sv); /* what a wonderful hack! */
1064 sv_setiv(sv, (IV)PL_uid);
1067 sv_setiv(sv, (IV)PL_euid);
1070 sv_setiv(sv, (IV)PL_gid);
1073 sv_setiv(sv, (IV)PL_egid);
1075 #ifdef HAS_GETGROUPS
1077 Groups_t *gary = NULL;
1078 I32 i, num_groups = getgroups(0, gary);
1079 Newx(gary, num_groups, Groups_t);
1080 num_groups = getgroups(num_groups, gary);
1081 for (i = 0; i < num_groups; i++)
1082 Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]);
1085 (void)SvIOK_on(sv); /* what a wonderful hack! */
1095 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
1097 struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
1099 PERL_ARGS_ASSERT_MAGIC_GETUVAR;
1101 if (uf && uf->uf_val)
1102 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
1107 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
1110 STRLEN len = 0, klen;
1111 const char *s = SvOK(sv) ? SvPV_const(sv,len) : "";
1112 const char * const ptr = MgPV_const(mg,klen);
1115 PERL_ARGS_ASSERT_MAGIC_SETENV;
1117 #ifdef DYNAMIC_ENV_FETCH
1118 /* We just undefd an environment var. Is a replacement */
1119 /* waiting in the wings? */
1121 SV ** const valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE);
1123 s = SvOK(*valp) ? SvPV_const(*valp, len) : "";
1127 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
1128 /* And you'll never guess what the dog had */
1129 /* in its mouth... */
1131 MgTAINTEDDIR_off(mg);
1133 if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
1134 char pathbuf[256], eltbuf[256], *cp, *elt;
1138 my_strlcpy(eltbuf, s, sizeof(eltbuf));
1140 do { /* DCL$PATH may be a search list */
1141 while (1) { /* as may dev portion of any element */
1142 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1143 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1144 cando_by_name(S_IWUSR,0,elt) ) {
1145 MgTAINTEDDIR_on(mg);
1149 if ((cp = strchr(elt, ':')) != NULL)
1151 if (my_trnlnm(elt, eltbuf, j++))
1157 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1160 if (s && klen == 4 && strEQ(ptr,"PATH")) {
1161 const char * const strend = s + len;
1163 while (s < strend) {
1167 #ifdef VMS /* Hmm. How do we get $Config{path_sep} from C? */
1168 const char path_sep = '|';
1170 const char path_sep = ':';
1172 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
1173 s, strend, path_sep, &i);
1175 if (i >= (I32)sizeof tmpbuf /* too long -- assume the worst */
1177 || !strchr(tmpbuf, ':') /* no colon thus no device name -- assume relative path */
1179 || *tmpbuf != '/' /* no starting slash -- assume relative path */
1181 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1182 MgTAINTEDDIR_on(mg);
1188 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1194 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1196 PERL_ARGS_ASSERT_MAGIC_CLEARENV;
1197 PERL_UNUSED_ARG(sv);
1198 my_setenv(MgPV_nolen_const(mg),NULL);
1203 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1206 PERL_ARGS_ASSERT_MAGIC_SET_ALL_ENV;
1207 PERL_UNUSED_ARG(mg);
1209 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1211 if (PL_localizing) {
1214 hv_iterinit(MUTABLE_HV(sv));
1215 while ((entry = hv_iternext(MUTABLE_HV(sv)))) {
1217 my_setenv(hv_iterkey(entry, &keylen),
1218 SvPV_nolen_const(hv_iterval(MUTABLE_HV(sv), entry)));
1226 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1229 PERL_ARGS_ASSERT_MAGIC_CLEAR_ALL_ENV;
1230 PERL_UNUSED_ARG(sv);
1231 PERL_UNUSED_ARG(mg);
1233 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1241 #ifdef HAS_SIGPROCMASK
1243 restore_sigmask(pTHX_ SV *save_sv)
1245 const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1246 (void)sigprocmask(SIG_SETMASK, ossetp, NULL);
1250 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1253 /* Are we fetching a signal entry? */
1254 int i = (I16)mg->mg_private;
1256 PERL_ARGS_ASSERT_MAGIC_GETSIG;
1259 mg->mg_private = i = whichsig(MgPV_nolen_const(mg));
1264 sv_setsv(sv,PL_psig_ptr[i]);
1266 Sighandler_t sigstate = rsignal_state(i);
1267 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1268 if (PL_sig_handlers_initted && PL_sig_ignoring[i])
1271 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1272 if (PL_sig_handlers_initted && PL_sig_defaulting[i])
1275 /* cache state so we don't fetch it again */
1276 if(sigstate == (Sighandler_t) SIG_IGN)
1277 sv_setpvs(sv,"IGNORE");
1279 sv_setsv(sv,&PL_sv_undef);
1280 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1287 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1289 PERL_ARGS_ASSERT_MAGIC_CLEARSIG;
1290 PERL_UNUSED_ARG(sv);
1292 magic_setsig(NULL, mg);
1293 return sv_unmagic(sv, mg->mg_type);
1297 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1298 Perl_csighandler(int sig, siginfo_t *sip PERL_UNUSED_DECL, void *uap PERL_UNUSED_DECL)
1300 Perl_csighandler(int sig)
1303 #ifdef PERL_GET_SIG_CONTEXT
1304 dTHXa(PERL_GET_SIG_CONTEXT);
1308 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1309 (void) rsignal(sig, PL_csighandlerp);
1310 if (PL_sig_ignoring[sig]) return;
1312 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1313 if (PL_sig_defaulting[sig])
1314 #ifdef KILL_BY_SIGPRC
1315 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1330 (PL_signals & PERL_SIGNALS_UNSAFE_FLAG))
1331 /* Call the perl level handler now--
1332 * with risk we may be in malloc() or being destructed etc. */
1333 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1334 (*PL_sighandlerp)(sig, NULL, NULL);
1336 (*PL_sighandlerp)(sig);
1339 if (!PL_psig_pend) return;
1340 /* Set a flag to say this signal is pending, that is awaiting delivery after
1341 * the current Perl opcode completes */
1342 PL_psig_pend[sig]++;
1344 #ifndef SIG_PENDING_DIE_COUNT
1345 # define SIG_PENDING_DIE_COUNT 120
1347 /* Add one to say _a_ signal is pending */
1348 if (++PL_sig_pending >= SIG_PENDING_DIE_COUNT)
1349 Perl_croak(aTHX_ "Maximal count of pending signals (%lu) exceeded",
1350 (unsigned long)SIG_PENDING_DIE_COUNT);
1354 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1356 Perl_csighandler_init(void)
1359 if (PL_sig_handlers_initted) return;
1361 for (sig = 1; sig < SIG_SIZE; sig++) {
1362 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1364 PL_sig_defaulting[sig] = 1;
1365 (void) rsignal(sig, PL_csighandlerp);
1367 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1368 PL_sig_ignoring[sig] = 0;
1371 PL_sig_handlers_initted = 1;
1376 Perl_despatch_signals(pTHX)
1381 for (sig = 1; sig < SIG_SIZE; sig++) {
1382 if (PL_psig_pend[sig]) {
1383 PERL_BLOCKSIG_ADD(set, sig);
1384 PL_psig_pend[sig] = 0;
1385 PERL_BLOCKSIG_BLOCK(set);
1386 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1387 (*PL_sighandlerp)(sig, NULL, NULL);
1389 (*PL_sighandlerp)(sig);
1391 PERL_BLOCKSIG_UNBLOCK(set);
1396 /* sv of NULL signifies that we're acting as magic_clearsig. */
1398 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1403 /* Need to be careful with SvREFCNT_dec(), because that can have side
1404 * effects (due to closures). We must make sure that the new disposition
1405 * is in place before it is called.
1409 #ifdef HAS_SIGPROCMASK
1413 register const char *s = MgPV_const(mg,len);
1415 PERL_ARGS_ASSERT_MAGIC_SETSIG;
1418 if (strEQ(s,"__DIE__"))
1420 else if (strEQ(s,"__WARN__")
1421 && (sv ? 1 : PL_warnhook != PERL_WARNHOOK_FATAL)) {
1422 /* Merge the existing behaviours, which are as follows:
1423 magic_setsig, we always set svp to &PL_warnhook
1424 (hence we always change the warnings handler)
1425 For magic_clearsig, we don't change the warnings handler if it's
1426 set to the &PL_warnhook. */
1429 Perl_croak(aTHX_ "No such hook: %s", s);
1432 if (*svp != PERL_WARNHOOK_FATAL)
1438 i = (I16)mg->mg_private;
1440 i = whichsig(s); /* ...no, a brick */
1441 mg->mg_private = (U16)i;
1445 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
1448 #ifdef HAS_SIGPROCMASK
1449 /* Avoid having the signal arrive at a bad time, if possible. */
1452 sigprocmask(SIG_BLOCK, &set, &save);
1454 save_sv = newSVpvn((char *)(&save), sizeof(sigset_t));
1455 SAVEFREESV(save_sv);
1456 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1459 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1460 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1462 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1463 PL_sig_ignoring[i] = 0;
1465 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1466 PL_sig_defaulting[i] = 0;
1468 to_dec = PL_psig_ptr[i];
1470 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1471 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1473 /* Signals don't change name during the program's execution, so once
1474 they're cached in the appropriate slot of PL_psig_name, they can
1477 Ideally we'd find some way of making SVs at (C) compile time, or
1478 at least, doing most of the work. */
1479 if (!PL_psig_name[i]) {
1480 PL_psig_name[i] = newSVpvn(s, len);
1481 SvREADONLY_on(PL_psig_name[i]);
1484 SvREFCNT_dec(PL_psig_name[i]);
1485 PL_psig_name[i] = NULL;
1486 PL_psig_ptr[i] = NULL;
1489 if (sv && (isGV_with_GP(sv) || SvROK(sv))) {
1491 (void)rsignal(i, PL_csighandlerp);
1494 *svp = SvREFCNT_inc_simple_NN(sv);
1496 if (sv && SvOK(sv)) {
1497 s = SvPV_force(sv, len);
1501 if (sv && strEQ(s,"IGNORE")) {
1503 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1504 PL_sig_ignoring[i] = 1;
1505 (void)rsignal(i, PL_csighandlerp);
1507 (void)rsignal(i, (Sighandler_t) SIG_IGN);
1511 else if (!sv || strEQ(s,"DEFAULT") || !len) {
1513 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1514 PL_sig_defaulting[i] = 1;
1515 (void)rsignal(i, PL_csighandlerp);
1517 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1523 * We should warn if HINT_STRICT_REFS, but without
1524 * access to a known hint bit in a known OP, we can't
1525 * tell whether HINT_STRICT_REFS is in force or not.
1527 if (!strchr(s,':') && !strchr(s,'\''))
1528 Perl_sv_insert_flags(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"),
1531 (void)rsignal(i, PL_csighandlerp);
1533 *svp = SvREFCNT_inc_simple_NN(sv);
1537 #ifdef HAS_SIGPROCMASK
1541 SvREFCNT_dec(to_dec);
1544 #endif /* !PERL_MICRO */
1547 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1550 PERL_ARGS_ASSERT_MAGIC_SETISA;
1551 PERL_UNUSED_ARG(sv);
1553 /* Skip _isaelem because _isa will handle it shortly */
1554 if (PL_delaymagic & DM_ARRAY && mg->mg_type == PERL_MAGIC_isaelem)
1557 return magic_clearisa(NULL, mg);
1560 /* sv of NULL signifies that we're acting as magic_setisa. */
1562 Perl_magic_clearisa(pTHX_ SV *sv, MAGIC *mg)
1567 PERL_ARGS_ASSERT_MAGIC_CLEARISA;
1569 /* Bail out if destruction is going on */
1570 if(PL_dirty) return 0;
1573 av_clear(MUTABLE_AV(sv));
1575 /* XXX Once it's possible, we need to
1576 detect that our @ISA is aliased in
1577 other stashes, and act on the stashes
1578 of all of the aliases */
1580 /* The first case occurs via setisa,
1581 the second via setisa_elem, which
1582 calls this same magic */
1584 SvTYPE(mg->mg_obj) == SVt_PVGV
1585 ? (const GV *)mg->mg_obj
1586 : (const GV *)mg_find(mg->mg_obj, PERL_MAGIC_isa)->mg_obj
1590 mro_isa_changed_in(stash);
1596 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
1599 PERL_ARGS_ASSERT_MAGIC_SETAMAGIC;
1600 PERL_UNUSED_ARG(sv);
1601 PERL_UNUSED_ARG(mg);
1602 PL_amagic_generation++;
1608 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1610 HV * const hv = MUTABLE_HV(LvTARG(sv));
1613 PERL_ARGS_ASSERT_MAGIC_GETNKEYS;
1614 PERL_UNUSED_ARG(mg);
1617 (void) hv_iterinit(hv);
1618 if (! SvTIED_mg((const SV *)hv, PERL_MAGIC_tied))
1621 while (hv_iternext(hv))
1626 sv_setiv(sv, (IV)i);
1631 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1633 PERL_ARGS_ASSERT_MAGIC_SETNKEYS;
1634 PERL_UNUSED_ARG(mg);
1636 hv_ksplit(MUTABLE_HV(LvTARG(sv)), SvIV(sv));
1641 /* caller is responsible for stack switching/cleanup */
1643 S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV *val)
1648 PERL_ARGS_ASSERT_MAGIC_METHCALL;
1652 PUSHs(SvTIED_obj(sv, mg));
1655 if (mg->mg_len >= 0)
1656 mPUSHp(mg->mg_ptr, mg->mg_len);
1657 else if (mg->mg_len == HEf_SVKEY)
1658 PUSHs(MUTABLE_SV(mg->mg_ptr));
1660 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1669 return call_method(meth, flags);
1673 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
1677 PERL_ARGS_ASSERT_MAGIC_METHPACK;
1681 PUSHSTACKi(PERLSI_MAGIC);
1683 if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
1684 sv_setsv(sv, *PL_stack_sp--);
1694 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1696 PERL_ARGS_ASSERT_MAGIC_GETPACK;
1698 if (mg->mg_type == PERL_MAGIC_tiedelem)
1699 mg->mg_flags |= MGf_GSKIP;
1700 magic_methpack(sv,mg,"FETCH");
1705 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1711 PERL_ARGS_ASSERT_MAGIC_SETPACK;
1713 /* in the code C<$tied{foo} = $val>, the "thing" that gets passed to
1714 * STORE() is not $val, but rather a PVLV (the sv in this call), whose
1715 * public flags indicate its value based on copying from $val. Doing
1716 * mg_set() on the PVLV temporarily does SvMAGICAL_off(), then calls us.
1717 * So STORE()'s $_[2] arg is a temporarily disarmed PVLV. This goes
1718 * wrong if $val happened to be tainted, as sv hasn't got magic
1719 * enabled, even though taint magic is in the chain. In which case,
1720 * fake up a temporary tainted value (this is easier than temporarily
1721 * re-enabling magic on sv). */
1723 if (PL_tainting && (tmg = mg_find(sv, PERL_MAGIC_taint))
1724 && (tmg->mg_len & 1))
1726 val = sv_mortalcopy(sv);
1733 PUSHSTACKi(PERLSI_MAGIC);
1734 magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, val);
1741 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1743 PERL_ARGS_ASSERT_MAGIC_CLEARPACK;
1745 return magic_methpack(sv,mg,"DELETE");
1750 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1755 PERL_ARGS_ASSERT_MAGIC_SIZEPACK;
1759 PUSHSTACKi(PERLSI_MAGIC);
1760 if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
1761 sv = *PL_stack_sp--;
1762 retval = SvIV(sv)-1;
1764 Perl_croak(aTHX_ "FETCHSIZE returned a negative value");
1769 return (U32) retval;
1773 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1777 PERL_ARGS_ASSERT_MAGIC_WIPEPACK;
1780 PUSHSTACKi(PERLSI_MAGIC);
1782 XPUSHs(SvTIED_obj(sv, mg));
1784 call_method("CLEAR", G_SCALAR|G_DISCARD);
1792 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1795 const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
1797 PERL_ARGS_ASSERT_MAGIC_NEXTPACK;
1801 PUSHSTACKi(PERLSI_MAGIC);
1804 PUSHs(SvTIED_obj(sv, mg));
1809 if (call_method(meth, G_SCALAR))
1810 sv_setsv(key, *PL_stack_sp--);
1819 Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg)
1821 PERL_ARGS_ASSERT_MAGIC_EXISTSPACK;
1823 return magic_methpack(sv,mg,"EXISTS");
1827 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1831 SV * const tied = SvTIED_obj(MUTABLE_SV(hv), mg);
1832 HV * const pkg = SvSTASH((const SV *)SvRV(tied));
1834 PERL_ARGS_ASSERT_MAGIC_SCALARPACK;
1836 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1838 if (HvEITER_get(hv))
1839 /* we are in an iteration so the hash cannot be empty */
1841 /* no xhv_eiter so now use FIRSTKEY */
1842 key = sv_newmortal();
1843 magic_nextpack(MUTABLE_SV(hv), mg, key);
1844 HvEITER_set(hv, NULL); /* need to reset iterator */
1845 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1848 /* there is a SCALAR method that we can call */
1850 PUSHSTACKi(PERLSI_MAGIC);
1856 if (call_method("SCALAR", G_SCALAR))
1857 retval = *PL_stack_sp--;
1859 retval = &PL_sv_undef;
1866 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1869 GV * const gv = PL_DBline;
1870 const I32 i = SvTRUE(sv);
1871 SV ** const svp = av_fetch(GvAV(gv),
1872 atoi(MgPV_nolen_const(mg)), FALSE);
1874 PERL_ARGS_ASSERT_MAGIC_SETDBLINE;
1876 if (svp && SvIOKp(*svp)) {
1877 OP * const o = INT2PTR(OP*,SvIVX(*svp));
1879 /* set or clear breakpoint in the relevant control op */
1881 o->op_flags |= OPf_SPECIAL;
1883 o->op_flags &= ~OPf_SPECIAL;
1890 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
1893 AV * const obj = MUTABLE_AV(mg->mg_obj);
1895 PERL_ARGS_ASSERT_MAGIC_GETARYLEN;
1898 sv_setiv(sv, AvFILL(obj) + CopARYBASE_get(PL_curcop));
1906 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
1909 AV * const obj = MUTABLE_AV(mg->mg_obj);
1911 PERL_ARGS_ASSERT_MAGIC_SETARYLEN;
1914 av_fill(obj, SvIV(sv) - CopARYBASE_get(PL_curcop));
1916 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
1917 "Attempt to set length of freed array");
1923 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
1927 PERL_ARGS_ASSERT_MAGIC_FREEARYLEN_P;
1928 PERL_UNUSED_ARG(sv);
1930 /* during global destruction, mg_obj may already have been freed */
1931 if (PL_in_clean_all)
1934 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
1937 /* arylen scalar holds a pointer back to the array, but doesn't own a
1938 reference. Hence the we (the array) are about to go away with it
1939 still pointing at us. Clear its pointer, else it would be pointing
1940 at free memory. See the comment in sv_magic about reference loops,
1941 and why it can't own a reference to us. */
1948 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
1951 SV* const lsv = LvTARG(sv);
1953 PERL_ARGS_ASSERT_MAGIC_GETPOS;
1954 PERL_UNUSED_ARG(mg);
1956 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1957 MAGIC * const found = mg_find(lsv, PERL_MAGIC_regex_global);
1958 if (found && found->mg_len >= 0) {
1959 I32 i = found->mg_len;
1961 sv_pos_b2u(lsv, &i);
1962 sv_setiv(sv, i + CopARYBASE_get(PL_curcop));
1971 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
1974 SV* const lsv = LvTARG(sv);
1980 PERL_ARGS_ASSERT_MAGIC_SETPOS;
1981 PERL_UNUSED_ARG(mg);
1983 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
1984 found = mg_find(lsv, PERL_MAGIC_regex_global);
1990 #ifdef PERL_OLD_COPY_ON_WRITE
1992 sv_force_normal_flags(lsv, 0);
1994 found = sv_magicext(lsv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
1997 else if (!SvOK(sv)) {
2001 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
2003 pos = SvIV(sv) - CopARYBASE_get(PL_curcop);
2006 ulen = sv_len_utf8(lsv);
2016 else if (pos > (SSize_t)len)
2021 sv_pos_u2b(lsv, &p, 0);
2025 found->mg_len = pos;
2026 found->mg_flags &= ~MGf_MINMATCH;
2032 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
2035 SV * const lsv = LvTARG(sv);
2036 const char * const tmps = SvPV_const(lsv,len);
2037 STRLEN offs = LvTARGOFF(sv);
2038 STRLEN rem = LvTARGLEN(sv);
2040 PERL_ARGS_ASSERT_MAGIC_GETSUBSTR;
2041 PERL_UNUSED_ARG(mg);
2044 offs = sv_pos_u2b_flags(lsv, offs, &rem, SV_CONST_RETURN);
2047 if (rem > len - offs)
2049 sv_setpvn(sv, tmps + offs, rem);
2056 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
2060 const char * const tmps = SvPV_const(sv, len);
2061 SV * const lsv = LvTARG(sv);
2062 STRLEN lvoff = LvTARGOFF(sv);
2063 STRLEN lvlen = LvTARGLEN(sv);
2065 PERL_ARGS_ASSERT_MAGIC_SETSUBSTR;
2066 PERL_UNUSED_ARG(mg);
2069 sv_utf8_upgrade(lsv);
2070 lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
2071 sv_insert(lsv, lvoff, lvlen, tmps, len);
2072 LvTARGLEN(sv) = sv_len_utf8(sv);
2075 else if (lsv && SvUTF8(lsv)) {
2077 lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
2078 LvTARGLEN(sv) = len;
2079 utf8 = (char*)bytes_to_utf8((U8*)tmps, &len);
2080 sv_insert(lsv, lvoff, lvlen, utf8, len);
2084 sv_insert(lsv, lvoff, lvlen, tmps, len);
2085 LvTARGLEN(sv) = len;
2092 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
2096 PERL_ARGS_ASSERT_MAGIC_GETTAINT;
2097 PERL_UNUSED_ARG(sv);
2099 TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
2104 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
2108 PERL_ARGS_ASSERT_MAGIC_SETTAINT;
2109 PERL_UNUSED_ARG(sv);
2111 /* update taint status */
2120 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
2122 SV * const lsv = LvTARG(sv);
2124 PERL_ARGS_ASSERT_MAGIC_GETVEC;
2125 PERL_UNUSED_ARG(mg);
2128 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
2136 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
2138 PERL_ARGS_ASSERT_MAGIC_SETVEC;
2139 PERL_UNUSED_ARG(mg);
2140 do_vecset(sv); /* XXX slurp this routine */
2145 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
2150 PERL_ARGS_ASSERT_MAGIC_GETDEFELEM;
2152 if (LvTARGLEN(sv)) {
2154 SV * const ahv = LvTARG(sv);
2155 HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, FALSE, 0);
2160 AV *const av = MUTABLE_AV(LvTARG(sv));
2161 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
2162 targ = AvARRAY(av)[LvTARGOFF(sv)];
2164 if (targ && (targ != &PL_sv_undef)) {
2165 /* somebody else defined it for us */
2166 SvREFCNT_dec(LvTARG(sv));
2167 LvTARG(sv) = SvREFCNT_inc_simple_NN(targ);
2169 SvREFCNT_dec(mg->mg_obj);
2171 mg->mg_flags &= ~MGf_REFCOUNTED;
2176 sv_setsv(sv, targ ? targ : &PL_sv_undef);
2181 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
2183 PERL_ARGS_ASSERT_MAGIC_SETDEFELEM;
2184 PERL_UNUSED_ARG(mg);
2188 sv_setsv(LvTARG(sv), sv);
2189 SvSETMAGIC(LvTARG(sv));
2195 Perl_vivify_defelem(pTHX_ SV *sv)
2201 PERL_ARGS_ASSERT_VIVIFY_DEFELEM;
2203 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2206 SV * const ahv = LvTARG(sv);
2207 HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, TRUE, 0);
2210 if (!value || value == &PL_sv_undef)
2211 Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(mg->mg_obj));
2214 AV *const av = MUTABLE_AV(LvTARG(sv));
2215 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
2216 LvTARG(sv) = NULL; /* array can't be extended */
2218 SV* const * const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
2219 if (!svp || (value = *svp) == &PL_sv_undef)
2220 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
2223 SvREFCNT_inc_simple_void(value);
2224 SvREFCNT_dec(LvTARG(sv));
2227 SvREFCNT_dec(mg->mg_obj);
2229 mg->mg_flags &= ~MGf_REFCOUNTED;
2233 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2235 PERL_ARGS_ASSERT_MAGIC_KILLBACKREFS;
2236 return Perl_sv_kill_backrefs(aTHX_ sv, MUTABLE_AV(mg->mg_obj));
2240 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2242 PERL_ARGS_ASSERT_MAGIC_SETMGLOB;
2243 PERL_UNUSED_CONTEXT;
2245 if (!isGV_with_GP(sv))
2251 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2253 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2255 PERL_ARGS_ASSERT_MAGIC_SETUVAR;
2257 if (uf && uf->uf_set)
2258 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2263 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2265 const char type = mg->mg_type;
2267 PERL_ARGS_ASSERT_MAGIC_SETREGEXP;
2269 if (type == PERL_MAGIC_qr) {
2270 } else if (type == PERL_MAGIC_bm) {
2274 assert(type == PERL_MAGIC_fm);
2277 return sv_unmagic(sv, type);
2280 #ifdef USE_LOCALE_COLLATE
2282 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2284 PERL_ARGS_ASSERT_MAGIC_SETCOLLXFRM;
2287 * RenE<eacute> Descartes said "I think not."
2288 * and vanished with a faint plop.
2290 PERL_UNUSED_CONTEXT;
2291 PERL_UNUSED_ARG(sv);
2293 Safefree(mg->mg_ptr);
2299 #endif /* USE_LOCALE_COLLATE */
2301 /* Just clear the UTF-8 cache data. */
2303 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2305 PERL_ARGS_ASSERT_MAGIC_SETUTF8;
2306 PERL_UNUSED_CONTEXT;
2307 PERL_UNUSED_ARG(sv);
2308 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2310 mg->mg_len = -1; /* The mg_len holds the len cache. */
2315 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2318 register const char *s;
2320 register const REGEXP * rx;
2321 const char * const remaining = mg->mg_ptr + 1;
2325 PERL_ARGS_ASSERT_MAGIC_SET;
2327 switch (*mg->mg_ptr) {
2328 case '\015': /* $^MATCH */
2329 if (strEQ(remaining, "ATCH"))
2331 case '`': /* ${^PREMATCH} caught below */
2333 paren = RX_BUFF_IDX_PREMATCH;
2335 case '\'': /* ${^POSTMATCH} caught below */
2337 paren = RX_BUFF_IDX_POSTMATCH;
2341 paren = RX_BUFF_IDX_FULLMATCH;
2343 case '1': case '2': case '3': case '4':
2344 case '5': case '6': case '7': case '8': case '9':
2345 paren = atoi(mg->mg_ptr);
2347 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
2348 CALLREG_NUMBUF_STORE((REGEXP * const)rx,paren,sv);
2351 /* Croak with a READONLY error when a numbered match var is
2352 * set without a previous pattern match. Unless it's C<local $1>
2354 if (!PL_localizing) {
2355 Perl_croak(aTHX_ "%s", PL_no_modify);
2358 case '\001': /* ^A */
2359 sv_setsv(PL_bodytarget, sv);
2361 case '\003': /* ^C */
2362 PL_minus_c = (bool)SvIV(sv);
2365 case '\004': /* ^D */
2367 s = SvPV_nolen_const(sv);
2368 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2369 if (DEBUG_x_TEST || DEBUG_B_TEST)
2370 dump_all_perl(!DEBUG_B_TEST);
2372 PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG;
2375 case '\005': /* ^E */
2376 if (*(mg->mg_ptr+1) == '\0') {
2378 set_vaxc_errno(SvIV(sv));
2381 SetLastError( SvIV(sv) );
2384 os2_setsyserrno(SvIV(sv));
2386 /* will anyone ever use this? */
2387 SETERRNO(SvIV(sv), 4);
2392 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2393 SvREFCNT_dec(PL_encoding);
2394 if (SvOK(sv) || SvGMAGICAL(sv)) {
2395 PL_encoding = newSVsv(sv);
2402 case '\006': /* ^F */
2403 PL_maxsysfd = SvIV(sv);
2405 case '\010': /* ^H */
2406 PL_hints = SvIV(sv);
2408 case '\011': /* ^I */ /* NOT \t in EBCDIC */
2409 Safefree(PL_inplace);
2410 PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
2412 case '\017': /* ^O */
2413 if (*(mg->mg_ptr+1) == '\0') {
2414 Safefree(PL_osname);
2417 TAINT_PROPER("assigning to $^O");
2418 PL_osname = savesvpv(sv);
2421 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2423 const char *const start = SvPV(sv, len);
2424 const char *out = (const char*)memchr(start, '\0', len);
2428 PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2429 PL_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2431 /* Opening for input is more common than opening for output, so
2432 ensure that hints for input are sooner on linked list. */
2433 tmp = out ? newSVpvn_flags(out + 1, start + len - out - 1,
2435 : newSVpvs_flags("", SvUTF8(sv));
2436 (void)hv_stores(GvHV(PL_hintgv), "open>", tmp);
2439 tmp = newSVpvn_flags(start, out ? (STRLEN)(out - start) : len,
2441 (void)hv_stores(GvHV(PL_hintgv), "open<", tmp);
2445 case '\020': /* ^P */
2446 if (*remaining == '\0') { /* ^P */
2447 PL_perldb = SvIV(sv);
2448 if (PL_perldb && !PL_DBsingle)
2451 } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
2453 } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
2456 case '\024': /* ^T */
2458 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2460 PL_basetime = (Time_t)SvIV(sv);
2463 case '\025': /* ^UTF8CACHE */
2464 if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
2465 PL_utf8cache = (signed char) sv_2iv(sv);
2468 case '\027': /* ^W & $^WARNING_BITS */
2469 if (*(mg->mg_ptr+1) == '\0') {
2470 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2472 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2473 | (i ? G_WARN_ON : G_WARN_OFF) ;
2476 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2477 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2478 if (!SvPOK(sv) && PL_localizing) {
2479 sv_setpvn(sv, WARN_NONEstring, WARNsize);
2480 PL_compiling.cop_warnings = pWARN_NONE;
2485 int accumulate = 0 ;
2486 int any_fatals = 0 ;
2487 const char * const ptr = SvPV_const(sv, len) ;
2488 for (i = 0 ; i < len ; ++i) {
2489 accumulate |= ptr[i] ;
2490 any_fatals |= (ptr[i] & 0xAA) ;
2493 if (!specialWARN(PL_compiling.cop_warnings))
2494 PerlMemShared_free(PL_compiling.cop_warnings);
2495 PL_compiling.cop_warnings = pWARN_NONE;
2497 /* Yuck. I can't see how to abstract this: */
2498 else if (isWARN_on(((STRLEN *)SvPV_nolen_const(sv)) - 1,
2499 WARN_ALL) && !any_fatals) {
2500 if (!specialWARN(PL_compiling.cop_warnings))
2501 PerlMemShared_free(PL_compiling.cop_warnings);
2502 PL_compiling.cop_warnings = pWARN_ALL;
2503 PL_dowarn |= G_WARN_ONCE ;
2507 const char *const p = SvPV_const(sv, len);
2509 PL_compiling.cop_warnings
2510 = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
2513 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2514 PL_dowarn |= G_WARN_ONCE ;
2522 if (PL_localizing) {
2523 if (PL_localizing == 1)
2524 SAVESPTR(PL_last_in_gv);
2526 else if (SvOK(sv) && GvIO(PL_last_in_gv))
2527 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2530 if (isGV_with_GP(PL_defoutgv)) {
2531 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2532 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2533 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2537 if (isGV_with_GP(PL_defoutgv)) {
2538 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2539 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2540 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2544 if (isGV_with_GP(PL_defoutgv))
2545 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
2548 if (isGV_with_GP(PL_defoutgv)) {
2549 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
2550 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2551 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2555 if (isGV_with_GP(PL_defoutgv))
2556 IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
2560 IO * const io = GvIO(PL_defoutgv);
2563 if ((SvIV(sv)) == 0)
2564 IoFLAGS(io) &= ~IOf_FLUSH;
2566 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2567 PerlIO *ofp = IoOFP(io);
2569 (void)PerlIO_flush(ofp);
2570 IoFLAGS(io) |= IOf_FLUSH;
2576 SvREFCNT_dec(PL_rs);
2577 PL_rs = newSVsv(sv);
2580 SvREFCNT_dec(PL_ors_sv);
2581 if (SvOK(sv) || SvGMAGICAL(sv)) {
2582 PL_ors_sv = newSVsv(sv);
2589 CopARYBASE_set(&PL_compiling, SvIV(sv));
2592 #ifdef COMPLEX_STATUS
2593 if (PL_localizing == 2) {
2594 SvUPGRADE(sv, SVt_PVLV);
2595 PL_statusvalue = LvTARGOFF(sv);
2596 PL_statusvalue_vms = LvTARGLEN(sv);
2600 #ifdef VMSISH_STATUS
2602 STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2605 STATUS_UNIX_EXIT_SET(SvIV(sv));
2610 # define PERL_VMS_BANG vaxc$errno
2612 # define PERL_VMS_BANG 0
2614 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2615 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2620 if (PL_delaymagic) {
2621 PL_delaymagic |= DM_RUID;
2622 break; /* don't do magic till later */
2625 (void)setruid((Uid_t)PL_uid);
2628 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2630 #ifdef HAS_SETRESUID
2631 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2633 if (PL_uid == PL_euid) { /* special case $< = $> */
2635 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2636 if (PL_uid != 0 && PerlProc_getuid() == 0)
2637 (void)PerlProc_setuid(0);
2639 (void)PerlProc_setuid(PL_uid);
2641 PL_uid = PerlProc_getuid();
2642 Perl_croak(aTHX_ "setruid() not implemented");
2647 PL_uid = PerlProc_getuid();
2651 if (PL_delaymagic) {
2652 PL_delaymagic |= DM_EUID;
2653 break; /* don't do magic till later */
2656 (void)seteuid((Uid_t)PL_euid);
2659 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2661 #ifdef HAS_SETRESUID
2662 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2664 if (PL_euid == PL_uid) /* special case $> = $< */
2665 PerlProc_setuid(PL_euid);
2667 PL_euid = PerlProc_geteuid();
2668 Perl_croak(aTHX_ "seteuid() not implemented");
2673 PL_euid = PerlProc_geteuid();
2677 if (PL_delaymagic) {
2678 PL_delaymagic |= DM_RGID;
2679 break; /* don't do magic till later */
2682 (void)setrgid((Gid_t)PL_gid);
2685 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2687 #ifdef HAS_SETRESGID
2688 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2690 if (PL_gid == PL_egid) /* special case $( = $) */
2691 (void)PerlProc_setgid(PL_gid);
2693 PL_gid = PerlProc_getgid();
2694 Perl_croak(aTHX_ "setrgid() not implemented");
2699 PL_gid = PerlProc_getgid();
2702 #ifdef HAS_SETGROUPS
2704 const char *p = SvPV_const(sv, len);
2705 Groups_t *gary = NULL;
2706 #ifdef _SC_NGROUPS_MAX
2707 int maxgrp = sysconf(_SC_NGROUPS_MAX);
2712 int maxgrp = NGROUPS;
2718 for (i = 0; i < maxgrp; ++i) {
2719 while (*p && !isSPACE(*p))
2726 Newx(gary, i + 1, Groups_t);
2728 Renew(gary, i + 1, Groups_t);
2732 (void)setgroups(i, gary);
2735 #else /* HAS_SETGROUPS */
2737 #endif /* HAS_SETGROUPS */
2738 if (PL_delaymagic) {
2739 PL_delaymagic |= DM_EGID;
2740 break; /* don't do magic till later */
2743 (void)setegid((Gid_t)PL_egid);
2746 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2748 #ifdef HAS_SETRESGID
2749 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2751 if (PL_egid == PL_gid) /* special case $) = $( */
2752 (void)PerlProc_setgid(PL_egid);
2754 PL_egid = PerlProc_getegid();
2755 Perl_croak(aTHX_ "setegid() not implemented");
2760 PL_egid = PerlProc_getegid();
2763 PL_chopset = SvPV_force(sv,len);
2766 LOCK_DOLLARZERO_MUTEX;
2767 #ifdef HAS_SETPROCTITLE
2768 /* The BSDs don't show the argv[] in ps(1) output, they
2769 * show a string from the process struct and provide
2770 * the setproctitle() routine to manipulate that. */
2771 if (PL_origalen != 1) {
2772 s = SvPV_const(sv, len);
2773 # if __FreeBSD_version > 410001
2774 /* The leading "-" removes the "perl: " prefix,
2775 * but not the "(perl) suffix from the ps(1)
2776 * output, because that's what ps(1) shows if the
2777 * argv[] is modified. */
2778 setproctitle("-%s", s);
2779 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2780 /* This doesn't really work if you assume that
2781 * $0 = 'foobar'; will wipe out 'perl' from the $0
2782 * because in ps(1) output the result will be like
2783 * sprintf("perl: %s (perl)", s)
2784 * I guess this is a security feature:
2785 * one (a user process) cannot get rid of the original name.
2787 setproctitle("%s", s);
2790 #elif defined(__hpux) && defined(PSTAT_SETCMD)
2791 if (PL_origalen != 1) {
2793 s = SvPV_const(sv, len);
2794 un.pst_command = (char *)s;
2795 pstat(PSTAT_SETCMD, un, len, 0, 0);
2798 if (PL_origalen > 1) {
2799 /* PL_origalen is set in perl_parse(). */
2800 s = SvPV_force(sv,len);
2801 if (len >= (STRLEN)PL_origalen-1) {
2802 /* Longer than original, will be truncated. We assume that
2803 * PL_origalen bytes are available. */
2804 Copy(s, PL_origargv[0], PL_origalen-1, char);
2807 /* Shorter than original, will be padded. */
2809 /* Special case for Mac OS X: see [perl #38868] */
2812 /* Is the space counterintuitive? Yes.
2813 * (You were expecting \0?)
2814 * Does it work? Seems to. (In Linux 2.4.20 at least.)
2816 const int pad = ' ';
2818 Copy(s, PL_origargv[0], len, char);
2819 PL_origargv[0][len] = 0;
2820 memset(PL_origargv[0] + len + 1,
2821 pad, PL_origalen - len - 1);
2823 PL_origargv[0][PL_origalen-1] = 0;
2824 for (i = 1; i < PL_origargc; i++)
2828 UNLOCK_DOLLARZERO_MUTEX;
2835 Perl_whichsig(pTHX_ const char *sig)
2837 register char* const* sigv;
2839 PERL_ARGS_ASSERT_WHICHSIG;
2840 PERL_UNUSED_CONTEXT;
2842 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
2843 if (strEQ(sig,*sigv))
2844 return PL_sig_num[sigv - (char* const*)PL_sig_name];
2846 if (strEQ(sig,"CHLD"))
2850 if (strEQ(sig,"CLD"))
2857 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2858 Perl_sighandler(int sig, siginfo_t *sip, void *uap PERL_UNUSED_DECL)
2860 Perl_sighandler(int sig)
2863 #ifdef PERL_GET_SIG_CONTEXT
2864 dTHXa(PERL_GET_SIG_CONTEXT);
2871 SV * const tSv = PL_Sv;
2875 XPV * const tXpv = PL_Xpv;
2877 if (PL_savestack_ix + 15 <= PL_savestack_max)
2879 if (PL_markstack_ptr < PL_markstack_max - 2)
2881 if (PL_scopestack_ix < PL_scopestack_max - 3)
2884 if (!PL_psig_ptr[sig]) {
2885 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2890 /* Max number of items pushed there is 3*n or 4. We cannot fix
2891 infinity, so we fix 4 (in fact 5): */
2893 PL_savestack_ix += 5; /* Protect save in progress. */
2894 SAVEDESTRUCTOR_X(S_unwind_handler_stack, (void*)&flags);
2897 PL_markstack_ptr++; /* Protect mark. */
2899 PL_scopestack_ix += 1;
2900 /* sv_2cv is too complicated, try a simpler variant first: */
2901 if (!SvROK(PL_psig_ptr[sig]) || !(cv = MUTABLE_CV(SvRV(PL_psig_ptr[sig])))
2902 || SvTYPE(cv) != SVt_PVCV) {
2904 cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
2907 if (!cv || !CvROOT(cv)) {
2908 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2909 PL_sig_name[sig], (gv ? GvENAME(gv)
2916 if(PL_psig_name[sig]) {
2917 sv = SvREFCNT_inc_NN(PL_psig_name[sig]);
2919 #if !defined(PERL_IMPLICIT_CONTEXT)
2923 sv = sv_newmortal();
2924 sv_setpv(sv,PL_sig_name[sig]);
2927 PUSHSTACKi(PERLSI_SIGNAL);
2930 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2932 struct sigaction oact;
2934 if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
2937 SV *rv = newRV_noinc(MUTABLE_SV(sih));
2938 /* The siginfo fields signo, code, errno, pid, uid,
2939 * addr, status, and band are defined by POSIX/SUSv3. */
2940 (void)hv_stores(sih, "signo", newSViv(sip->si_signo));
2941 (void)hv_stores(sih, "code", newSViv(sip->si_code));
2942 #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. */
2943 hv_stores(sih, "errno", newSViv(sip->si_errno));
2944 hv_stores(sih, "status", newSViv(sip->si_status));
2945 hv_stores(sih, "uid", newSViv(sip->si_uid));
2946 hv_stores(sih, "pid", newSViv(sip->si_pid));
2947 hv_stores(sih, "addr", newSVuv(PTR2UV(sip->si_addr)));
2948 hv_stores(sih, "band", newSViv(sip->si_band));
2952 mPUSHp((char *)sip, sizeof(*sip));
2960 call_sv(MUTABLE_SV(cv), G_DISCARD|G_EVAL);
2963 if (SvTRUE(ERRSV)) {
2965 #ifdef HAS_SIGPROCMASK
2966 /* Handler "died", for example to get out of a restart-able read().
2967 * Before we re-do that on its behalf re-enable the signal which was
2968 * blocked by the system when we entered.
2972 sigaddset(&set,sig);
2973 sigprocmask(SIG_UNBLOCK, &set, NULL);
2975 /* Not clear if this will work */
2976 (void)rsignal(sig, SIG_IGN);
2977 (void)rsignal(sig, PL_csighandlerp);
2979 #endif /* !PERL_MICRO */
2980 Perl_die(aTHX_ NULL);
2984 PL_savestack_ix -= 8; /* Unprotect save in progress. */
2988 PL_scopestack_ix -= 1;
2991 PL_op = myop; /* Apparently not needed... */
2993 PL_Sv = tSv; /* Restore global temporaries. */
3000 S_restore_magic(pTHX_ const void *p)
3003 MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
3004 SV* const sv = mgs->mgs_sv;
3009 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
3011 #ifdef PERL_OLD_COPY_ON_WRITE
3012 /* While magic was saved (and off) sv_setsv may well have seen
3013 this SV as a prime candidate for COW. */
3015 sv_force_normal_flags(sv, 0);
3018 if (mgs->mgs_readonly)
3020 if (mgs->mgs_magical)
3021 SvFLAGS(sv) |= mgs->mgs_magical;
3024 if (SvGMAGICAL(sv)) {
3025 /* downgrade public flags to private,
3026 and discard any other private flags */
3028 const U32 pubflags = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
3030 SvFLAGS(sv) &= ~( pubflags | (SVp_IOK|SVp_NOK|SVp_POK) );
3031 SvFLAGS(sv) |= ( pubflags << PRIVSHIFT );
3036 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
3038 /* If we're still on top of the stack, pop us off. (That condition
3039 * will be satisfied if restore_magic was called explicitly, but *not*
3040 * if it's being called via leave_scope.)
3041 * The reason for doing this is that otherwise, things like sv_2cv()
3042 * may leave alloc gunk on the savestack, and some code
3043 * (e.g. sighandler) doesn't expect that...
3045 if (PL_savestack_ix == mgs->mgs_ss_ix)
3047 I32 popval = SSPOPINT;
3048 assert(popval == SAVEt_DESTRUCTOR_X);
3049 PL_savestack_ix -= 2;
3051 assert(popval == SAVEt_ALLOC);
3053 PL_savestack_ix -= popval;
3059 S_unwind_handler_stack(pTHX_ const void *p)
3062 const U32 flags = *(const U32*)p;
3064 PERL_ARGS_ASSERT_UNWIND_HANDLER_STACK;
3067 PL_savestack_ix -= 5; /* Unprotect save in progress. */
3068 #if !defined(PERL_IMPLICIT_CONTEXT)
3070 SvREFCNT_dec(PL_sig_sv);
3075 =for apidoc magic_sethint
3077 Triggered by a store to %^H, records the key/value pair to
3078 C<PL_compiling.cop_hints_hash>. It is assumed that hints aren't storing
3079 anything that would need a deep copy. Maybe we should warn if we find a
3085 Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
3088 SV *key = (mg->mg_len == HEf_SVKEY) ? MUTABLE_SV(mg->mg_ptr)
3089 : newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
3091 PERL_ARGS_ASSERT_MAGIC_SETHINT;
3093 /* mg->mg_obj isn't being used. If needed, it would be possible to store
3094 an alternative leaf in there, with PL_compiling.cop_hints being used if
3095 it's NULL. If needed for threads, the alternative could lock a mutex,
3096 or take other more complex action. */
3098 /* Something changed in %^H, so it will need to be restored on scope exit.
3099 Doing this here saves a lot of doing it manually in perl code (and
3100 forgetting to do it, and consequent subtle errors. */
3101 PL_hints |= HINT_LOCALIZE_HH;
3102 PL_compiling.cop_hints_hash
3103 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash, key, sv);
3108 =for apidoc magic_clearhint
3110 Triggered by a delete from %^H, records the key to
3111 C<PL_compiling.cop_hints_hash>.
3116 Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
3120 PERL_ARGS_ASSERT_MAGIC_CLEARHINT;
3121 PERL_UNUSED_ARG(sv);
3123 assert(mg->mg_len == HEf_SVKEY);
3125 PERL_UNUSED_ARG(sv);
3127 PL_hints |= HINT_LOCALIZE_HH;
3128 PL_compiling.cop_hints_hash
3129 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
3130 MUTABLE_SV(mg->mg_ptr), &PL_sv_placeholder);
3135 =for apidoc magic_clearhints
3137 Triggered by clearing %^H, resets C<PL_compiling.cop_hints_hash>.
3142 Perl_magic_clearhints(pTHX_ SV *sv, MAGIC *mg)
3144 PERL_ARGS_ASSERT_MAGIC_CLEARHINTS;
3145 PERL_UNUSED_ARG(sv);
3146 PERL_UNUSED_ARG(mg);
3147 if (PL_compiling.cop_hints_hash) {
3148 Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
3149 PL_compiling.cop_hints_hash = NULL;
3156 * c-indentation-style: bsd
3158 * indent-tabs-mode: t
3161 * ex: set ts=8 sts=4 sw=4 noet: