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 const U8 *s = (U8*)SvPV_const(sv, len);
313 len = utf8_length(s, s + len);
316 (void)SvPV_const(sv, len);
321 Perl_mg_size(pTHX_ SV *sv)
325 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
326 const MGVTBL* const vtbl = mg->mg_virtual;
327 if (vtbl && vtbl->svt_len) {
328 const I32 mgs_ix = SSNEW(sizeof(MGS));
330 save_magic(mgs_ix, sv);
331 /* omit MGf_GSKIP -- not changed here */
332 len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
333 restore_magic(INT2PTR(void*, (IV)mgs_ix));
340 return AvFILLp((AV *) sv); /* Fallback to non-tied array */
344 Perl_croak(aTHX_ "Size magic not implemented");
353 Clear something magical that the SV represents. See C<sv_magic>.
359 Perl_mg_clear(pTHX_ SV *sv)
361 const I32 mgs_ix = SSNEW(sizeof(MGS));
364 save_magic(mgs_ix, sv);
366 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
367 const MGVTBL* const vtbl = mg->mg_virtual;
368 /* omit GSKIP -- never set here */
370 if (vtbl && vtbl->svt_clear)
371 CALL_FPTR(vtbl->svt_clear)(aTHX_ sv, mg);
374 restore_magic(INT2PTR(void*, (IV)mgs_ix));
381 Finds the magic pointer for type matching the SV. See C<sv_magic>.
387 Perl_mg_find(pTHX_ const SV *sv, int type)
392 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
393 if (mg->mg_type == type)
403 Copies the magic from one SV to another. See C<sv_magic>.
409 Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
413 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
414 const MGVTBL* const vtbl = mg->mg_virtual;
415 if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){
416 count += CALL_FPTR(vtbl->svt_copy)(aTHX_ sv, mg, nsv, key, klen);
419 const char type = mg->mg_type;
420 if (isUPPER(type) && type != PERL_MAGIC_uvar) {
422 (type == PERL_MAGIC_tied)
424 : (type == PERL_MAGIC_regdata && mg->mg_obj)
427 toLOWER(type), key, klen);
436 =for apidoc mg_localize
438 Copy some of the magic from an existing SV to new localized version of
439 that SV. Container magic (eg %ENV, $1, tie) gets copied, value magic
440 doesn't (eg taint, pos).
446 Perl_mg_localize(pTHX_ SV *sv, SV *nsv)
450 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
451 const MGVTBL* const vtbl = mg->mg_virtual;
452 if (!S_is_container_magic(mg))
455 if ((mg->mg_flags & MGf_LOCAL) && vtbl->svt_local)
456 (void)CALL_FPTR(vtbl->svt_local)(aTHX_ nsv, mg);
458 sv_magicext(nsv, mg->mg_obj, mg->mg_type, vtbl,
459 mg->mg_ptr, mg->mg_len);
461 /* container types should remain read-only across localization */
462 SvFLAGS(nsv) |= SvREADONLY(sv);
465 if (SvTYPE(nsv) >= SVt_PVMG && SvMAGIC(nsv)) {
466 SvFLAGS(nsv) |= SvMAGICAL(sv);
476 Free any magic storage used by the SV. See C<sv_magic>.
482 Perl_mg_free(pTHX_ SV *sv)
486 for (mg = SvMAGIC(sv); mg; mg = moremagic) {
487 const MGVTBL* const vtbl = mg->mg_virtual;
488 moremagic = mg->mg_moremagic;
489 if (vtbl && vtbl->svt_free)
490 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
491 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
492 if (mg->mg_len > 0 || mg->mg_type == PERL_MAGIC_utf8)
493 Safefree(mg->mg_ptr);
494 else if (mg->mg_len == HEf_SVKEY)
495 SvREFCNT_dec((SV*)mg->mg_ptr);
497 if (mg->mg_flags & MGf_REFCOUNTED)
498 SvREFCNT_dec(mg->mg_obj);
501 SvMAGIC_set(sv, NULL);
508 Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
514 register const REGEXP * const rx = PM_GETRE(PL_curpm);
516 if (mg->mg_obj) { /* @+ */
517 /* return the number possible */
520 I32 paren = rx->lastparen;
522 /* return the last filled */
524 && (rx->offs[paren].start == -1
525 || rx->offs[paren].end == -1) )
536 Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
540 register const REGEXP * const rx = PM_GETRE(PL_curpm);
542 register const I32 paren = mg->mg_len;
547 if (paren <= (I32)rx->nparens &&
548 (s = rx->offs[paren].start) != -1 &&
549 (t = rx->offs[paren].end) != -1)
552 if (mg->mg_obj) /* @+ */
557 if (i > 0 && RX_MATCH_UTF8(rx)) {
558 const char * const b = rx->subbeg;
560 i = utf8_length((U8*)b, (U8*)(b+i));
571 Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
575 Perl_croak(aTHX_ PL_no_modify);
576 NORETURN_FUNCTION_END;
580 Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
585 register const REGEXP * rx;
586 const char * const remaining = mg->mg_ptr + 1;
588 switch (*mg->mg_ptr) {
590 if (*remaining == '\0') { /* ^P */
592 } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
594 } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
598 case '\015': /* $^MATCH */
599 if (strEQ(remaining, "ATCH")) {
606 paren = RX_BUFF_IDX_PREMATCH;
610 paren = RX_BUFF_IDX_POSTMATCH;
614 paren = RX_BUFF_IDX_FULLMATCH;
616 case '1': case '2': case '3': case '4':
617 case '5': case '6': case '7': case '8': case '9':
618 paren = atoi(mg->mg_ptr);
620 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
622 i = CALLREG_NUMBUF_LENGTH((REGEXP * const)rx, sv, paren);
625 Perl_croak(aTHX_ "panic: magic_len: %"IVdf, (IV)i);
628 if (ckWARN(WARN_UNINITIALIZED))
633 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
634 paren = rx->lastparen;
639 case '\016': /* ^N */
640 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
641 paren = rx->lastcloseparen;
648 if (!SvPOK(sv) && SvNIOK(sv)) {
656 #define SvRTRIM(sv) STMT_START { \
658 STRLEN len = SvCUR(sv); \
659 char * const p = SvPVX(sv); \
660 while (len > 0 && isSPACE(p[len-1])) \
662 SvCUR_set(sv, len); \
668 Perl_emulate_cop_io(pTHX_ const COP *const c, SV *const sv)
670 if (!(CopHINTS_get(c) & (HINT_LEXICAL_IO_IN|HINT_LEXICAL_IO_OUT)))
671 sv_setsv(sv, &PL_sv_undef);
675 if ((CopHINTS_get(c) & HINT_LEXICAL_IO_IN)) {
676 SV *const value = Perl_refcounted_he_fetch(aTHX_
678 0, "open<", 5, 0, 0);
683 if ((CopHINTS_get(c) & HINT_LEXICAL_IO_OUT)) {
684 SV *const value = Perl_refcounted_he_fetch(aTHX_
686 0, "open>", 5, 0, 0);
694 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
698 register char *s = NULL;
700 const char * const remaining = mg->mg_ptr + 1;
701 const char nextchar = *remaining;
703 switch (*mg->mg_ptr) {
704 case '\001': /* ^A */
705 sv_setsv(sv, PL_bodytarget);
707 case '\003': /* ^C, ^CHILD_ERROR_NATIVE */
708 if (nextchar == '\0') {
709 sv_setiv(sv, (IV)PL_minus_c);
711 else if (strEQ(remaining, "HILD_ERROR_NATIVE")) {
712 sv_setiv(sv, (IV)STATUS_NATIVE);
716 case '\004': /* ^D */
717 sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
719 case '\005': /* ^E */
720 if (nextchar == '\0') {
721 #if defined(MACOS_TRADITIONAL)
725 sv_setnv(sv,(double)gMacPerl_OSErr);
726 sv_setpv(sv, gMacPerl_OSErr ? GetSysErrText(gMacPerl_OSErr, msg) : "");
730 # include <descrip.h>
731 # include <starlet.h>
733 $DESCRIPTOR(msgdsc,msg);
734 sv_setnv(sv,(NV) vaxc$errno);
735 if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
736 sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
741 if (!(_emx_env & 0x200)) { /* Under DOS */
742 sv_setnv(sv, (NV)errno);
743 sv_setpv(sv, errno ? Strerror(errno) : "");
745 if (errno != errno_isOS2) {
746 const int tmp = _syserrno();
747 if (tmp) /* 2nd call to _syserrno() makes it 0 */
750 sv_setnv(sv, (NV)Perl_rc);
751 sv_setpv(sv, os2error(Perl_rc));
755 const DWORD dwErr = GetLastError();
756 sv_setnv(sv, (NV)dwErr);
758 PerlProc_GetOSError(sv, dwErr);
761 sv_setpvn(sv, "", 0);
766 const int saveerrno = errno;
767 sv_setnv(sv, (NV)errno);
768 sv_setpv(sv, errno ? Strerror(errno) : "");
773 SvNOK_on(sv); /* what a wonderful hack! */
775 else if (strEQ(remaining, "NCODING"))
776 sv_setsv(sv, PL_encoding);
778 case '\006': /* ^F */
779 sv_setiv(sv, (IV)PL_maxsysfd);
781 case '\010': /* ^H */
782 sv_setiv(sv, (IV)PL_hints);
784 case '\011': /* ^I */ /* NOT \t in EBCDIC */
786 sv_setpv(sv, PL_inplace);
788 sv_setsv(sv, &PL_sv_undef);
790 case '\017': /* ^O & ^OPEN */
791 if (nextchar == '\0') {
792 sv_setpv(sv, PL_osname);
795 else if (strEQ(remaining, "PEN")) {
796 Perl_emulate_cop_io(aTHX_ &PL_compiling, sv);
800 if (nextchar == '\0') { /* ^P */
801 sv_setiv(sv, (IV)PL_perldb);
802 } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
803 goto do_prematch_fetch;
804 } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
805 goto do_postmatch_fetch;
808 case '\023': /* ^S */
809 if (nextchar == '\0') {
810 if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING)
813 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
818 case '\024': /* ^T */
819 if (nextchar == '\0') {
821 sv_setnv(sv, PL_basetime);
823 sv_setiv(sv, (IV)PL_basetime);
826 else if (strEQ(remaining, "AINT"))
827 sv_setiv(sv, PL_tainting
828 ? (PL_taint_warn || PL_unsafe ? -1 : 1)
831 case '\025': /* $^UNICODE, $^UTF8LOCALE, $^UTF8CACHE */
832 if (strEQ(remaining, "NICODE"))
833 sv_setuv(sv, (UV) PL_unicode);
834 else if (strEQ(remaining, "TF8LOCALE"))
835 sv_setuv(sv, (UV) PL_utf8locale);
836 else if (strEQ(remaining, "TF8CACHE"))
837 sv_setiv(sv, (IV) PL_utf8cache);
839 case '\027': /* ^W & $^WARNING_BITS */
840 if (nextchar == '\0')
841 sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
842 else if (strEQ(remaining, "ARNING_BITS")) {
843 if (PL_compiling.cop_warnings == pWARN_NONE) {
844 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
846 else if (PL_compiling.cop_warnings == pWARN_STD) {
849 (PL_dowarn & G_WARN_ON) ? WARN_ALLstring : WARN_NONEstring,
853 else if (PL_compiling.cop_warnings == pWARN_ALL) {
854 /* Get the bit mask for $warnings::Bits{all}, because
855 * it could have been extended by warnings::register */
856 HV * const bits=get_hv("warnings::Bits", FALSE);
858 SV ** const bits_all = hv_fetchs(bits, "all", FALSE);
860 sv_setsv(sv, *bits_all);
863 sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
867 sv_setpvn(sv, (char *) (PL_compiling.cop_warnings + 1),
868 *PL_compiling.cop_warnings);
873 case '\015': /* $^MATCH */
874 if (strEQ(remaining, "ATCH")) {
875 case '1': case '2': case '3': case '4':
876 case '5': case '6': case '7': case '8': case '9': case '&':
877 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
879 * Pre-threads, this was paren = atoi(GvENAME((GV*)mg->mg_obj));
880 * XXX Does the new way break anything?
882 paren = atoi(mg->mg_ptr); /* $& is in [0] */
883 CALLREG_NUMBUF_FETCH(rx,paren,sv);
886 sv_setsv(sv,&PL_sv_undef);
890 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
892 CALLREG_NUMBUF_FETCH(rx,rx->lastparen,sv);
896 sv_setsv(sv,&PL_sv_undef);
898 case '\016': /* ^N */
899 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
900 if (rx->lastcloseparen) {
901 CALLREG_NUMBUF_FETCH(rx,rx->lastcloseparen,sv);
906 sv_setsv(sv,&PL_sv_undef);
910 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
911 CALLREG_NUMBUF_FETCH(rx,-2,sv);
914 sv_setsv(sv,&PL_sv_undef);
918 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
919 CALLREG_NUMBUF_FETCH(rx,-1,sv);
922 sv_setsv(sv,&PL_sv_undef);
925 if (GvIO(PL_last_in_gv)) {
926 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
931 sv_setiv(sv, (IV)STATUS_CURRENT);
932 #ifdef COMPLEX_STATUS
933 LvTARGOFF(sv) = PL_statusvalue;
934 LvTARGLEN(sv) = PL_statusvalue_vms;
939 if (GvIOp(PL_defoutgv))
940 s = IoTOP_NAME(GvIOp(PL_defoutgv));
944 sv_setpv(sv,GvENAME(PL_defoutgv));
945 sv_catpvs(sv,"_TOP");
949 if (GvIOp(PL_defoutgv))
950 s = IoFMT_NAME(GvIOp(PL_defoutgv));
952 s = GvENAME(PL_defoutgv);
956 if (GvIOp(PL_defoutgv))
957 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
960 if (GvIOp(PL_defoutgv))
961 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
964 if (GvIOp(PL_defoutgv))
965 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
972 sv_setiv(sv, (IV)CopARYBASE_get(PL_curcop));
975 if (GvIOp(PL_defoutgv))
976 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
982 sv_copypv(sv, PL_ors_sv);
986 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
987 sv_setpv(sv, errno ? Strerror(errno) : "");
990 const int saveerrno = errno;
991 sv_setnv(sv, (NV)errno);
993 if (errno == errno_isOS2 || errno == errno_isOS2_set)
994 sv_setpv(sv, os2error(Perl_rc));
997 sv_setpv(sv, errno ? Strerror(errno) : "");
1002 SvNOK_on(sv); /* what a wonderful hack! */
1005 sv_setiv(sv, (IV)PL_uid);
1008 sv_setiv(sv, (IV)PL_euid);
1011 sv_setiv(sv, (IV)PL_gid);
1014 sv_setiv(sv, (IV)PL_egid);
1016 #ifdef HAS_GETGROUPS
1018 Groups_t *gary = NULL;
1019 I32 i, num_groups = getgroups(0, gary);
1020 Newx(gary, num_groups, Groups_t);
1021 num_groups = getgroups(num_groups, gary);
1022 for (i = 0; i < num_groups; i++)
1023 Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]);
1026 (void)SvIOK_on(sv); /* what a wonderful hack! */
1029 #ifndef MACOS_TRADITIONAL
1038 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
1040 struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
1042 if (uf && uf->uf_val)
1043 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
1048 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
1051 STRLEN len = 0, klen;
1052 const char *s = SvOK(sv) ? SvPV_const(sv,len) : "";
1053 const char * const ptr = MgPV_const(mg,klen);
1056 #ifdef DYNAMIC_ENV_FETCH
1057 /* We just undefd an environment var. Is a replacement */
1058 /* waiting in the wings? */
1060 SV ** const valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE);
1062 s = SvOK(*valp) ? SvPV_const(*valp, len) : "";
1066 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
1067 /* And you'll never guess what the dog had */
1068 /* in its mouth... */
1070 MgTAINTEDDIR_off(mg);
1072 if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
1073 char pathbuf[256], eltbuf[256], *cp, *elt;
1077 my_strlcpy(eltbuf, s, sizeof(eltbuf));
1079 do { /* DCL$PATH may be a search list */
1080 while (1) { /* as may dev portion of any element */
1081 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1082 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1083 cando_by_name(S_IWUSR,0,elt) ) {
1084 MgTAINTEDDIR_on(mg);
1088 if ((cp = strchr(elt, ':')) != NULL)
1090 if (my_trnlnm(elt, eltbuf, j++))
1096 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1099 if (s && klen == 4 && strEQ(ptr,"PATH")) {
1100 const char * const strend = s + len;
1102 while (s < strend) {
1106 #ifdef VMS /* Hmm. How do we get $Config{path_sep} from C? */
1107 const char path_sep = '|';
1109 const char path_sep = ':';
1111 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
1112 s, strend, path_sep, &i);
1114 if (i >= (I32)sizeof tmpbuf /* too long -- assume the worst */
1116 || !strchr(tmpbuf, ':') /* no colon thus no device name -- assume relative path */
1118 || *tmpbuf != '/' /* no starting slash -- assume relative path */
1120 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1121 MgTAINTEDDIR_on(mg);
1127 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1133 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1135 PERL_UNUSED_ARG(sv);
1136 my_setenv(MgPV_nolen_const(mg),NULL);
1141 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1144 PERL_UNUSED_ARG(mg);
1146 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1148 if (PL_localizing) {
1151 hv_iterinit((HV*)sv);
1152 while ((entry = hv_iternext((HV*)sv))) {
1154 my_setenv(hv_iterkey(entry, &keylen),
1155 SvPV_nolen_const(hv_iterval((HV*)sv, entry)));
1163 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1166 PERL_UNUSED_ARG(sv);
1167 PERL_UNUSED_ARG(mg);
1169 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1177 #ifdef HAS_SIGPROCMASK
1179 restore_sigmask(pTHX_ SV *save_sv)
1181 const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1182 (void)sigprocmask(SIG_SETMASK, ossetp, NULL);
1186 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1189 /* Are we fetching a signal entry? */
1190 const I32 i = whichsig(MgPV_nolen_const(mg));
1193 sv_setsv(sv,PL_psig_ptr[i]);
1195 Sighandler_t sigstate = rsignal_state(i);
1196 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1197 if (PL_sig_handlers_initted && PL_sig_ignoring[i])
1200 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1201 if (PL_sig_handlers_initted && PL_sig_defaulting[i])
1204 /* cache state so we don't fetch it again */
1205 if(sigstate == (Sighandler_t) SIG_IGN)
1206 sv_setpvs(sv,"IGNORE");
1208 sv_setsv(sv,&PL_sv_undef);
1209 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1216 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1218 /* XXX Some of this code was copied from Perl_magic_setsig. A little
1219 * refactoring might be in order.
1222 register const char * const s = MgPV_nolen_const(mg);
1223 PERL_UNUSED_ARG(sv);
1226 if (strEQ(s,"__DIE__"))
1228 else if (strEQ(s,"__WARN__") && PL_warnhook != PERL_WARNHOOK_FATAL)
1231 SV *const to_dec = *svp;
1233 SvREFCNT_dec(to_dec);
1237 /* Are we clearing a signal entry? */
1238 const I32 i = whichsig(s);
1240 #ifdef HAS_SIGPROCMASK
1243 /* Avoid having the signal arrive at a bad time, if possible. */
1246 sigprocmask(SIG_BLOCK, &set, &save);
1248 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1249 SAVEFREESV(save_sv);
1250 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1253 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1254 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1256 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1257 PL_sig_defaulting[i] = 1;
1258 (void)rsignal(i, PL_csighandlerp);
1260 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1262 if(PL_psig_name[i]) {
1263 SvREFCNT_dec(PL_psig_name[i]);
1266 if(PL_psig_ptr[i]) {
1267 SV * const to_dec=PL_psig_ptr[i];
1270 SvREFCNT_dec(to_dec);
1280 * The signal handling nomenclature has gotten a bit confusing since the advent of
1281 * safe signals. S_raise_signal only raises signals by analogy with what the
1282 * underlying system's signal mechanism does. It might be more proper to say that
1283 * it defers signals that have already been raised and caught.
1285 * PL_sig_pending and PL_psig_pend likewise do not track signals that are pending
1286 * in the sense of being on the system's signal queue in between raising and delivery.
1287 * They are only pending on Perl's deferral list, i.e., they track deferred signals
1288 * awaiting delivery after the current Perl opcode completes and say nothing about
1289 * signals raised but not yet caught in the underlying signal implementation.
1292 #ifndef SIG_PENDING_DIE_COUNT
1293 # define SIG_PENDING_DIE_COUNT 120
1297 S_raise_signal(pTHX_ int sig)
1300 /* Set a flag to say this signal is pending */
1301 PL_psig_pend[sig]++;
1302 /* And one to say _a_ signal is pending */
1303 if (++PL_sig_pending >= SIG_PENDING_DIE_COUNT)
1304 Perl_croak(aTHX_ "Maximal count of pending signals (%lu) exceeded",
1305 (unsigned long)SIG_PENDING_DIE_COUNT);
1309 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1310 Perl_csighandler(int sig, siginfo_t *sip PERL_UNUSED_DECL, void *uap PERL_UNUSED_DECL)
1312 Perl_csighandler(int sig)
1315 #ifdef PERL_GET_SIG_CONTEXT
1316 dTHXa(PERL_GET_SIG_CONTEXT);
1320 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1322 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1323 (void) rsignal(sig, PL_csighandlerp);
1324 if (PL_sig_ignoring[sig]) return;
1326 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1327 if (PL_sig_defaulting[sig])
1328 #ifdef KILL_BY_SIGPRC
1329 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1334 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1346 (PL_signals & PERL_SIGNALS_UNSAFE_FLAG))
1347 /* Call the perl level handler now--
1348 * with risk we may be in malloc() etc. */
1349 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1350 (*PL_sighandlerp)(sig, NULL, NULL);
1352 (*PL_sighandlerp)(sig);
1355 S_raise_signal(aTHX_ sig);
1358 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1360 Perl_csighandler_init(void)
1363 if (PL_sig_handlers_initted) return;
1365 for (sig = 1; sig < SIG_SIZE; sig++) {
1366 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1368 PL_sig_defaulting[sig] = 1;
1369 (void) rsignal(sig, PL_csighandlerp);
1371 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1372 PL_sig_ignoring[sig] = 0;
1375 PL_sig_handlers_initted = 1;
1380 Perl_despatch_signals(pTHX)
1385 for (sig = 1; sig < SIG_SIZE; sig++) {
1386 if (PL_psig_pend[sig]) {
1387 PERL_BLOCKSIG_ADD(set, sig);
1388 PL_psig_pend[sig] = 0;
1389 PERL_BLOCKSIG_BLOCK(set);
1390 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1391 (*PL_sighandlerp)(sig, NULL, NULL);
1393 (*PL_sighandlerp)(sig);
1395 PERL_BLOCKSIG_UNBLOCK(set);
1401 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1406 /* Need to be careful with SvREFCNT_dec(), because that can have side
1407 * effects (due to closures). We must make sure that the new disposition
1408 * is in place before it is called.
1412 #ifdef HAS_SIGPROCMASK
1417 register const char *s = MgPV_const(mg,len);
1419 if (strEQ(s,"__DIE__"))
1421 else if (strEQ(s,"__WARN__"))
1424 Perl_croak(aTHX_ "No such hook: %s", s);
1427 if (*svp != PERL_WARNHOOK_FATAL)
1433 i = whichsig(s); /* ...no, a brick */
1435 if (ckWARN(WARN_SIGNAL))
1436 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
1439 #ifdef HAS_SIGPROCMASK
1440 /* Avoid having the signal arrive at a bad time, if possible. */
1443 sigprocmask(SIG_BLOCK, &set, &save);
1445 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1446 SAVEFREESV(save_sv);
1447 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1450 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1451 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1453 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1454 PL_sig_ignoring[i] = 0;
1456 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1457 PL_sig_defaulting[i] = 0;
1459 SvREFCNT_dec(PL_psig_name[i]);
1460 to_dec = PL_psig_ptr[i];
1461 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1462 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1463 PL_psig_name[i] = newSVpvn(s, len);
1464 SvREADONLY_on(PL_psig_name[i]);
1466 if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
1468 (void)rsignal(i, PL_csighandlerp);
1469 #ifdef HAS_SIGPROCMASK
1474 *svp = SvREFCNT_inc_simple_NN(sv);
1476 SvREFCNT_dec(to_dec);
1479 s = SvOK(sv) ? SvPV_force(sv,len) : "DEFAULT";
1480 if (strEQ(s,"IGNORE")) {
1482 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1483 PL_sig_ignoring[i] = 1;
1484 (void)rsignal(i, PL_csighandlerp);
1486 (void)rsignal(i, (Sighandler_t) SIG_IGN);
1490 else if (strEQ(s,"DEFAULT") || !*s) {
1492 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1494 PL_sig_defaulting[i] = 1;
1495 (void)rsignal(i, PL_csighandlerp);
1498 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1503 * We should warn if HINT_STRICT_REFS, but without
1504 * access to a known hint bit in a known OP, we can't
1505 * tell whether HINT_STRICT_REFS is in force or not.
1507 if (!strchr(s,':') && !strchr(s,'\''))
1508 Perl_sv_insert(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"));
1510 (void)rsignal(i, PL_csighandlerp);
1512 *svp = SvREFCNT_inc_simple_NN(sv);
1514 #ifdef HAS_SIGPROCMASK
1519 SvREFCNT_dec(to_dec);
1522 #endif /* !PERL_MICRO */
1525 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1529 PERL_UNUSED_ARG(sv);
1531 /* Bail out if destruction is going on */
1532 if(PL_dirty) return 0;
1534 /* Skip _isaelem because _isa will handle it shortly */
1535 if (PL_delaymagic & DM_ARRAY && mg->mg_type == PERL_MAGIC_isaelem)
1538 /* XXX Once it's possible, we need to
1539 detect that our @ISA is aliased in
1540 other stashes, and act on the stashes
1541 of all of the aliases */
1543 /* The first case occurs via setisa,
1544 the second via setisa_elem, which
1545 calls this same magic */
1547 SvTYPE(mg->mg_obj) == SVt_PVGV
1549 : (GV*)SvMAGIC(mg->mg_obj)->mg_obj
1552 mro_isa_changed_in(stash);
1558 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
1561 PERL_UNUSED_ARG(sv);
1562 PERL_UNUSED_ARG(mg);
1563 PL_amagic_generation++;
1569 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1571 HV * const hv = (HV*)LvTARG(sv);
1573 PERL_UNUSED_ARG(mg);
1576 (void) hv_iterinit(hv);
1577 if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
1580 while (hv_iternext(hv))
1585 sv_setiv(sv, (IV)i);
1590 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1592 PERL_UNUSED_ARG(mg);
1594 hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
1599 /* caller is responsible for stack switching/cleanup */
1601 S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV *val)
1608 PUSHs(SvTIED_obj(sv, mg));
1611 if (mg->mg_len >= 0)
1612 PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len)));
1613 else if (mg->mg_len == HEf_SVKEY)
1614 PUSHs((SV*)mg->mg_ptr);
1616 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1617 PUSHs(sv_2mortal(newSViv(mg->mg_len)));
1625 return call_method(meth, flags);
1629 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
1635 PUSHSTACKi(PERLSI_MAGIC);
1637 if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
1638 sv_setsv(sv, *PL_stack_sp--);
1648 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1651 mg->mg_flags |= MGf_GSKIP;
1652 magic_methpack(sv,mg,"FETCH");
1657 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1661 PUSHSTACKi(PERLSI_MAGIC);
1662 magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
1669 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1671 return magic_methpack(sv,mg,"DELETE");
1676 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1683 PUSHSTACKi(PERLSI_MAGIC);
1684 if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
1685 sv = *PL_stack_sp--;
1686 retval = SvIV(sv)-1;
1688 Perl_croak(aTHX_ "FETCHSIZE returned a negative value");
1693 return (U32) retval;
1697 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1702 PUSHSTACKi(PERLSI_MAGIC);
1704 XPUSHs(SvTIED_obj(sv, mg));
1706 call_method("CLEAR", G_SCALAR|G_DISCARD);
1714 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1717 const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
1721 PUSHSTACKi(PERLSI_MAGIC);
1724 PUSHs(SvTIED_obj(sv, mg));
1729 if (call_method(meth, G_SCALAR))
1730 sv_setsv(key, *PL_stack_sp--);
1739 Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg)
1741 return magic_methpack(sv,mg,"EXISTS");
1745 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1749 SV * const tied = SvTIED_obj((SV*)hv, mg);
1750 HV * const pkg = SvSTASH((SV*)SvRV(tied));
1752 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1754 if (HvEITER_get(hv))
1755 /* we are in an iteration so the hash cannot be empty */
1757 /* no xhv_eiter so now use FIRSTKEY */
1758 key = sv_newmortal();
1759 magic_nextpack((SV*)hv, mg, key);
1760 HvEITER_set(hv, NULL); /* need to reset iterator */
1761 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1764 /* there is a SCALAR method that we can call */
1766 PUSHSTACKi(PERLSI_MAGIC);
1772 if (call_method("SCALAR", G_SCALAR))
1773 retval = *PL_stack_sp--;
1775 retval = &PL_sv_undef;
1782 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1785 GV * const gv = PL_DBline;
1786 const I32 i = SvTRUE(sv);
1787 SV ** const svp = av_fetch(GvAV(gv),
1788 atoi(MgPV_nolen_const(mg)), FALSE);
1789 if (svp && SvIOKp(*svp)) {
1790 OP * const o = INT2PTR(OP*,SvIVX(*svp));
1792 /* set or clear breakpoint in the relevant control op */
1794 o->op_flags |= OPf_SPECIAL;
1796 o->op_flags &= ~OPf_SPECIAL;
1803 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
1806 const AV * const obj = (AV*)mg->mg_obj;
1808 sv_setiv(sv, AvFILL(obj) + CopARYBASE_get(PL_curcop));
1816 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
1819 AV * const obj = (AV*)mg->mg_obj;
1821 av_fill(obj, SvIV(sv) - CopARYBASE_get(PL_curcop));
1823 if (ckWARN(WARN_MISC))
1824 Perl_warner(aTHX_ packWARN(WARN_MISC),
1825 "Attempt to set length of freed array");
1831 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
1834 PERL_UNUSED_ARG(sv);
1835 /* during global destruction, mg_obj may already have been freed */
1836 if (PL_in_clean_all)
1839 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
1842 /* arylen scalar holds a pointer back to the array, but doesn't own a
1843 reference. Hence the we (the array) are about to go away with it
1844 still pointing at us. Clear its pointer, else it would be pointing
1845 at free memory. See the comment in sv_magic about reference loops,
1846 and why it can't own a reference to us. */
1853 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
1856 SV* const lsv = LvTARG(sv);
1857 PERL_UNUSED_ARG(mg);
1859 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1860 MAGIC * const found = mg_find(lsv, PERL_MAGIC_regex_global);
1861 if (found && found->mg_len >= 0) {
1862 I32 i = found->mg_len;
1864 sv_pos_b2u(lsv, &i);
1865 sv_setiv(sv, i + CopARYBASE_get(PL_curcop));
1874 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
1877 SV* const lsv = LvTARG(sv);
1883 PERL_UNUSED_ARG(mg);
1885 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
1886 found = mg_find(lsv, PERL_MAGIC_regex_global);
1892 #ifdef PERL_OLD_COPY_ON_WRITE
1894 sv_force_normal_flags(lsv, 0);
1896 found = sv_magicext(lsv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
1899 else if (!SvOK(sv)) {
1903 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1905 pos = SvIV(sv) - CopARYBASE_get(PL_curcop);
1908 ulen = sv_len_utf8(lsv);
1918 else if (pos > (SSize_t)len)
1923 sv_pos_u2b(lsv, &p, 0);
1927 found->mg_len = pos;
1928 found->mg_flags &= ~MGf_MINMATCH;
1934 Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg)
1937 PERL_UNUSED_ARG(mg);
1939 Perl_croak(aTHX_ "Perl_magic_setglob is dead code?");
1943 if (isGV_with_GP(sv)) {
1944 /* We're actually already a typeglob, so don't need the stuff below.
1948 gv = gv_fetchsv(sv, GV_ADD, SVt_PVGV);
1953 GvGP(sv) = gp_ref(GvGP(gv));
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_setbm(pTHX_ SV *sv, MAGIC *mg)
2158 PERL_UNUSED_ARG(mg);
2159 sv_unmagic(sv, PERL_MAGIC_bm);
2166 Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
2168 PERL_UNUSED_ARG(mg);
2169 sv_unmagic(sv, PERL_MAGIC_fm);
2175 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2177 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2179 if (uf && uf->uf_set)
2180 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2185 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2187 PERL_UNUSED_ARG(mg);
2188 sv_unmagic(sv, PERL_MAGIC_qr);
2193 Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
2196 regexp * const re = (regexp *)mg->mg_obj;
2197 PERL_UNUSED_ARG(sv);
2203 #ifdef USE_LOCALE_COLLATE
2205 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2208 * RenE<eacute> Descartes said "I think not."
2209 * and vanished with a faint plop.
2211 PERL_UNUSED_CONTEXT;
2212 PERL_UNUSED_ARG(sv);
2214 Safefree(mg->mg_ptr);
2220 #endif /* USE_LOCALE_COLLATE */
2222 /* Just clear the UTF-8 cache data. */
2224 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2226 PERL_UNUSED_CONTEXT;
2227 PERL_UNUSED_ARG(sv);
2228 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2230 mg->mg_len = -1; /* The mg_len holds the len cache. */
2235 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2238 register const char *s;
2240 register const REGEXP * rx;
2241 const char * const remaining = mg->mg_ptr + 1;
2245 switch (*mg->mg_ptr) {
2246 case '\015': /* $^MATCH */
2247 if (strEQ(remaining, "ATCH"))
2249 case '`': /* ${^PREMATCH} caught below */
2251 paren = RX_BUFF_IDX_PREMATCH;
2253 case '\'': /* ${^POSTMATCH} caught below */
2255 paren = RX_BUFF_IDX_POSTMATCH;
2259 paren = RX_BUFF_IDX_FULLMATCH;
2261 case '1': case '2': case '3': case '4':
2262 case '5': case '6': case '7': case '8': case '9':
2263 paren = atoi(mg->mg_ptr);
2265 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
2266 CALLREG_NUMBUF_STORE((REGEXP * const)rx,paren,sv);
2269 /* Croak with a READONLY error when a numbered match var is
2270 * set without a previous pattern match. Unless it's C<local $1>
2272 if (!PL_localizing) {
2273 Perl_croak(aTHX_ PL_no_modify);
2276 case '\001': /* ^A */
2277 sv_setsv(PL_bodytarget, sv);
2279 case '\003': /* ^C */
2280 PL_minus_c = (bool)SvIV(sv);
2283 case '\004': /* ^D */
2285 s = SvPV_nolen_const(sv);
2286 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2287 DEBUG_x(dump_all());
2289 PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG;
2292 case '\005': /* ^E */
2293 if (*(mg->mg_ptr+1) == '\0') {
2294 #ifdef MACOS_TRADITIONAL
2295 gMacPerl_OSErr = SvIV(sv);
2298 set_vaxc_errno(SvIV(sv));
2301 SetLastError( SvIV(sv) );
2304 os2_setsyserrno(SvIV(sv));
2306 /* will anyone ever use this? */
2307 SETERRNO(SvIV(sv), 4);
2313 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2315 SvREFCNT_dec(PL_encoding);
2316 if (SvOK(sv) || SvGMAGICAL(sv)) {
2317 PL_encoding = newSVsv(sv);
2324 case '\006': /* ^F */
2325 PL_maxsysfd = SvIV(sv);
2327 case '\010': /* ^H */
2328 PL_hints = SvIV(sv);
2330 case '\011': /* ^I */ /* NOT \t in EBCDIC */
2331 Safefree(PL_inplace);
2332 PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
2334 case '\017': /* ^O */
2335 if (*(mg->mg_ptr+1) == '\0') {
2336 Safefree(PL_osname);
2339 TAINT_PROPER("assigning to $^O");
2340 PL_osname = savesvpv(sv);
2343 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2345 const char *const start = SvPV(sv, len);
2346 const char *out = (const char*)memchr(start, '\0', len);
2348 struct refcounted_he *tmp_he;
2351 PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2353 |= HINT_LOCALIZE_HH | HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2355 /* Opening for input is more common than opening for output, so
2356 ensure that hints for input are sooner on linked list. */
2357 tmp = sv_2mortal(out ? newSVpvn(out + 1, start + len - out - 1)
2359 SvFLAGS(tmp) |= SvUTF8(sv);
2362 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
2363 sv_2mortal(newSVpvs("open>")), tmp);
2365 /* The UTF-8 setting is carried over */
2366 sv_setpvn(tmp, start, out ? (STRLEN)(out - start) : len);
2368 PL_compiling.cop_hints_hash
2369 = Perl_refcounted_he_new(aTHX_ tmp_he,
2370 sv_2mortal(newSVpvs("open<")), tmp);
2373 case '\020': /* ^P */
2374 if (*remaining == '\0') { /* ^P */
2375 PL_perldb = SvIV(sv);
2376 if (PL_perldb && !PL_DBsingle)
2379 } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
2381 } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
2384 case '\024': /* ^T */
2386 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2388 PL_basetime = (Time_t)SvIV(sv);
2391 case '\025': /* ^UTF8CACHE */
2392 if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
2393 PL_utf8cache = (signed char) sv_2iv(sv);
2396 case '\027': /* ^W & $^WARNING_BITS */
2397 if (*(mg->mg_ptr+1) == '\0') {
2398 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2400 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2401 | (i ? G_WARN_ON : G_WARN_OFF) ;
2404 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2405 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2406 if (!SvPOK(sv) && PL_localizing) {
2407 sv_setpvn(sv, WARN_NONEstring, WARNsize);
2408 PL_compiling.cop_warnings = pWARN_NONE;
2413 int accumulate = 0 ;
2414 int any_fatals = 0 ;
2415 const char * const ptr = SvPV_const(sv, len) ;
2416 for (i = 0 ; i < len ; ++i) {
2417 accumulate |= ptr[i] ;
2418 any_fatals |= (ptr[i] & 0xAA) ;
2421 if (!specialWARN(PL_compiling.cop_warnings))
2422 PerlMemShared_free(PL_compiling.cop_warnings);
2423 PL_compiling.cop_warnings = pWARN_NONE;
2425 /* Yuck. I can't see how to abstract this: */
2426 else if (isWARN_on(((STRLEN *)SvPV_nolen_const(sv)) - 1,
2427 WARN_ALL) && !any_fatals) {
2428 if (!specialWARN(PL_compiling.cop_warnings))
2429 PerlMemShared_free(PL_compiling.cop_warnings);
2430 PL_compiling.cop_warnings = pWARN_ALL;
2431 PL_dowarn |= G_WARN_ONCE ;
2435 const char *const p = SvPV_const(sv, len);
2437 PL_compiling.cop_warnings
2438 = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
2441 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2442 PL_dowarn |= G_WARN_ONCE ;
2450 if (PL_localizing) {
2451 if (PL_localizing == 1)
2452 SAVESPTR(PL_last_in_gv);
2454 else if (SvOK(sv) && GvIO(PL_last_in_gv))
2455 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2458 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2459 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2460 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2463 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2464 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2465 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2468 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
2471 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
2472 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2473 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2476 IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
2480 IO * const io = GvIOp(PL_defoutgv);
2483 if ((SvIV(sv)) == 0)
2484 IoFLAGS(io) &= ~IOf_FLUSH;
2486 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2487 PerlIO *ofp = IoOFP(io);
2489 (void)PerlIO_flush(ofp);
2490 IoFLAGS(io) |= IOf_FLUSH;
2496 SvREFCNT_dec(PL_rs);
2497 PL_rs = newSVsv(sv);
2501 SvREFCNT_dec(PL_ors_sv);
2502 if (SvOK(sv) || SvGMAGICAL(sv)) {
2503 PL_ors_sv = newSVsv(sv);
2511 SvREFCNT_dec(PL_ofs_sv);
2512 if (SvOK(sv) || SvGMAGICAL(sv)) {
2513 PL_ofs_sv = newSVsv(sv);
2520 CopARYBASE_set(&PL_compiling, SvIV(sv));
2523 #ifdef COMPLEX_STATUS
2524 if (PL_localizing == 2) {
2525 PL_statusvalue = LvTARGOFF(sv);
2526 PL_statusvalue_vms = LvTARGLEN(sv);
2530 #ifdef VMSISH_STATUS
2532 STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2535 STATUS_UNIX_EXIT_SET(SvIV(sv));
2540 # define PERL_VMS_BANG vaxc$errno
2542 # define PERL_VMS_BANG 0
2544 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2545 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2550 if (PL_delaymagic) {
2551 PL_delaymagic |= DM_RUID;
2552 break; /* don't do magic till later */
2555 (void)setruid((Uid_t)PL_uid);
2558 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2560 #ifdef HAS_SETRESUID
2561 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2563 if (PL_uid == PL_euid) { /* special case $< = $> */
2565 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2566 if (PL_uid != 0 && PerlProc_getuid() == 0)
2567 (void)PerlProc_setuid(0);
2569 (void)PerlProc_setuid(PL_uid);
2571 PL_uid = PerlProc_getuid();
2572 Perl_croak(aTHX_ "setruid() not implemented");
2577 PL_uid = PerlProc_getuid();
2578 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2582 if (PL_delaymagic) {
2583 PL_delaymagic |= DM_EUID;
2584 break; /* don't do magic till later */
2587 (void)seteuid((Uid_t)PL_euid);
2590 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2592 #ifdef HAS_SETRESUID
2593 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2595 if (PL_euid == PL_uid) /* special case $> = $< */
2596 PerlProc_setuid(PL_euid);
2598 PL_euid = PerlProc_geteuid();
2599 Perl_croak(aTHX_ "seteuid() not implemented");
2604 PL_euid = PerlProc_geteuid();
2605 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2609 if (PL_delaymagic) {
2610 PL_delaymagic |= DM_RGID;
2611 break; /* don't do magic till later */
2614 (void)setrgid((Gid_t)PL_gid);
2617 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2619 #ifdef HAS_SETRESGID
2620 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2622 if (PL_gid == PL_egid) /* special case $( = $) */
2623 (void)PerlProc_setgid(PL_gid);
2625 PL_gid = PerlProc_getgid();
2626 Perl_croak(aTHX_ "setrgid() not implemented");
2631 PL_gid = PerlProc_getgid();
2632 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2635 #ifdef HAS_SETGROUPS
2637 const char *p = SvPV_const(sv, len);
2638 Groups_t *gary = NULL;
2643 for (i = 0; i < NGROUPS; ++i) {
2644 while (*p && !isSPACE(*p))
2651 Newx(gary, i + 1, Groups_t);
2653 Renew(gary, i + 1, Groups_t);
2657 (void)setgroups(i, gary);
2660 #else /* HAS_SETGROUPS */
2662 #endif /* HAS_SETGROUPS */
2663 if (PL_delaymagic) {
2664 PL_delaymagic |= DM_EGID;
2665 break; /* don't do magic till later */
2668 (void)setegid((Gid_t)PL_egid);
2671 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2673 #ifdef HAS_SETRESGID
2674 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2676 if (PL_egid == PL_gid) /* special case $) = $( */
2677 (void)PerlProc_setgid(PL_egid);
2679 PL_egid = PerlProc_getegid();
2680 Perl_croak(aTHX_ "setegid() not implemented");
2685 PL_egid = PerlProc_getegid();
2686 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2689 PL_chopset = SvPV_force(sv,len);
2691 #ifndef MACOS_TRADITIONAL
2693 LOCK_DOLLARZERO_MUTEX;
2694 #ifdef HAS_SETPROCTITLE
2695 /* The BSDs don't show the argv[] in ps(1) output, they
2696 * show a string from the process struct and provide
2697 * the setproctitle() routine to manipulate that. */
2698 if (PL_origalen != 1) {
2699 s = SvPV_const(sv, len);
2700 # if __FreeBSD_version > 410001
2701 /* The leading "-" removes the "perl: " prefix,
2702 * but not the "(perl) suffix from the ps(1)
2703 * output, because that's what ps(1) shows if the
2704 * argv[] is modified. */
2705 setproctitle("-%s", s);
2706 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2707 /* This doesn't really work if you assume that
2708 * $0 = 'foobar'; will wipe out 'perl' from the $0
2709 * because in ps(1) output the result will be like
2710 * sprintf("perl: %s (perl)", s)
2711 * I guess this is a security feature:
2712 * one (a user process) cannot get rid of the original name.
2714 setproctitle("%s", s);
2717 #elif defined(__hpux) && defined(PSTAT_SETCMD)
2718 if (PL_origalen != 1) {
2720 s = SvPV_const(sv, len);
2721 un.pst_command = (char *)s;
2722 pstat(PSTAT_SETCMD, un, len, 0, 0);
2725 if (PL_origalen > 1) {
2726 /* PL_origalen is set in perl_parse(). */
2727 s = SvPV_force(sv,len);
2728 if (len >= (STRLEN)PL_origalen-1) {
2729 /* Longer than original, will be truncated. We assume that
2730 * PL_origalen bytes are available. */
2731 Copy(s, PL_origargv[0], PL_origalen-1, char);
2734 /* Shorter than original, will be padded. */
2736 /* Special case for Mac OS X: see [perl #38868] */
2739 /* Is the space counterintuitive? Yes.
2740 * (You were expecting \0?)
2741 * Does it work? Seems to. (In Linux 2.4.20 at least.)
2743 const int pad = ' ';
2745 Copy(s, PL_origargv[0], len, char);
2746 PL_origargv[0][len] = 0;
2747 memset(PL_origargv[0] + len + 1,
2748 pad, PL_origalen - len - 1);
2750 PL_origargv[0][PL_origalen-1] = 0;
2751 for (i = 1; i < PL_origargc; i++)
2755 UNLOCK_DOLLARZERO_MUTEX;
2763 Perl_whichsig(pTHX_ const char *sig)
2765 register char* const* sigv;
2766 PERL_UNUSED_CONTEXT;
2768 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
2769 if (strEQ(sig,*sigv))
2770 return PL_sig_num[sigv - (char* const*)PL_sig_name];
2772 if (strEQ(sig,"CHLD"))
2776 if (strEQ(sig,"CLD"))
2783 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2784 Perl_sighandler(int sig, siginfo_t *sip, void *uap PERL_UNUSED_DECL)
2786 Perl_sighandler(int sig)
2789 #ifdef PERL_GET_SIG_CONTEXT
2790 dTHXa(PERL_GET_SIG_CONTEXT);
2797 SV * const tSv = PL_Sv;
2801 XPV * const tXpv = PL_Xpv;
2803 if (PL_savestack_ix + 15 <= PL_savestack_max)
2805 if (PL_markstack_ptr < PL_markstack_max - 2)
2807 if (PL_scopestack_ix < PL_scopestack_max - 3)
2810 if (!PL_psig_ptr[sig]) {
2811 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2816 /* Max number of items pushed there is 3*n or 4. We cannot fix
2817 infinity, so we fix 4 (in fact 5): */
2819 PL_savestack_ix += 5; /* Protect save in progress. */
2820 SAVEDESTRUCTOR_X(S_unwind_handler_stack, (void*)&flags);
2823 PL_markstack_ptr++; /* Protect mark. */
2825 PL_scopestack_ix += 1;
2826 /* sv_2cv is too complicated, try a simpler variant first: */
2827 if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
2828 || SvTYPE(cv) != SVt_PVCV) {
2830 cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
2833 if (!cv || !CvROOT(cv)) {
2834 if (ckWARN(WARN_SIGNAL))
2835 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2836 PL_sig_name[sig], (gv ? GvENAME(gv)
2843 if(PL_psig_name[sig]) {
2844 sv = SvREFCNT_inc_NN(PL_psig_name[sig]);
2846 #if !defined(PERL_IMPLICIT_CONTEXT)
2850 sv = sv_newmortal();
2851 sv_setpv(sv,PL_sig_name[sig]);
2854 PUSHSTACKi(PERLSI_SIGNAL);
2857 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2859 struct sigaction oact;
2861 if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
2864 SV *rv = newRV_noinc((SV*)sih);
2865 /* The siginfo fields signo, code, errno, pid, uid,
2866 * addr, status, and band are defined by POSIX/SUSv3. */
2867 (void)hv_stores(sih, "signo", newSViv(sip->si_signo));
2868 (void)hv_stores(sih, "code", newSViv(sip->si_code));
2869 #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. */
2870 hv_stores(sih, "errno", newSViv(sip->si_errno));
2871 hv_stores(sih, "status", newSViv(sip->si_status));
2872 hv_stores(sih, "uid", newSViv(sip->si_uid));
2873 hv_stores(sih, "pid", newSViv(sip->si_pid));
2874 hv_stores(sih, "addr", newSVuv(PTR2UV(sip->si_addr)));
2875 hv_stores(sih, "band", newSViv(sip->si_band));
2879 PUSHs(newSVpv((char *)sip, sizeof(*sip)));
2887 call_sv((SV*)cv, G_DISCARD|G_EVAL);
2890 if (SvTRUE(ERRSV)) {
2892 #ifdef HAS_SIGPROCMASK
2893 /* Handler "died", for example to get out of a restart-able read().
2894 * Before we re-do that on its behalf re-enable the signal which was
2895 * blocked by the system when we entered.
2899 sigaddset(&set,sig);
2900 sigprocmask(SIG_UNBLOCK, &set, NULL);
2902 /* Not clear if this will work */
2903 (void)rsignal(sig, SIG_IGN);
2904 (void)rsignal(sig, PL_csighandlerp);
2906 #endif /* !PERL_MICRO */
2907 Perl_die(aTHX_ NULL);
2911 PL_savestack_ix -= 8; /* Unprotect save in progress. */
2915 PL_scopestack_ix -= 1;
2918 PL_op = myop; /* Apparently not needed... */
2920 PL_Sv = tSv; /* Restore global temporaries. */
2927 S_restore_magic(pTHX_ const void *p)
2930 MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
2931 SV* const sv = mgs->mgs_sv;
2936 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2938 #ifdef PERL_OLD_COPY_ON_WRITE
2939 /* While magic was saved (and off) sv_setsv may well have seen
2940 this SV as a prime candidate for COW. */
2942 sv_force_normal_flags(sv, 0);
2946 SvFLAGS(sv) |= mgs->mgs_flags;
2949 if (SvGMAGICAL(sv)) {
2950 /* downgrade public flags to private,
2951 and discard any other private flags */
2953 const U32 pubflags = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
2955 SvFLAGS(sv) &= ~( pubflags | (SVp_IOK|SVp_NOK|SVp_POK) );
2956 SvFLAGS(sv) |= ( pubflags << PRIVSHIFT );
2961 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
2963 /* If we're still on top of the stack, pop us off. (That condition
2964 * will be satisfied if restore_magic was called explicitly, but *not*
2965 * if it's being called via leave_scope.)
2966 * The reason for doing this is that otherwise, things like sv_2cv()
2967 * may leave alloc gunk on the savestack, and some code
2968 * (e.g. sighandler) doesn't expect that...
2970 if (PL_savestack_ix == mgs->mgs_ss_ix)
2972 I32 popval = SSPOPINT;
2973 assert(popval == SAVEt_DESTRUCTOR_X);
2974 PL_savestack_ix -= 2;
2976 assert(popval == SAVEt_ALLOC);
2978 PL_savestack_ix -= popval;
2984 S_unwind_handler_stack(pTHX_ const void *p)
2987 const U32 flags = *(const U32*)p;
2990 PL_savestack_ix -= 5; /* Unprotect save in progress. */
2991 #if !defined(PERL_IMPLICIT_CONTEXT)
2993 SvREFCNT_dec(PL_sig_sv);
2998 =for apidoc magic_sethint
3000 Triggered by a store to %^H, records the key/value pair to
3001 C<PL_compiling.cop_hints_hash>. It is assumed that hints aren't storing
3002 anything that would need a deep copy. Maybe we should warn if we find a
3008 Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
3011 SV *key = (mg->mg_len == HEf_SVKEY) ? (SV *)mg->mg_ptr
3012 : sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len));
3014 /* mg->mg_obj isn't being used. If needed, it would be possible to store
3015 an alternative leaf in there, with PL_compiling.cop_hints being used if
3016 it's NULL. If needed for threads, the alternative could lock a mutex,
3017 or take other more complex action. */
3019 /* Something changed in %^H, so it will need to be restored on scope exit.
3020 Doing this here saves a lot of doing it manually in perl code (and
3021 forgetting to do it, and consequent subtle errors. */
3022 PL_hints |= HINT_LOCALIZE_HH;
3023 PL_compiling.cop_hints_hash
3024 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash, key, sv);
3029 =for apidoc magic_sethint
3031 Triggered by a delete from %^H, records the key to
3032 C<PL_compiling.cop_hints_hash>.
3037 Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
3040 PERL_UNUSED_ARG(sv);
3042 assert(mg->mg_len == HEf_SVKEY);
3044 PERL_UNUSED_ARG(sv);
3046 PL_hints |= HINT_LOCALIZE_HH;
3047 PL_compiling.cop_hints_hash
3048 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
3049 (SV *)mg->mg_ptr, &PL_sv_placeholder);
3055 * c-indentation-style: bsd
3057 * indent-tabs-mode: t
3060 * ex: set ts=8 sts=4 sw=4 noet: