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 SvUPGRADE(sv, SVt_PVLV);
981 LvTARGOFF(sv) = PL_statusvalue;
982 LvTARGLEN(sv) = PL_statusvalue_vms;
987 if (GvIOp(PL_defoutgv))
988 s = IoTOP_NAME(GvIOp(PL_defoutgv));
992 sv_setpv(sv,GvENAME(PL_defoutgv));
993 sv_catpvs(sv,"_TOP");
997 if (GvIOp(PL_defoutgv))
998 s = IoFMT_NAME(GvIOp(PL_defoutgv));
1000 s = GvENAME(PL_defoutgv);
1004 if (GvIOp(PL_defoutgv))
1005 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
1008 if (GvIOp(PL_defoutgv))
1009 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
1012 if (GvIOp(PL_defoutgv))
1013 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
1020 sv_setiv(sv, (IV)CopARYBASE_get(PL_curcop));
1023 if (GvIOp(PL_defoutgv))
1024 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
1028 sv_copypv(sv, PL_ors_sv);
1032 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
1033 sv_setpv(sv, errno ? Strerror(errno) : "");
1037 sv_setnv(sv, (NV)errno);
1039 if (errno == errno_isOS2 || errno == errno_isOS2_set)
1040 sv_setpv(sv, os2error(Perl_rc));
1043 sv_setpv(sv, errno ? Strerror(errno) : "");
1048 SvNOK_on(sv); /* what a wonderful hack! */
1051 sv_setiv(sv, (IV)PL_uid);
1054 sv_setiv(sv, (IV)PL_euid);
1057 sv_setiv(sv, (IV)PL_gid);
1060 sv_setiv(sv, (IV)PL_egid);
1062 #ifdef HAS_GETGROUPS
1064 Groups_t *gary = NULL;
1065 I32 i, num_groups = getgroups(0, gary);
1066 Newx(gary, num_groups, Groups_t);
1067 num_groups = getgroups(num_groups, gary);
1068 for (i = 0; i < num_groups; i++)
1069 Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]);
1072 (void)SvIOK_on(sv); /* what a wonderful hack! */
1082 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
1084 struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
1086 PERL_ARGS_ASSERT_MAGIC_GETUVAR;
1088 if (uf && uf->uf_val)
1089 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
1094 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
1097 STRLEN len = 0, klen;
1098 const char *s = SvOK(sv) ? SvPV_const(sv,len) : "";
1099 const char * const ptr = MgPV_const(mg,klen);
1102 PERL_ARGS_ASSERT_MAGIC_SETENV;
1104 #ifdef DYNAMIC_ENV_FETCH
1105 /* We just undefd an environment var. Is a replacement */
1106 /* waiting in the wings? */
1108 SV ** const valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE);
1110 s = SvOK(*valp) ? SvPV_const(*valp, len) : "";
1114 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
1115 /* And you'll never guess what the dog had */
1116 /* in its mouth... */
1118 MgTAINTEDDIR_off(mg);
1120 if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
1121 char pathbuf[256], eltbuf[256], *cp, *elt;
1125 my_strlcpy(eltbuf, s, sizeof(eltbuf));
1127 do { /* DCL$PATH may be a search list */
1128 while (1) { /* as may dev portion of any element */
1129 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1130 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1131 cando_by_name(S_IWUSR,0,elt) ) {
1132 MgTAINTEDDIR_on(mg);
1136 if ((cp = strchr(elt, ':')) != NULL)
1138 if (my_trnlnm(elt, eltbuf, j++))
1144 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1147 if (s && klen == 4 && strEQ(ptr,"PATH")) {
1148 const char * const strend = s + len;
1150 while (s < strend) {
1154 #ifdef VMS /* Hmm. How do we get $Config{path_sep} from C? */
1155 const char path_sep = '|';
1157 const char path_sep = ':';
1159 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
1160 s, strend, path_sep, &i);
1162 if (i >= (I32)sizeof tmpbuf /* too long -- assume the worst */
1164 || !strchr(tmpbuf, ':') /* no colon thus no device name -- assume relative path */
1166 || *tmpbuf != '/' /* no starting slash -- assume relative path */
1168 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1169 MgTAINTEDDIR_on(mg);
1175 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1181 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1183 PERL_ARGS_ASSERT_MAGIC_CLEARENV;
1184 PERL_UNUSED_ARG(sv);
1185 my_setenv(MgPV_nolen_const(mg),NULL);
1190 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1193 PERL_ARGS_ASSERT_MAGIC_SET_ALL_ENV;
1194 PERL_UNUSED_ARG(mg);
1196 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1198 if (PL_localizing) {
1201 hv_iterinit(MUTABLE_HV(sv));
1202 while ((entry = hv_iternext(MUTABLE_HV(sv)))) {
1204 my_setenv(hv_iterkey(entry, &keylen),
1205 SvPV_nolen_const(hv_iterval(MUTABLE_HV(sv), entry)));
1213 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1216 PERL_ARGS_ASSERT_MAGIC_CLEAR_ALL_ENV;
1217 PERL_UNUSED_ARG(sv);
1218 PERL_UNUSED_ARG(mg);
1220 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1228 #ifdef HAS_SIGPROCMASK
1230 restore_sigmask(pTHX_ SV *save_sv)
1232 const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1233 (void)sigprocmask(SIG_SETMASK, ossetp, NULL);
1237 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1240 /* Are we fetching a signal entry? */
1241 int i = (I16)mg->mg_private;
1243 PERL_ARGS_ASSERT_MAGIC_GETSIG;
1246 mg->mg_private = i = whichsig(MgPV_nolen_const(mg));
1251 sv_setsv(sv,PL_psig_ptr[i]);
1253 Sighandler_t sigstate = rsignal_state(i);
1254 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1255 if (PL_sig_handlers_initted && PL_sig_ignoring[i])
1258 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1259 if (PL_sig_handlers_initted && PL_sig_defaulting[i])
1262 /* cache state so we don't fetch it again */
1263 if(sigstate == (Sighandler_t) SIG_IGN)
1264 sv_setpvs(sv,"IGNORE");
1266 sv_setsv(sv,&PL_sv_undef);
1267 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1274 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1276 PERL_ARGS_ASSERT_MAGIC_CLEARSIG;
1277 PERL_UNUSED_ARG(sv);
1279 magic_setsig(NULL, mg);
1280 return sv_unmagic(sv, mg->mg_type);
1284 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1285 Perl_csighandler(int sig, siginfo_t *sip PERL_UNUSED_DECL, void *uap PERL_UNUSED_DECL)
1287 Perl_csighandler(int sig)
1290 #ifdef PERL_GET_SIG_CONTEXT
1291 dTHXa(PERL_GET_SIG_CONTEXT);
1295 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1296 (void) rsignal(sig, PL_csighandlerp);
1297 if (PL_sig_ignoring[sig]) return;
1299 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1300 if (PL_sig_defaulting[sig])
1301 #ifdef KILL_BY_SIGPRC
1302 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1317 (PL_signals & PERL_SIGNALS_UNSAFE_FLAG))
1318 /* Call the perl level handler now--
1319 * with risk we may be in malloc() or being destructed etc. */
1320 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1321 (*PL_sighandlerp)(sig, NULL, NULL);
1323 (*PL_sighandlerp)(sig);
1326 if (!PL_psig_pend) return;
1327 /* Set a flag to say this signal is pending, that is awaiting delivery after
1328 * the current Perl opcode completes */
1329 PL_psig_pend[sig]++;
1331 #ifndef SIG_PENDING_DIE_COUNT
1332 # define SIG_PENDING_DIE_COUNT 120
1334 /* Add one to say _a_ signal is pending */
1335 if (++PL_sig_pending >= SIG_PENDING_DIE_COUNT)
1336 Perl_croak(aTHX_ "Maximal count of pending signals (%lu) exceeded",
1337 (unsigned long)SIG_PENDING_DIE_COUNT);
1341 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1343 Perl_csighandler_init(void)
1346 if (PL_sig_handlers_initted) return;
1348 for (sig = 1; sig < SIG_SIZE; sig++) {
1349 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1351 PL_sig_defaulting[sig] = 1;
1352 (void) rsignal(sig, PL_csighandlerp);
1354 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1355 PL_sig_ignoring[sig] = 0;
1358 PL_sig_handlers_initted = 1;
1363 Perl_despatch_signals(pTHX)
1368 for (sig = 1; sig < SIG_SIZE; sig++) {
1369 if (PL_psig_pend[sig]) {
1370 PERL_BLOCKSIG_ADD(set, sig);
1371 PL_psig_pend[sig] = 0;
1372 PERL_BLOCKSIG_BLOCK(set);
1373 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1374 (*PL_sighandlerp)(sig, NULL, NULL);
1376 (*PL_sighandlerp)(sig);
1378 PERL_BLOCKSIG_UNBLOCK(set);
1383 /* sv of NULL signifies that we're acting as magic_clearsig. */
1385 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1390 /* Need to be careful with SvREFCNT_dec(), because that can have side
1391 * effects (due to closures). We must make sure that the new disposition
1392 * is in place before it is called.
1396 #ifdef HAS_SIGPROCMASK
1400 register const char *s = MgPV_const(mg,len);
1402 PERL_ARGS_ASSERT_MAGIC_SETSIG;
1405 if (strEQ(s,"__DIE__"))
1407 else if (strEQ(s,"__WARN__")
1408 && (sv ? 1 : PL_warnhook != PERL_WARNHOOK_FATAL)) {
1409 /* Merge the existing behaviours, which are as follows:
1410 magic_setsig, we always set svp to &PL_warnhook
1411 (hence we always change the warnings handler)
1412 For magic_clearsig, we don't change the warnings handler if it's
1413 set to the &PL_warnhook. */
1416 Perl_croak(aTHX_ "No such hook: %s", s);
1419 if (*svp != PERL_WARNHOOK_FATAL)
1425 i = (I16)mg->mg_private;
1427 i = whichsig(s); /* ...no, a brick */
1428 mg->mg_private = (U16)i;
1431 if (sv && ckWARN(WARN_SIGNAL))
1432 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
1435 #ifdef HAS_SIGPROCMASK
1436 /* Avoid having the signal arrive at a bad time, if possible. */
1439 sigprocmask(SIG_BLOCK, &set, &save);
1441 save_sv = newSVpvn((char *)(&save), sizeof(sigset_t));
1442 SAVEFREESV(save_sv);
1443 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1446 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1447 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1449 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1450 PL_sig_ignoring[i] = 0;
1452 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1453 PL_sig_defaulting[i] = 0;
1455 to_dec = PL_psig_ptr[i];
1457 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1458 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1460 /* Signals don't change name during the program's execution, so once
1461 they're cached in the appropriate slot of PL_psig_name, they can
1464 Ideally we'd find some way of making SVs at (C) compile time, or
1465 at least, doing most of the work. */
1466 if (!PL_psig_name[i]) {
1467 PL_psig_name[i] = newSVpvn(s, len);
1468 SvREADONLY_on(PL_psig_name[i]);
1471 SvREFCNT_dec(PL_psig_name[i]);
1472 PL_psig_name[i] = NULL;
1473 PL_psig_ptr[i] = NULL;
1476 if (sv && (isGV_with_GP(sv) || SvROK(sv))) {
1478 (void)rsignal(i, PL_csighandlerp);
1481 *svp = SvREFCNT_inc_simple_NN(sv);
1483 if (sv && SvOK(sv)) {
1484 s = SvPV_force(sv, len);
1488 if (sv && strEQ(s,"IGNORE")) {
1490 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1491 PL_sig_ignoring[i] = 1;
1492 (void)rsignal(i, PL_csighandlerp);
1494 (void)rsignal(i, (Sighandler_t) SIG_IGN);
1498 else if (!sv || strEQ(s,"DEFAULT") || !len) {
1500 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1501 PL_sig_defaulting[i] = 1;
1502 (void)rsignal(i, PL_csighandlerp);
1504 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1510 * We should warn if HINT_STRICT_REFS, but without
1511 * access to a known hint bit in a known OP, we can't
1512 * tell whether HINT_STRICT_REFS is in force or not.
1514 if (!strchr(s,':') && !strchr(s,'\''))
1515 Perl_sv_insert_flags(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"),
1518 (void)rsignal(i, PL_csighandlerp);
1520 *svp = SvREFCNT_inc_simple_NN(sv);
1524 #ifdef HAS_SIGPROCMASK
1529 SvREFCNT_dec(to_dec);
1532 #endif /* !PERL_MICRO */
1535 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1538 PERL_ARGS_ASSERT_MAGIC_SETISA;
1539 PERL_UNUSED_ARG(sv);
1541 /* Skip _isaelem because _isa will handle it shortly */
1542 if (PL_delaymagic & DM_ARRAY && mg->mg_type == PERL_MAGIC_isaelem)
1545 return magic_clearisa(NULL, mg);
1548 /* sv of NULL signifies that we're acting as magic_setisa. */
1550 Perl_magic_clearisa(pTHX_ SV *sv, MAGIC *mg)
1555 PERL_ARGS_ASSERT_MAGIC_CLEARISA;
1557 /* Bail out if destruction is going on */
1558 if(PL_dirty) return 0;
1561 av_clear(MUTABLE_AV(sv));
1563 /* XXX Once it's possible, we need to
1564 detect that our @ISA is aliased in
1565 other stashes, and act on the stashes
1566 of all of the aliases */
1568 /* The first case occurs via setisa,
1569 the second via setisa_elem, which
1570 calls this same magic */
1572 SvTYPE(mg->mg_obj) == SVt_PVGV
1573 ? (const GV *)mg->mg_obj
1574 : (const GV *)mg_find(mg->mg_obj, PERL_MAGIC_isa)->mg_obj
1578 mro_isa_changed_in(stash);
1584 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
1587 PERL_ARGS_ASSERT_MAGIC_SETAMAGIC;
1588 PERL_UNUSED_ARG(sv);
1589 PERL_UNUSED_ARG(mg);
1590 PL_amagic_generation++;
1596 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1598 HV * const hv = MUTABLE_HV(LvTARG(sv));
1601 PERL_ARGS_ASSERT_MAGIC_GETNKEYS;
1602 PERL_UNUSED_ARG(mg);
1605 (void) hv_iterinit(hv);
1606 if (! SvTIED_mg((const SV *)hv, PERL_MAGIC_tied))
1609 while (hv_iternext(hv))
1614 sv_setiv(sv, (IV)i);
1619 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1621 PERL_ARGS_ASSERT_MAGIC_SETNKEYS;
1622 PERL_UNUSED_ARG(mg);
1624 hv_ksplit(MUTABLE_HV(LvTARG(sv)), SvIV(sv));
1629 /* caller is responsible for stack switching/cleanup */
1631 S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV *val)
1636 PERL_ARGS_ASSERT_MAGIC_METHCALL;
1640 PUSHs(SvTIED_obj(sv, mg));
1643 if (mg->mg_len >= 0)
1644 mPUSHp(mg->mg_ptr, mg->mg_len);
1645 else if (mg->mg_len == HEf_SVKEY)
1646 PUSHs(MUTABLE_SV(mg->mg_ptr));
1648 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1657 return call_method(meth, flags);
1661 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
1665 PERL_ARGS_ASSERT_MAGIC_METHPACK;
1669 PUSHSTACKi(PERLSI_MAGIC);
1671 if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
1672 sv_setsv(sv, *PL_stack_sp--);
1682 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1684 PERL_ARGS_ASSERT_MAGIC_GETPACK;
1687 mg->mg_flags |= MGf_GSKIP;
1688 magic_methpack(sv,mg,"FETCH");
1693 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1697 PERL_ARGS_ASSERT_MAGIC_SETPACK;
1700 PUSHSTACKi(PERLSI_MAGIC);
1701 magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
1708 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1710 PERL_ARGS_ASSERT_MAGIC_CLEARPACK;
1712 return magic_methpack(sv,mg,"DELETE");
1717 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1722 PERL_ARGS_ASSERT_MAGIC_SIZEPACK;
1726 PUSHSTACKi(PERLSI_MAGIC);
1727 if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
1728 sv = *PL_stack_sp--;
1729 retval = SvIV(sv)-1;
1731 Perl_croak(aTHX_ "FETCHSIZE returned a negative value");
1736 return (U32) retval;
1740 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1744 PERL_ARGS_ASSERT_MAGIC_WIPEPACK;
1747 PUSHSTACKi(PERLSI_MAGIC);
1749 XPUSHs(SvTIED_obj(sv, mg));
1751 call_method("CLEAR", G_SCALAR|G_DISCARD);
1759 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1762 const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
1764 PERL_ARGS_ASSERT_MAGIC_NEXTPACK;
1768 PUSHSTACKi(PERLSI_MAGIC);
1771 PUSHs(SvTIED_obj(sv, mg));
1776 if (call_method(meth, G_SCALAR))
1777 sv_setsv(key, *PL_stack_sp--);
1786 Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg)
1788 PERL_ARGS_ASSERT_MAGIC_EXISTSPACK;
1790 return magic_methpack(sv,mg,"EXISTS");
1794 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1798 SV * const tied = SvTIED_obj(MUTABLE_SV(hv), mg);
1799 HV * const pkg = SvSTASH((const SV *)SvRV(tied));
1801 PERL_ARGS_ASSERT_MAGIC_SCALARPACK;
1803 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1805 if (HvEITER_get(hv))
1806 /* we are in an iteration so the hash cannot be empty */
1808 /* no xhv_eiter so now use FIRSTKEY */
1809 key = sv_newmortal();
1810 magic_nextpack(MUTABLE_SV(hv), mg, key);
1811 HvEITER_set(hv, NULL); /* need to reset iterator */
1812 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1815 /* there is a SCALAR method that we can call */
1817 PUSHSTACKi(PERLSI_MAGIC);
1823 if (call_method("SCALAR", G_SCALAR))
1824 retval = *PL_stack_sp--;
1826 retval = &PL_sv_undef;
1833 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1836 GV * const gv = PL_DBline;
1837 const I32 i = SvTRUE(sv);
1838 SV ** const svp = av_fetch(GvAV(gv),
1839 atoi(MgPV_nolen_const(mg)), FALSE);
1841 PERL_ARGS_ASSERT_MAGIC_SETDBLINE;
1843 if (svp && SvIOKp(*svp)) {
1844 OP * const o = INT2PTR(OP*,SvIVX(*svp));
1846 /* set or clear breakpoint in the relevant control op */
1848 o->op_flags |= OPf_SPECIAL;
1850 o->op_flags &= ~OPf_SPECIAL;
1857 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
1860 AV * const obj = MUTABLE_AV(mg->mg_obj);
1862 PERL_ARGS_ASSERT_MAGIC_GETARYLEN;
1865 sv_setiv(sv, AvFILL(obj) + CopARYBASE_get(PL_curcop));
1873 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
1876 AV * const obj = MUTABLE_AV(mg->mg_obj);
1878 PERL_ARGS_ASSERT_MAGIC_SETARYLEN;
1881 av_fill(obj, SvIV(sv) - CopARYBASE_get(PL_curcop));
1883 if (ckWARN(WARN_MISC))
1884 Perl_warner(aTHX_ packWARN(WARN_MISC),
1885 "Attempt to set length of freed array");
1891 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
1895 PERL_ARGS_ASSERT_MAGIC_FREEARYLEN_P;
1896 PERL_UNUSED_ARG(sv);
1898 /* during global destruction, mg_obj may already have been freed */
1899 if (PL_in_clean_all)
1902 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
1905 /* arylen scalar holds a pointer back to the array, but doesn't own a
1906 reference. Hence the we (the array) are about to go away with it
1907 still pointing at us. Clear its pointer, else it would be pointing
1908 at free memory. See the comment in sv_magic about reference loops,
1909 and why it can't own a reference to us. */
1916 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
1919 SV* const lsv = LvTARG(sv);
1921 PERL_ARGS_ASSERT_MAGIC_GETPOS;
1922 PERL_UNUSED_ARG(mg);
1924 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1925 MAGIC * const found = mg_find(lsv, PERL_MAGIC_regex_global);
1926 if (found && found->mg_len >= 0) {
1927 I32 i = found->mg_len;
1929 sv_pos_b2u(lsv, &i);
1930 sv_setiv(sv, i + CopARYBASE_get(PL_curcop));
1939 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
1942 SV* const lsv = LvTARG(sv);
1948 PERL_ARGS_ASSERT_MAGIC_SETPOS;
1949 PERL_UNUSED_ARG(mg);
1951 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
1952 found = mg_find(lsv, PERL_MAGIC_regex_global);
1958 #ifdef PERL_OLD_COPY_ON_WRITE
1960 sv_force_normal_flags(lsv, 0);
1962 found = sv_magicext(lsv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
1965 else if (!SvOK(sv)) {
1969 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1971 pos = SvIV(sv) - CopARYBASE_get(PL_curcop);
1974 ulen = sv_len_utf8(lsv);
1984 else if (pos > (SSize_t)len)
1989 sv_pos_u2b(lsv, &p, 0);
1993 found->mg_len = pos;
1994 found->mg_flags &= ~MGf_MINMATCH;
2000 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
2003 SV * const lsv = LvTARG(sv);
2004 const char * const tmps = SvPV_const(lsv,len);
2005 I32 offs = LvTARGOFF(sv);
2006 I32 rem = LvTARGLEN(sv);
2008 PERL_ARGS_ASSERT_MAGIC_GETSUBSTR;
2009 PERL_UNUSED_ARG(mg);
2012 sv_pos_u2b(lsv, &offs, &rem);
2013 if (offs > (I32)len)
2015 if (rem + offs > (I32)len)
2017 sv_setpvn(sv, tmps + offs, (STRLEN)rem);
2024 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
2028 const char * const tmps = SvPV_const(sv, len);
2029 SV * const lsv = LvTARG(sv);
2030 I32 lvoff = LvTARGOFF(sv);
2031 I32 lvlen = LvTARGLEN(sv);
2033 PERL_ARGS_ASSERT_MAGIC_SETSUBSTR;
2034 PERL_UNUSED_ARG(mg);
2037 sv_utf8_upgrade(lsv);
2038 sv_pos_u2b(lsv, &lvoff, &lvlen);
2039 sv_insert(lsv, lvoff, lvlen, tmps, len);
2040 LvTARGLEN(sv) = sv_len_utf8(sv);
2043 else if (lsv && SvUTF8(lsv)) {
2045 sv_pos_u2b(lsv, &lvoff, &lvlen);
2046 LvTARGLEN(sv) = len;
2047 utf8 = (char*)bytes_to_utf8((U8*)tmps, &len);
2048 sv_insert(lsv, lvoff, lvlen, utf8, len);
2052 sv_insert(lsv, lvoff, lvlen, tmps, len);
2053 LvTARGLEN(sv) = len;
2061 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
2065 PERL_ARGS_ASSERT_MAGIC_GETTAINT;
2066 PERL_UNUSED_ARG(sv);
2068 TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
2073 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
2077 PERL_ARGS_ASSERT_MAGIC_SETTAINT;
2078 PERL_UNUSED_ARG(sv);
2080 /* update taint status */
2089 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
2091 SV * const lsv = LvTARG(sv);
2093 PERL_ARGS_ASSERT_MAGIC_GETVEC;
2094 PERL_UNUSED_ARG(mg);
2097 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
2105 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
2107 PERL_ARGS_ASSERT_MAGIC_SETVEC;
2108 PERL_UNUSED_ARG(mg);
2109 do_vecset(sv); /* XXX slurp this routine */
2114 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
2119 PERL_ARGS_ASSERT_MAGIC_GETDEFELEM;
2121 if (LvTARGLEN(sv)) {
2123 SV * const ahv = LvTARG(sv);
2124 HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, FALSE, 0);
2129 AV *const av = MUTABLE_AV(LvTARG(sv));
2130 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
2131 targ = AvARRAY(av)[LvTARGOFF(sv)];
2133 if (targ && (targ != &PL_sv_undef)) {
2134 /* somebody else defined it for us */
2135 SvREFCNT_dec(LvTARG(sv));
2136 LvTARG(sv) = SvREFCNT_inc_simple_NN(targ);
2138 SvREFCNT_dec(mg->mg_obj);
2140 mg->mg_flags &= ~MGf_REFCOUNTED;
2145 sv_setsv(sv, targ ? targ : &PL_sv_undef);
2150 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
2152 PERL_ARGS_ASSERT_MAGIC_SETDEFELEM;
2153 PERL_UNUSED_ARG(mg);
2157 sv_setsv(LvTARG(sv), sv);
2158 SvSETMAGIC(LvTARG(sv));
2164 Perl_vivify_defelem(pTHX_ SV *sv)
2170 PERL_ARGS_ASSERT_VIVIFY_DEFELEM;
2172 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2175 SV * const ahv = LvTARG(sv);
2176 HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, TRUE, 0);
2179 if (!value || value == &PL_sv_undef)
2180 Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(mg->mg_obj));
2183 AV *const av = MUTABLE_AV(LvTARG(sv));
2184 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
2185 LvTARG(sv) = NULL; /* array can't be extended */
2187 SV* const * const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
2188 if (!svp || (value = *svp) == &PL_sv_undef)
2189 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
2192 SvREFCNT_inc_simple_void(value);
2193 SvREFCNT_dec(LvTARG(sv));
2196 SvREFCNT_dec(mg->mg_obj);
2198 mg->mg_flags &= ~MGf_REFCOUNTED;
2202 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2204 PERL_ARGS_ASSERT_MAGIC_KILLBACKREFS;
2205 return Perl_sv_kill_backrefs(aTHX_ sv, MUTABLE_AV(mg->mg_obj));
2209 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2211 PERL_ARGS_ASSERT_MAGIC_SETMGLOB;
2212 PERL_UNUSED_CONTEXT;
2219 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2221 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2223 PERL_ARGS_ASSERT_MAGIC_SETUVAR;
2225 if (uf && uf->uf_set)
2226 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2231 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2233 const char type = mg->mg_type;
2235 PERL_ARGS_ASSERT_MAGIC_SETREGEXP;
2237 if (type == PERL_MAGIC_qr) {
2238 } else if (type == PERL_MAGIC_bm) {
2242 assert(type == PERL_MAGIC_fm);
2245 return sv_unmagic(sv, type);
2248 #ifdef USE_LOCALE_COLLATE
2250 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2252 PERL_ARGS_ASSERT_MAGIC_SETCOLLXFRM;
2255 * RenE<eacute> Descartes said "I think not."
2256 * and vanished with a faint plop.
2258 PERL_UNUSED_CONTEXT;
2259 PERL_UNUSED_ARG(sv);
2261 Safefree(mg->mg_ptr);
2267 #endif /* USE_LOCALE_COLLATE */
2269 /* Just clear the UTF-8 cache data. */
2271 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2273 PERL_ARGS_ASSERT_MAGIC_SETUTF8;
2274 PERL_UNUSED_CONTEXT;
2275 PERL_UNUSED_ARG(sv);
2276 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2278 mg->mg_len = -1; /* The mg_len holds the len cache. */
2283 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2286 register const char *s;
2288 register const REGEXP * rx;
2289 const char * const remaining = mg->mg_ptr + 1;
2293 PERL_ARGS_ASSERT_MAGIC_SET;
2295 switch (*mg->mg_ptr) {
2296 case '\015': /* $^MATCH */
2297 if (strEQ(remaining, "ATCH"))
2299 case '`': /* ${^PREMATCH} caught below */
2301 paren = RX_BUFF_IDX_PREMATCH;
2303 case '\'': /* ${^POSTMATCH} caught below */
2305 paren = RX_BUFF_IDX_POSTMATCH;
2309 paren = RX_BUFF_IDX_FULLMATCH;
2311 case '1': case '2': case '3': case '4':
2312 case '5': case '6': case '7': case '8': case '9':
2313 paren = atoi(mg->mg_ptr);
2315 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
2316 CALLREG_NUMBUF_STORE((REGEXP * const)rx,paren,sv);
2319 /* Croak with a READONLY error when a numbered match var is
2320 * set without a previous pattern match. Unless it's C<local $1>
2322 if (!PL_localizing) {
2323 Perl_croak(aTHX_ "%s", PL_no_modify);
2326 case '\001': /* ^A */
2327 sv_setsv(PL_bodytarget, sv);
2329 case '\003': /* ^C */
2330 PL_minus_c = (bool)SvIV(sv);
2333 case '\004': /* ^D */
2335 s = SvPV_nolen_const(sv);
2336 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2337 if (DEBUG_x_TEST || DEBUG_B_TEST)
2338 dump_all_perl(!DEBUG_B_TEST);
2340 PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG;
2343 case '\005': /* ^E */
2344 if (*(mg->mg_ptr+1) == '\0') {
2346 set_vaxc_errno(SvIV(sv));
2349 SetLastError( SvIV(sv) );
2352 os2_setsyserrno(SvIV(sv));
2354 /* will anyone ever use this? */
2355 SETERRNO(SvIV(sv), 4);
2360 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2362 SvREFCNT_dec(PL_encoding);
2363 if (SvOK(sv) || SvGMAGICAL(sv)) {
2364 PL_encoding = newSVsv(sv);
2371 case '\006': /* ^F */
2372 PL_maxsysfd = SvIV(sv);
2374 case '\010': /* ^H */
2375 PL_hints = SvIV(sv);
2377 case '\011': /* ^I */ /* NOT \t in EBCDIC */
2378 Safefree(PL_inplace);
2379 PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
2381 case '\017': /* ^O */
2382 if (*(mg->mg_ptr+1) == '\0') {
2383 Safefree(PL_osname);
2386 TAINT_PROPER("assigning to $^O");
2387 PL_osname = savesvpv(sv);
2390 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2392 const char *const start = SvPV(sv, len);
2393 const char *out = (const char*)memchr(start, '\0', len);
2397 PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2398 PL_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2400 /* Opening for input is more common than opening for output, so
2401 ensure that hints for input are sooner on linked list. */
2402 tmp = out ? newSVpvn_flags(out + 1, start + len - out - 1,
2404 : newSVpvs_flags("", SvUTF8(sv));
2405 (void)hv_stores(GvHV(PL_hintgv), "open>", tmp);
2408 tmp = newSVpvn_flags(start, out ? (STRLEN)(out - start) : len,
2410 (void)hv_stores(GvHV(PL_hintgv), "open<", tmp);
2414 case '\020': /* ^P */
2415 if (*remaining == '\0') { /* ^P */
2416 PL_perldb = SvIV(sv);
2417 if (PL_perldb && !PL_DBsingle)
2420 } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
2422 } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
2425 case '\024': /* ^T */
2427 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2429 PL_basetime = (Time_t)SvIV(sv);
2432 case '\025': /* ^UTF8CACHE */
2433 if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
2434 PL_utf8cache = (signed char) sv_2iv(sv);
2437 case '\027': /* ^W & $^WARNING_BITS */
2438 if (*(mg->mg_ptr+1) == '\0') {
2439 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2441 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2442 | (i ? G_WARN_ON : G_WARN_OFF) ;
2445 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2446 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2447 if (!SvPOK(sv) && PL_localizing) {
2448 sv_setpvn(sv, WARN_NONEstring, WARNsize);
2449 PL_compiling.cop_warnings = pWARN_NONE;
2454 int accumulate = 0 ;
2455 int any_fatals = 0 ;
2456 const char * const ptr = SvPV_const(sv, len) ;
2457 for (i = 0 ; i < len ; ++i) {
2458 accumulate |= ptr[i] ;
2459 any_fatals |= (ptr[i] & 0xAA) ;
2462 if (!specialWARN(PL_compiling.cop_warnings))
2463 PerlMemShared_free(PL_compiling.cop_warnings);
2464 PL_compiling.cop_warnings = pWARN_NONE;
2466 /* Yuck. I can't see how to abstract this: */
2467 else if (isWARN_on(((STRLEN *)SvPV_nolen_const(sv)) - 1,
2468 WARN_ALL) && !any_fatals) {
2469 if (!specialWARN(PL_compiling.cop_warnings))
2470 PerlMemShared_free(PL_compiling.cop_warnings);
2471 PL_compiling.cop_warnings = pWARN_ALL;
2472 PL_dowarn |= G_WARN_ONCE ;
2476 const char *const p = SvPV_const(sv, len);
2478 PL_compiling.cop_warnings
2479 = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
2482 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2483 PL_dowarn |= G_WARN_ONCE ;
2491 if (PL_localizing) {
2492 if (PL_localizing == 1)
2493 SAVESPTR(PL_last_in_gv);
2495 else if (SvOK(sv) && GvIO(PL_last_in_gv))
2496 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2499 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2500 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2501 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2504 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2505 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2506 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2509 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
2512 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
2513 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2514 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2517 IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
2521 IO * const io = GvIOp(PL_defoutgv);
2524 if ((SvIV(sv)) == 0)
2525 IoFLAGS(io) &= ~IOf_FLUSH;
2527 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2528 PerlIO *ofp = IoOFP(io);
2530 (void)PerlIO_flush(ofp);
2531 IoFLAGS(io) |= IOf_FLUSH;
2537 SvREFCNT_dec(PL_rs);
2538 PL_rs = newSVsv(sv);
2542 SvREFCNT_dec(PL_ors_sv);
2543 if (SvOK(sv) || SvGMAGICAL(sv)) {
2544 PL_ors_sv = newSVsv(sv);
2551 CopARYBASE_set(&PL_compiling, SvIV(sv));
2554 #ifdef COMPLEX_STATUS
2555 if (PL_localizing == 2) {
2556 SvUPGRADE(sv, SVt_PVLV);
2557 PL_statusvalue = LvTARGOFF(sv);
2558 PL_statusvalue_vms = LvTARGLEN(sv);
2562 #ifdef VMSISH_STATUS
2564 STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2567 STATUS_UNIX_EXIT_SET(SvIV(sv));
2572 # define PERL_VMS_BANG vaxc$errno
2574 # define PERL_VMS_BANG 0
2576 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2577 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2582 if (PL_delaymagic) {
2583 PL_delaymagic |= DM_RUID;
2584 break; /* don't do magic till later */
2587 (void)setruid((Uid_t)PL_uid);
2590 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2592 #ifdef HAS_SETRESUID
2593 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2595 if (PL_uid == PL_euid) { /* special case $< = $> */
2597 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2598 if (PL_uid != 0 && PerlProc_getuid() == 0)
2599 (void)PerlProc_setuid(0);
2601 (void)PerlProc_setuid(PL_uid);
2603 PL_uid = PerlProc_getuid();
2604 Perl_croak(aTHX_ "setruid() not implemented");
2609 PL_uid = PerlProc_getuid();
2610 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2614 if (PL_delaymagic) {
2615 PL_delaymagic |= DM_EUID;
2616 break; /* don't do magic till later */
2619 (void)seteuid((Uid_t)PL_euid);
2622 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2624 #ifdef HAS_SETRESUID
2625 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2627 if (PL_euid == PL_uid) /* special case $> = $< */
2628 PerlProc_setuid(PL_euid);
2630 PL_euid = PerlProc_geteuid();
2631 Perl_croak(aTHX_ "seteuid() not implemented");
2636 PL_euid = PerlProc_geteuid();
2637 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2641 if (PL_delaymagic) {
2642 PL_delaymagic |= DM_RGID;
2643 break; /* don't do magic till later */
2646 (void)setrgid((Gid_t)PL_gid);
2649 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2651 #ifdef HAS_SETRESGID
2652 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2654 if (PL_gid == PL_egid) /* special case $( = $) */
2655 (void)PerlProc_setgid(PL_gid);
2657 PL_gid = PerlProc_getgid();
2658 Perl_croak(aTHX_ "setrgid() not implemented");
2663 PL_gid = PerlProc_getgid();
2664 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2667 #ifdef HAS_SETGROUPS
2669 const char *p = SvPV_const(sv, len);
2670 Groups_t *gary = NULL;
2675 for (i = 0; i < NGROUPS; ++i) {
2676 while (*p && !isSPACE(*p))
2683 Newx(gary, i + 1, Groups_t);
2685 Renew(gary, i + 1, Groups_t);
2689 (void)setgroups(i, gary);
2692 #else /* HAS_SETGROUPS */
2694 #endif /* HAS_SETGROUPS */
2695 if (PL_delaymagic) {
2696 PL_delaymagic |= DM_EGID;
2697 break; /* don't do magic till later */
2700 (void)setegid((Gid_t)PL_egid);
2703 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2705 #ifdef HAS_SETRESGID
2706 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2708 if (PL_egid == PL_gid) /* special case $) = $( */
2709 (void)PerlProc_setgid(PL_egid);
2711 PL_egid = PerlProc_getegid();
2712 Perl_croak(aTHX_ "setegid() not implemented");
2717 PL_egid = PerlProc_getegid();
2718 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2721 PL_chopset = SvPV_force(sv,len);
2724 LOCK_DOLLARZERO_MUTEX;
2725 #ifdef HAS_SETPROCTITLE
2726 /* The BSDs don't show the argv[] in ps(1) output, they
2727 * show a string from the process struct and provide
2728 * the setproctitle() routine to manipulate that. */
2729 if (PL_origalen != 1) {
2730 s = SvPV_const(sv, len);
2731 # if __FreeBSD_version > 410001
2732 /* The leading "-" removes the "perl: " prefix,
2733 * but not the "(perl) suffix from the ps(1)
2734 * output, because that's what ps(1) shows if the
2735 * argv[] is modified. */
2736 setproctitle("-%s", s);
2737 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2738 /* This doesn't really work if you assume that
2739 * $0 = 'foobar'; will wipe out 'perl' from the $0
2740 * because in ps(1) output the result will be like
2741 * sprintf("perl: %s (perl)", s)
2742 * I guess this is a security feature:
2743 * one (a user process) cannot get rid of the original name.
2745 setproctitle("%s", s);
2748 #elif defined(__hpux) && defined(PSTAT_SETCMD)
2749 if (PL_origalen != 1) {
2751 s = SvPV_const(sv, len);
2752 un.pst_command = (char *)s;
2753 pstat(PSTAT_SETCMD, un, len, 0, 0);
2756 if (PL_origalen > 1) {
2757 /* PL_origalen is set in perl_parse(). */
2758 s = SvPV_force(sv,len);
2759 if (len >= (STRLEN)PL_origalen-1) {
2760 /* Longer than original, will be truncated. We assume that
2761 * PL_origalen bytes are available. */
2762 Copy(s, PL_origargv[0], PL_origalen-1, char);
2765 /* Shorter than original, will be padded. */
2767 /* Special case for Mac OS X: see [perl #38868] */
2770 /* Is the space counterintuitive? Yes.
2771 * (You were expecting \0?)
2772 * Does it work? Seems to. (In Linux 2.4.20 at least.)
2774 const int pad = ' ';
2776 Copy(s, PL_origargv[0], len, char);
2777 PL_origargv[0][len] = 0;
2778 memset(PL_origargv[0] + len + 1,
2779 pad, PL_origalen - len - 1);
2781 PL_origargv[0][PL_origalen-1] = 0;
2782 for (i = 1; i < PL_origargc; i++)
2786 UNLOCK_DOLLARZERO_MUTEX;
2793 Perl_whichsig(pTHX_ const char *sig)
2795 register char* const* sigv;
2797 PERL_ARGS_ASSERT_WHICHSIG;
2798 PERL_UNUSED_CONTEXT;
2800 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
2801 if (strEQ(sig,*sigv))
2802 return PL_sig_num[sigv - (char* const*)PL_sig_name];
2804 if (strEQ(sig,"CHLD"))
2808 if (strEQ(sig,"CLD"))
2815 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2816 Perl_sighandler(int sig, siginfo_t *sip, void *uap PERL_UNUSED_DECL)
2818 Perl_sighandler(int sig)
2821 #ifdef PERL_GET_SIG_CONTEXT
2822 dTHXa(PERL_GET_SIG_CONTEXT);
2829 SV * const tSv = PL_Sv;
2833 XPV * const tXpv = PL_Xpv;
2835 if (PL_savestack_ix + 15 <= PL_savestack_max)
2837 if (PL_markstack_ptr < PL_markstack_max - 2)
2839 if (PL_scopestack_ix < PL_scopestack_max - 3)
2842 if (!PL_psig_ptr[sig]) {
2843 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2848 /* Max number of items pushed there is 3*n or 4. We cannot fix
2849 infinity, so we fix 4 (in fact 5): */
2851 PL_savestack_ix += 5; /* Protect save in progress. */
2852 SAVEDESTRUCTOR_X(S_unwind_handler_stack, (void*)&flags);
2855 PL_markstack_ptr++; /* Protect mark. */
2857 PL_scopestack_ix += 1;
2858 /* sv_2cv is too complicated, try a simpler variant first: */
2859 if (!SvROK(PL_psig_ptr[sig]) || !(cv = MUTABLE_CV(SvRV(PL_psig_ptr[sig])))
2860 || SvTYPE(cv) != SVt_PVCV) {
2862 cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
2865 if (!cv || !CvROOT(cv)) {
2866 if (ckWARN(WARN_SIGNAL))
2867 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2868 PL_sig_name[sig], (gv ? GvENAME(gv)
2875 if(PL_psig_name[sig]) {
2876 sv = SvREFCNT_inc_NN(PL_psig_name[sig]);
2878 #if !defined(PERL_IMPLICIT_CONTEXT)
2882 sv = sv_newmortal();
2883 sv_setpv(sv,PL_sig_name[sig]);
2886 PUSHSTACKi(PERLSI_SIGNAL);
2889 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2891 struct sigaction oact;
2893 if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
2896 SV *rv = newRV_noinc(MUTABLE_SV(sih));
2897 /* The siginfo fields signo, code, errno, pid, uid,
2898 * addr, status, and band are defined by POSIX/SUSv3. */
2899 (void)hv_stores(sih, "signo", newSViv(sip->si_signo));
2900 (void)hv_stores(sih, "code", newSViv(sip->si_code));
2901 #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. */
2902 hv_stores(sih, "errno", newSViv(sip->si_errno));
2903 hv_stores(sih, "status", newSViv(sip->si_status));
2904 hv_stores(sih, "uid", newSViv(sip->si_uid));
2905 hv_stores(sih, "pid", newSViv(sip->si_pid));
2906 hv_stores(sih, "addr", newSVuv(PTR2UV(sip->si_addr)));
2907 hv_stores(sih, "band", newSViv(sip->si_band));
2911 mPUSHp((char *)sip, sizeof(*sip));
2919 call_sv(MUTABLE_SV(cv), G_DISCARD|G_EVAL);
2922 if (SvTRUE(ERRSV)) {
2924 #ifdef HAS_SIGPROCMASK
2925 /* Handler "died", for example to get out of a restart-able read().
2926 * Before we re-do that on its behalf re-enable the signal which was
2927 * blocked by the system when we entered.
2931 sigaddset(&set,sig);
2932 sigprocmask(SIG_UNBLOCK, &set, NULL);
2934 /* Not clear if this will work */
2935 (void)rsignal(sig, SIG_IGN);
2936 (void)rsignal(sig, PL_csighandlerp);
2938 #endif /* !PERL_MICRO */
2939 Perl_die(aTHX_ NULL);
2943 PL_savestack_ix -= 8; /* Unprotect save in progress. */
2947 PL_scopestack_ix -= 1;
2950 PL_op = myop; /* Apparently not needed... */
2952 PL_Sv = tSv; /* Restore global temporaries. */
2959 S_restore_magic(pTHX_ const void *p)
2962 MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
2963 SV* const sv = mgs->mgs_sv;
2968 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2970 #ifdef PERL_OLD_COPY_ON_WRITE
2971 /* While magic was saved (and off) sv_setsv may well have seen
2972 this SV as a prime candidate for COW. */
2974 sv_force_normal_flags(sv, 0);
2978 SvFLAGS(sv) |= mgs->mgs_flags;
2981 if (SvGMAGICAL(sv)) {
2982 /* downgrade public flags to private,
2983 and discard any other private flags */
2985 const U32 pubflags = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
2987 SvFLAGS(sv) &= ~( pubflags | (SVp_IOK|SVp_NOK|SVp_POK) );
2988 SvFLAGS(sv) |= ( pubflags << PRIVSHIFT );
2993 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
2995 /* If we're still on top of the stack, pop us off. (That condition
2996 * will be satisfied if restore_magic was called explicitly, but *not*
2997 * if it's being called via leave_scope.)
2998 * The reason for doing this is that otherwise, things like sv_2cv()
2999 * may leave alloc gunk on the savestack, and some code
3000 * (e.g. sighandler) doesn't expect that...
3002 if (PL_savestack_ix == mgs->mgs_ss_ix)
3004 I32 popval = SSPOPINT;
3005 assert(popval == SAVEt_DESTRUCTOR_X);
3006 PL_savestack_ix -= 2;
3008 assert(popval == SAVEt_ALLOC);
3010 PL_savestack_ix -= popval;
3016 S_unwind_handler_stack(pTHX_ const void *p)
3019 const U32 flags = *(const U32*)p;
3021 PERL_ARGS_ASSERT_UNWIND_HANDLER_STACK;
3024 PL_savestack_ix -= 5; /* Unprotect save in progress. */
3025 #if !defined(PERL_IMPLICIT_CONTEXT)
3027 SvREFCNT_dec(PL_sig_sv);
3032 =for apidoc magic_sethint
3034 Triggered by a store to %^H, records the key/value pair to
3035 C<PL_compiling.cop_hints_hash>. It is assumed that hints aren't storing
3036 anything that would need a deep copy. Maybe we should warn if we find a
3042 Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
3045 SV *key = (mg->mg_len == HEf_SVKEY) ? MUTABLE_SV(mg->mg_ptr)
3046 : newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
3048 PERL_ARGS_ASSERT_MAGIC_SETHINT;
3050 /* mg->mg_obj isn't being used. If needed, it would be possible to store
3051 an alternative leaf in there, with PL_compiling.cop_hints being used if
3052 it's NULL. If needed for threads, the alternative could lock a mutex,
3053 or take other more complex action. */
3055 /* Something changed in %^H, so it will need to be restored on scope exit.
3056 Doing this here saves a lot of doing it manually in perl code (and
3057 forgetting to do it, and consequent subtle errors. */
3058 PL_hints |= HINT_LOCALIZE_HH;
3059 PL_compiling.cop_hints_hash
3060 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash, key, sv);
3065 =for apidoc magic_clearhint
3067 Triggered by a delete from %^H, records the key to
3068 C<PL_compiling.cop_hints_hash>.
3073 Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
3077 PERL_ARGS_ASSERT_MAGIC_CLEARHINT;
3078 PERL_UNUSED_ARG(sv);
3080 assert(mg->mg_len == HEf_SVKEY);
3082 PERL_UNUSED_ARG(sv);
3084 PL_hints |= HINT_LOCALIZE_HH;
3085 PL_compiling.cop_hints_hash
3086 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
3087 MUTABLE_SV(mg->mg_ptr), &PL_sv_placeholder);
3092 =for apidoc magic_clearhints
3094 Triggered by clearing %^H, resets C<PL_compiling.cop_hints_hash>.
3099 Perl_magic_clearhints(pTHX_ SV *sv, MAGIC *mg)
3101 PERL_ARGS_ASSERT_MAGIC_CLEARHINTS;
3102 PERL_UNUSED_ARG(sv);
3103 PERL_UNUSED_ARG(mg);
3104 if (PL_compiling.cop_hints_hash) {
3105 Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
3106 PL_compiling.cop_hints_hash = NULL;
3113 * c-indentation-style: bsd
3115 * indent-tabs-mode: t
3118 * ex: set ts=8 sts=4 sw=4 noet: