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 */
785 sv_setpv(sv, PL_inplace); /* Will undefine sv if PL_inplace is NULL */
787 case '\017': /* ^O & ^OPEN */
788 if (nextchar == '\0') {
789 sv_setpv(sv, PL_osname);
792 else if (strEQ(remaining, "PEN")) {
793 Perl_emulate_cop_io(aTHX_ &PL_compiling, sv);
797 if (nextchar == '\0') { /* ^P */
798 sv_setiv(sv, (IV)PL_perldb);
799 } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
800 goto do_prematch_fetch;
801 } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
802 goto do_postmatch_fetch;
805 case '\023': /* ^S */
806 if (nextchar == '\0') {
807 if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING)
810 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
815 case '\024': /* ^T */
816 if (nextchar == '\0') {
818 sv_setnv(sv, PL_basetime);
820 sv_setiv(sv, (IV)PL_basetime);
823 else if (strEQ(remaining, "AINT"))
824 sv_setiv(sv, PL_tainting
825 ? (PL_taint_warn || PL_unsafe ? -1 : 1)
828 case '\025': /* $^UNICODE, $^UTF8LOCALE, $^UTF8CACHE */
829 if (strEQ(remaining, "NICODE"))
830 sv_setuv(sv, (UV) PL_unicode);
831 else if (strEQ(remaining, "TF8LOCALE"))
832 sv_setuv(sv, (UV) PL_utf8locale);
833 else if (strEQ(remaining, "TF8CACHE"))
834 sv_setiv(sv, (IV) PL_utf8cache);
836 case '\027': /* ^W & $^WARNING_BITS */
837 if (nextchar == '\0')
838 sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
839 else if (strEQ(remaining, "ARNING_BITS")) {
840 if (PL_compiling.cop_warnings == pWARN_NONE) {
841 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
843 else if (PL_compiling.cop_warnings == pWARN_STD) {
846 (PL_dowarn & G_WARN_ON) ? WARN_ALLstring : WARN_NONEstring,
850 else if (PL_compiling.cop_warnings == pWARN_ALL) {
851 /* Get the bit mask for $warnings::Bits{all}, because
852 * it could have been extended by warnings::register */
853 HV * const bits=get_hv("warnings::Bits", FALSE);
855 SV ** const bits_all = hv_fetchs(bits, "all", FALSE);
857 sv_setsv(sv, *bits_all);
860 sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
864 sv_setpvn(sv, (char *) (PL_compiling.cop_warnings + 1),
865 *PL_compiling.cop_warnings);
870 case '\015': /* $^MATCH */
871 if (strEQ(remaining, "ATCH")) {
872 case '1': case '2': case '3': case '4':
873 case '5': case '6': case '7': case '8': case '9': case '&':
874 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
876 * Pre-threads, this was paren = atoi(GvENAME((GV*)mg->mg_obj));
877 * XXX Does the new way break anything?
879 paren = atoi(mg->mg_ptr); /* $& is in [0] */
880 CALLREG_NUMBUF_FETCH(rx,paren,sv);
883 sv_setsv(sv,&PL_sv_undef);
887 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
889 CALLREG_NUMBUF_FETCH(rx,rx->lastparen,sv);
893 sv_setsv(sv,&PL_sv_undef);
895 case '\016': /* ^N */
896 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
897 if (rx->lastcloseparen) {
898 CALLREG_NUMBUF_FETCH(rx,rx->lastcloseparen,sv);
903 sv_setsv(sv,&PL_sv_undef);
907 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
908 CALLREG_NUMBUF_FETCH(rx,-2,sv);
911 sv_setsv(sv,&PL_sv_undef);
915 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
916 CALLREG_NUMBUF_FETCH(rx,-1,sv);
919 sv_setsv(sv,&PL_sv_undef);
922 if (GvIO(PL_last_in_gv)) {
923 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
928 sv_setiv(sv, (IV)STATUS_CURRENT);
929 #ifdef COMPLEX_STATUS
930 LvTARGOFF(sv) = PL_statusvalue;
931 LvTARGLEN(sv) = PL_statusvalue_vms;
936 if (GvIOp(PL_defoutgv))
937 s = IoTOP_NAME(GvIOp(PL_defoutgv));
941 sv_setpv(sv,GvENAME(PL_defoutgv));
942 sv_catpvs(sv,"_TOP");
946 if (GvIOp(PL_defoutgv))
947 s = IoFMT_NAME(GvIOp(PL_defoutgv));
949 s = GvENAME(PL_defoutgv);
953 if (GvIOp(PL_defoutgv))
954 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
957 if (GvIOp(PL_defoutgv))
958 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
961 if (GvIOp(PL_defoutgv))
962 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
969 sv_setiv(sv, (IV)CopARYBASE_get(PL_curcop));
972 if (GvIOp(PL_defoutgv))
973 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
979 sv_copypv(sv, PL_ors_sv);
983 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
984 sv_setpv(sv, errno ? Strerror(errno) : "");
987 const int saveerrno = errno;
988 sv_setnv(sv, (NV)errno);
990 if (errno == errno_isOS2 || errno == errno_isOS2_set)
991 sv_setpv(sv, os2error(Perl_rc));
994 sv_setpv(sv, errno ? Strerror(errno) : "");
999 SvNOK_on(sv); /* what a wonderful hack! */
1002 sv_setiv(sv, (IV)PL_uid);
1005 sv_setiv(sv, (IV)PL_euid);
1008 sv_setiv(sv, (IV)PL_gid);
1011 sv_setiv(sv, (IV)PL_egid);
1013 #ifdef HAS_GETGROUPS
1015 Groups_t *gary = NULL;
1016 I32 i, num_groups = getgroups(0, gary);
1017 Newx(gary, num_groups, Groups_t);
1018 num_groups = getgroups(num_groups, gary);
1019 for (i = 0; i < num_groups; i++)
1020 Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]);
1023 (void)SvIOK_on(sv); /* what a wonderful hack! */
1026 #ifndef MACOS_TRADITIONAL
1035 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
1037 struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
1039 if (uf && uf->uf_val)
1040 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
1045 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
1048 STRLEN len = 0, klen;
1049 const char *s = SvOK(sv) ? SvPV_const(sv,len) : "";
1050 const char * const ptr = MgPV_const(mg,klen);
1053 #ifdef DYNAMIC_ENV_FETCH
1054 /* We just undefd an environment var. Is a replacement */
1055 /* waiting in the wings? */
1057 SV ** const valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE);
1059 s = SvOK(*valp) ? SvPV_const(*valp, len) : "";
1063 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
1064 /* And you'll never guess what the dog had */
1065 /* in its mouth... */
1067 MgTAINTEDDIR_off(mg);
1069 if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
1070 char pathbuf[256], eltbuf[256], *cp, *elt;
1074 my_strlcpy(eltbuf, s, sizeof(eltbuf));
1076 do { /* DCL$PATH may be a search list */
1077 while (1) { /* as may dev portion of any element */
1078 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1079 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1080 cando_by_name(S_IWUSR,0,elt) ) {
1081 MgTAINTEDDIR_on(mg);
1085 if ((cp = strchr(elt, ':')) != NULL)
1087 if (my_trnlnm(elt, eltbuf, j++))
1093 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1096 if (s && klen == 4 && strEQ(ptr,"PATH")) {
1097 const char * const strend = s + len;
1099 while (s < strend) {
1103 #ifdef VMS /* Hmm. How do we get $Config{path_sep} from C? */
1104 const char path_sep = '|';
1106 const char path_sep = ':';
1108 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
1109 s, strend, path_sep, &i);
1111 if (i >= (I32)sizeof tmpbuf /* too long -- assume the worst */
1113 || !strchr(tmpbuf, ':') /* no colon thus no device name -- assume relative path */
1115 || *tmpbuf != '/' /* no starting slash -- assume relative path */
1117 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1118 MgTAINTEDDIR_on(mg);
1124 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1130 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1132 PERL_UNUSED_ARG(sv);
1133 my_setenv(MgPV_nolen_const(mg),NULL);
1138 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1141 PERL_UNUSED_ARG(mg);
1143 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1145 if (PL_localizing) {
1148 hv_iterinit((HV*)sv);
1149 while ((entry = hv_iternext((HV*)sv))) {
1151 my_setenv(hv_iterkey(entry, &keylen),
1152 SvPV_nolen_const(hv_iterval((HV*)sv, entry)));
1160 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1163 PERL_UNUSED_ARG(sv);
1164 PERL_UNUSED_ARG(mg);
1166 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1174 #ifdef HAS_SIGPROCMASK
1176 restore_sigmask(pTHX_ SV *save_sv)
1178 const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1179 (void)sigprocmask(SIG_SETMASK, ossetp, NULL);
1183 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1186 /* Are we fetching a signal entry? */
1187 const I32 i = whichsig(MgPV_nolen_const(mg));
1190 sv_setsv(sv,PL_psig_ptr[i]);
1192 Sighandler_t sigstate = rsignal_state(i);
1193 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1194 if (PL_sig_handlers_initted && PL_sig_ignoring[i])
1197 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1198 if (PL_sig_handlers_initted && PL_sig_defaulting[i])
1201 /* cache state so we don't fetch it again */
1202 if(sigstate == (Sighandler_t) SIG_IGN)
1203 sv_setpvs(sv,"IGNORE");
1205 sv_setsv(sv,&PL_sv_undef);
1206 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1213 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1215 /* XXX Some of this code was copied from Perl_magic_setsig. A little
1216 * refactoring might be in order.
1219 register const char * const s = MgPV_nolen_const(mg);
1220 PERL_UNUSED_ARG(sv);
1223 if (strEQ(s,"__DIE__"))
1225 else if (strEQ(s,"__WARN__") && PL_warnhook != PERL_WARNHOOK_FATAL)
1228 SV *const to_dec = *svp;
1230 SvREFCNT_dec(to_dec);
1234 /* Are we clearing a signal entry? */
1235 const I32 i = whichsig(s);
1237 #ifdef HAS_SIGPROCMASK
1240 /* Avoid having the signal arrive at a bad time, if possible. */
1243 sigprocmask(SIG_BLOCK, &set, &save);
1245 save_sv = newSVpvn((char *)(&save), sizeof(sigset_t));
1246 SAVEFREESV(save_sv);
1247 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1250 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1251 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1253 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1254 PL_sig_defaulting[i] = 1;
1255 (void)rsignal(i, PL_csighandlerp);
1257 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1259 if(PL_psig_name[i]) {
1260 SvREFCNT_dec(PL_psig_name[i]);
1263 if(PL_psig_ptr[i]) {
1264 SV * const to_dec=PL_psig_ptr[i];
1267 SvREFCNT_dec(to_dec);
1277 * The signal handling nomenclature has gotten a bit confusing since the advent of
1278 * safe signals. S_raise_signal only raises signals by analogy with what the
1279 * underlying system's signal mechanism does. It might be more proper to say that
1280 * it defers signals that have already been raised and caught.
1282 * PL_sig_pending and PL_psig_pend likewise do not track signals that are pending
1283 * in the sense of being on the system's signal queue in between raising and delivery.
1284 * They are only pending on Perl's deferral list, i.e., they track deferred signals
1285 * awaiting delivery after the current Perl opcode completes and say nothing about
1286 * signals raised but not yet caught in the underlying signal implementation.
1289 #ifndef SIG_PENDING_DIE_COUNT
1290 # define SIG_PENDING_DIE_COUNT 120
1294 S_raise_signal(pTHX_ int sig)
1297 /* Set a flag to say this signal is pending */
1298 PL_psig_pend[sig]++;
1299 /* And one to say _a_ signal is pending */
1300 if (++PL_sig_pending >= SIG_PENDING_DIE_COUNT)
1301 Perl_croak(aTHX_ "Maximal count of pending signals (%lu) exceeded",
1302 (unsigned long)SIG_PENDING_DIE_COUNT);
1306 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1307 Perl_csighandler(int sig, siginfo_t *sip PERL_UNUSED_DECL, void *uap PERL_UNUSED_DECL)
1309 Perl_csighandler(int sig)
1312 #ifdef PERL_GET_SIG_CONTEXT
1313 dTHXa(PERL_GET_SIG_CONTEXT);
1317 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1319 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1320 (void) rsignal(sig, PL_csighandlerp);
1321 if (PL_sig_ignoring[sig]) return;
1323 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1324 if (PL_sig_defaulting[sig])
1325 #ifdef KILL_BY_SIGPRC
1326 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1331 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1343 (PL_signals & PERL_SIGNALS_UNSAFE_FLAG))
1344 /* Call the perl level handler now--
1345 * with risk we may be in malloc() etc. */
1346 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1347 (*PL_sighandlerp)(sig, NULL, NULL);
1349 (*PL_sighandlerp)(sig);
1352 S_raise_signal(aTHX_ sig);
1355 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1357 Perl_csighandler_init(void)
1360 if (PL_sig_handlers_initted) return;
1362 for (sig = 1; sig < SIG_SIZE; sig++) {
1363 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1365 PL_sig_defaulting[sig] = 1;
1366 (void) rsignal(sig, PL_csighandlerp);
1368 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1369 PL_sig_ignoring[sig] = 0;
1372 PL_sig_handlers_initted = 1;
1377 Perl_despatch_signals(pTHX)
1382 for (sig = 1; sig < SIG_SIZE; sig++) {
1383 if (PL_psig_pend[sig]) {
1384 PERL_BLOCKSIG_ADD(set, sig);
1385 PL_psig_pend[sig] = 0;
1386 PERL_BLOCKSIG_BLOCK(set);
1387 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1388 (*PL_sighandlerp)(sig, NULL, NULL);
1390 (*PL_sighandlerp)(sig);
1392 PERL_BLOCKSIG_UNBLOCK(set);
1398 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1403 /* Need to be careful with SvREFCNT_dec(), because that can have side
1404 * effects (due to closures). We must make sure that the new disposition
1405 * is in place before it is called.
1409 #ifdef HAS_SIGPROCMASK
1414 register const char *s = MgPV_const(mg,len);
1416 if (strEQ(s,"__DIE__"))
1418 else if (strEQ(s,"__WARN__"))
1421 Perl_croak(aTHX_ "No such hook: %s", s);
1424 if (*svp != PERL_WARNHOOK_FATAL)
1430 i = whichsig(s); /* ...no, a brick */
1432 if (ckWARN(WARN_SIGNAL))
1433 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
1436 #ifdef HAS_SIGPROCMASK
1437 /* Avoid having the signal arrive at a bad time, if possible. */
1440 sigprocmask(SIG_BLOCK, &set, &save);
1442 save_sv = newSVpvn((char *)(&save), sizeof(sigset_t));
1443 SAVEFREESV(save_sv);
1444 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1447 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1448 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1450 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1451 PL_sig_ignoring[i] = 0;
1453 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1454 PL_sig_defaulting[i] = 0;
1456 SvREFCNT_dec(PL_psig_name[i]);
1457 to_dec = PL_psig_ptr[i];
1458 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1459 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1460 PL_psig_name[i] = newSVpvn(s, len);
1461 SvREADONLY_on(PL_psig_name[i]);
1463 if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
1465 (void)rsignal(i, PL_csighandlerp);
1466 #ifdef HAS_SIGPROCMASK
1471 *svp = SvREFCNT_inc_simple_NN(sv);
1473 SvREFCNT_dec(to_dec);
1476 s = SvOK(sv) ? SvPV_force(sv,len) : "DEFAULT";
1477 if (strEQ(s,"IGNORE")) {
1479 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1480 PL_sig_ignoring[i] = 1;
1481 (void)rsignal(i, PL_csighandlerp);
1483 (void)rsignal(i, (Sighandler_t) SIG_IGN);
1487 else if (strEQ(s,"DEFAULT") || !*s) {
1489 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1491 PL_sig_defaulting[i] = 1;
1492 (void)rsignal(i, PL_csighandlerp);
1495 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1500 * We should warn if HINT_STRICT_REFS, but without
1501 * access to a known hint bit in a known OP, we can't
1502 * tell whether HINT_STRICT_REFS is in force or not.
1504 if (!strchr(s,':') && !strchr(s,'\''))
1505 Perl_sv_insert(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"));
1507 (void)rsignal(i, PL_csighandlerp);
1509 *svp = SvREFCNT_inc_simple_NN(sv);
1511 #ifdef HAS_SIGPROCMASK
1516 SvREFCNT_dec(to_dec);
1519 #endif /* !PERL_MICRO */
1522 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1526 PERL_UNUSED_ARG(sv);
1528 /* Bail out if destruction is going on */
1529 if(PL_dirty) return 0;
1531 /* Skip _isaelem because _isa will handle it shortly */
1532 if (PL_delaymagic & DM_ARRAY && mg->mg_type == PERL_MAGIC_isaelem)
1535 /* XXX Once it's possible, we need to
1536 detect that our @ISA is aliased in
1537 other stashes, and act on the stashes
1538 of all of the aliases */
1540 /* The first case occurs via setisa,
1541 the second via setisa_elem, which
1542 calls this same magic */
1544 SvTYPE(mg->mg_obj) == SVt_PVGV
1546 : (GV*)SvMAGIC(mg->mg_obj)->mg_obj
1549 mro_isa_changed_in(stash);
1555 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
1558 PERL_UNUSED_ARG(sv);
1559 PERL_UNUSED_ARG(mg);
1560 PL_amagic_generation++;
1566 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1568 HV * const hv = (HV*)LvTARG(sv);
1570 PERL_UNUSED_ARG(mg);
1573 (void) hv_iterinit(hv);
1574 if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
1577 while (hv_iternext(hv))
1582 sv_setiv(sv, (IV)i);
1587 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1589 PERL_UNUSED_ARG(mg);
1591 hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
1596 /* caller is responsible for stack switching/cleanup */
1598 S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV *val)
1605 PUSHs(SvTIED_obj(sv, mg));
1608 if (mg->mg_len >= 0)
1609 PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len)));
1610 else if (mg->mg_len == HEf_SVKEY)
1611 PUSHs((SV*)mg->mg_ptr);
1613 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1614 PUSHs(sv_2mortal(newSViv(mg->mg_len)));
1622 return call_method(meth, flags);
1626 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
1632 PUSHSTACKi(PERLSI_MAGIC);
1634 if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
1635 sv_setsv(sv, *PL_stack_sp--);
1645 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1648 mg->mg_flags |= MGf_GSKIP;
1649 magic_methpack(sv,mg,"FETCH");
1654 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1658 PUSHSTACKi(PERLSI_MAGIC);
1659 magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
1666 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1668 return magic_methpack(sv,mg,"DELETE");
1673 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1680 PUSHSTACKi(PERLSI_MAGIC);
1681 if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
1682 sv = *PL_stack_sp--;
1683 retval = SvIV(sv)-1;
1685 Perl_croak(aTHX_ "FETCHSIZE returned a negative value");
1690 return (U32) retval;
1694 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1699 PUSHSTACKi(PERLSI_MAGIC);
1701 XPUSHs(SvTIED_obj(sv, mg));
1703 call_method("CLEAR", G_SCALAR|G_DISCARD);
1711 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1714 const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
1718 PUSHSTACKi(PERLSI_MAGIC);
1721 PUSHs(SvTIED_obj(sv, mg));
1726 if (call_method(meth, G_SCALAR))
1727 sv_setsv(key, *PL_stack_sp--);
1736 Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg)
1738 return magic_methpack(sv,mg,"EXISTS");
1742 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1746 SV * const tied = SvTIED_obj((SV*)hv, mg);
1747 HV * const pkg = SvSTASH((SV*)SvRV(tied));
1749 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1751 if (HvEITER_get(hv))
1752 /* we are in an iteration so the hash cannot be empty */
1754 /* no xhv_eiter so now use FIRSTKEY */
1755 key = sv_newmortal();
1756 magic_nextpack((SV*)hv, mg, key);
1757 HvEITER_set(hv, NULL); /* need to reset iterator */
1758 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1761 /* there is a SCALAR method that we can call */
1763 PUSHSTACKi(PERLSI_MAGIC);
1769 if (call_method("SCALAR", G_SCALAR))
1770 retval = *PL_stack_sp--;
1772 retval = &PL_sv_undef;
1779 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1782 GV * const gv = PL_DBline;
1783 const I32 i = SvTRUE(sv);
1784 SV ** const svp = av_fetch(GvAV(gv),
1785 atoi(MgPV_nolen_const(mg)), FALSE);
1786 if (svp && SvIOKp(*svp)) {
1787 OP * const o = INT2PTR(OP*,SvIVX(*svp));
1789 /* set or clear breakpoint in the relevant control op */
1791 o->op_flags |= OPf_SPECIAL;
1793 o->op_flags &= ~OPf_SPECIAL;
1800 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
1803 const AV * const obj = (AV*)mg->mg_obj;
1805 sv_setiv(sv, AvFILL(obj) + CopARYBASE_get(PL_curcop));
1813 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
1816 AV * const obj = (AV*)mg->mg_obj;
1818 av_fill(obj, SvIV(sv) - CopARYBASE_get(PL_curcop));
1820 if (ckWARN(WARN_MISC))
1821 Perl_warner(aTHX_ packWARN(WARN_MISC),
1822 "Attempt to set length of freed array");
1828 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
1831 PERL_UNUSED_ARG(sv);
1832 /* during global destruction, mg_obj may already have been freed */
1833 if (PL_in_clean_all)
1836 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
1839 /* arylen scalar holds a pointer back to the array, but doesn't own a
1840 reference. Hence the we (the array) are about to go away with it
1841 still pointing at us. Clear its pointer, else it would be pointing
1842 at free memory. See the comment in sv_magic about reference loops,
1843 and why it can't own a reference to us. */
1850 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
1853 SV* const lsv = LvTARG(sv);
1854 PERL_UNUSED_ARG(mg);
1856 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1857 MAGIC * const found = mg_find(lsv, PERL_MAGIC_regex_global);
1858 if (found && found->mg_len >= 0) {
1859 I32 i = found->mg_len;
1861 sv_pos_b2u(lsv, &i);
1862 sv_setiv(sv, i + CopARYBASE_get(PL_curcop));
1871 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
1874 SV* const lsv = LvTARG(sv);
1880 PERL_UNUSED_ARG(mg);
1882 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
1883 found = mg_find(lsv, PERL_MAGIC_regex_global);
1889 #ifdef PERL_OLD_COPY_ON_WRITE
1891 sv_force_normal_flags(lsv, 0);
1893 found = sv_magicext(lsv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
1896 else if (!SvOK(sv)) {
1900 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1902 pos = SvIV(sv) - CopARYBASE_get(PL_curcop);
1905 ulen = sv_len_utf8(lsv);
1915 else if (pos > (SSize_t)len)
1920 sv_pos_u2b(lsv, &p, 0);
1924 found->mg_len = pos;
1925 found->mg_flags &= ~MGf_MINMATCH;
1931 Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg)
1934 PERL_UNUSED_ARG(mg);
1936 Perl_croak(aTHX_ "Perl_magic_setglob is dead code?");
1940 if (isGV_with_GP(sv)) {
1941 /* We're actually already a typeglob, so don't need the stuff below.
1945 gv = gv_fetchsv(sv, GV_ADD, SVt_PVGV);
1950 GvGP(sv) = gp_ref(GvGP(gv));
1955 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
1958 SV * const lsv = LvTARG(sv);
1959 const char * const tmps = SvPV_const(lsv,len);
1960 I32 offs = LvTARGOFF(sv);
1961 I32 rem = LvTARGLEN(sv);
1962 PERL_UNUSED_ARG(mg);
1965 sv_pos_u2b(lsv, &offs, &rem);
1966 if (offs > (I32)len)
1968 if (rem + offs > (I32)len)
1970 sv_setpvn(sv, tmps + offs, (STRLEN)rem);
1977 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
1981 const char * const tmps = SvPV_const(sv, len);
1982 SV * const lsv = LvTARG(sv);
1983 I32 lvoff = LvTARGOFF(sv);
1984 I32 lvlen = LvTARGLEN(sv);
1985 PERL_UNUSED_ARG(mg);
1988 sv_utf8_upgrade(lsv);
1989 sv_pos_u2b(lsv, &lvoff, &lvlen);
1990 sv_insert(lsv, lvoff, lvlen, tmps, len);
1991 LvTARGLEN(sv) = sv_len_utf8(sv);
1994 else if (lsv && SvUTF8(lsv)) {
1996 sv_pos_u2b(lsv, &lvoff, &lvlen);
1997 LvTARGLEN(sv) = len;
1998 utf8 = (char*)bytes_to_utf8((U8*)tmps, &len);
1999 sv_insert(lsv, lvoff, lvlen, utf8, len);
2003 sv_insert(lsv, lvoff, lvlen, tmps, len);
2004 LvTARGLEN(sv) = len;
2012 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
2015 PERL_UNUSED_ARG(sv);
2016 TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
2021 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
2024 PERL_UNUSED_ARG(sv);
2025 /* update taint status */
2034 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
2036 SV * const lsv = LvTARG(sv);
2037 PERL_UNUSED_ARG(mg);
2040 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
2048 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
2050 PERL_UNUSED_ARG(mg);
2051 do_vecset(sv); /* XXX slurp this routine */
2056 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
2060 if (LvTARGLEN(sv)) {
2062 SV * const ahv = LvTARG(sv);
2063 HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
2068 AV* const av = (AV*)LvTARG(sv);
2069 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
2070 targ = AvARRAY(av)[LvTARGOFF(sv)];
2072 if (targ && (targ != &PL_sv_undef)) {
2073 /* somebody else defined it for us */
2074 SvREFCNT_dec(LvTARG(sv));
2075 LvTARG(sv) = SvREFCNT_inc_simple_NN(targ);
2077 SvREFCNT_dec(mg->mg_obj);
2079 mg->mg_flags &= ~MGf_REFCOUNTED;
2084 sv_setsv(sv, targ ? targ : &PL_sv_undef);
2089 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
2091 PERL_UNUSED_ARG(mg);
2095 sv_setsv(LvTARG(sv), sv);
2096 SvSETMAGIC(LvTARG(sv));
2102 Perl_vivify_defelem(pTHX_ SV *sv)
2108 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2111 SV * const ahv = LvTARG(sv);
2112 HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
2115 if (!value || value == &PL_sv_undef)
2116 Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(mg->mg_obj));
2119 AV* const av = (AV*)LvTARG(sv);
2120 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
2121 LvTARG(sv) = NULL; /* array can't be extended */
2123 SV* const * const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
2124 if (!svp || (value = *svp) == &PL_sv_undef)
2125 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
2128 SvREFCNT_inc_simple_void(value);
2129 SvREFCNT_dec(LvTARG(sv));
2132 SvREFCNT_dec(mg->mg_obj);
2134 mg->mg_flags &= ~MGf_REFCOUNTED;
2138 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2140 return Perl_sv_kill_backrefs(aTHX_ sv, (AV*)mg->mg_obj);
2144 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2146 PERL_UNUSED_CONTEXT;
2153 Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
2155 PERL_UNUSED_ARG(mg);
2156 sv_unmagic(sv, PERL_MAGIC_bm);
2163 Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
2165 PERL_UNUSED_ARG(mg);
2166 sv_unmagic(sv, PERL_MAGIC_fm);
2172 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2174 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2176 if (uf && uf->uf_set)
2177 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2182 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2184 PERL_UNUSED_ARG(mg);
2185 sv_unmagic(sv, PERL_MAGIC_qr);
2190 Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
2193 regexp * const re = (regexp *)mg->mg_obj;
2194 PERL_UNUSED_ARG(sv);
2200 #ifdef USE_LOCALE_COLLATE
2202 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2205 * RenE<eacute> Descartes said "I think not."
2206 * and vanished with a faint plop.
2208 PERL_UNUSED_CONTEXT;
2209 PERL_UNUSED_ARG(sv);
2211 Safefree(mg->mg_ptr);
2217 #endif /* USE_LOCALE_COLLATE */
2219 /* Just clear the UTF-8 cache data. */
2221 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2223 PERL_UNUSED_CONTEXT;
2224 PERL_UNUSED_ARG(sv);
2225 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2227 mg->mg_len = -1; /* The mg_len holds the len cache. */
2232 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2235 register const char *s;
2237 register const REGEXP * rx;
2238 const char * const remaining = mg->mg_ptr + 1;
2242 switch (*mg->mg_ptr) {
2243 case '\015': /* $^MATCH */
2244 if (strEQ(remaining, "ATCH"))
2246 case '`': /* ${^PREMATCH} caught below */
2248 paren = RX_BUFF_IDX_PREMATCH;
2250 case '\'': /* ${^POSTMATCH} caught below */
2252 paren = RX_BUFF_IDX_POSTMATCH;
2256 paren = RX_BUFF_IDX_FULLMATCH;
2258 case '1': case '2': case '3': case '4':
2259 case '5': case '6': case '7': case '8': case '9':
2260 paren = atoi(mg->mg_ptr);
2262 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
2263 CALLREG_NUMBUF_STORE((REGEXP * const)rx,paren,sv);
2266 /* Croak with a READONLY error when a numbered match var is
2267 * set without a previous pattern match. Unless it's C<local $1>
2269 if (!PL_localizing) {
2270 Perl_croak(aTHX_ PL_no_modify);
2273 case '\001': /* ^A */
2274 sv_setsv(PL_bodytarget, sv);
2276 case '\003': /* ^C */
2277 PL_minus_c = (bool)SvIV(sv);
2280 case '\004': /* ^D */
2282 s = SvPV_nolen_const(sv);
2283 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2284 DEBUG_x(dump_all());
2286 PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG;
2289 case '\005': /* ^E */
2290 if (*(mg->mg_ptr+1) == '\0') {
2291 #ifdef MACOS_TRADITIONAL
2292 gMacPerl_OSErr = SvIV(sv);
2295 set_vaxc_errno(SvIV(sv));
2298 SetLastError( SvIV(sv) );
2301 os2_setsyserrno(SvIV(sv));
2303 /* will anyone ever use this? */
2304 SETERRNO(SvIV(sv), 4);
2310 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2312 SvREFCNT_dec(PL_encoding);
2313 if (SvOK(sv) || SvGMAGICAL(sv)) {
2314 PL_encoding = newSVsv(sv);
2321 case '\006': /* ^F */
2322 PL_maxsysfd = SvIV(sv);
2324 case '\010': /* ^H */
2325 PL_hints = SvIV(sv);
2327 case '\011': /* ^I */ /* NOT \t in EBCDIC */
2328 Safefree(PL_inplace);
2329 PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
2331 case '\017': /* ^O */
2332 if (*(mg->mg_ptr+1) == '\0') {
2333 Safefree(PL_osname);
2336 TAINT_PROPER("assigning to $^O");
2337 PL_osname = savesvpv(sv);
2340 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2342 const char *const start = SvPV(sv, len);
2343 const char *out = (const char*)memchr(start, '\0', len);
2345 struct refcounted_he *tmp_he;
2348 PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2350 |= HINT_LOCALIZE_HH | HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2352 /* Opening for input is more common than opening for output, so
2353 ensure that hints for input are sooner on linked list. */
2354 tmp = sv_2mortal(out ? newSVpvn(out + 1, start + len - out - 1)
2356 SvFLAGS(tmp) |= SvUTF8(sv);
2359 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
2360 sv_2mortal(newSVpvs("open>")), tmp);
2362 /* The UTF-8 setting is carried over */
2363 sv_setpvn(tmp, start, out ? (STRLEN)(out - start) : len);
2365 PL_compiling.cop_hints_hash
2366 = Perl_refcounted_he_new(aTHX_ tmp_he,
2367 sv_2mortal(newSVpvs("open<")), tmp);
2370 case '\020': /* ^P */
2371 if (*remaining == '\0') { /* ^P */
2372 PL_perldb = SvIV(sv);
2373 if (PL_perldb && !PL_DBsingle)
2376 } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
2378 } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
2381 case '\024': /* ^T */
2383 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2385 PL_basetime = (Time_t)SvIV(sv);
2388 case '\025': /* ^UTF8CACHE */
2389 if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
2390 PL_utf8cache = (signed char) sv_2iv(sv);
2393 case '\027': /* ^W & $^WARNING_BITS */
2394 if (*(mg->mg_ptr+1) == '\0') {
2395 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2397 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2398 | (i ? G_WARN_ON : G_WARN_OFF) ;
2401 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2402 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2403 if (!SvPOK(sv) && PL_localizing) {
2404 sv_setpvn(sv, WARN_NONEstring, WARNsize);
2405 PL_compiling.cop_warnings = pWARN_NONE;
2410 int accumulate = 0 ;
2411 int any_fatals = 0 ;
2412 const char * const ptr = SvPV_const(sv, len) ;
2413 for (i = 0 ; i < len ; ++i) {
2414 accumulate |= ptr[i] ;
2415 any_fatals |= (ptr[i] & 0xAA) ;
2418 if (!specialWARN(PL_compiling.cop_warnings))
2419 PerlMemShared_free(PL_compiling.cop_warnings);
2420 PL_compiling.cop_warnings = pWARN_NONE;
2422 /* Yuck. I can't see how to abstract this: */
2423 else if (isWARN_on(((STRLEN *)SvPV_nolen_const(sv)) - 1,
2424 WARN_ALL) && !any_fatals) {
2425 if (!specialWARN(PL_compiling.cop_warnings))
2426 PerlMemShared_free(PL_compiling.cop_warnings);
2427 PL_compiling.cop_warnings = pWARN_ALL;
2428 PL_dowarn |= G_WARN_ONCE ;
2432 const char *const p = SvPV_const(sv, len);
2434 PL_compiling.cop_warnings
2435 = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
2438 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2439 PL_dowarn |= G_WARN_ONCE ;
2447 if (PL_localizing) {
2448 if (PL_localizing == 1)
2449 SAVESPTR(PL_last_in_gv);
2451 else if (SvOK(sv) && GvIO(PL_last_in_gv))
2452 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2455 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2456 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2457 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2460 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2461 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2462 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2465 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
2468 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
2469 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2470 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2473 IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
2477 IO * const io = GvIOp(PL_defoutgv);
2480 if ((SvIV(sv)) == 0)
2481 IoFLAGS(io) &= ~IOf_FLUSH;
2483 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2484 PerlIO *ofp = IoOFP(io);
2486 (void)PerlIO_flush(ofp);
2487 IoFLAGS(io) |= IOf_FLUSH;
2493 SvREFCNT_dec(PL_rs);
2494 PL_rs = newSVsv(sv);
2498 SvREFCNT_dec(PL_ors_sv);
2499 if (SvOK(sv) || SvGMAGICAL(sv)) {
2500 PL_ors_sv = newSVsv(sv);
2508 SvREFCNT_dec(PL_ofs_sv);
2509 if (SvOK(sv) || SvGMAGICAL(sv)) {
2510 PL_ofs_sv = newSVsv(sv);
2517 CopARYBASE_set(&PL_compiling, SvIV(sv));
2520 #ifdef COMPLEX_STATUS
2521 if (PL_localizing == 2) {
2522 PL_statusvalue = LvTARGOFF(sv);
2523 PL_statusvalue_vms = LvTARGLEN(sv);
2527 #ifdef VMSISH_STATUS
2529 STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2532 STATUS_UNIX_EXIT_SET(SvIV(sv));
2537 # define PERL_VMS_BANG vaxc$errno
2539 # define PERL_VMS_BANG 0
2541 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2542 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2547 if (PL_delaymagic) {
2548 PL_delaymagic |= DM_RUID;
2549 break; /* don't do magic till later */
2552 (void)setruid((Uid_t)PL_uid);
2555 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2557 #ifdef HAS_SETRESUID
2558 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2560 if (PL_uid == PL_euid) { /* special case $< = $> */
2562 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2563 if (PL_uid != 0 && PerlProc_getuid() == 0)
2564 (void)PerlProc_setuid(0);
2566 (void)PerlProc_setuid(PL_uid);
2568 PL_uid = PerlProc_getuid();
2569 Perl_croak(aTHX_ "setruid() not implemented");
2574 PL_uid = PerlProc_getuid();
2575 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2579 if (PL_delaymagic) {
2580 PL_delaymagic |= DM_EUID;
2581 break; /* don't do magic till later */
2584 (void)seteuid((Uid_t)PL_euid);
2587 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2589 #ifdef HAS_SETRESUID
2590 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2592 if (PL_euid == PL_uid) /* special case $> = $< */
2593 PerlProc_setuid(PL_euid);
2595 PL_euid = PerlProc_geteuid();
2596 Perl_croak(aTHX_ "seteuid() not implemented");
2601 PL_euid = PerlProc_geteuid();
2602 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2606 if (PL_delaymagic) {
2607 PL_delaymagic |= DM_RGID;
2608 break; /* don't do magic till later */
2611 (void)setrgid((Gid_t)PL_gid);
2614 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2616 #ifdef HAS_SETRESGID
2617 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2619 if (PL_gid == PL_egid) /* special case $( = $) */
2620 (void)PerlProc_setgid(PL_gid);
2622 PL_gid = PerlProc_getgid();
2623 Perl_croak(aTHX_ "setrgid() not implemented");
2628 PL_gid = PerlProc_getgid();
2629 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2632 #ifdef HAS_SETGROUPS
2634 const char *p = SvPV_const(sv, len);
2635 Groups_t *gary = NULL;
2640 for (i = 0; i < NGROUPS; ++i) {
2641 while (*p && !isSPACE(*p))
2648 Newx(gary, i + 1, Groups_t);
2650 Renew(gary, i + 1, Groups_t);
2654 (void)setgroups(i, gary);
2657 #else /* HAS_SETGROUPS */
2659 #endif /* HAS_SETGROUPS */
2660 if (PL_delaymagic) {
2661 PL_delaymagic |= DM_EGID;
2662 break; /* don't do magic till later */
2665 (void)setegid((Gid_t)PL_egid);
2668 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2670 #ifdef HAS_SETRESGID
2671 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2673 if (PL_egid == PL_gid) /* special case $) = $( */
2674 (void)PerlProc_setgid(PL_egid);
2676 PL_egid = PerlProc_getegid();
2677 Perl_croak(aTHX_ "setegid() not implemented");
2682 PL_egid = PerlProc_getegid();
2683 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2686 PL_chopset = SvPV_force(sv,len);
2688 #ifndef MACOS_TRADITIONAL
2690 LOCK_DOLLARZERO_MUTEX;
2691 #ifdef HAS_SETPROCTITLE
2692 /* The BSDs don't show the argv[] in ps(1) output, they
2693 * show a string from the process struct and provide
2694 * the setproctitle() routine to manipulate that. */
2695 if (PL_origalen != 1) {
2696 s = SvPV_const(sv, len);
2697 # if __FreeBSD_version > 410001
2698 /* The leading "-" removes the "perl: " prefix,
2699 * but not the "(perl) suffix from the ps(1)
2700 * output, because that's what ps(1) shows if the
2701 * argv[] is modified. */
2702 setproctitle("-%s", s);
2703 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2704 /* This doesn't really work if you assume that
2705 * $0 = 'foobar'; will wipe out 'perl' from the $0
2706 * because in ps(1) output the result will be like
2707 * sprintf("perl: %s (perl)", s)
2708 * I guess this is a security feature:
2709 * one (a user process) cannot get rid of the original name.
2711 setproctitle("%s", s);
2714 #elif defined(__hpux) && defined(PSTAT_SETCMD)
2715 if (PL_origalen != 1) {
2717 s = SvPV_const(sv, len);
2718 un.pst_command = (char *)s;
2719 pstat(PSTAT_SETCMD, un, len, 0, 0);
2722 if (PL_origalen > 1) {
2723 /* PL_origalen is set in perl_parse(). */
2724 s = SvPV_force(sv,len);
2725 if (len >= (STRLEN)PL_origalen-1) {
2726 /* Longer than original, will be truncated. We assume that
2727 * PL_origalen bytes are available. */
2728 Copy(s, PL_origargv[0], PL_origalen-1, char);
2731 /* Shorter than original, will be padded. */
2733 /* Special case for Mac OS X: see [perl #38868] */
2736 /* Is the space counterintuitive? Yes.
2737 * (You were expecting \0?)
2738 * Does it work? Seems to. (In Linux 2.4.20 at least.)
2740 const int pad = ' ';
2742 Copy(s, PL_origargv[0], len, char);
2743 PL_origargv[0][len] = 0;
2744 memset(PL_origargv[0] + len + 1,
2745 pad, PL_origalen - len - 1);
2747 PL_origargv[0][PL_origalen-1] = 0;
2748 for (i = 1; i < PL_origargc; i++)
2752 UNLOCK_DOLLARZERO_MUTEX;
2760 Perl_whichsig(pTHX_ const char *sig)
2762 register char* const* sigv;
2763 PERL_UNUSED_CONTEXT;
2765 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
2766 if (strEQ(sig,*sigv))
2767 return PL_sig_num[sigv - (char* const*)PL_sig_name];
2769 if (strEQ(sig,"CHLD"))
2773 if (strEQ(sig,"CLD"))
2780 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2781 Perl_sighandler(int sig, siginfo_t *sip, void *uap PERL_UNUSED_DECL)
2783 Perl_sighandler(int sig)
2786 #ifdef PERL_GET_SIG_CONTEXT
2787 dTHXa(PERL_GET_SIG_CONTEXT);
2794 SV * const tSv = PL_Sv;
2798 XPV * const tXpv = PL_Xpv;
2800 if (PL_savestack_ix + 15 <= PL_savestack_max)
2802 if (PL_markstack_ptr < PL_markstack_max - 2)
2804 if (PL_scopestack_ix < PL_scopestack_max - 3)
2807 if (!PL_psig_ptr[sig]) {
2808 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2813 /* Max number of items pushed there is 3*n or 4. We cannot fix
2814 infinity, so we fix 4 (in fact 5): */
2816 PL_savestack_ix += 5; /* Protect save in progress. */
2817 SAVEDESTRUCTOR_X(S_unwind_handler_stack, (void*)&flags);
2820 PL_markstack_ptr++; /* Protect mark. */
2822 PL_scopestack_ix += 1;
2823 /* sv_2cv is too complicated, try a simpler variant first: */
2824 if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
2825 || SvTYPE(cv) != SVt_PVCV) {
2827 cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
2830 if (!cv || !CvROOT(cv)) {
2831 if (ckWARN(WARN_SIGNAL))
2832 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2833 PL_sig_name[sig], (gv ? GvENAME(gv)
2840 if(PL_psig_name[sig]) {
2841 sv = SvREFCNT_inc_NN(PL_psig_name[sig]);
2843 #if !defined(PERL_IMPLICIT_CONTEXT)
2847 sv = sv_newmortal();
2848 sv_setpv(sv,PL_sig_name[sig]);
2851 PUSHSTACKi(PERLSI_SIGNAL);
2854 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2856 struct sigaction oact;
2858 if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
2861 SV *rv = newRV_noinc((SV*)sih);
2862 /* The siginfo fields signo, code, errno, pid, uid,
2863 * addr, status, and band are defined by POSIX/SUSv3. */
2864 (void)hv_stores(sih, "signo", newSViv(sip->si_signo));
2865 (void)hv_stores(sih, "code", newSViv(sip->si_code));
2866 #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. */
2867 hv_stores(sih, "errno", newSViv(sip->si_errno));
2868 hv_stores(sih, "status", newSViv(sip->si_status));
2869 hv_stores(sih, "uid", newSViv(sip->si_uid));
2870 hv_stores(sih, "pid", newSViv(sip->si_pid));
2871 hv_stores(sih, "addr", newSVuv(PTR2UV(sip->si_addr)));
2872 hv_stores(sih, "band", newSViv(sip->si_band));
2876 PUSHs(newSVpvn((char *)sip, sizeof(*sip)));
2884 call_sv((SV*)cv, G_DISCARD|G_EVAL);
2887 if (SvTRUE(ERRSV)) {
2889 #ifdef HAS_SIGPROCMASK
2890 /* Handler "died", for example to get out of a restart-able read().
2891 * Before we re-do that on its behalf re-enable the signal which was
2892 * blocked by the system when we entered.
2896 sigaddset(&set,sig);
2897 sigprocmask(SIG_UNBLOCK, &set, NULL);
2899 /* Not clear if this will work */
2900 (void)rsignal(sig, SIG_IGN);
2901 (void)rsignal(sig, PL_csighandlerp);
2903 #endif /* !PERL_MICRO */
2904 Perl_die(aTHX_ NULL);
2908 PL_savestack_ix -= 8; /* Unprotect save in progress. */
2912 PL_scopestack_ix -= 1;
2915 PL_op = myop; /* Apparently not needed... */
2917 PL_Sv = tSv; /* Restore global temporaries. */
2924 S_restore_magic(pTHX_ const void *p)
2927 MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
2928 SV* const sv = mgs->mgs_sv;
2933 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2935 #ifdef PERL_OLD_COPY_ON_WRITE
2936 /* While magic was saved (and off) sv_setsv may well have seen
2937 this SV as a prime candidate for COW. */
2939 sv_force_normal_flags(sv, 0);
2943 SvFLAGS(sv) |= mgs->mgs_flags;
2946 if (SvGMAGICAL(sv)) {
2947 /* downgrade public flags to private,
2948 and discard any other private flags */
2950 const U32 pubflags = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
2952 SvFLAGS(sv) &= ~( pubflags | (SVp_IOK|SVp_NOK|SVp_POK) );
2953 SvFLAGS(sv) |= ( pubflags << PRIVSHIFT );
2958 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
2960 /* If we're still on top of the stack, pop us off. (That condition
2961 * will be satisfied if restore_magic was called explicitly, but *not*
2962 * if it's being called via leave_scope.)
2963 * The reason for doing this is that otherwise, things like sv_2cv()
2964 * may leave alloc gunk on the savestack, and some code
2965 * (e.g. sighandler) doesn't expect that...
2967 if (PL_savestack_ix == mgs->mgs_ss_ix)
2969 I32 popval = SSPOPINT;
2970 assert(popval == SAVEt_DESTRUCTOR_X);
2971 PL_savestack_ix -= 2;
2973 assert(popval == SAVEt_ALLOC);
2975 PL_savestack_ix -= popval;
2981 S_unwind_handler_stack(pTHX_ const void *p)
2984 const U32 flags = *(const U32*)p;
2987 PL_savestack_ix -= 5; /* Unprotect save in progress. */
2988 #if !defined(PERL_IMPLICIT_CONTEXT)
2990 SvREFCNT_dec(PL_sig_sv);
2995 =for apidoc magic_sethint
2997 Triggered by a store to %^H, records the key/value pair to
2998 C<PL_compiling.cop_hints_hash>. It is assumed that hints aren't storing
2999 anything that would need a deep copy. Maybe we should warn if we find a
3005 Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
3008 SV *key = (mg->mg_len == HEf_SVKEY) ? (SV *)mg->mg_ptr
3009 : sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len));
3011 /* mg->mg_obj isn't being used. If needed, it would be possible to store
3012 an alternative leaf in there, with PL_compiling.cop_hints being used if
3013 it's NULL. If needed for threads, the alternative could lock a mutex,
3014 or take other more complex action. */
3016 /* Something changed in %^H, so it will need to be restored on scope exit.
3017 Doing this here saves a lot of doing it manually in perl code (and
3018 forgetting to do it, and consequent subtle errors. */
3019 PL_hints |= HINT_LOCALIZE_HH;
3020 PL_compiling.cop_hints_hash
3021 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash, key, sv);
3026 =for apidoc magic_sethint
3028 Triggered by a delete from %^H, records the key to
3029 C<PL_compiling.cop_hints_hash>.
3034 Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
3037 PERL_UNUSED_ARG(sv);
3039 assert(mg->mg_len == HEf_SVKEY);
3041 PERL_UNUSED_ARG(sv);
3043 PL_hints |= HINT_LOCALIZE_HH;
3044 PL_compiling.cop_hints_hash
3045 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
3046 (SV *)mg->mg_ptr, &PL_sv_placeholder);
3052 * c-indentation-style: bsd
3054 * indent-tabs-mode: t
3057 * ex: set ts=8 sts=4 sw=4 noet: