3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 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."
17 =head1 Magical Functions
19 "Magic" is special data attached to SV structures in order to give them
20 "magical" properties. When any Perl code tries to read from, or assign to,
21 an SV marked as magical, it calls the 'get' or 'set' function associated
22 with that SV's magic. A get is called prior to reading an SV, in order to
23 give it a chance to update its internal value (get on $. writes the line
24 number of the last read filehandle into to the SV's IV slot), while
25 set is called after an SV has been written to, in order to allow it to make
26 use of its changed value (set on $/ copies the SV's new value to the
27 PL_rs global variable).
29 Magic is implemented as a linked list of MAGIC structures attached to the
30 SV. Each MAGIC struct holds the type of the magic, a pointer to an array
31 of functions that implement the get(), set(), length() etc functions,
32 plus space for some flags and pointers. For example, a tied variable has
33 a MAGIC structure that contains a pointer to the object associated with the
42 #if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS)
48 #if defined(HAS_SETGROUPS)
55 # include <sys/pstat.h>
58 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
59 Signal_t Perl_csighandler(int sig, siginfo_t *, void *);
61 Signal_t Perl_csighandler(int sig);
65 /* Missing protos on LynxOS */
66 void setruid(uid_t id);
67 void seteuid(uid_t id);
68 void setrgid(uid_t id);
69 void setegid(uid_t id);
73 * Use the "DESTRUCTOR" scope cleanup to reinstate magic.
81 /* MGS is typedef'ed to struct magic_state in perl.h */
84 S_save_magic(pTHX_ I32 mgs_ix, SV *sv)
88 assert(SvMAGICAL(sv));
89 /* Turning READONLY off for a copy-on-write scalar (including shared
90 hash keys) is a bad idea. */
92 sv_force_normal_flags(sv, 0);
94 SAVEDESTRUCTOR_X(S_restore_magic, INT2PTR(void*, (IV)mgs_ix));
96 mgs = SSPTR(mgs_ix, MGS*);
98 mgs->mgs_flags = SvMAGICAL(sv) | SvREADONLY(sv);
99 mgs->mgs_ss_ix = PL_savestack_ix; /* points after the saved destructor */
103 if (!(SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK))) {
104 /* No public flags are set, so promote any private flags to public. */
105 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
110 =for apidoc mg_magical
112 Turns on the magical status of an SV. See C<sv_magic>.
118 Perl_mg_magical(pTHX_ SV *sv)
122 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
123 const MGVTBL* const vtbl = mg->mg_virtual;
125 if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
129 if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)) || vtbl->svt_clear)
136 /* is this container magic (%ENV, $1 etc), or value magic (pos, taint etc)? */
139 S_is_container_magic(const MAGIC *mg)
141 switch (mg->mg_type) {
144 case PERL_MAGIC_regex_global:
145 case PERL_MAGIC_nkeys:
146 #ifdef USE_LOCALE_COLLATE
147 case PERL_MAGIC_collxfrm:
150 case PERL_MAGIC_taint:
152 case PERL_MAGIC_vstring:
153 case PERL_MAGIC_utf8:
154 case PERL_MAGIC_substr:
155 case PERL_MAGIC_defelem:
156 case PERL_MAGIC_arylen:
158 case PERL_MAGIC_backref:
159 case PERL_MAGIC_arylen_p:
160 case PERL_MAGIC_rhash:
161 case PERL_MAGIC_symtab:
171 Do magic after a value is retrieved from the SV. See C<sv_magic>.
177 Perl_mg_get(pTHX_ SV *sv)
180 const I32 mgs_ix = SSNEW(sizeof(MGS));
181 const bool was_temp = (bool)SvTEMP(sv);
183 MAGIC *newmg, *head, *cur, *mg;
184 /* guard against sv having being freed midway by holding a private
187 /* sv_2mortal has this side effect of turning on the TEMP flag, which can
188 cause the SV's buffer to get stolen (and maybe other stuff).
191 sv_2mortal(SvREFCNT_inc_simple_NN(sv));
196 save_magic(mgs_ix, sv);
198 /* We must call svt_get(sv, mg) for each valid entry in the linked
199 list of magic. svt_get() may delete the current entry, add new
200 magic to the head of the list, or upgrade the SV. AMS 20010810 */
202 newmg = cur = head = mg = SvMAGIC(sv);
204 const MGVTBL * const vtbl = mg->mg_virtual;
206 if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
207 CALL_FPTR(vtbl->svt_get)(aTHX_ sv, mg);
209 /* guard against magic having been deleted - eg FETCH calling
214 /* Don't restore the flags for this entry if it was deleted. */
215 if (mg->mg_flags & MGf_GSKIP)
216 (SSPTR(mgs_ix, MGS *))->mgs_flags = 0;
219 mg = mg->mg_moremagic;
222 /* Have we finished with the new entries we saw? Start again
223 where we left off (unless there are more new entries). */
231 /* Were any new entries added? */
232 if (!have_new && (newmg = SvMAGIC(sv)) != head) {
239 restore_magic(INT2PTR(void *, (IV)mgs_ix));
241 if (SvREFCNT(sv) == 1) {
242 /* We hold the last reference to this SV, which implies that the
243 SV was deleted as a side effect of the routines we called. */
252 Do magic after a value is assigned to the SV. See C<sv_magic>.
258 Perl_mg_set(pTHX_ SV *sv)
261 const I32 mgs_ix = SSNEW(sizeof(MGS));
265 save_magic(mgs_ix, sv);
267 for (mg = SvMAGIC(sv); mg; mg = nextmg) {
268 const MGVTBL* vtbl = mg->mg_virtual;
269 nextmg = mg->mg_moremagic; /* it may delete itself */
270 if (mg->mg_flags & MGf_GSKIP) {
271 mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */
272 (SSPTR(mgs_ix, MGS*))->mgs_flags = 0;
274 if (PL_localizing == 2 && !S_is_container_magic(mg))
276 if (vtbl && vtbl->svt_set)
277 CALL_FPTR(vtbl->svt_set)(aTHX_ sv, mg);
280 restore_magic(INT2PTR(void*, (IV)mgs_ix));
285 =for apidoc mg_length
287 Report on the SV's length. See C<sv_magic>.
293 Perl_mg_length(pTHX_ SV *sv)
299 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
300 const MGVTBL * const vtbl = mg->mg_virtual;
301 if (vtbl && vtbl->svt_len) {
302 const I32 mgs_ix = SSNEW(sizeof(MGS));
303 save_magic(mgs_ix, sv);
304 /* omit MGf_GSKIP -- not changed here */
305 len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
306 restore_magic(INT2PTR(void*, (IV)mgs_ix));
312 /* You can't know whether it's UTF-8 until you get the string again...
314 const U8 *s = (U8*)SvPV_const(sv, len);
317 len = utf8_length(s, s + len);
324 Perl_mg_size(pTHX_ SV *sv)
328 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
329 const MGVTBL* const vtbl = mg->mg_virtual;
330 if (vtbl && vtbl->svt_len) {
331 const I32 mgs_ix = SSNEW(sizeof(MGS));
333 save_magic(mgs_ix, sv);
334 /* omit MGf_GSKIP -- not changed here */
335 len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
336 restore_magic(INT2PTR(void*, (IV)mgs_ix));
343 return AvFILLp((AV *) sv); /* Fallback to non-tied array */
347 Perl_croak(aTHX_ "Size magic not implemented");
356 Clear something magical that the SV represents. See C<sv_magic>.
362 Perl_mg_clear(pTHX_ SV *sv)
364 const I32 mgs_ix = SSNEW(sizeof(MGS));
367 save_magic(mgs_ix, sv);
369 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
370 const MGVTBL* const vtbl = mg->mg_virtual;
371 /* omit GSKIP -- never set here */
373 if (vtbl && vtbl->svt_clear)
374 CALL_FPTR(vtbl->svt_clear)(aTHX_ sv, mg);
377 restore_magic(INT2PTR(void*, (IV)mgs_ix));
384 Finds the magic pointer for type matching the SV. See C<sv_magic>.
390 Perl_mg_find(pTHX_ const SV *sv, int type)
395 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
396 if (mg->mg_type == type)
406 Copies the magic from one SV to another. See C<sv_magic>.
412 Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
416 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
417 const MGVTBL* const vtbl = mg->mg_virtual;
418 if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){
419 count += CALL_FPTR(vtbl->svt_copy)(aTHX_ sv, mg, nsv, key, klen);
422 const char type = mg->mg_type;
423 if (isUPPER(type) && type != PERL_MAGIC_uvar) {
425 (type == PERL_MAGIC_tied)
427 : (type == PERL_MAGIC_regdata && mg->mg_obj)
430 toLOWER(type), key, klen);
439 =for apidoc mg_localize
441 Copy some of the magic from an existing SV to new localized version of
442 that SV. Container magic (eg %ENV, $1, tie) gets copied, value magic
443 doesn't (eg taint, pos).
449 Perl_mg_localize(pTHX_ SV *sv, SV *nsv)
453 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
454 const MGVTBL* const vtbl = mg->mg_virtual;
455 if (!S_is_container_magic(mg))
458 if ((mg->mg_flags & MGf_LOCAL) && vtbl->svt_local)
459 (void)CALL_FPTR(vtbl->svt_local)(aTHX_ nsv, mg);
461 sv_magicext(nsv, mg->mg_obj, mg->mg_type, vtbl,
462 mg->mg_ptr, mg->mg_len);
464 /* container types should remain read-only across localization */
465 SvFLAGS(nsv) |= SvREADONLY(sv);
468 if (SvTYPE(nsv) >= SVt_PVMG && SvMAGIC(nsv)) {
469 SvFLAGS(nsv) |= SvMAGICAL(sv);
479 Free any magic storage used by the SV. See C<sv_magic>.
485 Perl_mg_free(pTHX_ SV *sv)
489 for (mg = SvMAGIC(sv); mg; mg = moremagic) {
490 const MGVTBL* const vtbl = mg->mg_virtual;
491 moremagic = mg->mg_moremagic;
492 if (vtbl && vtbl->svt_free)
493 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
494 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
495 if (mg->mg_len > 0 || mg->mg_type == PERL_MAGIC_utf8)
496 Safefree(mg->mg_ptr);
497 else if (mg->mg_len == HEf_SVKEY)
498 SvREFCNT_dec((SV*)mg->mg_ptr);
500 if (mg->mg_flags & MGf_REFCOUNTED)
501 SvREFCNT_dec(mg->mg_obj);
503 SvMAGIC_set(sv, moremagic);
505 SvMAGIC_set(sv, NULL);
512 Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
518 register const REGEXP * const rx = PM_GETRE(PL_curpm);
520 if (mg->mg_obj) { /* @+ */
521 /* return the number possible */
522 return RX_NPARENS(rx);
524 I32 paren = RX_LASTPAREN(rx);
526 /* return the last filled */
528 && (RX_OFFS(rx)[paren].start == -1
529 || RX_OFFS(rx)[paren].end == -1) )
540 Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
544 register const REGEXP * const rx = PM_GETRE(PL_curpm);
546 register const I32 paren = mg->mg_len;
551 if (paren <= (I32)RX_NPARENS(rx) &&
552 (s = RX_OFFS(rx)[paren].start) != -1 &&
553 (t = RX_OFFS(rx)[paren].end) != -1)
556 if (mg->mg_obj) /* @+ */
561 if (i > 0 && RX_MATCH_UTF8(rx)) {
562 const char * const b = RX_SUBBEG(rx);
564 i = utf8_length((U8*)b, (U8*)(b+i));
575 Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
579 Perl_croak(aTHX_ PL_no_modify);
580 NORETURN_FUNCTION_END;
584 Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
589 register const REGEXP * rx;
590 const char * const remaining = mg->mg_ptr + 1;
592 switch (*mg->mg_ptr) {
594 if (*remaining == '\0') { /* ^P */
596 } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
598 } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
602 case '\015': /* $^MATCH */
603 if (strEQ(remaining, "ATCH")) {
610 paren = RX_BUFF_IDX_PREMATCH;
614 paren = RX_BUFF_IDX_POSTMATCH;
618 paren = RX_BUFF_IDX_FULLMATCH;
620 case '1': case '2': case '3': case '4':
621 case '5': case '6': case '7': case '8': case '9':
622 paren = atoi(mg->mg_ptr);
624 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
626 i = CALLREG_NUMBUF_LENGTH((REGEXP * const)rx, sv, paren);
629 Perl_croak(aTHX_ "panic: magic_len: %"IVdf, (IV)i);
632 if (ckWARN(WARN_UNINITIALIZED))
637 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
638 paren = RX_LASTPAREN(rx);
643 case '\016': /* ^N */
644 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
645 paren = RX_LASTCLOSEPAREN(rx);
652 if (!SvPOK(sv) && SvNIOK(sv)) {
660 #define SvRTRIM(sv) STMT_START { \
662 STRLEN len = SvCUR(sv); \
663 char * const p = SvPVX(sv); \
664 while (len > 0 && isSPACE(p[len-1])) \
666 SvCUR_set(sv, len); \
672 Perl_emulate_cop_io(pTHX_ const COP *const c, SV *const sv)
674 if (!(CopHINTS_get(c) & (HINT_LEXICAL_IO_IN|HINT_LEXICAL_IO_OUT)))
675 sv_setsv(sv, &PL_sv_undef);
679 if ((CopHINTS_get(c) & HINT_LEXICAL_IO_IN)) {
680 SV *const value = Perl_refcounted_he_fetch(aTHX_
682 0, "open<", 5, 0, 0);
687 if ((CopHINTS_get(c) & HINT_LEXICAL_IO_OUT)) {
688 SV *const value = Perl_refcounted_he_fetch(aTHX_
690 0, "open>", 5, 0, 0);
698 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
702 register char *s = NULL;
704 const char * const remaining = mg->mg_ptr + 1;
705 const char nextchar = *remaining;
707 switch (*mg->mg_ptr) {
708 case '\001': /* ^A */
709 sv_setsv(sv, PL_bodytarget);
711 case '\003': /* ^C, ^CHILD_ERROR_NATIVE */
712 if (nextchar == '\0') {
713 sv_setiv(sv, (IV)PL_minus_c);
715 else if (strEQ(remaining, "HILD_ERROR_NATIVE")) {
716 sv_setiv(sv, (IV)STATUS_NATIVE);
720 case '\004': /* ^D */
721 sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
723 case '\005': /* ^E */
724 if (nextchar == '\0') {
725 #if defined(MACOS_TRADITIONAL)
729 sv_setnv(sv,(double)gMacPerl_OSErr);
730 sv_setpv(sv, gMacPerl_OSErr ? GetSysErrText(gMacPerl_OSErr, msg) : "");
734 # include <descrip.h>
735 # include <starlet.h>
737 $DESCRIPTOR(msgdsc,msg);
738 sv_setnv(sv,(NV) vaxc$errno);
739 if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
740 sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
745 if (!(_emx_env & 0x200)) { /* Under DOS */
746 sv_setnv(sv, (NV)errno);
747 sv_setpv(sv, errno ? Strerror(errno) : "");
749 if (errno != errno_isOS2) {
750 const int tmp = _syserrno();
751 if (tmp) /* 2nd call to _syserrno() makes it 0 */
754 sv_setnv(sv, (NV)Perl_rc);
755 sv_setpv(sv, os2error(Perl_rc));
759 const DWORD dwErr = GetLastError();
760 sv_setnv(sv, (NV)dwErr);
762 PerlProc_GetOSError(sv, dwErr);
765 sv_setpvn(sv, "", 0);
770 const int saveerrno = errno;
771 sv_setnv(sv, (NV)errno);
772 sv_setpv(sv, errno ? Strerror(errno) : "");
777 SvNOK_on(sv); /* what a wonderful hack! */
779 else if (strEQ(remaining, "NCODING"))
780 sv_setsv(sv, PL_encoding);
782 case '\006': /* ^F */
783 sv_setiv(sv, (IV)PL_maxsysfd);
785 case '\010': /* ^H */
786 sv_setiv(sv, (IV)PL_hints);
788 case '\011': /* ^I */ /* NOT \t in EBCDIC */
789 sv_setpv(sv, PL_inplace); /* Will undefine sv if PL_inplace is NULL */
791 case '\017': /* ^O & ^OPEN */
792 if (nextchar == '\0') {
793 sv_setpv(sv, PL_osname);
796 else if (strEQ(remaining, "PEN")) {
797 Perl_emulate_cop_io(aTHX_ &PL_compiling, sv);
801 if (nextchar == '\0') { /* ^P */
802 sv_setiv(sv, (IV)PL_perldb);
803 } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
804 goto do_prematch_fetch;
805 } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
806 goto do_postmatch_fetch;
809 case '\023': /* ^S */
810 if (nextchar == '\0') {
811 if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING)
814 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
819 case '\024': /* ^T */
820 if (nextchar == '\0') {
822 sv_setnv(sv, PL_basetime);
824 sv_setiv(sv, (IV)PL_basetime);
827 else if (strEQ(remaining, "AINT"))
828 sv_setiv(sv, PL_tainting
829 ? (PL_taint_warn || PL_unsafe ? -1 : 1)
832 case '\025': /* $^UNICODE, $^UTF8LOCALE, $^UTF8CACHE */
833 if (strEQ(remaining, "NICODE"))
834 sv_setuv(sv, (UV) PL_unicode);
835 else if (strEQ(remaining, "TF8LOCALE"))
836 sv_setuv(sv, (UV) PL_utf8locale);
837 else if (strEQ(remaining, "TF8CACHE"))
838 sv_setiv(sv, (IV) PL_utf8cache);
840 case '\027': /* ^W & $^WARNING_BITS */
841 if (nextchar == '\0')
842 sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
843 else if (strEQ(remaining, "ARNING_BITS")) {
844 if (PL_compiling.cop_warnings == pWARN_NONE) {
845 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
847 else if (PL_compiling.cop_warnings == pWARN_STD) {
850 (PL_dowarn & G_WARN_ON) ? WARN_ALLstring : WARN_NONEstring,
854 else if (PL_compiling.cop_warnings == pWARN_ALL) {
855 /* Get the bit mask for $warnings::Bits{all}, because
856 * it could have been extended by warnings::register */
857 HV * const bits=get_hv("warnings::Bits", FALSE);
859 SV ** const bits_all = hv_fetchs(bits, "all", FALSE);
861 sv_setsv(sv, *bits_all);
864 sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
868 sv_setpvn(sv, (char *) (PL_compiling.cop_warnings + 1),
869 *PL_compiling.cop_warnings);
874 case '\015': /* $^MATCH */
875 if (strEQ(remaining, "ATCH")) {
876 case '1': case '2': case '3': case '4':
877 case '5': case '6': case '7': case '8': case '9': case '&':
878 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
880 * Pre-threads, this was paren = atoi(GvENAME((GV*)mg->mg_obj));
881 * XXX Does the new way break anything?
883 paren = atoi(mg->mg_ptr); /* $& is in [0] */
884 CALLREG_NUMBUF_FETCH(rx,paren,sv);
887 sv_setsv(sv,&PL_sv_undef);
891 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
892 if (RX_LASTPAREN(rx)) {
893 CALLREG_NUMBUF_FETCH(rx,RX_LASTPAREN(rx),sv);
897 sv_setsv(sv,&PL_sv_undef);
899 case '\016': /* ^N */
900 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
901 if (RX_LASTCLOSEPAREN(rx)) {
902 CALLREG_NUMBUF_FETCH(rx,RX_LASTCLOSEPAREN(rx),sv);
907 sv_setsv(sv,&PL_sv_undef);
911 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
912 CALLREG_NUMBUF_FETCH(rx,-2,sv);
915 sv_setsv(sv,&PL_sv_undef);
919 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
920 CALLREG_NUMBUF_FETCH(rx,-1,sv);
923 sv_setsv(sv,&PL_sv_undef);
926 if (GvIO(PL_last_in_gv)) {
927 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
932 sv_setiv(sv, (IV)STATUS_CURRENT);
933 #ifdef COMPLEX_STATUS
934 LvTARGOFF(sv) = PL_statusvalue;
935 LvTARGLEN(sv) = PL_statusvalue_vms;
940 if (GvIOp(PL_defoutgv))
941 s = IoTOP_NAME(GvIOp(PL_defoutgv));
945 sv_setpv(sv,GvENAME(PL_defoutgv));
946 sv_catpvs(sv,"_TOP");
950 if (GvIOp(PL_defoutgv))
951 s = IoFMT_NAME(GvIOp(PL_defoutgv));
953 s = GvENAME(PL_defoutgv);
957 if (GvIOp(PL_defoutgv))
958 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
961 if (GvIOp(PL_defoutgv))
962 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
965 if (GvIOp(PL_defoutgv))
966 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
973 sv_setiv(sv, (IV)CopARYBASE_get(PL_curcop));
976 if (GvIOp(PL_defoutgv))
977 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
983 sv_copypv(sv, PL_ors_sv);
987 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
988 sv_setpv(sv, errno ? Strerror(errno) : "");
991 const int saveerrno = errno;
992 sv_setnv(sv, (NV)errno);
994 if (errno == errno_isOS2 || errno == errno_isOS2_set)
995 sv_setpv(sv, os2error(Perl_rc));
998 sv_setpv(sv, errno ? Strerror(errno) : "");
1003 SvNOK_on(sv); /* what a wonderful hack! */
1006 sv_setiv(sv, (IV)PL_uid);
1009 sv_setiv(sv, (IV)PL_euid);
1012 sv_setiv(sv, (IV)PL_gid);
1015 sv_setiv(sv, (IV)PL_egid);
1017 #ifdef HAS_GETGROUPS
1019 Groups_t *gary = NULL;
1020 I32 i, num_groups = getgroups(0, gary);
1021 Newx(gary, num_groups, Groups_t);
1022 num_groups = getgroups(num_groups, gary);
1023 for (i = 0; i < num_groups; i++)
1024 Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]);
1027 (void)SvIOK_on(sv); /* what a wonderful hack! */
1030 #ifndef MACOS_TRADITIONAL
1039 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
1041 struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
1043 if (uf && uf->uf_val)
1044 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
1049 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
1052 STRLEN len = 0, klen;
1053 const char *s = SvOK(sv) ? SvPV_const(sv,len) : "";
1054 const char * const ptr = MgPV_const(mg,klen);
1057 #ifdef DYNAMIC_ENV_FETCH
1058 /* We just undefd an environment var. Is a replacement */
1059 /* waiting in the wings? */
1061 SV ** const valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE);
1063 s = SvOK(*valp) ? SvPV_const(*valp, len) : "";
1067 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
1068 /* And you'll never guess what the dog had */
1069 /* in its mouth... */
1071 MgTAINTEDDIR_off(mg);
1073 if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
1074 char pathbuf[256], eltbuf[256], *cp, *elt;
1078 my_strlcpy(eltbuf, s, sizeof(eltbuf));
1080 do { /* DCL$PATH may be a search list */
1081 while (1) { /* as may dev portion of any element */
1082 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1083 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1084 cando_by_name(S_IWUSR,0,elt) ) {
1085 MgTAINTEDDIR_on(mg);
1089 if ((cp = strchr(elt, ':')) != NULL)
1091 if (my_trnlnm(elt, eltbuf, j++))
1097 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1100 if (s && klen == 4 && strEQ(ptr,"PATH")) {
1101 const char * const strend = s + len;
1103 while (s < strend) {
1107 #ifdef VMS /* Hmm. How do we get $Config{path_sep} from C? */
1108 const char path_sep = '|';
1110 const char path_sep = ':';
1112 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
1113 s, strend, path_sep, &i);
1115 if (i >= (I32)sizeof tmpbuf /* too long -- assume the worst */
1117 || !strchr(tmpbuf, ':') /* no colon thus no device name -- assume relative path */
1119 || *tmpbuf != '/' /* no starting slash -- assume relative path */
1121 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1122 MgTAINTEDDIR_on(mg);
1128 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1134 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1136 PERL_UNUSED_ARG(sv);
1137 my_setenv(MgPV_nolen_const(mg),NULL);
1142 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1145 PERL_UNUSED_ARG(mg);
1147 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1149 if (PL_localizing) {
1152 hv_iterinit((HV*)sv);
1153 while ((entry = hv_iternext((HV*)sv))) {
1155 my_setenv(hv_iterkey(entry, &keylen),
1156 SvPV_nolen_const(hv_iterval((HV*)sv, entry)));
1164 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1167 PERL_UNUSED_ARG(sv);
1168 PERL_UNUSED_ARG(mg);
1170 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1178 #ifdef HAS_SIGPROCMASK
1180 restore_sigmask(pTHX_ SV *save_sv)
1182 const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1183 (void)sigprocmask(SIG_SETMASK, ossetp, NULL);
1187 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1190 /* Are we fetching a signal entry? */
1191 const I32 i = whichsig(MgPV_nolen_const(mg));
1194 sv_setsv(sv,PL_psig_ptr[i]);
1196 Sighandler_t sigstate = rsignal_state(i);
1197 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1198 if (PL_sig_handlers_initted && PL_sig_ignoring[i])
1201 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1202 if (PL_sig_handlers_initted && PL_sig_defaulting[i])
1205 /* cache state so we don't fetch it again */
1206 if(sigstate == (Sighandler_t) SIG_IGN)
1207 sv_setpvs(sv,"IGNORE");
1209 sv_setsv(sv,&PL_sv_undef);
1210 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1217 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1219 /* XXX Some of this code was copied from Perl_magic_setsig. A little
1220 * refactoring might be in order.
1223 register const char * const s = MgPV_nolen_const(mg);
1224 PERL_UNUSED_ARG(sv);
1227 if (strEQ(s,"__DIE__"))
1229 else if (strEQ(s,"__WARN__") && PL_warnhook != PERL_WARNHOOK_FATAL)
1232 SV *const to_dec = *svp;
1234 SvREFCNT_dec(to_dec);
1238 /* Are we clearing a signal entry? */
1239 const I32 i = whichsig(s);
1241 #ifdef HAS_SIGPROCMASK
1244 /* Avoid having the signal arrive at a bad time, if possible. */
1247 sigprocmask(SIG_BLOCK, &set, &save);
1249 save_sv = newSVpvn((char *)(&save), sizeof(sigset_t));
1250 SAVEFREESV(save_sv);
1251 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1254 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1255 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1257 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1258 PL_sig_defaulting[i] = 1;
1259 (void)rsignal(i, PL_csighandlerp);
1261 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1263 if(PL_psig_name[i]) {
1264 SvREFCNT_dec(PL_psig_name[i]);
1267 if(PL_psig_ptr[i]) {
1268 SV * const to_dec=PL_psig_ptr[i];
1271 SvREFCNT_dec(to_dec);
1281 * The signal handling nomenclature has gotten a bit confusing since the advent of
1282 * safe signals. S_raise_signal only raises signals by analogy with what the
1283 * underlying system's signal mechanism does. It might be more proper to say that
1284 * it defers signals that have already been raised and caught.
1286 * PL_sig_pending and PL_psig_pend likewise do not track signals that are pending
1287 * in the sense of being on the system's signal queue in between raising and delivery.
1288 * They are only pending on Perl's deferral list, i.e., they track deferred signals
1289 * awaiting delivery after the current Perl opcode completes and say nothing about
1290 * signals raised but not yet caught in the underlying signal implementation.
1293 #ifndef SIG_PENDING_DIE_COUNT
1294 # define SIG_PENDING_DIE_COUNT 120
1298 S_raise_signal(pTHX_ int sig)
1301 /* Set a flag to say this signal is pending */
1302 PL_psig_pend[sig]++;
1303 /* And one to say _a_ signal is pending */
1304 if (++PL_sig_pending >= SIG_PENDING_DIE_COUNT)
1305 Perl_croak(aTHX_ "Maximal count of pending signals (%lu) exceeded",
1306 (unsigned long)SIG_PENDING_DIE_COUNT);
1310 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1311 Perl_csighandler(int sig, siginfo_t *sip PERL_UNUSED_DECL, void *uap PERL_UNUSED_DECL)
1313 Perl_csighandler(int sig)
1316 #ifdef PERL_GET_SIG_CONTEXT
1317 dTHXa(PERL_GET_SIG_CONTEXT);
1321 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1323 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1324 (void) rsignal(sig, PL_csighandlerp);
1325 if (PL_sig_ignoring[sig]) return;
1327 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1328 if (PL_sig_defaulting[sig])
1329 #ifdef KILL_BY_SIGPRC
1330 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1335 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1347 (PL_signals & PERL_SIGNALS_UNSAFE_FLAG))
1348 /* Call the perl level handler now--
1349 * with risk we may be in malloc() etc. */
1350 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1351 (*PL_sighandlerp)(sig, NULL, NULL);
1353 (*PL_sighandlerp)(sig);
1356 S_raise_signal(aTHX_ sig);
1359 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1361 Perl_csighandler_init(void)
1364 if (PL_sig_handlers_initted) return;
1366 for (sig = 1; sig < SIG_SIZE; sig++) {
1367 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1369 PL_sig_defaulting[sig] = 1;
1370 (void) rsignal(sig, PL_csighandlerp);
1372 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1373 PL_sig_ignoring[sig] = 0;
1376 PL_sig_handlers_initted = 1;
1381 Perl_despatch_signals(pTHX)
1386 for (sig = 1; sig < SIG_SIZE; sig++) {
1387 if (PL_psig_pend[sig]) {
1388 PERL_BLOCKSIG_ADD(set, sig);
1389 PL_psig_pend[sig] = 0;
1390 PERL_BLOCKSIG_BLOCK(set);
1391 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1392 (*PL_sighandlerp)(sig, NULL, NULL);
1394 (*PL_sighandlerp)(sig);
1396 PERL_BLOCKSIG_UNBLOCK(set);
1402 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1407 /* Need to be careful with SvREFCNT_dec(), because that can have side
1408 * effects (due to closures). We must make sure that the new disposition
1409 * is in place before it is called.
1413 #ifdef HAS_SIGPROCMASK
1418 register const char *s = MgPV_const(mg,len);
1420 if (strEQ(s,"__DIE__"))
1422 else if (strEQ(s,"__WARN__"))
1425 Perl_croak(aTHX_ "No such hook: %s", s);
1428 if (*svp != PERL_WARNHOOK_FATAL)
1434 i = whichsig(s); /* ...no, a brick */
1436 if (ckWARN(WARN_SIGNAL))
1437 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
1440 #ifdef HAS_SIGPROCMASK
1441 /* Avoid having the signal arrive at a bad time, if possible. */
1444 sigprocmask(SIG_BLOCK, &set, &save);
1446 save_sv = newSVpvn((char *)(&save), sizeof(sigset_t));
1447 SAVEFREESV(save_sv);
1448 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1451 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1452 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1454 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1455 PL_sig_ignoring[i] = 0;
1457 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1458 PL_sig_defaulting[i] = 0;
1460 SvREFCNT_dec(PL_psig_name[i]);
1461 to_dec = PL_psig_ptr[i];
1462 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1463 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1464 PL_psig_name[i] = newSVpvn(s, len);
1465 SvREADONLY_on(PL_psig_name[i]);
1467 if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
1469 (void)rsignal(i, PL_csighandlerp);
1470 #ifdef HAS_SIGPROCMASK
1475 *svp = SvREFCNT_inc_simple_NN(sv);
1477 SvREFCNT_dec(to_dec);
1480 s = SvOK(sv) ? SvPV_force(sv,len) : "DEFAULT";
1481 if (strEQ(s,"IGNORE")) {
1483 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1484 PL_sig_ignoring[i] = 1;
1485 (void)rsignal(i, PL_csighandlerp);
1487 (void)rsignal(i, (Sighandler_t) SIG_IGN);
1491 else if (strEQ(s,"DEFAULT") || !*s) {
1493 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1495 PL_sig_defaulting[i] = 1;
1496 (void)rsignal(i, PL_csighandlerp);
1499 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1504 * We should warn if HINT_STRICT_REFS, but without
1505 * access to a known hint bit in a known OP, we can't
1506 * tell whether HINT_STRICT_REFS is in force or not.
1508 if (!strchr(s,':') && !strchr(s,'\''))
1509 Perl_sv_insert(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"));
1511 (void)rsignal(i, PL_csighandlerp);
1513 *svp = SvREFCNT_inc_simple_NN(sv);
1515 #ifdef HAS_SIGPROCMASK
1520 SvREFCNT_dec(to_dec);
1523 #endif /* !PERL_MICRO */
1526 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1530 PERL_UNUSED_ARG(sv);
1532 /* Bail out if destruction is going on */
1533 if(PL_dirty) return 0;
1535 /* Skip _isaelem because _isa will handle it shortly */
1536 if (PL_delaymagic & DM_ARRAY && mg->mg_type == PERL_MAGIC_isaelem)
1539 /* XXX Once it's possible, we need to
1540 detect that our @ISA is aliased in
1541 other stashes, and act on the stashes
1542 of all of the aliases */
1544 /* The first case occurs via setisa,
1545 the second via setisa_elem, which
1546 calls this same magic */
1548 SvTYPE(mg->mg_obj) == SVt_PVGV
1550 : (GV*)SvMAGIC(mg->mg_obj)->mg_obj
1553 mro_isa_changed_in(stash);
1559 Perl_magic_clearisa(pTHX_ SV *sv, MAGIC *mg)
1564 /* Bail out if destruction is going on */
1565 if(PL_dirty) return 0;
1569 /* XXX see comments in magic_setisa */
1571 SvTYPE(mg->mg_obj) == SVt_PVGV
1573 : (GV*)SvMAGIC(mg->mg_obj)->mg_obj
1576 mro_isa_changed_in(stash);
1582 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
1585 PERL_UNUSED_ARG(sv);
1586 PERL_UNUSED_ARG(mg);
1587 PL_amagic_generation++;
1593 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1595 HV * const hv = (HV*)LvTARG(sv);
1597 PERL_UNUSED_ARG(mg);
1600 (void) hv_iterinit(hv);
1601 if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
1604 while (hv_iternext(hv))
1609 sv_setiv(sv, (IV)i);
1614 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1616 PERL_UNUSED_ARG(mg);
1618 hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
1623 /* caller is responsible for stack switching/cleanup */
1625 S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV *val)
1632 PUSHs(SvTIED_obj(sv, mg));
1635 if (mg->mg_len >= 0)
1636 mPUSHp(mg->mg_ptr, mg->mg_len);
1637 else if (mg->mg_len == HEf_SVKEY)
1638 PUSHs((SV*)mg->mg_ptr);
1640 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1649 return call_method(meth, flags);
1653 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
1659 PUSHSTACKi(PERLSI_MAGIC);
1661 if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
1662 sv_setsv(sv, *PL_stack_sp--);
1672 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1675 mg->mg_flags |= MGf_GSKIP;
1676 magic_methpack(sv,mg,"FETCH");
1681 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1685 PUSHSTACKi(PERLSI_MAGIC);
1686 magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
1693 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1695 return magic_methpack(sv,mg,"DELETE");
1700 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1707 PUSHSTACKi(PERLSI_MAGIC);
1708 if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
1709 sv = *PL_stack_sp--;
1710 retval = SvIV(sv)-1;
1712 Perl_croak(aTHX_ "FETCHSIZE returned a negative value");
1717 return (U32) retval;
1721 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1726 PUSHSTACKi(PERLSI_MAGIC);
1728 XPUSHs(SvTIED_obj(sv, mg));
1730 call_method("CLEAR", G_SCALAR|G_DISCARD);
1738 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1741 const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
1745 PUSHSTACKi(PERLSI_MAGIC);
1748 PUSHs(SvTIED_obj(sv, mg));
1753 if (call_method(meth, G_SCALAR))
1754 sv_setsv(key, *PL_stack_sp--);
1763 Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg)
1765 return magic_methpack(sv,mg,"EXISTS");
1769 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1773 SV * const tied = SvTIED_obj((SV*)hv, mg);
1774 HV * const pkg = SvSTASH((SV*)SvRV(tied));
1776 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1778 if (HvEITER_get(hv))
1779 /* we are in an iteration so the hash cannot be empty */
1781 /* no xhv_eiter so now use FIRSTKEY */
1782 key = sv_newmortal();
1783 magic_nextpack((SV*)hv, mg, key);
1784 HvEITER_set(hv, NULL); /* need to reset iterator */
1785 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1788 /* there is a SCALAR method that we can call */
1790 PUSHSTACKi(PERLSI_MAGIC);
1796 if (call_method("SCALAR", G_SCALAR))
1797 retval = *PL_stack_sp--;
1799 retval = &PL_sv_undef;
1806 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1809 GV * const gv = PL_DBline;
1810 const I32 i = SvTRUE(sv);
1811 SV ** const svp = av_fetch(GvAV(gv),
1812 atoi(MgPV_nolen_const(mg)), FALSE);
1813 if (svp && SvIOKp(*svp)) {
1814 OP * const o = INT2PTR(OP*,SvIVX(*svp));
1816 /* set or clear breakpoint in the relevant control op */
1818 o->op_flags |= OPf_SPECIAL;
1820 o->op_flags &= ~OPf_SPECIAL;
1827 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
1830 const AV * const obj = (AV*)mg->mg_obj;
1832 sv_setiv(sv, AvFILL(obj) + CopARYBASE_get(PL_curcop));
1840 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
1843 AV * const obj = (AV*)mg->mg_obj;
1845 av_fill(obj, SvIV(sv) - CopARYBASE_get(PL_curcop));
1847 if (ckWARN(WARN_MISC))
1848 Perl_warner(aTHX_ packWARN(WARN_MISC),
1849 "Attempt to set length of freed array");
1855 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
1858 PERL_UNUSED_ARG(sv);
1859 /* during global destruction, mg_obj may already have been freed */
1860 if (PL_in_clean_all)
1863 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
1866 /* arylen scalar holds a pointer back to the array, but doesn't own a
1867 reference. Hence the we (the array) are about to go away with it
1868 still pointing at us. Clear its pointer, else it would be pointing
1869 at free memory. See the comment in sv_magic about reference loops,
1870 and why it can't own a reference to us. */
1877 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
1880 SV* const lsv = LvTARG(sv);
1881 PERL_UNUSED_ARG(mg);
1883 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1884 MAGIC * const found = mg_find(lsv, PERL_MAGIC_regex_global);
1885 if (found && found->mg_len >= 0) {
1886 I32 i = found->mg_len;
1888 sv_pos_b2u(lsv, &i);
1889 sv_setiv(sv, i + CopARYBASE_get(PL_curcop));
1898 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
1901 SV* const lsv = LvTARG(sv);
1907 PERL_UNUSED_ARG(mg);
1909 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
1910 found = mg_find(lsv, PERL_MAGIC_regex_global);
1916 #ifdef PERL_OLD_COPY_ON_WRITE
1918 sv_force_normal_flags(lsv, 0);
1920 found = sv_magicext(lsv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
1923 else if (!SvOK(sv)) {
1927 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1929 pos = SvIV(sv) - CopARYBASE_get(PL_curcop);
1932 ulen = sv_len_utf8(lsv);
1942 else if (pos > (SSize_t)len)
1947 sv_pos_u2b(lsv, &p, 0);
1951 found->mg_len = pos;
1952 found->mg_flags &= ~MGf_MINMATCH;
1958 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
1961 SV * const lsv = LvTARG(sv);
1962 const char * const tmps = SvPV_const(lsv,len);
1963 I32 offs = LvTARGOFF(sv);
1964 I32 rem = LvTARGLEN(sv);
1965 PERL_UNUSED_ARG(mg);
1968 sv_pos_u2b(lsv, &offs, &rem);
1969 if (offs > (I32)len)
1971 if (rem + offs > (I32)len)
1973 sv_setpvn(sv, tmps + offs, (STRLEN)rem);
1980 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
1984 const char * const tmps = SvPV_const(sv, len);
1985 SV * const lsv = LvTARG(sv);
1986 I32 lvoff = LvTARGOFF(sv);
1987 I32 lvlen = LvTARGLEN(sv);
1988 PERL_UNUSED_ARG(mg);
1991 sv_utf8_upgrade(lsv);
1992 sv_pos_u2b(lsv, &lvoff, &lvlen);
1993 sv_insert(lsv, lvoff, lvlen, tmps, len);
1994 LvTARGLEN(sv) = sv_len_utf8(sv);
1997 else if (lsv && SvUTF8(lsv)) {
1999 sv_pos_u2b(lsv, &lvoff, &lvlen);
2000 LvTARGLEN(sv) = len;
2001 utf8 = (char*)bytes_to_utf8((U8*)tmps, &len);
2002 sv_insert(lsv, lvoff, lvlen, utf8, len);
2006 sv_insert(lsv, lvoff, lvlen, tmps, len);
2007 LvTARGLEN(sv) = len;
2015 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
2018 PERL_UNUSED_ARG(sv);
2019 TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
2024 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
2027 PERL_UNUSED_ARG(sv);
2028 /* update taint status */
2037 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
2039 SV * const lsv = LvTARG(sv);
2040 PERL_UNUSED_ARG(mg);
2043 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
2051 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
2053 PERL_UNUSED_ARG(mg);
2054 do_vecset(sv); /* XXX slurp this routine */
2059 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
2063 if (LvTARGLEN(sv)) {
2065 SV * const ahv = LvTARG(sv);
2066 HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
2071 AV* const av = (AV*)LvTARG(sv);
2072 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
2073 targ = AvARRAY(av)[LvTARGOFF(sv)];
2075 if (targ && (targ != &PL_sv_undef)) {
2076 /* somebody else defined it for us */
2077 SvREFCNT_dec(LvTARG(sv));
2078 LvTARG(sv) = SvREFCNT_inc_simple_NN(targ);
2080 SvREFCNT_dec(mg->mg_obj);
2082 mg->mg_flags &= ~MGf_REFCOUNTED;
2087 sv_setsv(sv, targ ? targ : &PL_sv_undef);
2092 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
2094 PERL_UNUSED_ARG(mg);
2098 sv_setsv(LvTARG(sv), sv);
2099 SvSETMAGIC(LvTARG(sv));
2105 Perl_vivify_defelem(pTHX_ SV *sv)
2111 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2114 SV * const ahv = LvTARG(sv);
2115 HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
2118 if (!value || value == &PL_sv_undef)
2119 Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(mg->mg_obj));
2122 AV* const av = (AV*)LvTARG(sv);
2123 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
2124 LvTARG(sv) = NULL; /* array can't be extended */
2126 SV* const * const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
2127 if (!svp || (value = *svp) == &PL_sv_undef)
2128 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
2131 SvREFCNT_inc_simple_void(value);
2132 SvREFCNT_dec(LvTARG(sv));
2135 SvREFCNT_dec(mg->mg_obj);
2137 mg->mg_flags &= ~MGf_REFCOUNTED;
2141 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2143 return Perl_sv_kill_backrefs(aTHX_ sv, (AV*)mg->mg_obj);
2147 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2149 PERL_UNUSED_CONTEXT;
2156 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2158 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2160 if (uf && uf->uf_set)
2161 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2166 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2168 const char type = mg->mg_type;
2169 if (type == PERL_MAGIC_qr) {
2170 } else if (type == PERL_MAGIC_bm) {
2174 assert(type == PERL_MAGIC_fm);
2177 return sv_unmagic(sv, type);
2180 #ifdef USE_LOCALE_COLLATE
2182 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2185 * RenE<eacute> Descartes said "I think not."
2186 * and vanished with a faint plop.
2188 PERL_UNUSED_CONTEXT;
2189 PERL_UNUSED_ARG(sv);
2191 Safefree(mg->mg_ptr);
2197 #endif /* USE_LOCALE_COLLATE */
2199 /* Just clear the UTF-8 cache data. */
2201 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2203 PERL_UNUSED_CONTEXT;
2204 PERL_UNUSED_ARG(sv);
2205 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2207 mg->mg_len = -1; /* The mg_len holds the len cache. */
2212 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2215 register const char *s;
2217 register const REGEXP * rx;
2218 const char * const remaining = mg->mg_ptr + 1;
2222 switch (*mg->mg_ptr) {
2223 case '\015': /* $^MATCH */
2224 if (strEQ(remaining, "ATCH"))
2226 case '`': /* ${^PREMATCH} caught below */
2228 paren = RX_BUFF_IDX_PREMATCH;
2230 case '\'': /* ${^POSTMATCH} caught below */
2232 paren = RX_BUFF_IDX_POSTMATCH;
2236 paren = RX_BUFF_IDX_FULLMATCH;
2238 case '1': case '2': case '3': case '4':
2239 case '5': case '6': case '7': case '8': case '9':
2240 paren = atoi(mg->mg_ptr);
2242 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
2243 CALLREG_NUMBUF_STORE((REGEXP * const)rx,paren,sv);
2246 /* Croak with a READONLY error when a numbered match var is
2247 * set without a previous pattern match. Unless it's C<local $1>
2249 if (!PL_localizing) {
2250 Perl_croak(aTHX_ PL_no_modify);
2253 case '\001': /* ^A */
2254 sv_setsv(PL_bodytarget, sv);
2256 case '\003': /* ^C */
2257 PL_minus_c = (bool)SvIV(sv);
2260 case '\004': /* ^D */
2262 s = SvPV_nolen_const(sv);
2263 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2264 DEBUG_x(dump_all());
2266 PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG;
2269 case '\005': /* ^E */
2270 if (*(mg->mg_ptr+1) == '\0') {
2271 #ifdef MACOS_TRADITIONAL
2272 gMacPerl_OSErr = SvIV(sv);
2275 set_vaxc_errno(SvIV(sv));
2278 SetLastError( SvIV(sv) );
2281 os2_setsyserrno(SvIV(sv));
2283 /* will anyone ever use this? */
2284 SETERRNO(SvIV(sv), 4);
2290 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2292 SvREFCNT_dec(PL_encoding);
2293 if (SvOK(sv) || SvGMAGICAL(sv)) {
2294 PL_encoding = newSVsv(sv);
2301 case '\006': /* ^F */
2302 PL_maxsysfd = SvIV(sv);
2304 case '\010': /* ^H */
2305 PL_hints = SvIV(sv);
2307 case '\011': /* ^I */ /* NOT \t in EBCDIC */
2308 Safefree(PL_inplace);
2309 PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
2311 case '\017': /* ^O */
2312 if (*(mg->mg_ptr+1) == '\0') {
2313 Safefree(PL_osname);
2316 TAINT_PROPER("assigning to $^O");
2317 PL_osname = savesvpv(sv);
2320 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2322 const char *const start = SvPV(sv, len);
2323 const char *out = (const char*)memchr(start, '\0', len);
2325 struct refcounted_he *tmp_he;
2328 PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2330 |= HINT_LOCALIZE_HH | HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2332 /* Opening for input is more common than opening for output, so
2333 ensure that hints for input are sooner on linked list. */
2334 tmp = out ? newSVpvn_flags(out + 1, start + len - out - 1,
2335 SVs_TEMP | SvUTF8(sv))
2336 : newSVpvn_flags("", 0, SVs_TEMP | SvUTF8(sv));
2339 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
2340 newSVpvs_flags("open>", SVs_TEMP),
2343 /* The UTF-8 setting is carried over */
2344 sv_setpvn(tmp, start, out ? (STRLEN)(out - start) : len);
2346 PL_compiling.cop_hints_hash
2347 = Perl_refcounted_he_new(aTHX_ tmp_he,
2348 newSVpvs_flags("open<", SVs_TEMP),
2352 case '\020': /* ^P */
2353 if (*remaining == '\0') { /* ^P */
2354 PL_perldb = SvIV(sv);
2355 if (PL_perldb && !PL_DBsingle)
2358 } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
2360 } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
2363 case '\024': /* ^T */
2365 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2367 PL_basetime = (Time_t)SvIV(sv);
2370 case '\025': /* ^UTF8CACHE */
2371 if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
2372 PL_utf8cache = (signed char) sv_2iv(sv);
2375 case '\027': /* ^W & $^WARNING_BITS */
2376 if (*(mg->mg_ptr+1) == '\0') {
2377 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2379 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2380 | (i ? G_WARN_ON : G_WARN_OFF) ;
2383 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2384 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2385 if (!SvPOK(sv) && PL_localizing) {
2386 sv_setpvn(sv, WARN_NONEstring, WARNsize);
2387 PL_compiling.cop_warnings = pWARN_NONE;
2392 int accumulate = 0 ;
2393 int any_fatals = 0 ;
2394 const char * const ptr = SvPV_const(sv, len) ;
2395 for (i = 0 ; i < len ; ++i) {
2396 accumulate |= ptr[i] ;
2397 any_fatals |= (ptr[i] & 0xAA) ;
2400 if (!specialWARN(PL_compiling.cop_warnings))
2401 PerlMemShared_free(PL_compiling.cop_warnings);
2402 PL_compiling.cop_warnings = pWARN_NONE;
2404 /* Yuck. I can't see how to abstract this: */
2405 else if (isWARN_on(((STRLEN *)SvPV_nolen_const(sv)) - 1,
2406 WARN_ALL) && !any_fatals) {
2407 if (!specialWARN(PL_compiling.cop_warnings))
2408 PerlMemShared_free(PL_compiling.cop_warnings);
2409 PL_compiling.cop_warnings = pWARN_ALL;
2410 PL_dowarn |= G_WARN_ONCE ;
2414 const char *const p = SvPV_const(sv, len);
2416 PL_compiling.cop_warnings
2417 = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
2420 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2421 PL_dowarn |= G_WARN_ONCE ;
2429 if (PL_localizing) {
2430 if (PL_localizing == 1)
2431 SAVESPTR(PL_last_in_gv);
2433 else if (SvOK(sv) && GvIO(PL_last_in_gv))
2434 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2437 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2438 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2439 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2442 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2443 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2444 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2447 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
2450 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
2451 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2452 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2455 IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
2459 IO * const io = GvIOp(PL_defoutgv);
2462 if ((SvIV(sv)) == 0)
2463 IoFLAGS(io) &= ~IOf_FLUSH;
2465 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2466 PerlIO *ofp = IoOFP(io);
2468 (void)PerlIO_flush(ofp);
2469 IoFLAGS(io) |= IOf_FLUSH;
2475 SvREFCNT_dec(PL_rs);
2476 PL_rs = newSVsv(sv);
2480 SvREFCNT_dec(PL_ors_sv);
2481 if (SvOK(sv) || SvGMAGICAL(sv)) {
2482 PL_ors_sv = newSVsv(sv);
2490 SvREFCNT_dec(PL_ofs_sv);
2491 if (SvOK(sv) || SvGMAGICAL(sv)) {
2492 PL_ofs_sv = newSVsv(sv);
2499 CopARYBASE_set(&PL_compiling, SvIV(sv));
2502 #ifdef COMPLEX_STATUS
2503 if (PL_localizing == 2) {
2504 PL_statusvalue = LvTARGOFF(sv);
2505 PL_statusvalue_vms = LvTARGLEN(sv);
2509 #ifdef VMSISH_STATUS
2511 STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2514 STATUS_UNIX_EXIT_SET(SvIV(sv));
2519 # define PERL_VMS_BANG vaxc$errno
2521 # define PERL_VMS_BANG 0
2523 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2524 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2529 if (PL_delaymagic) {
2530 PL_delaymagic |= DM_RUID;
2531 break; /* don't do magic till later */
2534 (void)setruid((Uid_t)PL_uid);
2537 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2539 #ifdef HAS_SETRESUID
2540 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2542 if (PL_uid == PL_euid) { /* special case $< = $> */
2544 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2545 if (PL_uid != 0 && PerlProc_getuid() == 0)
2546 (void)PerlProc_setuid(0);
2548 (void)PerlProc_setuid(PL_uid);
2550 PL_uid = PerlProc_getuid();
2551 Perl_croak(aTHX_ "setruid() not implemented");
2556 PL_uid = PerlProc_getuid();
2557 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2561 if (PL_delaymagic) {
2562 PL_delaymagic |= DM_EUID;
2563 break; /* don't do magic till later */
2566 (void)seteuid((Uid_t)PL_euid);
2569 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2571 #ifdef HAS_SETRESUID
2572 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2574 if (PL_euid == PL_uid) /* special case $> = $< */
2575 PerlProc_setuid(PL_euid);
2577 PL_euid = PerlProc_geteuid();
2578 Perl_croak(aTHX_ "seteuid() not implemented");
2583 PL_euid = PerlProc_geteuid();
2584 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2588 if (PL_delaymagic) {
2589 PL_delaymagic |= DM_RGID;
2590 break; /* don't do magic till later */
2593 (void)setrgid((Gid_t)PL_gid);
2596 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2598 #ifdef HAS_SETRESGID
2599 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2601 if (PL_gid == PL_egid) /* special case $( = $) */
2602 (void)PerlProc_setgid(PL_gid);
2604 PL_gid = PerlProc_getgid();
2605 Perl_croak(aTHX_ "setrgid() not implemented");
2610 PL_gid = PerlProc_getgid();
2611 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2614 #ifdef HAS_SETGROUPS
2616 const char *p = SvPV_const(sv, len);
2617 Groups_t *gary = NULL;
2622 for (i = 0; i < NGROUPS; ++i) {
2623 while (*p && !isSPACE(*p))
2630 Newx(gary, i + 1, Groups_t);
2632 Renew(gary, i + 1, Groups_t);
2636 (void)setgroups(i, gary);
2639 #else /* HAS_SETGROUPS */
2641 #endif /* HAS_SETGROUPS */
2642 if (PL_delaymagic) {
2643 PL_delaymagic |= DM_EGID;
2644 break; /* don't do magic till later */
2647 (void)setegid((Gid_t)PL_egid);
2650 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2652 #ifdef HAS_SETRESGID
2653 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2655 if (PL_egid == PL_gid) /* special case $) = $( */
2656 (void)PerlProc_setgid(PL_egid);
2658 PL_egid = PerlProc_getegid();
2659 Perl_croak(aTHX_ "setegid() not implemented");
2664 PL_egid = PerlProc_getegid();
2665 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2668 PL_chopset = SvPV_force(sv,len);
2670 #ifndef MACOS_TRADITIONAL
2672 LOCK_DOLLARZERO_MUTEX;
2673 #ifdef HAS_SETPROCTITLE
2674 /* The BSDs don't show the argv[] in ps(1) output, they
2675 * show a string from the process struct and provide
2676 * the setproctitle() routine to manipulate that. */
2677 if (PL_origalen != 1) {
2678 s = SvPV_const(sv, len);
2679 # if __FreeBSD_version > 410001
2680 /* The leading "-" removes the "perl: " prefix,
2681 * but not the "(perl) suffix from the ps(1)
2682 * output, because that's what ps(1) shows if the
2683 * argv[] is modified. */
2684 setproctitle("-%s", s);
2685 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2686 /* This doesn't really work if you assume that
2687 * $0 = 'foobar'; will wipe out 'perl' from the $0
2688 * because in ps(1) output the result will be like
2689 * sprintf("perl: %s (perl)", s)
2690 * I guess this is a security feature:
2691 * one (a user process) cannot get rid of the original name.
2693 setproctitle("%s", s);
2696 #elif defined(__hpux) && defined(PSTAT_SETCMD)
2697 if (PL_origalen != 1) {
2699 s = SvPV_const(sv, len);
2700 un.pst_command = (char *)s;
2701 pstat(PSTAT_SETCMD, un, len, 0, 0);
2704 if (PL_origalen > 1) {
2705 /* PL_origalen is set in perl_parse(). */
2706 s = SvPV_force(sv,len);
2707 if (len >= (STRLEN)PL_origalen-1) {
2708 /* Longer than original, will be truncated. We assume that
2709 * PL_origalen bytes are available. */
2710 Copy(s, PL_origargv[0], PL_origalen-1, char);
2713 /* Shorter than original, will be padded. */
2715 /* Special case for Mac OS X: see [perl #38868] */
2718 /* Is the space counterintuitive? Yes.
2719 * (You were expecting \0?)
2720 * Does it work? Seems to. (In Linux 2.4.20 at least.)
2722 const int pad = ' ';
2724 Copy(s, PL_origargv[0], len, char);
2725 PL_origargv[0][len] = 0;
2726 memset(PL_origargv[0] + len + 1,
2727 pad, PL_origalen - len - 1);
2729 PL_origargv[0][PL_origalen-1] = 0;
2730 for (i = 1; i < PL_origargc; i++)
2734 UNLOCK_DOLLARZERO_MUTEX;
2742 Perl_whichsig(pTHX_ const char *sig)
2744 register char* const* sigv;
2745 PERL_UNUSED_CONTEXT;
2747 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
2748 if (strEQ(sig,*sigv))
2749 return PL_sig_num[sigv - (char* const*)PL_sig_name];
2751 if (strEQ(sig,"CHLD"))
2755 if (strEQ(sig,"CLD"))
2762 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2763 Perl_sighandler(int sig, siginfo_t *sip, void *uap PERL_UNUSED_DECL)
2765 Perl_sighandler(int sig)
2768 #ifdef PERL_GET_SIG_CONTEXT
2769 dTHXa(PERL_GET_SIG_CONTEXT);
2776 SV * const tSv = PL_Sv;
2780 XPV * const tXpv = PL_Xpv;
2782 if (PL_savestack_ix + 15 <= PL_savestack_max)
2784 if (PL_markstack_ptr < PL_markstack_max - 2)
2786 if (PL_scopestack_ix < PL_scopestack_max - 3)
2789 if (!PL_psig_ptr[sig]) {
2790 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2795 /* Max number of items pushed there is 3*n or 4. We cannot fix
2796 infinity, so we fix 4 (in fact 5): */
2798 PL_savestack_ix += 5; /* Protect save in progress. */
2799 SAVEDESTRUCTOR_X(S_unwind_handler_stack, (void*)&flags);
2802 PL_markstack_ptr++; /* Protect mark. */
2804 PL_scopestack_ix += 1;
2805 /* sv_2cv is too complicated, try a simpler variant first: */
2806 if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
2807 || SvTYPE(cv) != SVt_PVCV) {
2809 cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
2812 if (!cv || !CvROOT(cv)) {
2813 if (ckWARN(WARN_SIGNAL))
2814 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2815 PL_sig_name[sig], (gv ? GvENAME(gv)
2822 if(PL_psig_name[sig]) {
2823 sv = SvREFCNT_inc_NN(PL_psig_name[sig]);
2825 #if !defined(PERL_IMPLICIT_CONTEXT)
2829 sv = sv_newmortal();
2830 sv_setpv(sv,PL_sig_name[sig]);
2833 PUSHSTACKi(PERLSI_SIGNAL);
2836 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2838 struct sigaction oact;
2840 if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
2843 SV *rv = newRV_noinc((SV*)sih);
2844 /* The siginfo fields signo, code, errno, pid, uid,
2845 * addr, status, and band are defined by POSIX/SUSv3. */
2846 (void)hv_stores(sih, "signo", newSViv(sip->si_signo));
2847 (void)hv_stores(sih, "code", newSViv(sip->si_code));
2848 #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. */
2849 hv_stores(sih, "errno", newSViv(sip->si_errno));
2850 hv_stores(sih, "status", newSViv(sip->si_status));
2851 hv_stores(sih, "uid", newSViv(sip->si_uid));
2852 hv_stores(sih, "pid", newSViv(sip->si_pid));
2853 hv_stores(sih, "addr", newSVuv(PTR2UV(sip->si_addr)));
2854 hv_stores(sih, "band", newSViv(sip->si_band));
2858 mPUSHp((char *)sip, sizeof(*sip));
2866 call_sv((SV*)cv, G_DISCARD|G_EVAL);
2869 if (SvTRUE(ERRSV)) {
2871 #ifdef HAS_SIGPROCMASK
2872 /* Handler "died", for example to get out of a restart-able read().
2873 * Before we re-do that on its behalf re-enable the signal which was
2874 * blocked by the system when we entered.
2878 sigaddset(&set,sig);
2879 sigprocmask(SIG_UNBLOCK, &set, NULL);
2881 /* Not clear if this will work */
2882 (void)rsignal(sig, SIG_IGN);
2883 (void)rsignal(sig, PL_csighandlerp);
2885 #endif /* !PERL_MICRO */
2886 Perl_die(aTHX_ NULL);
2890 PL_savestack_ix -= 8; /* Unprotect save in progress. */
2894 PL_scopestack_ix -= 1;
2897 PL_op = myop; /* Apparently not needed... */
2899 PL_Sv = tSv; /* Restore global temporaries. */
2906 S_restore_magic(pTHX_ const void *p)
2909 MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
2910 SV* const sv = mgs->mgs_sv;
2915 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2917 #ifdef PERL_OLD_COPY_ON_WRITE
2918 /* While magic was saved (and off) sv_setsv may well have seen
2919 this SV as a prime candidate for COW. */
2921 sv_force_normal_flags(sv, 0);
2925 SvFLAGS(sv) |= mgs->mgs_flags;
2928 if (SvGMAGICAL(sv)) {
2929 /* downgrade public flags to private,
2930 and discard any other private flags */
2932 const U32 pubflags = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
2934 SvFLAGS(sv) &= ~( pubflags | (SVp_IOK|SVp_NOK|SVp_POK) );
2935 SvFLAGS(sv) |= ( pubflags << PRIVSHIFT );
2940 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
2942 /* If we're still on top of the stack, pop us off. (That condition
2943 * will be satisfied if restore_magic was called explicitly, but *not*
2944 * if it's being called via leave_scope.)
2945 * The reason for doing this is that otherwise, things like sv_2cv()
2946 * may leave alloc gunk on the savestack, and some code
2947 * (e.g. sighandler) doesn't expect that...
2949 if (PL_savestack_ix == mgs->mgs_ss_ix)
2951 I32 popval = SSPOPINT;
2952 assert(popval == SAVEt_DESTRUCTOR_X);
2953 PL_savestack_ix -= 2;
2955 assert(popval == SAVEt_ALLOC);
2957 PL_savestack_ix -= popval;
2963 S_unwind_handler_stack(pTHX_ const void *p)
2966 const U32 flags = *(const U32*)p;
2969 PL_savestack_ix -= 5; /* Unprotect save in progress. */
2970 #if !defined(PERL_IMPLICIT_CONTEXT)
2972 SvREFCNT_dec(PL_sig_sv);
2977 =for apidoc magic_sethint
2979 Triggered by a store to %^H, records the key/value pair to
2980 C<PL_compiling.cop_hints_hash>. It is assumed that hints aren't storing
2981 anything that would need a deep copy. Maybe we should warn if we find a
2987 Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
2990 SV *key = (mg->mg_len == HEf_SVKEY) ? (SV *)mg->mg_ptr
2991 : newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
2993 /* mg->mg_obj isn't being used. If needed, it would be possible to store
2994 an alternative leaf in there, with PL_compiling.cop_hints being used if
2995 it's NULL. If needed for threads, the alternative could lock a mutex,
2996 or take other more complex action. */
2998 /* Something changed in %^H, so it will need to be restored on scope exit.
2999 Doing this here saves a lot of doing it manually in perl code (and
3000 forgetting to do it, and consequent subtle errors. */
3001 PL_hints |= HINT_LOCALIZE_HH;
3002 PL_compiling.cop_hints_hash
3003 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash, key, sv);
3008 =for apidoc magic_sethint
3010 Triggered by a delete from %^H, records the key to
3011 C<PL_compiling.cop_hints_hash>.
3016 Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
3019 PERL_UNUSED_ARG(sv);
3021 assert(mg->mg_len == HEf_SVKEY);
3023 PERL_UNUSED_ARG(sv);
3025 PL_hints |= HINT_LOCALIZE_HH;
3026 PL_compiling.cop_hints_hash
3027 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
3028 (SV *)mg->mg_ptr, &PL_sv_placeholder);
3034 * c-indentation-style: bsd
3036 * indent-tabs-mode: t
3039 * ex: set ts=8 sts=4 sw=4 noet: