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.
83 /* MGS is typedef'ed to struct magic_state in perl.h */
86 S_save_magic(pTHX_ I32 mgs_ix, SV *sv)
91 PERL_ARGS_ASSERT_SAVE_MAGIC;
93 assert(SvMAGICAL(sv));
94 /* Turning READONLY off for a copy-on-write scalar (including shared
95 hash keys) is a bad idea. */
97 sv_force_normal_flags(sv, 0);
99 SAVEDESTRUCTOR_X(S_restore_magic, INT2PTR(void*, (IV)mgs_ix));
101 mgs = SSPTR(mgs_ix, MGS*);
103 mgs->mgs_flags = SvMAGICAL(sv) | SvREADONLY(sv);
104 mgs->mgs_ss_ix = PL_savestack_ix; /* points after the saved destructor */
108 if (!(SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK))) {
109 /* No public flags are set, so promote any private flags to public. */
110 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
115 =for apidoc mg_magical
117 Turns on the magical status of an SV. See C<sv_magic>.
123 Perl_mg_magical(pTHX_ SV *sv)
126 PERL_ARGS_ASSERT_MG_MAGICAL;
128 if ((mg = SvMAGIC(sv))) {
131 const MGVTBL* const vtbl = mg->mg_virtual;
133 if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
140 } while ((mg = mg->mg_moremagic));
141 if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)))
147 /* is this container magic (%ENV, $1 etc), or value magic (pos, taint etc)? */
150 S_is_container_magic(const MAGIC *mg)
153 switch (mg->mg_type) {
156 case PERL_MAGIC_regex_global:
157 case PERL_MAGIC_nkeys:
158 #ifdef USE_LOCALE_COLLATE
159 case PERL_MAGIC_collxfrm:
162 case PERL_MAGIC_taint:
164 case PERL_MAGIC_vstring:
165 case PERL_MAGIC_utf8:
166 case PERL_MAGIC_substr:
167 case PERL_MAGIC_defelem:
168 case PERL_MAGIC_arylen:
170 case PERL_MAGIC_backref:
171 case PERL_MAGIC_arylen_p:
172 case PERL_MAGIC_rhash:
173 case PERL_MAGIC_symtab:
183 Do magic after a value is retrieved from the SV. See C<sv_magic>.
189 Perl_mg_get(pTHX_ SV *sv)
192 const I32 mgs_ix = SSNEW(sizeof(MGS));
193 const bool was_temp = (bool)SvTEMP(sv);
195 MAGIC *newmg, *head, *cur, *mg;
196 /* guard against sv having being freed midway by holding a private
199 PERL_ARGS_ASSERT_MG_GET;
201 /* sv_2mortal has this side effect of turning on the TEMP flag, which can
202 cause the SV's buffer to get stolen (and maybe other stuff).
205 sv_2mortal(SvREFCNT_inc_simple_NN(sv));
210 save_magic(mgs_ix, sv);
212 /* We must call svt_get(sv, mg) for each valid entry in the linked
213 list of magic. svt_get() may delete the current entry, add new
214 magic to the head of the list, or upgrade the SV. AMS 20010810 */
216 newmg = cur = head = mg = SvMAGIC(sv);
218 const MGVTBL * const vtbl = mg->mg_virtual;
220 if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
221 CALL_FPTR(vtbl->svt_get)(aTHX_ sv, mg);
223 /* guard against magic having been deleted - eg FETCH calling
228 /* Don't restore the flags for this entry if it was deleted. */
229 if (mg->mg_flags & MGf_GSKIP)
230 (SSPTR(mgs_ix, MGS *))->mgs_flags = 0;
233 mg = mg->mg_moremagic;
236 /* Have we finished with the new entries we saw? Start again
237 where we left off (unless there are more new entries). */
245 /* Were any new entries added? */
246 if (!have_new && (newmg = SvMAGIC(sv)) != head) {
253 restore_magic(INT2PTR(void *, (IV)mgs_ix));
255 if (SvREFCNT(sv) == 1) {
256 /* We hold the last reference to this SV, which implies that the
257 SV was deleted as a side effect of the routines we called. */
266 Do magic after a value is assigned to the SV. See C<sv_magic>.
272 Perl_mg_set(pTHX_ SV *sv)
275 const I32 mgs_ix = SSNEW(sizeof(MGS));
279 PERL_ARGS_ASSERT_MG_SET;
281 save_magic(mgs_ix, sv);
283 for (mg = SvMAGIC(sv); mg; mg = nextmg) {
284 const MGVTBL* vtbl = mg->mg_virtual;
285 nextmg = mg->mg_moremagic; /* it may delete itself */
286 if (mg->mg_flags & MGf_GSKIP) {
287 mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */
288 (SSPTR(mgs_ix, MGS*))->mgs_flags = 0;
290 if (PL_localizing == 2 && !S_is_container_magic(mg))
292 if (vtbl && vtbl->svt_set)
293 CALL_FPTR(vtbl->svt_set)(aTHX_ sv, mg);
296 restore_magic(INT2PTR(void*, (IV)mgs_ix));
301 =for apidoc mg_length
303 Report on the SV's length. See C<sv_magic>.
309 Perl_mg_length(pTHX_ SV *sv)
315 PERL_ARGS_ASSERT_MG_LENGTH;
317 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
318 const MGVTBL * const vtbl = mg->mg_virtual;
319 if (vtbl && vtbl->svt_len) {
320 const I32 mgs_ix = SSNEW(sizeof(MGS));
321 save_magic(mgs_ix, sv);
322 /* omit MGf_GSKIP -- not changed here */
323 len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
324 restore_magic(INT2PTR(void*, (IV)mgs_ix));
330 /* You can't know whether it's UTF-8 until you get the string again...
332 const U8 *s = (U8*)SvPV_const(sv, len);
335 len = utf8_length(s, s + len);
342 Perl_mg_size(pTHX_ SV *sv)
346 PERL_ARGS_ASSERT_MG_SIZE;
348 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
349 const MGVTBL* const vtbl = mg->mg_virtual;
350 if (vtbl && vtbl->svt_len) {
351 const I32 mgs_ix = SSNEW(sizeof(MGS));
353 save_magic(mgs_ix, sv);
354 /* omit MGf_GSKIP -- not changed here */
355 len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
356 restore_magic(INT2PTR(void*, (IV)mgs_ix));
363 return AvFILLp((const AV *) sv); /* Fallback to non-tied array */
367 Perl_croak(aTHX_ "Size magic not implemented");
376 Clear something magical that the SV represents. See C<sv_magic>.
382 Perl_mg_clear(pTHX_ SV *sv)
384 const I32 mgs_ix = SSNEW(sizeof(MGS));
388 PERL_ARGS_ASSERT_MG_CLEAR;
390 save_magic(mgs_ix, sv);
392 for (mg = SvMAGIC(sv); mg; mg = nextmg) {
393 const MGVTBL* const vtbl = mg->mg_virtual;
394 /* omit GSKIP -- never set here */
396 nextmg = mg->mg_moremagic; /* it may delete itself */
398 if (vtbl && vtbl->svt_clear)
399 CALL_FPTR(vtbl->svt_clear)(aTHX_ sv, mg);
402 restore_magic(INT2PTR(void*, (IV)mgs_ix));
409 Finds the magic pointer for type matching the SV. See C<sv_magic>.
415 Perl_mg_find(pTHX_ const SV *sv, int type)
420 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
421 if (mg->mg_type == type)
431 Copies the magic from one SV to another. See C<sv_magic>.
437 Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
442 PERL_ARGS_ASSERT_MG_COPY;
444 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
445 const MGVTBL* const vtbl = mg->mg_virtual;
446 if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){
447 count += CALL_FPTR(vtbl->svt_copy)(aTHX_ sv, mg, nsv, key, klen);
450 const char type = mg->mg_type;
451 if (isUPPER(type) && type != PERL_MAGIC_uvar) {
453 (type == PERL_MAGIC_tied)
455 : (type == PERL_MAGIC_regdata && mg->mg_obj)
458 toLOWER(type), key, klen);
467 =for apidoc mg_localize
469 Copy some of the magic from an existing SV to new localized version of that
470 SV. Container magic (eg %ENV, $1, tie) gets copied, value magic doesn't (eg
473 If setmagic is false then no set magic will be called on the new (empty) SV.
474 This typically means that assignment will soon follow (e.g. 'local $x = $y'),
475 and that will handle the magic.
481 Perl_mg_localize(pTHX_ SV *sv, SV *nsv, bool setmagic)
486 PERL_ARGS_ASSERT_MG_LOCALIZE;
488 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
489 const MGVTBL* const vtbl = mg->mg_virtual;
490 if (!S_is_container_magic(mg))
493 if ((mg->mg_flags & MGf_LOCAL) && vtbl->svt_local)
494 (void)CALL_FPTR(vtbl->svt_local)(aTHX_ nsv, mg);
496 sv_magicext(nsv, mg->mg_obj, mg->mg_type, vtbl,
497 mg->mg_ptr, mg->mg_len);
499 /* container types should remain read-only across localization */
500 SvFLAGS(nsv) |= SvREADONLY(sv);
503 if (SvTYPE(nsv) >= SVt_PVMG && SvMAGIC(nsv)) {
504 SvFLAGS(nsv) |= SvMAGICAL(sv);
516 Free any magic storage used by the SV. See C<sv_magic>.
522 Perl_mg_free(pTHX_ SV *sv)
527 PERL_ARGS_ASSERT_MG_FREE;
529 for (mg = SvMAGIC(sv); mg; mg = moremagic) {
530 const MGVTBL* const vtbl = mg->mg_virtual;
531 moremagic = mg->mg_moremagic;
532 if (vtbl && vtbl->svt_free)
533 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
534 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
535 if (mg->mg_len > 0 || mg->mg_type == PERL_MAGIC_utf8)
536 Safefree(mg->mg_ptr);
537 else if (mg->mg_len == HEf_SVKEY)
538 SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr));
540 if (mg->mg_flags & MGf_REFCOUNTED)
541 SvREFCNT_dec(mg->mg_obj);
543 SvMAGIC_set(sv, moremagic);
545 SvMAGIC_set(sv, NULL);
553 Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
558 PERL_ARGS_ASSERT_MAGIC_REGDATA_CNT;
561 register const REGEXP * const rx = PM_GETRE(PL_curpm);
563 if (mg->mg_obj) { /* @+ */
564 /* return the number possible */
565 return RX_NPARENS(rx);
567 I32 paren = RX_LASTPAREN(rx);
569 /* return the last filled */
571 && (RX_OFFS(rx)[paren].start == -1
572 || RX_OFFS(rx)[paren].end == -1) )
583 Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
587 PERL_ARGS_ASSERT_MAGIC_REGDATUM_GET;
590 register const REGEXP * const rx = PM_GETRE(PL_curpm);
592 register const I32 paren = mg->mg_len;
597 if (paren <= (I32)RX_NPARENS(rx) &&
598 (s = RX_OFFS(rx)[paren].start) != -1 &&
599 (t = RX_OFFS(rx)[paren].end) != -1)
602 if (mg->mg_obj) /* @+ */
607 if (i > 0 && RX_MATCH_UTF8(rx)) {
608 const char * const b = RX_SUBBEG(rx);
610 i = utf8_length((U8*)b, (U8*)(b+i));
621 Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
623 PERL_ARGS_ASSERT_MAGIC_REGDATUM_SET;
626 Perl_croak(aTHX_ "%s", PL_no_modify);
627 NORETURN_FUNCTION_END;
631 Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
636 register const REGEXP * rx;
637 const char * const remaining = mg->mg_ptr + 1;
639 PERL_ARGS_ASSERT_MAGIC_LEN;
641 switch (*mg->mg_ptr) {
643 if (*remaining == '\0') { /* ^P */
645 } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
647 } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
651 case '\015': /* $^MATCH */
652 if (strEQ(remaining, "ATCH")) {
659 paren = RX_BUFF_IDX_PREMATCH;
663 paren = RX_BUFF_IDX_POSTMATCH;
667 paren = RX_BUFF_IDX_FULLMATCH;
669 case '1': case '2': case '3': case '4':
670 case '5': case '6': case '7': case '8': case '9':
671 paren = atoi(mg->mg_ptr);
673 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
675 i = CALLREG_NUMBUF_LENGTH((REGEXP * const)rx, sv, paren);
678 Perl_croak(aTHX_ "panic: magic_len: %"IVdf, (IV)i);
681 if (ckWARN(WARN_UNINITIALIZED))
686 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
687 paren = RX_LASTPAREN(rx);
692 case '\016': /* ^N */
693 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
694 paren = RX_LASTCLOSEPAREN(rx);
701 if (!SvPOK(sv) && SvNIOK(sv)) {
709 #define SvRTRIM(sv) STMT_START { \
711 STRLEN len = SvCUR(sv); \
712 char * const p = SvPVX(sv); \
713 while (len > 0 && isSPACE(p[len-1])) \
715 SvCUR_set(sv, len); \
721 Perl_emulate_cop_io(pTHX_ const COP *const c, SV *const sv)
723 PERL_ARGS_ASSERT_EMULATE_COP_IO;
725 if (!(CopHINTS_get(c) & (HINT_LEXICAL_IO_IN|HINT_LEXICAL_IO_OUT)))
726 sv_setsv(sv, &PL_sv_undef);
730 if ((CopHINTS_get(c) & HINT_LEXICAL_IO_IN)) {
731 SV *const value = Perl_refcounted_he_fetch(aTHX_
733 0, "open<", 5, 0, 0);
738 if ((CopHINTS_get(c) & HINT_LEXICAL_IO_OUT)) {
739 SV *const value = Perl_refcounted_he_fetch(aTHX_
741 0, "open>", 5, 0, 0);
749 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
753 register char *s = NULL;
755 const char * const remaining = mg->mg_ptr + 1;
756 const char nextchar = *remaining;
758 PERL_ARGS_ASSERT_MAGIC_GET;
760 switch (*mg->mg_ptr) {
761 case '\001': /* ^A */
762 sv_setsv(sv, PL_bodytarget);
764 case '\003': /* ^C, ^CHILD_ERROR_NATIVE */
765 if (nextchar == '\0') {
766 sv_setiv(sv, (IV)PL_minus_c);
768 else if (strEQ(remaining, "HILD_ERROR_NATIVE")) {
769 sv_setiv(sv, (IV)STATUS_NATIVE);
773 case '\004': /* ^D */
774 sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
776 case '\005': /* ^E */
777 if (nextchar == '\0') {
780 # include <descrip.h>
781 # include <starlet.h>
783 $DESCRIPTOR(msgdsc,msg);
784 sv_setnv(sv,(NV) vaxc$errno);
785 if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
786 sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
791 if (!(_emx_env & 0x200)) { /* Under DOS */
792 sv_setnv(sv, (NV)errno);
793 sv_setpv(sv, errno ? Strerror(errno) : "");
795 if (errno != errno_isOS2) {
796 const int tmp = _syserrno();
797 if (tmp) /* 2nd call to _syserrno() makes it 0 */
800 sv_setnv(sv, (NV)Perl_rc);
801 sv_setpv(sv, os2error(Perl_rc));
805 const DWORD dwErr = GetLastError();
806 sv_setnv(sv, (NV)dwErr);
808 PerlProc_GetOSError(sv, dwErr);
817 sv_setnv(sv, (NV)errno);
818 sv_setpv(sv, errno ? Strerror(errno) : "");
823 SvNOK_on(sv); /* what a wonderful hack! */
825 else if (strEQ(remaining, "NCODING"))
826 sv_setsv(sv, PL_encoding);
828 case '\006': /* ^F */
829 sv_setiv(sv, (IV)PL_maxsysfd);
831 case '\010': /* ^H */
832 sv_setiv(sv, (IV)PL_hints);
834 case '\011': /* ^I */ /* NOT \t in EBCDIC */
835 sv_setpv(sv, PL_inplace); /* Will undefine sv if PL_inplace is NULL */
837 case '\017': /* ^O & ^OPEN */
838 if (nextchar == '\0') {
839 sv_setpv(sv, PL_osname);
842 else if (strEQ(remaining, "PEN")) {
843 Perl_emulate_cop_io(aTHX_ &PL_compiling, sv);
847 if (nextchar == '\0') { /* ^P */
848 sv_setiv(sv, (IV)PL_perldb);
849 } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
850 goto do_prematch_fetch;
851 } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
852 goto do_postmatch_fetch;
855 case '\023': /* ^S */
856 if (nextchar == '\0') {
857 if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING)
860 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
865 case '\024': /* ^T */
866 if (nextchar == '\0') {
868 sv_setnv(sv, PL_basetime);
870 sv_setiv(sv, (IV)PL_basetime);
873 else if (strEQ(remaining, "AINT"))
874 sv_setiv(sv, PL_tainting
875 ? (PL_taint_warn || PL_unsafe ? -1 : 1)
878 case '\025': /* $^UNICODE, $^UTF8LOCALE, $^UTF8CACHE */
879 if (strEQ(remaining, "NICODE"))
880 sv_setuv(sv, (UV) PL_unicode);
881 else if (strEQ(remaining, "TF8LOCALE"))
882 sv_setuv(sv, (UV) PL_utf8locale);
883 else if (strEQ(remaining, "TF8CACHE"))
884 sv_setiv(sv, (IV) PL_utf8cache);
886 case '\027': /* ^W & $^WARNING_BITS */
887 if (nextchar == '\0')
888 sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
889 else if (strEQ(remaining, "ARNING_BITS")) {
890 if (PL_compiling.cop_warnings == pWARN_NONE) {
891 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
893 else if (PL_compiling.cop_warnings == pWARN_STD) {
896 (PL_dowarn & G_WARN_ON) ? WARN_ALLstring : WARN_NONEstring,
900 else if (PL_compiling.cop_warnings == pWARN_ALL) {
901 /* Get the bit mask for $warnings::Bits{all}, because
902 * it could have been extended by warnings::register */
903 HV * const bits=get_hv("warnings::Bits", 0);
905 SV ** const bits_all = hv_fetchs(bits, "all", FALSE);
907 sv_setsv(sv, *bits_all);
910 sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
914 sv_setpvn(sv, (char *) (PL_compiling.cop_warnings + 1),
915 *PL_compiling.cop_warnings);
920 case '\015': /* $^MATCH */
921 if (strEQ(remaining, "ATCH")) {
922 case '1': case '2': case '3': case '4':
923 case '5': case '6': case '7': case '8': case '9': case '&':
924 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
926 * Pre-threads, this was paren = atoi(GvENAME((const GV *)mg->mg_obj));
927 * XXX Does the new way break anything?
929 paren = atoi(mg->mg_ptr); /* $& is in [0] */
930 CALLREG_NUMBUF_FETCH(rx,paren,sv);
933 sv_setsv(sv,&PL_sv_undef);
937 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
938 if (RX_LASTPAREN(rx)) {
939 CALLREG_NUMBUF_FETCH(rx,RX_LASTPAREN(rx),sv);
943 sv_setsv(sv,&PL_sv_undef);
945 case '\016': /* ^N */
946 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
947 if (RX_LASTCLOSEPAREN(rx)) {
948 CALLREG_NUMBUF_FETCH(rx,RX_LASTCLOSEPAREN(rx),sv);
953 sv_setsv(sv,&PL_sv_undef);
957 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
958 CALLREG_NUMBUF_FETCH(rx,-2,sv);
961 sv_setsv(sv,&PL_sv_undef);
965 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
966 CALLREG_NUMBUF_FETCH(rx,-1,sv);
969 sv_setsv(sv,&PL_sv_undef);
972 if (GvIO(PL_last_in_gv)) {
973 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
978 sv_setiv(sv, (IV)STATUS_CURRENT);
979 #ifdef COMPLEX_STATUS
980 LvTARGOFF(sv) = PL_statusvalue;
981 LvTARGLEN(sv) = PL_statusvalue_vms;
986 if (GvIOp(PL_defoutgv))
987 s = IoTOP_NAME(GvIOp(PL_defoutgv));
991 sv_setpv(sv,GvENAME(PL_defoutgv));
992 sv_catpvs(sv,"_TOP");
996 if (GvIOp(PL_defoutgv))
997 s = IoFMT_NAME(GvIOp(PL_defoutgv));
999 s = GvENAME(PL_defoutgv);
1003 if (GvIOp(PL_defoutgv))
1004 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
1007 if (GvIOp(PL_defoutgv))
1008 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
1011 if (GvIOp(PL_defoutgv))
1012 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
1019 sv_setiv(sv, (IV)CopARYBASE_get(PL_curcop));
1022 if (GvIOp(PL_defoutgv))
1023 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
1027 sv_copypv(sv, PL_ors_sv);
1031 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
1032 sv_setpv(sv, errno ? Strerror(errno) : "");
1036 sv_setnv(sv, (NV)errno);
1038 if (errno == errno_isOS2 || errno == errno_isOS2_set)
1039 sv_setpv(sv, os2error(Perl_rc));
1042 sv_setpv(sv, errno ? Strerror(errno) : "");
1047 SvNOK_on(sv); /* what a wonderful hack! */
1050 sv_setiv(sv, (IV)PL_uid);
1053 sv_setiv(sv, (IV)PL_euid);
1056 sv_setiv(sv, (IV)PL_gid);
1059 sv_setiv(sv, (IV)PL_egid);
1061 #ifdef HAS_GETGROUPS
1063 Groups_t *gary = NULL;
1064 I32 i, num_groups = getgroups(0, gary);
1065 Newx(gary, num_groups, Groups_t);
1066 num_groups = getgroups(num_groups, gary);
1067 for (i = 0; i < num_groups; i++)
1068 Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]);
1071 (void)SvIOK_on(sv); /* what a wonderful hack! */
1081 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
1083 struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
1085 PERL_ARGS_ASSERT_MAGIC_GETUVAR;
1087 if (uf && uf->uf_val)
1088 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
1093 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
1096 STRLEN len = 0, klen;
1097 const char *s = SvOK(sv) ? SvPV_const(sv,len) : "";
1098 const char * const ptr = MgPV_const(mg,klen);
1101 PERL_ARGS_ASSERT_MAGIC_SETENV;
1103 #ifdef DYNAMIC_ENV_FETCH
1104 /* We just undefd an environment var. Is a replacement */
1105 /* waiting in the wings? */
1107 SV ** const valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE);
1109 s = SvOK(*valp) ? SvPV_const(*valp, len) : "";
1113 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
1114 /* And you'll never guess what the dog had */
1115 /* in its mouth... */
1117 MgTAINTEDDIR_off(mg);
1119 if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
1120 char pathbuf[256], eltbuf[256], *cp, *elt;
1124 my_strlcpy(eltbuf, s, sizeof(eltbuf));
1126 do { /* DCL$PATH may be a search list */
1127 while (1) { /* as may dev portion of any element */
1128 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1129 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1130 cando_by_name(S_IWUSR,0,elt) ) {
1131 MgTAINTEDDIR_on(mg);
1135 if ((cp = strchr(elt, ':')) != NULL)
1137 if (my_trnlnm(elt, eltbuf, j++))
1143 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1146 if (s && klen == 4 && strEQ(ptr,"PATH")) {
1147 const char * const strend = s + len;
1149 while (s < strend) {
1153 #ifdef VMS /* Hmm. How do we get $Config{path_sep} from C? */
1154 const char path_sep = '|';
1156 const char path_sep = ':';
1158 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
1159 s, strend, path_sep, &i);
1161 if (i >= (I32)sizeof tmpbuf /* too long -- assume the worst */
1163 || !strchr(tmpbuf, ':') /* no colon thus no device name -- assume relative path */
1165 || *tmpbuf != '/' /* no starting slash -- assume relative path */
1167 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1168 MgTAINTEDDIR_on(mg);
1174 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1180 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1182 PERL_ARGS_ASSERT_MAGIC_CLEARENV;
1183 PERL_UNUSED_ARG(sv);
1184 my_setenv(MgPV_nolen_const(mg),NULL);
1189 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1192 PERL_ARGS_ASSERT_MAGIC_SET_ALL_ENV;
1193 PERL_UNUSED_ARG(mg);
1195 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1197 if (PL_localizing) {
1200 hv_iterinit(MUTABLE_HV(sv));
1201 while ((entry = hv_iternext(MUTABLE_HV(sv)))) {
1203 my_setenv(hv_iterkey(entry, &keylen),
1204 SvPV_nolen_const(hv_iterval(MUTABLE_HV(sv), entry)));
1212 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1215 PERL_ARGS_ASSERT_MAGIC_CLEAR_ALL_ENV;
1216 PERL_UNUSED_ARG(sv);
1217 PERL_UNUSED_ARG(mg);
1219 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1227 #ifdef HAS_SIGPROCMASK
1229 restore_sigmask(pTHX_ SV *save_sv)
1231 const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1232 (void)sigprocmask(SIG_SETMASK, ossetp, NULL);
1236 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1239 /* Are we fetching a signal entry? */
1240 int i = (I16)mg->mg_private;
1242 PERL_ARGS_ASSERT_MAGIC_GETSIG;
1245 mg->mg_private = i = whichsig(MgPV_nolen_const(mg));
1250 sv_setsv(sv,PL_psig_ptr[i]);
1252 Sighandler_t sigstate = rsignal_state(i);
1253 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1254 if (PL_sig_handlers_initted && PL_sig_ignoring[i])
1257 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1258 if (PL_sig_handlers_initted && PL_sig_defaulting[i])
1261 /* cache state so we don't fetch it again */
1262 if(sigstate == (Sighandler_t) SIG_IGN)
1263 sv_setpvs(sv,"IGNORE");
1265 sv_setsv(sv,&PL_sv_undef);
1266 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1273 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1275 PERL_ARGS_ASSERT_MAGIC_CLEARSIG;
1276 PERL_UNUSED_ARG(sv);
1278 magic_setsig(NULL, mg);
1279 return sv_unmagic(sv, mg->mg_type);
1283 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1284 Perl_csighandler(int sig, siginfo_t *sip PERL_UNUSED_DECL, void *uap PERL_UNUSED_DECL)
1286 Perl_csighandler(int sig)
1289 #ifdef PERL_GET_SIG_CONTEXT
1290 dTHXa(PERL_GET_SIG_CONTEXT);
1294 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1295 (void) rsignal(sig, PL_csighandlerp);
1296 if (PL_sig_ignoring[sig]) return;
1298 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1299 if (PL_sig_defaulting[sig])
1300 #ifdef KILL_BY_SIGPRC
1301 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1316 (PL_signals & PERL_SIGNALS_UNSAFE_FLAG))
1317 /* Call the perl level handler now--
1318 * with risk we may be in malloc() etc. */
1319 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1320 (*PL_sighandlerp)(sig, NULL, NULL);
1322 (*PL_sighandlerp)(sig);
1325 /* Set a flag to say this signal is pending, that is awaiting delivery after
1326 * the current Perl opcode completes */
1327 PL_psig_pend[sig]++;
1329 #ifndef SIG_PENDING_DIE_COUNT
1330 # define SIG_PENDING_DIE_COUNT 120
1332 /* And one to say _a_ signal is pending */
1333 if (++PL_sig_pending >= SIG_PENDING_DIE_COUNT)
1334 Perl_croak(aTHX_ "Maximal count of pending signals (%lu) exceeded",
1335 (unsigned long)SIG_PENDING_DIE_COUNT);
1339 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1341 Perl_csighandler_init(void)
1344 if (PL_sig_handlers_initted) return;
1346 for (sig = 1; sig < SIG_SIZE; sig++) {
1347 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1349 PL_sig_defaulting[sig] = 1;
1350 (void) rsignal(sig, PL_csighandlerp);
1352 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1353 PL_sig_ignoring[sig] = 0;
1356 PL_sig_handlers_initted = 1;
1361 Perl_despatch_signals(pTHX)
1366 for (sig = 1; sig < SIG_SIZE; sig++) {
1367 if (PL_psig_pend[sig]) {
1368 PERL_BLOCKSIG_ADD(set, sig);
1369 PL_psig_pend[sig] = 0;
1370 PERL_BLOCKSIG_BLOCK(set);
1371 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1372 (*PL_sighandlerp)(sig, NULL, NULL);
1374 (*PL_sighandlerp)(sig);
1376 PERL_BLOCKSIG_UNBLOCK(set);
1381 /* sv of NULL signifies that we're acting as magic_clearsig. */
1383 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1388 /* Need to be careful with SvREFCNT_dec(), because that can have side
1389 * effects (due to closures). We must make sure that the new disposition
1390 * is in place before it is called.
1394 #ifdef HAS_SIGPROCMASK
1398 register const char *s = MgPV_const(mg,len);
1400 PERL_ARGS_ASSERT_MAGIC_SETSIG;
1403 if (strEQ(s,"__DIE__"))
1405 else if (strEQ(s,"__WARN__")
1406 && (sv ? 1 : PL_warnhook != PERL_WARNHOOK_FATAL)) {
1407 /* Merge the existing behaviours, which are as follows:
1408 magic_setsig, we always set svp to &PL_warnhook
1409 (hence we always change the warnings handler)
1410 For magic_clearsig, we don't change the warnings handler if it's
1411 set to the &PL_warnhook. */
1414 Perl_croak(aTHX_ "No such hook: %s", s);
1417 if (*svp != PERL_WARNHOOK_FATAL)
1423 i = (I16)mg->mg_private;
1425 mg->mg_private = i = whichsig(s); /* ...no, a brick */
1428 if (sv && ckWARN(WARN_SIGNAL))
1429 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
1432 #ifdef HAS_SIGPROCMASK
1433 /* Avoid having the signal arrive at a bad time, if possible. */
1436 sigprocmask(SIG_BLOCK, &set, &save);
1438 save_sv = newSVpvn((char *)(&save), sizeof(sigset_t));
1439 SAVEFREESV(save_sv);
1440 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1443 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1444 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1446 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1447 PL_sig_ignoring[i] = 0;
1449 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1450 PL_sig_defaulting[i] = 0;
1452 to_dec = PL_psig_ptr[i];
1454 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1455 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1457 /* Signals don't change name during the program's execution, so once
1458 they're cached in the appropriate slot of PL_psig_name, they can
1461 Ideally we'd find some way of making SVs at (C) compile time, or
1462 at least, doing most of the work. */
1463 if (!PL_psig_name[i]) {
1464 PL_psig_name[i] = newSVpvn(s, len);
1465 SvREADONLY_on(PL_psig_name[i]);
1468 SvREFCNT_dec(PL_psig_name[i]);
1469 PL_psig_name[i] = NULL;
1470 PL_psig_ptr[i] = NULL;
1473 if (sv && (isGV_with_GP(sv) || SvROK(sv))) {
1475 (void)rsignal(i, PL_csighandlerp);
1478 *svp = SvREFCNT_inc_simple_NN(sv);
1480 if (sv && SvOK(sv)) {
1481 s = SvPV_force(sv, len);
1485 if (sv && strEQ(s,"IGNORE")) {
1487 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1488 PL_sig_ignoring[i] = 1;
1489 (void)rsignal(i, PL_csighandlerp);
1491 (void)rsignal(i, (Sighandler_t) SIG_IGN);
1495 else if (!sv || strEQ(s,"DEFAULT") || !len) {
1497 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1498 PL_sig_defaulting[i] = 1;
1499 (void)rsignal(i, PL_csighandlerp);
1501 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1507 * We should warn if HINT_STRICT_REFS, but without
1508 * access to a known hint bit in a known OP, we can't
1509 * tell whether HINT_STRICT_REFS is in force or not.
1511 if (!strchr(s,':') && !strchr(s,'\''))
1512 Perl_sv_insert_flags(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"),
1515 (void)rsignal(i, PL_csighandlerp);
1517 *svp = SvREFCNT_inc_simple_NN(sv);
1521 #ifdef HAS_SIGPROCMASK
1526 SvREFCNT_dec(to_dec);
1529 #endif /* !PERL_MICRO */
1532 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1537 PERL_ARGS_ASSERT_MAGIC_SETISA;
1538 PERL_UNUSED_ARG(sv);
1540 /* Skip _isaelem because _isa will handle it shortly */
1541 if (PL_delaymagic & DM_ARRAY && mg->mg_type == PERL_MAGIC_isaelem)
1544 /* Bail out if destruction is going on */
1545 if(PL_dirty) return 0;
1547 /* XXX Once it's possible, we need to
1548 detect that our @ISA is aliased in
1549 other stashes, and act on the stashes
1550 of all of the aliases */
1552 /* The first case occurs via setisa,
1553 the second via setisa_elem, which
1554 calls this same magic */
1556 SvTYPE(mg->mg_obj) == SVt_PVGV
1557 ? (const GV *)mg->mg_obj
1558 : (const GV *)mg_find(mg->mg_obj, PERL_MAGIC_isa)->mg_obj
1562 mro_isa_changed_in(stash);
1568 Perl_magic_clearisa(pTHX_ SV *sv, MAGIC *mg)
1573 PERL_ARGS_ASSERT_MAGIC_CLEARISA;
1575 /* Bail out if destruction is going on */
1576 if(PL_dirty) return 0;
1578 av_clear(MUTABLE_AV(sv));
1580 /* XXX see comments in magic_setisa */
1582 SvTYPE(mg->mg_obj) == SVt_PVGV
1583 ? (const GV *)mg->mg_obj
1584 : (const GV *)mg_find(mg->mg_obj, PERL_MAGIC_isa)->mg_obj
1588 mro_isa_changed_in(stash);
1594 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
1597 PERL_ARGS_ASSERT_MAGIC_SETAMAGIC;
1598 PERL_UNUSED_ARG(sv);
1599 PERL_UNUSED_ARG(mg);
1600 PL_amagic_generation++;
1606 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1608 HV * const hv = MUTABLE_HV(LvTARG(sv));
1611 PERL_ARGS_ASSERT_MAGIC_GETNKEYS;
1612 PERL_UNUSED_ARG(mg);
1615 (void) hv_iterinit(hv);
1616 if (! SvTIED_mg((const SV *)hv, PERL_MAGIC_tied))
1619 while (hv_iternext(hv))
1624 sv_setiv(sv, (IV)i);
1629 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1631 PERL_ARGS_ASSERT_MAGIC_SETNKEYS;
1632 PERL_UNUSED_ARG(mg);
1634 hv_ksplit(MUTABLE_HV(LvTARG(sv)), SvIV(sv));
1639 /* caller is responsible for stack switching/cleanup */
1641 S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV *val)
1646 PERL_ARGS_ASSERT_MAGIC_METHCALL;
1650 PUSHs(SvTIED_obj(sv, mg));
1653 if (mg->mg_len >= 0)
1654 mPUSHp(mg->mg_ptr, mg->mg_len);
1655 else if (mg->mg_len == HEf_SVKEY)
1656 PUSHs(MUTABLE_SV(mg->mg_ptr));
1658 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1667 return call_method(meth, flags);
1671 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
1675 PERL_ARGS_ASSERT_MAGIC_METHPACK;
1679 PUSHSTACKi(PERLSI_MAGIC);
1681 if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
1682 sv_setsv(sv, *PL_stack_sp--);
1692 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1694 PERL_ARGS_ASSERT_MAGIC_GETPACK;
1697 mg->mg_flags |= MGf_GSKIP;
1698 magic_methpack(sv,mg,"FETCH");
1703 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1707 PERL_ARGS_ASSERT_MAGIC_SETPACK;
1710 PUSHSTACKi(PERLSI_MAGIC);
1711 magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
1718 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1720 PERL_ARGS_ASSERT_MAGIC_CLEARPACK;
1722 return magic_methpack(sv,mg,"DELETE");
1727 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1732 PERL_ARGS_ASSERT_MAGIC_SIZEPACK;
1736 PUSHSTACKi(PERLSI_MAGIC);
1737 if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
1738 sv = *PL_stack_sp--;
1739 retval = SvIV(sv)-1;
1741 Perl_croak(aTHX_ "FETCHSIZE returned a negative value");
1746 return (U32) retval;
1750 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1754 PERL_ARGS_ASSERT_MAGIC_WIPEPACK;
1757 PUSHSTACKi(PERLSI_MAGIC);
1759 XPUSHs(SvTIED_obj(sv, mg));
1761 call_method("CLEAR", G_SCALAR|G_DISCARD);
1769 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1772 const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
1774 PERL_ARGS_ASSERT_MAGIC_NEXTPACK;
1778 PUSHSTACKi(PERLSI_MAGIC);
1781 PUSHs(SvTIED_obj(sv, mg));
1786 if (call_method(meth, G_SCALAR))
1787 sv_setsv(key, *PL_stack_sp--);
1796 Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg)
1798 PERL_ARGS_ASSERT_MAGIC_EXISTSPACK;
1800 return magic_methpack(sv,mg,"EXISTS");
1804 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1808 SV * const tied = SvTIED_obj(MUTABLE_SV(hv), mg);
1809 HV * const pkg = SvSTASH((const SV *)SvRV(tied));
1811 PERL_ARGS_ASSERT_MAGIC_SCALARPACK;
1813 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1815 if (HvEITER_get(hv))
1816 /* we are in an iteration so the hash cannot be empty */
1818 /* no xhv_eiter so now use FIRSTKEY */
1819 key = sv_newmortal();
1820 magic_nextpack(MUTABLE_SV(hv), mg, key);
1821 HvEITER_set(hv, NULL); /* need to reset iterator */
1822 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1825 /* there is a SCALAR method that we can call */
1827 PUSHSTACKi(PERLSI_MAGIC);
1833 if (call_method("SCALAR", G_SCALAR))
1834 retval = *PL_stack_sp--;
1836 retval = &PL_sv_undef;
1843 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1846 GV * const gv = PL_DBline;
1847 const I32 i = SvTRUE(sv);
1848 SV ** const svp = av_fetch(GvAV(gv),
1849 atoi(MgPV_nolen_const(mg)), FALSE);
1851 PERL_ARGS_ASSERT_MAGIC_SETDBLINE;
1853 if (svp && SvIOKp(*svp)) {
1854 OP * const o = INT2PTR(OP*,SvIVX(*svp));
1856 /* set or clear breakpoint in the relevant control op */
1858 o->op_flags |= OPf_SPECIAL;
1860 o->op_flags &= ~OPf_SPECIAL;
1867 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
1870 AV * const obj = MUTABLE_AV(mg->mg_obj);
1872 PERL_ARGS_ASSERT_MAGIC_GETARYLEN;
1875 sv_setiv(sv, AvFILL(obj) + CopARYBASE_get(PL_curcop));
1883 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
1886 AV * const obj = MUTABLE_AV(mg->mg_obj);
1888 PERL_ARGS_ASSERT_MAGIC_SETARYLEN;
1891 av_fill(obj, SvIV(sv) - CopARYBASE_get(PL_curcop));
1893 if (ckWARN(WARN_MISC))
1894 Perl_warner(aTHX_ packWARN(WARN_MISC),
1895 "Attempt to set length of freed array");
1901 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
1905 PERL_ARGS_ASSERT_MAGIC_FREEARYLEN_P;
1906 PERL_UNUSED_ARG(sv);
1908 /* during global destruction, mg_obj may already have been freed */
1909 if (PL_in_clean_all)
1912 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
1915 /* arylen scalar holds a pointer back to the array, but doesn't own a
1916 reference. Hence the we (the array) are about to go away with it
1917 still pointing at us. Clear its pointer, else it would be pointing
1918 at free memory. See the comment in sv_magic about reference loops,
1919 and why it can't own a reference to us. */
1926 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
1929 SV* const lsv = LvTARG(sv);
1931 PERL_ARGS_ASSERT_MAGIC_GETPOS;
1932 PERL_UNUSED_ARG(mg);
1934 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1935 MAGIC * const found = mg_find(lsv, PERL_MAGIC_regex_global);
1936 if (found && found->mg_len >= 0) {
1937 I32 i = found->mg_len;
1939 sv_pos_b2u(lsv, &i);
1940 sv_setiv(sv, i + CopARYBASE_get(PL_curcop));
1949 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
1952 SV* const lsv = LvTARG(sv);
1958 PERL_ARGS_ASSERT_MAGIC_SETPOS;
1959 PERL_UNUSED_ARG(mg);
1961 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
1962 found = mg_find(lsv, PERL_MAGIC_regex_global);
1968 #ifdef PERL_OLD_COPY_ON_WRITE
1970 sv_force_normal_flags(lsv, 0);
1972 found = sv_magicext(lsv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
1975 else if (!SvOK(sv)) {
1979 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1981 pos = SvIV(sv) - CopARYBASE_get(PL_curcop);
1984 ulen = sv_len_utf8(lsv);
1994 else if (pos > (SSize_t)len)
1999 sv_pos_u2b(lsv, &p, 0);
2003 found->mg_len = pos;
2004 found->mg_flags &= ~MGf_MINMATCH;
2010 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
2013 SV * const lsv = LvTARG(sv);
2014 const char * const tmps = SvPV_const(lsv,len);
2015 I32 offs = LvTARGOFF(sv);
2016 I32 rem = LvTARGLEN(sv);
2018 PERL_ARGS_ASSERT_MAGIC_GETSUBSTR;
2019 PERL_UNUSED_ARG(mg);
2022 sv_pos_u2b(lsv, &offs, &rem);
2023 if (offs > (I32)len)
2025 if (rem + offs > (I32)len)
2027 sv_setpvn(sv, tmps + offs, (STRLEN)rem);
2034 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
2038 const char * const tmps = SvPV_const(sv, len);
2039 SV * const lsv = LvTARG(sv);
2040 I32 lvoff = LvTARGOFF(sv);
2041 I32 lvlen = LvTARGLEN(sv);
2043 PERL_ARGS_ASSERT_MAGIC_SETSUBSTR;
2044 PERL_UNUSED_ARG(mg);
2047 sv_utf8_upgrade(lsv);
2048 sv_pos_u2b(lsv, &lvoff, &lvlen);
2049 sv_insert(lsv, lvoff, lvlen, tmps, len);
2050 LvTARGLEN(sv) = sv_len_utf8(sv);
2053 else if (lsv && SvUTF8(lsv)) {
2055 sv_pos_u2b(lsv, &lvoff, &lvlen);
2056 LvTARGLEN(sv) = len;
2057 utf8 = (char*)bytes_to_utf8((U8*)tmps, &len);
2058 sv_insert(lsv, lvoff, lvlen, utf8, len);
2062 sv_insert(lsv, lvoff, lvlen, tmps, len);
2063 LvTARGLEN(sv) = len;
2071 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
2075 PERL_ARGS_ASSERT_MAGIC_GETTAINT;
2076 PERL_UNUSED_ARG(sv);
2078 TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
2083 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
2087 PERL_ARGS_ASSERT_MAGIC_SETTAINT;
2088 PERL_UNUSED_ARG(sv);
2090 /* update taint status */
2099 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
2101 SV * const lsv = LvTARG(sv);
2103 PERL_ARGS_ASSERT_MAGIC_GETVEC;
2104 PERL_UNUSED_ARG(mg);
2107 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
2115 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
2117 PERL_ARGS_ASSERT_MAGIC_SETVEC;
2118 PERL_UNUSED_ARG(mg);
2119 do_vecset(sv); /* XXX slurp this routine */
2124 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
2129 PERL_ARGS_ASSERT_MAGIC_GETDEFELEM;
2131 if (LvTARGLEN(sv)) {
2133 SV * const ahv = LvTARG(sv);
2134 HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, FALSE, 0);
2139 AV *const av = MUTABLE_AV(LvTARG(sv));
2140 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
2141 targ = AvARRAY(av)[LvTARGOFF(sv)];
2143 if (targ && (targ != &PL_sv_undef)) {
2144 /* somebody else defined it for us */
2145 SvREFCNT_dec(LvTARG(sv));
2146 LvTARG(sv) = SvREFCNT_inc_simple_NN(targ);
2148 SvREFCNT_dec(mg->mg_obj);
2150 mg->mg_flags &= ~MGf_REFCOUNTED;
2155 sv_setsv(sv, targ ? targ : &PL_sv_undef);
2160 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
2162 PERL_ARGS_ASSERT_MAGIC_SETDEFELEM;
2163 PERL_UNUSED_ARG(mg);
2167 sv_setsv(LvTARG(sv), sv);
2168 SvSETMAGIC(LvTARG(sv));
2174 Perl_vivify_defelem(pTHX_ SV *sv)
2180 PERL_ARGS_ASSERT_VIVIFY_DEFELEM;
2182 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2185 SV * const ahv = LvTARG(sv);
2186 HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, TRUE, 0);
2189 if (!value || value == &PL_sv_undef)
2190 Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(mg->mg_obj));
2193 AV *const av = MUTABLE_AV(LvTARG(sv));
2194 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
2195 LvTARG(sv) = NULL; /* array can't be extended */
2197 SV* const * const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
2198 if (!svp || (value = *svp) == &PL_sv_undef)
2199 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
2202 SvREFCNT_inc_simple_void(value);
2203 SvREFCNT_dec(LvTARG(sv));
2206 SvREFCNT_dec(mg->mg_obj);
2208 mg->mg_flags &= ~MGf_REFCOUNTED;
2212 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2214 PERL_ARGS_ASSERT_MAGIC_KILLBACKREFS;
2215 return Perl_sv_kill_backrefs(aTHX_ sv, MUTABLE_AV(mg->mg_obj));
2219 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2221 PERL_ARGS_ASSERT_MAGIC_SETMGLOB;
2222 PERL_UNUSED_CONTEXT;
2229 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2231 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2233 PERL_ARGS_ASSERT_MAGIC_SETUVAR;
2235 if (uf && uf->uf_set)
2236 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2241 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2243 const char type = mg->mg_type;
2245 PERL_ARGS_ASSERT_MAGIC_SETREGEXP;
2247 if (type == PERL_MAGIC_qr) {
2248 } else if (type == PERL_MAGIC_bm) {
2252 assert(type == PERL_MAGIC_fm);
2255 return sv_unmagic(sv, type);
2258 #ifdef USE_LOCALE_COLLATE
2260 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2262 PERL_ARGS_ASSERT_MAGIC_SETCOLLXFRM;
2265 * RenE<eacute> Descartes said "I think not."
2266 * and vanished with a faint plop.
2268 PERL_UNUSED_CONTEXT;
2269 PERL_UNUSED_ARG(sv);
2271 Safefree(mg->mg_ptr);
2277 #endif /* USE_LOCALE_COLLATE */
2279 /* Just clear the UTF-8 cache data. */
2281 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2283 PERL_ARGS_ASSERT_MAGIC_SETUTF8;
2284 PERL_UNUSED_CONTEXT;
2285 PERL_UNUSED_ARG(sv);
2286 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2288 mg->mg_len = -1; /* The mg_len holds the len cache. */
2293 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2296 register const char *s;
2298 register const REGEXP * rx;
2299 const char * const remaining = mg->mg_ptr + 1;
2303 PERL_ARGS_ASSERT_MAGIC_SET;
2305 switch (*mg->mg_ptr) {
2306 case '\015': /* $^MATCH */
2307 if (strEQ(remaining, "ATCH"))
2309 case '`': /* ${^PREMATCH} caught below */
2311 paren = RX_BUFF_IDX_PREMATCH;
2313 case '\'': /* ${^POSTMATCH} caught below */
2315 paren = RX_BUFF_IDX_POSTMATCH;
2319 paren = RX_BUFF_IDX_FULLMATCH;
2321 case '1': case '2': case '3': case '4':
2322 case '5': case '6': case '7': case '8': case '9':
2323 paren = atoi(mg->mg_ptr);
2325 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
2326 CALLREG_NUMBUF_STORE((REGEXP * const)rx,paren,sv);
2329 /* Croak with a READONLY error when a numbered match var is
2330 * set without a previous pattern match. Unless it's C<local $1>
2332 if (!PL_localizing) {
2333 Perl_croak(aTHX_ "%s", PL_no_modify);
2336 case '\001': /* ^A */
2337 sv_setsv(PL_bodytarget, sv);
2339 case '\003': /* ^C */
2340 PL_minus_c = (bool)SvIV(sv);
2343 case '\004': /* ^D */
2345 s = SvPV_nolen_const(sv);
2346 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2347 DEBUG_x(dump_all());
2349 PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG;
2352 case '\005': /* ^E */
2353 if (*(mg->mg_ptr+1) == '\0') {
2355 set_vaxc_errno(SvIV(sv));
2358 SetLastError( SvIV(sv) );
2361 os2_setsyserrno(SvIV(sv));
2363 /* will anyone ever use this? */
2364 SETERRNO(SvIV(sv), 4);
2369 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2371 SvREFCNT_dec(PL_encoding);
2372 if (SvOK(sv) || SvGMAGICAL(sv)) {
2373 PL_encoding = newSVsv(sv);
2380 case '\006': /* ^F */
2381 PL_maxsysfd = SvIV(sv);
2383 case '\010': /* ^H */
2384 PL_hints = SvIV(sv);
2386 case '\011': /* ^I */ /* NOT \t in EBCDIC */
2387 Safefree(PL_inplace);
2388 PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
2390 case '\017': /* ^O */
2391 if (*(mg->mg_ptr+1) == '\0') {
2392 Safefree(PL_osname);
2395 TAINT_PROPER("assigning to $^O");
2396 PL_osname = savesvpv(sv);
2399 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2401 const char *const start = SvPV(sv, len);
2402 const char *out = (const char*)memchr(start, '\0', len);
2404 struct refcounted_he *tmp_he;
2407 PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2409 |= HINT_LOCALIZE_HH | HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2411 /* Opening for input is more common than opening for output, so
2412 ensure that hints for input are sooner on linked list. */
2413 tmp = out ? newSVpvn_flags(out + 1, start + len - out - 1,
2414 SVs_TEMP | SvUTF8(sv))
2415 : newSVpvs_flags("", SVs_TEMP | SvUTF8(sv));
2418 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
2419 newSVpvs_flags("open>", SVs_TEMP),
2422 /* The UTF-8 setting is carried over */
2423 sv_setpvn(tmp, start, out ? (STRLEN)(out - start) : len);
2425 PL_compiling.cop_hints_hash
2426 = Perl_refcounted_he_new(aTHX_ tmp_he,
2427 newSVpvs_flags("open<", SVs_TEMP),
2431 case '\020': /* ^P */
2432 if (*remaining == '\0') { /* ^P */
2433 PL_perldb = SvIV(sv);
2434 if (PL_perldb && !PL_DBsingle)
2437 } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
2439 } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
2442 case '\024': /* ^T */
2444 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2446 PL_basetime = (Time_t)SvIV(sv);
2449 case '\025': /* ^UTF8CACHE */
2450 if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
2451 PL_utf8cache = (signed char) sv_2iv(sv);
2454 case '\027': /* ^W & $^WARNING_BITS */
2455 if (*(mg->mg_ptr+1) == '\0') {
2456 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2458 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2459 | (i ? G_WARN_ON : G_WARN_OFF) ;
2462 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2463 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2464 if (!SvPOK(sv) && PL_localizing) {
2465 sv_setpvn(sv, WARN_NONEstring, WARNsize);
2466 PL_compiling.cop_warnings = pWARN_NONE;
2471 int accumulate = 0 ;
2472 int any_fatals = 0 ;
2473 const char * const ptr = SvPV_const(sv, len) ;
2474 for (i = 0 ; i < len ; ++i) {
2475 accumulate |= ptr[i] ;
2476 any_fatals |= (ptr[i] & 0xAA) ;
2479 if (!specialWARN(PL_compiling.cop_warnings))
2480 PerlMemShared_free(PL_compiling.cop_warnings);
2481 PL_compiling.cop_warnings = pWARN_NONE;
2483 /* Yuck. I can't see how to abstract this: */
2484 else if (isWARN_on(((STRLEN *)SvPV_nolen_const(sv)) - 1,
2485 WARN_ALL) && !any_fatals) {
2486 if (!specialWARN(PL_compiling.cop_warnings))
2487 PerlMemShared_free(PL_compiling.cop_warnings);
2488 PL_compiling.cop_warnings = pWARN_ALL;
2489 PL_dowarn |= G_WARN_ONCE ;
2493 const char *const p = SvPV_const(sv, len);
2495 PL_compiling.cop_warnings
2496 = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
2499 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2500 PL_dowarn |= G_WARN_ONCE ;
2508 if (PL_localizing) {
2509 if (PL_localizing == 1)
2510 SAVESPTR(PL_last_in_gv);
2512 else if (SvOK(sv) && GvIO(PL_last_in_gv))
2513 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2516 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2517 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2518 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2521 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2522 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2523 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2526 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
2529 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
2530 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2531 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2534 IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
2538 IO * const io = GvIOp(PL_defoutgv);
2541 if ((SvIV(sv)) == 0)
2542 IoFLAGS(io) &= ~IOf_FLUSH;
2544 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2545 PerlIO *ofp = IoOFP(io);
2547 (void)PerlIO_flush(ofp);
2548 IoFLAGS(io) |= IOf_FLUSH;
2554 SvREFCNT_dec(PL_rs);
2555 PL_rs = newSVsv(sv);
2559 SvREFCNT_dec(PL_ors_sv);
2560 if (SvOK(sv) || SvGMAGICAL(sv)) {
2561 PL_ors_sv = newSVsv(sv);
2568 CopARYBASE_set(&PL_compiling, SvIV(sv));
2571 #ifdef COMPLEX_STATUS
2572 if (PL_localizing == 2) {
2573 PL_statusvalue = LvTARGOFF(sv);
2574 PL_statusvalue_vms = LvTARGLEN(sv);
2578 #ifdef VMSISH_STATUS
2580 STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2583 STATUS_UNIX_EXIT_SET(SvIV(sv));
2588 # define PERL_VMS_BANG vaxc$errno
2590 # define PERL_VMS_BANG 0
2592 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2593 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2598 if (PL_delaymagic) {
2599 PL_delaymagic |= DM_RUID;
2600 break; /* don't do magic till later */
2603 (void)setruid((Uid_t)PL_uid);
2606 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2608 #ifdef HAS_SETRESUID
2609 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2611 if (PL_uid == PL_euid) { /* special case $< = $> */
2613 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2614 if (PL_uid != 0 && PerlProc_getuid() == 0)
2615 (void)PerlProc_setuid(0);
2617 (void)PerlProc_setuid(PL_uid);
2619 PL_uid = PerlProc_getuid();
2620 Perl_croak(aTHX_ "setruid() not implemented");
2625 PL_uid = PerlProc_getuid();
2626 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2630 if (PL_delaymagic) {
2631 PL_delaymagic |= DM_EUID;
2632 break; /* don't do magic till later */
2635 (void)seteuid((Uid_t)PL_euid);
2638 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2640 #ifdef HAS_SETRESUID
2641 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2643 if (PL_euid == PL_uid) /* special case $> = $< */
2644 PerlProc_setuid(PL_euid);
2646 PL_euid = PerlProc_geteuid();
2647 Perl_croak(aTHX_ "seteuid() not implemented");
2652 PL_euid = PerlProc_geteuid();
2653 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2657 if (PL_delaymagic) {
2658 PL_delaymagic |= DM_RGID;
2659 break; /* don't do magic till later */
2662 (void)setrgid((Gid_t)PL_gid);
2665 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2667 #ifdef HAS_SETRESGID
2668 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2670 if (PL_gid == PL_egid) /* special case $( = $) */
2671 (void)PerlProc_setgid(PL_gid);
2673 PL_gid = PerlProc_getgid();
2674 Perl_croak(aTHX_ "setrgid() not implemented");
2679 PL_gid = PerlProc_getgid();
2680 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2683 #ifdef HAS_SETGROUPS
2685 const char *p = SvPV_const(sv, len);
2686 Groups_t *gary = NULL;
2691 for (i = 0; i < NGROUPS; ++i) {
2692 while (*p && !isSPACE(*p))
2699 Newx(gary, i + 1, Groups_t);
2701 Renew(gary, i + 1, Groups_t);
2705 (void)setgroups(i, gary);
2708 #else /* HAS_SETGROUPS */
2710 #endif /* HAS_SETGROUPS */
2711 if (PL_delaymagic) {
2712 PL_delaymagic |= DM_EGID;
2713 break; /* don't do magic till later */
2716 (void)setegid((Gid_t)PL_egid);
2719 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2721 #ifdef HAS_SETRESGID
2722 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2724 if (PL_egid == PL_gid) /* special case $) = $( */
2725 (void)PerlProc_setgid(PL_egid);
2727 PL_egid = PerlProc_getegid();
2728 Perl_croak(aTHX_ "setegid() not implemented");
2733 PL_egid = PerlProc_getegid();
2734 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2737 PL_chopset = SvPV_force(sv,len);
2740 LOCK_DOLLARZERO_MUTEX;
2741 #ifdef HAS_SETPROCTITLE
2742 /* The BSDs don't show the argv[] in ps(1) output, they
2743 * show a string from the process struct and provide
2744 * the setproctitle() routine to manipulate that. */
2745 if (PL_origalen != 1) {
2746 s = SvPV_const(sv, len);
2747 # if __FreeBSD_version > 410001
2748 /* The leading "-" removes the "perl: " prefix,
2749 * but not the "(perl) suffix from the ps(1)
2750 * output, because that's what ps(1) shows if the
2751 * argv[] is modified. */
2752 setproctitle("-%s", s);
2753 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2754 /* This doesn't really work if you assume that
2755 * $0 = 'foobar'; will wipe out 'perl' from the $0
2756 * because in ps(1) output the result will be like
2757 * sprintf("perl: %s (perl)", s)
2758 * I guess this is a security feature:
2759 * one (a user process) cannot get rid of the original name.
2761 setproctitle("%s", s);
2764 #elif defined(__hpux) && defined(PSTAT_SETCMD)
2765 if (PL_origalen != 1) {
2767 s = SvPV_const(sv, len);
2768 un.pst_command = (char *)s;
2769 pstat(PSTAT_SETCMD, un, len, 0, 0);
2772 if (PL_origalen > 1) {
2773 /* PL_origalen is set in perl_parse(). */
2774 s = SvPV_force(sv,len);
2775 if (len >= (STRLEN)PL_origalen-1) {
2776 /* Longer than original, will be truncated. We assume that
2777 * PL_origalen bytes are available. */
2778 Copy(s, PL_origargv[0], PL_origalen-1, char);
2781 /* Shorter than original, will be padded. */
2783 /* Special case for Mac OS X: see [perl #38868] */
2786 /* Is the space counterintuitive? Yes.
2787 * (You were expecting \0?)
2788 * Does it work? Seems to. (In Linux 2.4.20 at least.)
2790 const int pad = ' ';
2792 Copy(s, PL_origargv[0], len, char);
2793 PL_origargv[0][len] = 0;
2794 memset(PL_origargv[0] + len + 1,
2795 pad, PL_origalen - len - 1);
2797 PL_origargv[0][PL_origalen-1] = 0;
2798 for (i = 1; i < PL_origargc; i++)
2802 UNLOCK_DOLLARZERO_MUTEX;
2809 Perl_whichsig(pTHX_ const char *sig)
2811 register char* const* sigv;
2813 PERL_ARGS_ASSERT_WHICHSIG;
2814 PERL_UNUSED_CONTEXT;
2816 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
2817 if (strEQ(sig,*sigv))
2818 return PL_sig_num[sigv - (char* const*)PL_sig_name];
2820 if (strEQ(sig,"CHLD"))
2824 if (strEQ(sig,"CLD"))
2831 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2832 Perl_sighandler(int sig, siginfo_t *sip, void *uap PERL_UNUSED_DECL)
2834 Perl_sighandler(int sig)
2837 #ifdef PERL_GET_SIG_CONTEXT
2838 dTHXa(PERL_GET_SIG_CONTEXT);
2845 SV * const tSv = PL_Sv;
2849 XPV * const tXpv = PL_Xpv;
2851 if (PL_savestack_ix + 15 <= PL_savestack_max)
2853 if (PL_markstack_ptr < PL_markstack_max - 2)
2855 if (PL_scopestack_ix < PL_scopestack_max - 3)
2858 if (!PL_psig_ptr[sig]) {
2859 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2864 /* Max number of items pushed there is 3*n or 4. We cannot fix
2865 infinity, so we fix 4 (in fact 5): */
2867 PL_savestack_ix += 5; /* Protect save in progress. */
2868 SAVEDESTRUCTOR_X(S_unwind_handler_stack, (void*)&flags);
2871 PL_markstack_ptr++; /* Protect mark. */
2873 PL_scopestack_ix += 1;
2874 /* sv_2cv is too complicated, try a simpler variant first: */
2875 if (!SvROK(PL_psig_ptr[sig]) || !(cv = MUTABLE_CV(SvRV(PL_psig_ptr[sig])))
2876 || SvTYPE(cv) != SVt_PVCV) {
2878 cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
2881 if (!cv || !CvROOT(cv)) {
2882 if (ckWARN(WARN_SIGNAL))
2883 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2884 PL_sig_name[sig], (gv ? GvENAME(gv)
2891 if(PL_psig_name[sig]) {
2892 sv = SvREFCNT_inc_NN(PL_psig_name[sig]);
2894 #if !defined(PERL_IMPLICIT_CONTEXT)
2898 sv = sv_newmortal();
2899 sv_setpv(sv,PL_sig_name[sig]);
2902 PUSHSTACKi(PERLSI_SIGNAL);
2905 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2907 struct sigaction oact;
2909 if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
2912 SV *rv = newRV_noinc(MUTABLE_SV(sih));
2913 /* The siginfo fields signo, code, errno, pid, uid,
2914 * addr, status, and band are defined by POSIX/SUSv3. */
2915 (void)hv_stores(sih, "signo", newSViv(sip->si_signo));
2916 (void)hv_stores(sih, "code", newSViv(sip->si_code));
2917 #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. */
2918 hv_stores(sih, "errno", newSViv(sip->si_errno));
2919 hv_stores(sih, "status", newSViv(sip->si_status));
2920 hv_stores(sih, "uid", newSViv(sip->si_uid));
2921 hv_stores(sih, "pid", newSViv(sip->si_pid));
2922 hv_stores(sih, "addr", newSVuv(PTR2UV(sip->si_addr)));
2923 hv_stores(sih, "band", newSViv(sip->si_band));
2927 mPUSHp((char *)sip, sizeof(*sip));
2935 call_sv(MUTABLE_SV(cv), G_DISCARD|G_EVAL);
2938 if (SvTRUE(ERRSV)) {
2940 #ifdef HAS_SIGPROCMASK
2941 /* Handler "died", for example to get out of a restart-able read().
2942 * Before we re-do that on its behalf re-enable the signal which was
2943 * blocked by the system when we entered.
2947 sigaddset(&set,sig);
2948 sigprocmask(SIG_UNBLOCK, &set, NULL);
2950 /* Not clear if this will work */
2951 (void)rsignal(sig, SIG_IGN);
2952 (void)rsignal(sig, PL_csighandlerp);
2954 #endif /* !PERL_MICRO */
2955 Perl_die(aTHX_ NULL);
2959 PL_savestack_ix -= 8; /* Unprotect save in progress. */
2963 PL_scopestack_ix -= 1;
2966 PL_op = myop; /* Apparently not needed... */
2968 PL_Sv = tSv; /* Restore global temporaries. */
2975 S_restore_magic(pTHX_ const void *p)
2978 MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
2979 SV* const sv = mgs->mgs_sv;
2984 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2986 #ifdef PERL_OLD_COPY_ON_WRITE
2987 /* While magic was saved (and off) sv_setsv may well have seen
2988 this SV as a prime candidate for COW. */
2990 sv_force_normal_flags(sv, 0);
2994 SvFLAGS(sv) |= mgs->mgs_flags;
2997 if (SvGMAGICAL(sv)) {
2998 /* downgrade public flags to private,
2999 and discard any other private flags */
3001 const U32 pubflags = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
3003 SvFLAGS(sv) &= ~( pubflags | (SVp_IOK|SVp_NOK|SVp_POK) );
3004 SvFLAGS(sv) |= ( pubflags << PRIVSHIFT );
3009 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
3011 /* If we're still on top of the stack, pop us off. (That condition
3012 * will be satisfied if restore_magic was called explicitly, but *not*
3013 * if it's being called via leave_scope.)
3014 * The reason for doing this is that otherwise, things like sv_2cv()
3015 * may leave alloc gunk on the savestack, and some code
3016 * (e.g. sighandler) doesn't expect that...
3018 if (PL_savestack_ix == mgs->mgs_ss_ix)
3020 I32 popval = SSPOPINT;
3021 assert(popval == SAVEt_DESTRUCTOR_X);
3022 PL_savestack_ix -= 2;
3024 assert(popval == SAVEt_ALLOC);
3026 PL_savestack_ix -= popval;
3032 S_unwind_handler_stack(pTHX_ const void *p)
3035 const U32 flags = *(const U32*)p;
3037 PERL_ARGS_ASSERT_UNWIND_HANDLER_STACK;
3040 PL_savestack_ix -= 5; /* Unprotect save in progress. */
3041 #if !defined(PERL_IMPLICIT_CONTEXT)
3043 SvREFCNT_dec(PL_sig_sv);
3048 =for apidoc magic_sethint
3050 Triggered by a store to %^H, records the key/value pair to
3051 C<PL_compiling.cop_hints_hash>. It is assumed that hints aren't storing
3052 anything that would need a deep copy. Maybe we should warn if we find a
3058 Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
3061 SV *key = (mg->mg_len == HEf_SVKEY) ? MUTABLE_SV(mg->mg_ptr)
3062 : newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
3064 PERL_ARGS_ASSERT_MAGIC_SETHINT;
3066 /* mg->mg_obj isn't being used. If needed, it would be possible to store
3067 an alternative leaf in there, with PL_compiling.cop_hints being used if
3068 it's NULL. If needed for threads, the alternative could lock a mutex,
3069 or take other more complex action. */
3071 /* Something changed in %^H, so it will need to be restored on scope exit.
3072 Doing this here saves a lot of doing it manually in perl code (and
3073 forgetting to do it, and consequent subtle errors. */
3074 PL_hints |= HINT_LOCALIZE_HH;
3075 PL_compiling.cop_hints_hash
3076 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash, key, sv);
3081 =for apidoc magic_clearhint
3083 Triggered by a delete from %^H, records the key to
3084 C<PL_compiling.cop_hints_hash>.
3089 Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
3093 PERL_ARGS_ASSERT_MAGIC_CLEARHINT;
3094 PERL_UNUSED_ARG(sv);
3096 assert(mg->mg_len == HEf_SVKEY);
3098 PERL_UNUSED_ARG(sv);
3100 PL_hints |= HINT_LOCALIZE_HH;
3101 PL_compiling.cop_hints_hash
3102 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
3103 MUTABLE_SV(mg->mg_ptr), &PL_sv_placeholder);
3109 * c-indentation-style: bsd
3111 * indent-tabs-mode: t
3114 * ex: set ts=8 sts=4 sw=4 noet: