3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 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
24 #if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS)
34 # include <sys/pstat.h>
37 Signal_t Perl_csighandler(int sig);
39 /* if you only have signal() and it resets on each signal, FAKE_PERSISTENT_SIGNAL_HANDLERS fixes */
40 #if !defined(HAS_SIGACTION) && defined(VMS)
41 # define FAKE_PERSISTENT_SIGNAL_HANDLERS
43 /* if we're doing kill() with sys$sigprc on VMS, FAKE_DEFAULT_SIGNAL_HANDLERS */
44 #if defined(KILL_BY_SIGPRC)
45 # define FAKE_DEFAULT_SIGNAL_HANDLERS
48 static void restore_magic(pTHX_ void *p);
49 static void unwind_handler_stack(pTHX_ void *p);
52 /* Missing protos on LynxOS */
53 void setruid(uid_t id);
54 void seteuid(uid_t id);
55 void setrgid(uid_t id);
56 void setegid(uid_t id);
60 * Use the "DESTRUCTOR" scope cleanup to reinstate magic.
68 /* MGS is typedef'ed to struct magic_state in perl.h */
71 S_save_magic(pTHX_ I32 mgs_ix, SV *sv)
74 assert(SvMAGICAL(sv));
75 #ifdef PERL_COPY_ON_WRITE
76 /* Turning READONLY off for a copy-on-write scalar is a bad idea. */
81 SAVEDESTRUCTOR_X(restore_magic, INT2PTR(void*, (IV)mgs_ix));
83 mgs = SSPTR(mgs_ix, MGS*);
85 mgs->mgs_flags = SvMAGICAL(sv) | SvREADONLY(sv);
86 mgs->mgs_ss_ix = PL_savestack_ix; /* points after the saved destructor */
90 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
94 =for apidoc mg_magical
96 Turns on the magical status of an SV. See C<sv_magic>.
102 Perl_mg_magical(pTHX_ SV *sv)
105 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
106 MGVTBL* vtbl = mg->mg_virtual;
108 if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
112 if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)) || vtbl->svt_clear)
121 Do magic after a value is retrieved from the SV. See C<sv_magic>.
127 Perl_mg_get(pTHX_ SV *sv)
130 MAGIC *newmg, *head, *cur, *mg;
131 I32 mgs_ix = SSNEW(sizeof(MGS));
132 /* guard against sv having being freed midway by holding a private
133 reference. It's not possible to make this sv mortal without failing
135 looks like it's important that it can get DESTROYed before the next
137 Also it's not possible to wrap this function in a SAVETMPS/FREETMPS
138 pair. We need drop our reference if croak() is called, but we also
139 can't simply make it mortal and wait for the next FREETMPS, because
140 other tests rely on the sv being freed earlier. Hence this hack.
141 We create an extra reference on the caller's sv, owned by the rv,
142 which is mortal. If croak is called the RV cleans up for us.
143 If we reach the end of the function we change it to point at
144 PL_sv_undef, and clean up manually. */
145 SV *temp_rv = sv_2mortal(newRV_inc(sv));
147 save_magic(mgs_ix, sv);
149 /* We must call svt_get(sv, mg) for each valid entry in the linked
150 list of magic. svt_get() may delete the current entry, add new
151 magic to the head of the list, or upgrade the SV. AMS 20010810 */
153 newmg = cur = head = mg = SvMAGIC(sv);
155 MGVTBL *vtbl = mg->mg_virtual;
157 if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
158 CALL_FPTR(vtbl->svt_get)(aTHX_ sv, mg);
160 /* guard against magic having been deleted - eg FETCH calling
165 /* Don't restore the flags for this entry if it was deleted. */
166 if (mg->mg_flags & MGf_GSKIP)
167 (SSPTR(mgs_ix, MGS *))->mgs_flags = 0;
170 mg = mg->mg_moremagic;
173 /* Have we finished with the new entries we saw? Start again
174 where we left off (unless there are more new entries). */
182 /* Were any new entries added? */
183 if (!new && (newmg = SvMAGIC(sv)) != head) {
190 restore_magic(aTHX_ INT2PTR(void *, (IV)mgs_ix));
191 SvRV(temp_rv) = &PL_sv_undef;
199 Do magic after a value is assigned to the SV. See C<sv_magic>.
205 Perl_mg_set(pTHX_ SV *sv)
211 mgs_ix = SSNEW(sizeof(MGS));
212 save_magic(mgs_ix, sv);
214 for (mg = SvMAGIC(sv); mg; mg = nextmg) {
215 MGVTBL* vtbl = mg->mg_virtual;
216 nextmg = mg->mg_moremagic; /* it may delete itself */
217 if (mg->mg_flags & MGf_GSKIP) {
218 mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */
219 (SSPTR(mgs_ix, MGS*))->mgs_flags = 0;
221 if (vtbl && vtbl->svt_set)
222 CALL_FPTR(vtbl->svt_set)(aTHX_ sv, mg);
225 restore_magic(aTHX_ INT2PTR(void*, (IV)mgs_ix));
230 =for apidoc mg_length
232 Report on the SV's length. See C<sv_magic>.
238 Perl_mg_length(pTHX_ SV *sv)
243 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
244 MGVTBL* vtbl = mg->mg_virtual;
245 if (vtbl && vtbl->svt_len) {
248 mgs_ix = SSNEW(sizeof(MGS));
249 save_magic(mgs_ix, sv);
250 /* omit MGf_GSKIP -- not changed here */
251 len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
252 restore_magic(aTHX_ INT2PTR(void*, (IV)mgs_ix));
259 U8 *s = (U8*)SvPV(sv, len);
260 len = Perl_utf8_length(aTHX_ s, s + len);
268 Perl_mg_size(pTHX_ SV *sv)
273 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
274 MGVTBL* vtbl = mg->mg_virtual;
275 if (vtbl && vtbl->svt_len) {
278 mgs_ix = SSNEW(sizeof(MGS));
279 save_magic(mgs_ix, sv);
280 /* omit MGf_GSKIP -- not changed here */
281 len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
282 restore_magic(aTHX_ INT2PTR(void*, (IV)mgs_ix));
289 len = AvFILLp((AV *) sv); /* Fallback to non-tied array */
294 Perl_croak(aTHX_ "Size magic not implemented");
303 Clear something magical that the SV represents. See C<sv_magic>.
309 Perl_mg_clear(pTHX_ SV *sv)
314 mgs_ix = SSNEW(sizeof(MGS));
315 save_magic(mgs_ix, sv);
317 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
318 MGVTBL* vtbl = mg->mg_virtual;
319 /* omit GSKIP -- never set here */
321 if (vtbl && vtbl->svt_clear)
322 CALL_FPTR(vtbl->svt_clear)(aTHX_ sv, mg);
325 restore_magic(aTHX_ INT2PTR(void*, (IV)mgs_ix));
332 Finds the magic pointer for type matching the SV. See C<sv_magic>.
338 Perl_mg_find(pTHX_ SV *sv, int type)
343 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
344 if (mg->mg_type == type)
353 Copies the magic from one SV to another. See C<sv_magic>.
359 Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
363 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
364 MGVTBL* vtbl = mg->mg_virtual;
365 if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){
366 count += CALL_FPTR(vtbl->svt_copy)(aTHX_ sv, mg, nsv, key, klen);
368 else if (isUPPER(mg->mg_type)) {
370 mg->mg_type == PERL_MAGIC_tied ? SvTIED_obj(sv, mg) :
371 (mg->mg_type == PERL_MAGIC_regdata && mg->mg_obj)
373 toLOWER(mg->mg_type), key, klen);
383 Free any magic storage used by the SV. See C<sv_magic>.
389 Perl_mg_free(pTHX_ SV *sv)
393 for (mg = SvMAGIC(sv); mg; mg = moremagic) {
394 MGVTBL* vtbl = mg->mg_virtual;
395 moremagic = mg->mg_moremagic;
396 if (vtbl && vtbl->svt_free)
397 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
398 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
399 if (mg->mg_len > 0 || mg->mg_type == PERL_MAGIC_utf8)
400 Safefree(mg->mg_ptr);
401 else if (mg->mg_len == HEf_SVKEY)
402 SvREFCNT_dec((SV*)mg->mg_ptr);
404 if (mg->mg_flags & MGf_REFCOUNTED)
405 SvREFCNT_dec(mg->mg_obj);
415 Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
419 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
420 if (mg->mg_obj) /* @+ */
423 return rx->lastparen;
430 Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
438 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
442 if (paren <= (I32)rx->nparens &&
443 (s = rx->startp[paren]) != -1 &&
444 (t = rx->endp[paren]) != -1)
446 if (mg->mg_obj) /* @+ */
451 if (i > 0 && RX_MATCH_UTF8(rx)) {
452 char *b = rx->subbeg;
454 i = Perl_utf8_length(aTHX_ (U8*)b, (U8*)(b+i));
464 Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
466 Perl_croak(aTHX_ PL_no_modify);
472 Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
479 switch (*mg->mg_ptr) {
480 case '1': case '2': case '3': case '4':
481 case '5': case '6': case '7': case '8': case '9': case '&':
482 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
484 paren = atoi(mg->mg_ptr); /* $& is in [0] */
486 if (paren <= (I32)rx->nparens &&
487 (s1 = rx->startp[paren]) != -1 &&
488 (t1 = rx->endp[paren]) != -1)
492 if (i > 0 && RX_MATCH_UTF8(rx)) {
493 char *s = rx->subbeg + s1;
494 char *send = rx->subbeg + t1;
497 if (is_utf8_string((U8*)s, i))
498 i = Perl_utf8_length(aTHX_ (U8*)s, (U8*)send);
501 Perl_croak(aTHX_ "panic: magic_len: %"IVdf, (IV)i);
505 if (ckWARN(WARN_UNINITIALIZED))
510 if (ckWARN(WARN_UNINITIALIZED))
515 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
516 paren = rx->lastparen;
521 case '\016': /* ^N */
522 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
523 paren = rx->lastcloseparen;
529 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
530 if (rx->startp[0] != -1) {
541 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
542 if (rx->endp[0] != -1) {
543 i = rx->sublen - rx->endp[0];
554 if (!SvPOK(sv) && SvNIOK(sv)) {
564 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
567 register char *s = NULL;
571 switch (*mg->mg_ptr) {
572 case '\001': /* ^A */
573 sv_setsv(sv, PL_bodytarget);
575 case '\003': /* ^C */
576 sv_setiv(sv, (IV)PL_minus_c);
579 case '\004': /* ^D */
580 sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
582 case '\005': /* ^E */
583 if (*(mg->mg_ptr+1) == '\0') {
584 #ifdef MACOS_TRADITIONAL
588 sv_setnv(sv,(double)gMacPerl_OSErr);
589 sv_setpv(sv, gMacPerl_OSErr ? GetSysErrText(gMacPerl_OSErr, msg) : "");
594 # include <descrip.h>
595 # include <starlet.h>
597 $DESCRIPTOR(msgdsc,msg);
598 sv_setnv(sv,(NV) vaxc$errno);
599 if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
600 sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
606 if (!(_emx_env & 0x200)) { /* Under DOS */
607 sv_setnv(sv, (NV)errno);
608 sv_setpv(sv, errno ? Strerror(errno) : "");
610 if (errno != errno_isOS2) {
611 int tmp = _syserrno();
612 if (tmp) /* 2nd call to _syserrno() makes it 0 */
615 sv_setnv(sv, (NV)Perl_rc);
616 sv_setpv(sv, os2error(Perl_rc));
621 DWORD dwErr = GetLastError();
622 sv_setnv(sv, (NV)dwErr);
625 PerlProc_GetOSError(sv, dwErr);
633 int saveerrno = errno;
634 sv_setnv(sv, (NV)errno);
635 sv_setpv(sv, errno ? Strerror(errno) : "");
642 SvNOK_on(sv); /* what a wonderful hack! */
644 else if (strEQ(mg->mg_ptr+1, "NCODING"))
645 sv_setsv(sv, PL_encoding);
647 case '\006': /* ^F */
648 sv_setiv(sv, (IV)PL_maxsysfd);
650 case '\010': /* ^H */
651 sv_setiv(sv, (IV)PL_hints);
653 case '\011': /* ^I */ /* NOT \t in EBCDIC */
655 sv_setpv(sv, PL_inplace);
657 sv_setsv(sv, &PL_sv_undef);
659 case '\017': /* ^O & ^OPEN */
660 if (*(mg->mg_ptr+1) == '\0') {
661 sv_setpv(sv, PL_osname);
664 else if (strEQ(mg->mg_ptr, "\017PEN")) {
665 if (!PL_compiling.cop_io)
666 sv_setsv(sv, &PL_sv_undef);
668 sv_setsv(sv, PL_compiling.cop_io);
672 case '\020': /* ^P */
673 sv_setiv(sv, (IV)PL_perldb);
675 case '\023': /* ^S */
676 if (*(mg->mg_ptr+1) == '\0') {
677 if (PL_lex_state != LEX_NOTPARSING)
680 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
685 case '\024': /* ^T */
686 if (*(mg->mg_ptr+1) == '\0') {
688 sv_setnv(sv, PL_basetime);
690 sv_setiv(sv, (IV)PL_basetime);
693 else if (strEQ(mg->mg_ptr, "\024AINT"))
694 sv_setiv(sv, PL_tainting
695 ? (PL_taint_warn || PL_unsafe ? -1 : 1)
698 case '\025': /* $^UNICODE */
699 if (strEQ(mg->mg_ptr, "\025NICODE"))
700 sv_setuv(sv, (UV) PL_unicode);
702 case '\027': /* ^W & $^WARNING_BITS */
703 if (*(mg->mg_ptr+1) == '\0')
704 sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
705 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
706 if (PL_compiling.cop_warnings == pWARN_NONE ||
707 PL_compiling.cop_warnings == pWARN_STD)
709 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
711 else if (PL_compiling.cop_warnings == pWARN_ALL) {
712 /* Get the bit mask for $warnings::Bits{all}, because
713 * it could have been extended by warnings::register */
715 HV *bits=get_hv("warnings::Bits", FALSE);
716 if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) {
717 sv_setsv(sv, *bits_all);
720 sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
724 sv_setsv(sv, PL_compiling.cop_warnings);
729 case '1': case '2': case '3': case '4':
730 case '5': case '6': case '7': case '8': case '9': case '&':
731 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
735 * Pre-threads, this was paren = atoi(GvENAME((GV*)mg->mg_obj));
736 * XXX Does the new way break anything?
738 paren = atoi(mg->mg_ptr); /* $& is in [0] */
740 if (paren <= (I32)rx->nparens &&
741 (s1 = rx->startp[paren]) != -1 &&
742 (t1 = rx->endp[paren]) != -1)
752 if (RX_MATCH_UTF8(rx) && is_utf8_string((U8*)s, i))
757 if (RX_MATCH_TAINTED(rx)) {
758 MAGIC* mg = SvMAGIC(sv);
761 SvMAGIC(sv) = mg->mg_moremagic;
763 if ((mgt = SvMAGIC(sv))) {
764 mg->mg_moremagic = mgt;
774 sv_setsv(sv,&PL_sv_undef);
777 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
778 paren = rx->lastparen;
782 sv_setsv(sv,&PL_sv_undef);
784 case '\016': /* ^N */
785 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
786 paren = rx->lastcloseparen;
790 sv_setsv(sv,&PL_sv_undef);
793 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
794 if ((s = rx->subbeg) && rx->startp[0] != -1) {
799 sv_setsv(sv,&PL_sv_undef);
802 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
803 if (rx->subbeg && rx->endp[0] != -1) {
804 s = rx->subbeg + rx->endp[0];
805 i = rx->sublen - rx->endp[0];
809 sv_setsv(sv,&PL_sv_undef);
813 if (GvIO(PL_last_in_gv)) {
814 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
820 sv_setiv(sv, (IV)STATUS_CURRENT);
821 #ifdef COMPLEX_STATUS
822 LvTARGOFF(sv) = PL_statusvalue;
823 LvTARGLEN(sv) = PL_statusvalue_vms;
828 if (GvIOp(PL_defoutgv))
829 s = IoTOP_NAME(GvIOp(PL_defoutgv));
833 sv_setpv(sv,GvENAME(PL_defoutgv));
838 if (GvIOp(PL_defoutgv))
839 s = IoFMT_NAME(GvIOp(PL_defoutgv));
841 s = GvENAME(PL_defoutgv);
846 if (GvIOp(PL_defoutgv))
847 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
850 if (GvIOp(PL_defoutgv))
851 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
854 if (GvIOp(PL_defoutgv))
855 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
863 WITH_THR(sv_setiv(sv, (IV)PL_curcop->cop_arybase));
866 if (GvIOp(PL_defoutgv))
867 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
873 sv_copypv(sv, PL_ors_sv);
876 sv_setpv(sv,PL_ofmt);
880 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
881 sv_setpv(sv, errno ? Strerror(errno) : "");
884 int saveerrno = errno;
885 sv_setnv(sv, (NV)errno);
887 if (errno == errno_isOS2 || errno == errno_isOS2_set)
888 sv_setpv(sv, os2error(Perl_rc));
891 sv_setpv(sv, errno ? Strerror(errno) : "");
895 SvNOK_on(sv); /* what a wonderful hack! */
898 sv_setiv(sv, (IV)PL_uid);
901 sv_setiv(sv, (IV)PL_euid);
904 sv_setiv(sv, (IV)PL_gid);
906 Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, PL_gid);
910 sv_setiv(sv, (IV)PL_egid);
912 Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, PL_egid);
917 Groups_t gary[NGROUPS];
918 i = getgroups(NGROUPS,gary);
920 Perl_sv_catpvf(aTHX_ sv, " %"Gid_t_f, gary[i]);
923 (void)SvIOK_on(sv); /* what a wonderful hack! */
925 #ifndef MACOS_TRADITIONAL
934 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
936 struct ufuncs *uf = (struct ufuncs *)mg->mg_ptr;
938 if (uf && uf->uf_val)
939 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
944 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
954 #ifdef DYNAMIC_ENV_FETCH
955 /* We just undefd an environment var. Is a replacement */
956 /* waiting in the wings? */
959 if ((valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE)))
960 s = SvPV(*valp, len);
964 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
965 /* And you'll never guess what the dog had */
966 /* in its mouth... */
968 MgTAINTEDDIR_off(mg);
970 if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
971 char pathbuf[256], eltbuf[256], *cp, *elt = s;
975 do { /* DCL$PATH may be a search list */
976 while (1) { /* as may dev portion of any element */
977 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
978 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
979 cando_by_name(S_IWUSR,0,elt) ) {
984 if ((cp = strchr(elt, ':')) != Nullch)
986 if (my_trnlnm(elt, eltbuf, j++))
992 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
995 if (s && klen == 4 && strEQ(ptr,"PATH")) {
996 char *strend = s + len;
1002 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
1003 s, strend, ':', &i);
1005 if (i >= sizeof tmpbuf /* too long -- assume the worst */
1007 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1008 MgTAINTEDDIR_on(mg);
1014 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1020 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1023 my_setenv(MgPV(mg,n_a),Nullch);
1028 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1031 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1033 if (PL_localizing) {
1036 magic_clear_all_env(sv,mg);
1037 hv_iterinit((HV*)sv);
1038 while ((entry = hv_iternext((HV*)sv))) {
1040 my_setenv(hv_iterkey(entry, &keylen),
1041 SvPV(hv_iterval((HV*)sv, entry), n_a));
1049 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1052 #if defined(VMS) || defined(EPOC)
1053 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1055 # if defined(PERL_IMPLICIT_SYS) || defined(WIN32)
1058 # ifdef USE_ENVIRON_ARRAY
1059 # if defined(USE_ITHREADS)
1060 /* only the parent thread can clobber the process environment */
1061 if (PL_curinterp == aTHX)
1064 # ifndef PERL_USE_SAFE_PUTENV
1067 if (environ == PL_origenviron)
1068 environ = (char**)safesysmalloc(sizeof(char*));
1070 for (i = 0; environ[i]; i++)
1071 safesysfree(environ[i]);
1072 # endif /* PERL_USE_SAFE_PUTENV */
1074 environ[0] = Nullch;
1076 # endif /* USE_ENVIRON_ARRAY */
1077 # endif /* PERL_IMPLICIT_SYS || WIN32 */
1078 #endif /* VMS || EPOC */
1079 #endif /* !PERL_MICRO */
1083 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS)||defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1084 static int sig_handlers_initted = 0;
1086 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1087 static int sig_ignoring[SIG_SIZE]; /* which signals we are ignoring */
1089 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1090 static int sig_defaulting[SIG_SIZE];
1094 #ifdef HAS_SIGPROCMASK
1096 restore_sigmask(pTHX_ SV *save_sv)
1098 sigset_t *ossetp = (sigset_t *) SvPV_nolen( save_sv );
1099 (void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0);
1103 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1107 /* Are we fetching a signal entry? */
1108 i = whichsig(MgPV(mg,n_a));
1111 sv_setsv(sv,PL_psig_ptr[i]);
1113 Sighandler_t sigstate;
1114 sigstate = rsignal_state(i);
1115 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1116 if (sig_handlers_initted && sig_ignoring[i]) sigstate = SIG_IGN;
1118 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1119 if (sig_handlers_initted && sig_defaulting[i]) sigstate = SIG_DFL;
1121 /* cache state so we don't fetch it again */
1122 if(sigstate == SIG_IGN)
1123 sv_setpv(sv,"IGNORE");
1125 sv_setsv(sv,&PL_sv_undef);
1126 PL_psig_ptr[i] = SvREFCNT_inc(sv);
1133 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1135 /* XXX Some of this code was copied from Perl_magic_setsig. A little
1136 * refactoring might be in order.
1144 if (strEQ(s,"__DIE__"))
1146 else if (strEQ(s,"__WARN__"))
1149 Perl_croak(aTHX_ "No such hook: %s", s);
1153 SvREFCNT_dec(to_dec);
1158 /* Are we clearing a signal entry? */
1161 #ifdef HAS_SIGPROCMASK
1164 /* Avoid having the signal arrive at a bad time, if possible. */
1167 sigprocmask(SIG_BLOCK, &set, &save);
1169 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1170 SAVEFREESV(save_sv);
1171 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1174 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1175 if (!sig_handlers_initted) Perl_csighandler_init();
1177 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1178 sig_defaulting[i] = 1;
1179 (void)rsignal(i, PL_csighandlerp);
1181 (void)rsignal(i, SIG_DFL);
1183 if(PL_psig_name[i]) {
1184 SvREFCNT_dec(PL_psig_name[i]);
1187 if(PL_psig_ptr[i]) {
1188 to_dec=PL_psig_ptr[i];
1191 SvREFCNT_dec(to_dec);
1201 Perl_raise_signal(pTHX_ int sig)
1203 /* Set a flag to say this signal is pending */
1204 PL_psig_pend[sig]++;
1205 /* And one to say _a_ signal is pending */
1210 Perl_csighandler(int sig)
1212 #ifdef PERL_GET_SIG_CONTEXT
1213 dTHXa(PERL_GET_SIG_CONTEXT);
1217 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1218 (void) rsignal(sig, PL_csighandlerp);
1219 if (sig_ignoring[sig]) return;
1221 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1222 if (sig_defaulting[sig])
1223 #ifdef KILL_BY_SIGPRC
1224 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1229 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
1230 /* Call the perl level handler now--
1231 * with risk we may be in malloc() etc. */
1232 (*PL_sighandlerp)(sig);
1234 Perl_raise_signal(aTHX_ sig);
1237 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1239 Perl_csighandler_init(void)
1242 if (sig_handlers_initted) return;
1244 for (sig = 1; sig < SIG_SIZE; sig++) {
1245 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1247 sig_defaulting[sig] = 1;
1248 (void) rsignal(sig, PL_csighandlerp);
1250 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1251 sig_ignoring[sig] = 0;
1254 sig_handlers_initted = 1;
1259 Perl_despatch_signals(pTHX)
1263 for (sig = 1; sig < SIG_SIZE; sig++) {
1264 if (PL_psig_pend[sig]) {
1265 PERL_BLOCKSIG_ADD(set, sig);
1266 PL_psig_pend[sig] = 0;
1267 PERL_BLOCKSIG_BLOCK(set);
1268 (*PL_sighandlerp)(sig);
1269 PERL_BLOCKSIG_UNBLOCK(set);
1275 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1280 /* Need to be careful with SvREFCNT_dec(), because that can have side
1281 * effects (due to closures). We must make sure that the new disposition
1282 * is in place before it is called.
1286 #ifdef HAS_SIGPROCMASK
1293 if (strEQ(s,"__DIE__"))
1295 else if (strEQ(s,"__WARN__"))
1298 Perl_croak(aTHX_ "No such hook: %s", s);
1306 i = whichsig(s); /* ...no, a brick */
1308 if (ckWARN(WARN_SIGNAL))
1309 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
1312 #ifdef HAS_SIGPROCMASK
1313 /* Avoid having the signal arrive at a bad time, if possible. */
1316 sigprocmask(SIG_BLOCK, &set, &save);
1318 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1319 SAVEFREESV(save_sv);
1320 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1323 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1324 if (!sig_handlers_initted) Perl_csighandler_init();
1326 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1327 sig_ignoring[i] = 0;
1329 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1330 sig_defaulting[i] = 0;
1332 SvREFCNT_dec(PL_psig_name[i]);
1333 to_dec = PL_psig_ptr[i];
1334 PL_psig_ptr[i] = SvREFCNT_inc(sv);
1335 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1336 PL_psig_name[i] = newSVpvn(s, len);
1337 SvREADONLY_on(PL_psig_name[i]);
1339 if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
1341 (void)rsignal(i, PL_csighandlerp);
1342 #ifdef HAS_SIGPROCMASK
1347 *svp = SvREFCNT_inc(sv);
1349 SvREFCNT_dec(to_dec);
1352 s = SvPV_force(sv,len);
1353 if (strEQ(s,"IGNORE")) {
1355 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1356 sig_ignoring[i] = 1;
1357 (void)rsignal(i, PL_csighandlerp);
1359 (void)rsignal(i, SIG_IGN);
1363 else if (strEQ(s,"DEFAULT") || !*s) {
1365 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1367 sig_defaulting[i] = 1;
1368 (void)rsignal(i, PL_csighandlerp);
1371 (void)rsignal(i, SIG_DFL);
1376 * We should warn if HINT_STRICT_REFS, but without
1377 * access to a known hint bit in a known OP, we can't
1378 * tell whether HINT_STRICT_REFS is in force or not.
1380 if (!strchr(s,':') && !strchr(s,'\''))
1381 sv_insert(sv, 0, 0, "main::", 6);
1383 (void)rsignal(i, PL_csighandlerp);
1385 *svp = SvREFCNT_inc(sv);
1387 #ifdef HAS_SIGPROCMASK
1392 SvREFCNT_dec(to_dec);
1395 #endif /* !PERL_MICRO */
1398 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1400 PL_sub_generation++;
1405 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
1407 /* HV_badAMAGIC_on(Sv_STASH(sv)); */
1408 PL_amagic_generation++;
1414 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1416 HV *hv = (HV*)LvTARG(sv);
1420 (void) hv_iterinit(hv);
1421 if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
1424 while (hv_iternext(hv))
1429 sv_setiv(sv, (IV)i);
1434 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1437 hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
1442 /* caller is responsible for stack switching/cleanup */
1444 S_magic_methcall(pTHX_ SV *sv, MAGIC *mg, char *meth, I32 flags, int n, SV *val)
1450 PUSHs(SvTIED_obj(sv, mg));
1453 if (mg->mg_len >= 0)
1454 PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len)));
1455 else if (mg->mg_len == HEf_SVKEY)
1456 PUSHs((SV*)mg->mg_ptr);
1458 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1459 PUSHs(sv_2mortal(newSViv(mg->mg_len)));
1467 return call_method(meth, flags);
1471 S_magic_methpack(pTHX_ SV *sv, MAGIC *mg, char *meth)
1477 PUSHSTACKi(PERLSI_MAGIC);
1479 if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
1480 sv_setsv(sv, *PL_stack_sp--);
1490 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1493 mg->mg_flags |= MGf_GSKIP;
1494 magic_methpack(sv,mg,"FETCH");
1499 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1503 PUSHSTACKi(PERLSI_MAGIC);
1504 magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
1511 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1513 return magic_methpack(sv,mg,"DELETE");
1518 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1525 PUSHSTACKi(PERLSI_MAGIC);
1526 if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
1527 sv = *PL_stack_sp--;
1528 retval = (U32) SvIV(sv)-1;
1537 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1542 PUSHSTACKi(PERLSI_MAGIC);
1544 XPUSHs(SvTIED_obj(sv, mg));
1546 call_method("CLEAR", G_SCALAR|G_DISCARD);
1554 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1557 const char *meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
1561 PUSHSTACKi(PERLSI_MAGIC);
1564 PUSHs(SvTIED_obj(sv, mg));
1569 if (call_method(meth, G_SCALAR))
1570 sv_setsv(key, *PL_stack_sp--);
1579 Perl_magic_existspack(pTHX_ SV *sv, MAGIC *mg)
1581 return magic_methpack(sv,mg,"EXISTS");
1585 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1588 SV *retval = &PL_sv_undef;
1589 SV *tied = SvTIED_obj((SV*)hv, mg);
1590 HV *pkg = SvSTASH((SV*)SvRV(tied));
1592 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1595 /* we are in an iteration so the hash cannot be empty */
1597 /* no xhv_eiter so now use FIRSTKEY */
1598 key = sv_newmortal();
1599 magic_nextpack((SV*)hv, mg, key);
1600 HvEITER(hv) = NULL; /* need to reset iterator */
1601 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1604 /* there is a SCALAR method that we can call */
1606 PUSHSTACKi(PERLSI_MAGIC);
1612 if (call_method("SCALAR", G_SCALAR))
1613 retval = *PL_stack_sp--;
1620 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1630 svp = av_fetch(GvAV(gv),
1631 atoi(MgPV(mg,n_a)), FALSE);
1632 if (svp && SvIOKp(*svp) && (o = INT2PTR(OP*,SvIVX(*svp)))) {
1633 /* set or clear breakpoint in the relevant control op */
1635 o->op_flags |= OPf_SPECIAL;
1637 o->op_flags &= ~OPf_SPECIAL;
1643 Perl_magic_getarylen(pTHX_ SV *sv, MAGIC *mg)
1645 sv_setiv(sv, AvFILL((AV*)mg->mg_obj) + PL_curcop->cop_arybase);
1650 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
1652 av_fill((AV*)mg->mg_obj, SvIV(sv) - PL_curcop->cop_arybase);
1657 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
1659 SV* lsv = LvTARG(sv);
1661 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1662 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1663 if (mg && mg->mg_len >= 0) {
1666 sv_pos_b2u(lsv, &i);
1667 sv_setiv(sv, i + PL_curcop->cop_arybase);
1676 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
1678 SV* lsv = LvTARG(sv);
1685 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
1686 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1690 sv_magic(lsv, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1691 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1693 else if (!SvOK(sv)) {
1697 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1699 pos = SvIV(sv) - PL_curcop->cop_arybase;
1702 ulen = sv_len_utf8(lsv);
1712 else if (pos > (SSize_t)len)
1717 sv_pos_u2b(lsv, &p, 0);
1722 mg->mg_flags &= ~MGf_MINMATCH;
1728 Perl_magic_getglob(pTHX_ SV *sv, MAGIC *mg)
1730 if (SvFAKE(sv)) { /* FAKE globs can get coerced */
1732 gv_efullname3(sv,((GV*)sv), "*");
1736 gv_efullname3(sv,((GV*)sv), "*"); /* a gv value, be nice */
1741 Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg)
1750 if (*s == '*' && s[1])
1752 gv = gv_fetchpv(s,TRUE, SVt_PVGV);
1757 GvGP(sv) = gp_ref(GvGP(gv));
1762 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
1765 SV *lsv = LvTARG(sv);
1766 char *tmps = SvPV(lsv,len);
1767 I32 offs = LvTARGOFF(sv);
1768 I32 rem = LvTARGLEN(sv);
1771 sv_pos_u2b(lsv, &offs, &rem);
1772 if (offs > (I32)len)
1774 if (rem + offs > (I32)len)
1776 sv_setpvn(sv, tmps + offs, (STRLEN)rem);
1783 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
1786 char *tmps = SvPV(sv, len);
1787 SV *lsv = LvTARG(sv);
1788 I32 lvoff = LvTARGOFF(sv);
1789 I32 lvlen = LvTARGLEN(sv);
1792 sv_utf8_upgrade(lsv);
1793 sv_pos_u2b(lsv, &lvoff, &lvlen);
1794 sv_insert(lsv, lvoff, lvlen, tmps, len);
1795 LvTARGLEN(sv) = sv_len_utf8(sv);
1798 else if (lsv && SvUTF8(lsv)) {
1799 sv_pos_u2b(lsv, &lvoff, &lvlen);
1800 LvTARGLEN(sv) = len;
1801 tmps = (char*)bytes_to_utf8((U8*)tmps, &len);
1802 sv_insert(lsv, lvoff, lvlen, tmps, len);
1806 sv_insert(lsv, lvoff, lvlen, tmps, len);
1807 LvTARGLEN(sv) = len;
1815 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
1817 TAINT_IF((mg->mg_len & 1) ||
1818 ((mg->mg_len & 2) && mg->mg_obj == sv)); /* kludge */
1823 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
1825 if (PL_localizing) {
1826 if (PL_localizing == 1)
1831 else if (PL_tainted)
1839 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
1841 SV *lsv = LvTARG(sv);
1848 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
1853 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
1855 do_vecset(sv); /* XXX slurp this routine */
1860 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
1863 if (LvTARGLEN(sv)) {
1865 SV *ahv = LvTARG(sv);
1866 HE *he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
1871 AV* av = (AV*)LvTARG(sv);
1872 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
1873 targ = AvARRAY(av)[LvTARGOFF(sv)];
1875 if (targ && targ != &PL_sv_undef) {
1876 /* somebody else defined it for us */
1877 SvREFCNT_dec(LvTARG(sv));
1878 LvTARG(sv) = SvREFCNT_inc(targ);
1880 SvREFCNT_dec(mg->mg_obj);
1881 mg->mg_obj = Nullsv;
1882 mg->mg_flags &= ~MGf_REFCOUNTED;
1887 sv_setsv(sv, targ ? targ : &PL_sv_undef);
1892 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
1897 sv_setsv(LvTARG(sv), sv);
1898 SvSETMAGIC(LvTARG(sv));
1904 Perl_vivify_defelem(pTHX_ SV *sv)
1909 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
1912 SV *ahv = LvTARG(sv);
1914 HE *he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
1917 if (!value || value == &PL_sv_undef)
1918 Perl_croak(aTHX_ PL_no_helem, SvPV(mg->mg_obj, n_a));
1921 AV* av = (AV*)LvTARG(sv);
1922 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
1923 LvTARG(sv) = Nullsv; /* array can't be extended */
1925 SV** svp = av_fetch(av, LvTARGOFF(sv), TRUE);
1926 if (!svp || (value = *svp) == &PL_sv_undef)
1927 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
1930 (void)SvREFCNT_inc(value);
1931 SvREFCNT_dec(LvTARG(sv));
1934 SvREFCNT_dec(mg->mg_obj);
1935 mg->mg_obj = Nullsv;
1936 mg->mg_flags &= ~MGf_REFCOUNTED;
1940 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
1942 AV *av = (AV*)mg->mg_obj;
1943 SV **svp = AvARRAY(av);
1944 I32 i = AvFILLp(av);
1947 if (!SvWEAKREF(svp[i]))
1948 Perl_croak(aTHX_ "panic: magic_killbackrefs");
1949 /* XXX Should we check that it hasn't changed? */
1951 (void)SvOK_off(svp[i]);
1952 SvWEAKREF_off(svp[i]);
1957 SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */
1962 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
1970 Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
1972 sv_unmagic(sv, PERL_MAGIC_bm);
1978 Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
1980 sv_unmagic(sv, PERL_MAGIC_fm);
1986 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
1988 struct ufuncs *uf = (struct ufuncs *)mg->mg_ptr;
1990 if (uf && uf->uf_set)
1991 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
1996 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
1998 sv_unmagic(sv, PERL_MAGIC_qr);
2003 Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
2005 regexp *re = (regexp *)mg->mg_obj;
2010 #ifdef USE_LOCALE_COLLATE
2012 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2015 * RenE<eacute> Descartes said "I think not."
2016 * and vanished with a faint plop.
2019 Safefree(mg->mg_ptr);
2025 #endif /* USE_LOCALE_COLLATE */
2027 /* Just clear the UTF-8 cache data. */
2029 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2031 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2033 mg->mg_len = -1; /* The mg_len holds the len cache. */
2038 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2043 switch (*mg->mg_ptr) {
2044 case '\001': /* ^A */
2045 sv_setsv(PL_bodytarget, sv);
2047 case '\003': /* ^C */
2048 PL_minus_c = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2051 case '\004': /* ^D */
2054 PL_debug = get_debug_opts(&s) | DEBUG_TOP_FLAG;
2055 DEBUG_x(dump_all());
2057 PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | DEBUG_TOP_FLAG;
2060 case '\005': /* ^E */
2061 if (*(mg->mg_ptr+1) == '\0') {
2062 #ifdef MACOS_TRADITIONAL
2063 gMacPerl_OSErr = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2066 set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2069 SetLastError( SvIV(sv) );
2072 os2_setsyserrno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2074 /* will anyone ever use this? */
2075 SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4);
2081 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2083 SvREFCNT_dec(PL_encoding);
2084 if (SvOK(sv) || SvGMAGICAL(sv)) {
2085 PL_encoding = newSVsv(sv);
2088 PL_encoding = Nullsv;
2092 case '\006': /* ^F */
2093 PL_maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2095 case '\010': /* ^H */
2096 PL_hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2098 case '\011': /* ^I */ /* NOT \t in EBCDIC */
2100 Safefree(PL_inplace);
2102 PL_inplace = savepv(SvPV(sv,len));
2104 PL_inplace = Nullch;
2106 case '\017': /* ^O */
2107 if (*(mg->mg_ptr+1) == '\0') {
2109 Safefree(PL_osname);
2113 TAINT_PROPER("assigning to $^O");
2114 PL_osname = savepv(SvPV(sv,len));
2117 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2118 if (!PL_compiling.cop_io)
2119 PL_compiling.cop_io = newSVsv(sv);
2121 sv_setsv(PL_compiling.cop_io,sv);
2124 case '\020': /* ^P */
2125 PL_perldb = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2126 if ((PERLDB_SUB || PERLDB_LINE || PERLDB_SUBLINE || PERLDB_ASSERTION)
2130 case '\024': /* ^T */
2132 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2134 PL_basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2137 case '\027': /* ^W & $^WARNING_BITS */
2138 if (*(mg->mg_ptr+1) == '\0') {
2139 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2140 i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2141 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2142 | (i ? G_WARN_ON : G_WARN_OFF) ;
2145 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2146 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2147 if (!SvPOK(sv) && PL_localizing) {
2148 sv_setpvn(sv, WARN_NONEstring, WARNsize);
2149 PL_compiling.cop_warnings = pWARN_NONE;
2154 int accumulate = 0 ;
2155 int any_fatals = 0 ;
2156 char * ptr = (char*)SvPV(sv, len) ;
2157 for (i = 0 ; i < len ; ++i) {
2158 accumulate |= ptr[i] ;
2159 any_fatals |= (ptr[i] & 0xAA) ;
2162 PL_compiling.cop_warnings = pWARN_NONE;
2163 else if (isWARN_on(sv, WARN_ALL) && !any_fatals) {
2164 PL_compiling.cop_warnings = pWARN_ALL;
2165 PL_dowarn |= G_WARN_ONCE ;
2168 if (specialWARN(PL_compiling.cop_warnings))
2169 PL_compiling.cop_warnings = newSVsv(sv) ;
2171 sv_setsv(PL_compiling.cop_warnings, sv);
2172 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2173 PL_dowarn |= G_WARN_ONCE ;
2181 if (PL_localizing) {
2182 if (PL_localizing == 1)
2183 SAVESPTR(PL_last_in_gv);
2185 else if (SvOK(sv) && GvIO(PL_last_in_gv))
2186 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2189 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2190 IoTOP_NAME(GvIOp(PL_defoutgv)) = s = savepv(SvPV(sv,len));
2191 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchpv(s,TRUE, SVt_PVIO);
2194 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2195 IoFMT_NAME(GvIOp(PL_defoutgv)) = s = savepv(SvPV(sv,len));
2196 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchpv(s,TRUE, SVt_PVIO);
2199 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2202 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2203 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2204 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2207 IoPAGE(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2211 IO *io = GvIOp(PL_defoutgv);
2214 if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) == 0)
2215 IoFLAGS(io) &= ~IOf_FLUSH;
2217 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2218 PerlIO *ofp = IoOFP(io);
2220 (void)PerlIO_flush(ofp);
2221 IoFLAGS(io) |= IOf_FLUSH;
2227 SvREFCNT_dec(PL_rs);
2228 PL_rs = newSVsv(sv);
2232 SvREFCNT_dec(PL_ors_sv);
2233 if (SvOK(sv) || SvGMAGICAL(sv)) {
2234 PL_ors_sv = newSVsv(sv);
2242 SvREFCNT_dec(PL_ofs_sv);
2243 if (SvOK(sv) || SvGMAGICAL(sv)) {
2244 PL_ofs_sv = newSVsv(sv);
2253 PL_ofmt = savepv(SvPV(sv,len));
2256 PL_compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2259 #ifdef COMPLEX_STATUS
2260 if (PL_localizing == 2) {
2261 PL_statusvalue = LvTARGOFF(sv);
2262 PL_statusvalue_vms = LvTARGLEN(sv);
2266 #ifdef VMSISH_STATUS
2268 STATUS_NATIVE_SET((U32)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)));
2271 STATUS_POSIX_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2276 # define PERL_VMS_BANG vaxc$errno
2278 # define PERL_VMS_BANG 0
2280 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2281 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2285 PL_uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2286 if (PL_delaymagic) {
2287 PL_delaymagic |= DM_RUID;
2288 break; /* don't do magic till later */
2291 (void)setruid((Uid_t)PL_uid);
2294 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2296 #ifdef HAS_SETRESUID
2297 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2299 if (PL_uid == PL_euid) { /* special case $< = $> */
2301 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2302 if (PL_uid != 0 && PerlProc_getuid() == 0)
2303 (void)PerlProc_setuid(0);
2305 (void)PerlProc_setuid(PL_uid);
2307 PL_uid = PerlProc_getuid();
2308 Perl_croak(aTHX_ "setruid() not implemented");
2313 PL_uid = PerlProc_getuid();
2314 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2317 PL_euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2318 if (PL_delaymagic) {
2319 PL_delaymagic |= DM_EUID;
2320 break; /* don't do magic till later */
2323 (void)seteuid((Uid_t)PL_euid);
2326 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2328 #ifdef HAS_SETRESUID
2329 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2331 if (PL_euid == PL_uid) /* special case $> = $< */
2332 PerlProc_setuid(PL_euid);
2334 PL_euid = PerlProc_geteuid();
2335 Perl_croak(aTHX_ "seteuid() not implemented");
2340 PL_euid = PerlProc_geteuid();
2341 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2344 PL_gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2345 if (PL_delaymagic) {
2346 PL_delaymagic |= DM_RGID;
2347 break; /* don't do magic till later */
2350 (void)setrgid((Gid_t)PL_gid);
2353 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2355 #ifdef HAS_SETRESGID
2356 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2358 if (PL_gid == PL_egid) /* special case $( = $) */
2359 (void)PerlProc_setgid(PL_gid);
2361 PL_gid = PerlProc_getgid();
2362 Perl_croak(aTHX_ "setrgid() not implemented");
2367 PL_gid = PerlProc_getgid();
2368 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2371 #ifdef HAS_SETGROUPS
2373 char *p = SvPV(sv, len);
2374 Groups_t gary[NGROUPS];
2379 for (i = 0; i < NGROUPS; ++i) {
2380 while (*p && !isSPACE(*p))
2389 (void)setgroups(i, gary);
2391 #else /* HAS_SETGROUPS */
2392 PL_egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2393 #endif /* HAS_SETGROUPS */
2394 if (PL_delaymagic) {
2395 PL_delaymagic |= DM_EGID;
2396 break; /* don't do magic till later */
2399 (void)setegid((Gid_t)PL_egid);
2402 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2404 #ifdef HAS_SETRESGID
2405 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2407 if (PL_egid == PL_gid) /* special case $) = $( */
2408 (void)PerlProc_setgid(PL_egid);
2410 PL_egid = PerlProc_getegid();
2411 Perl_croak(aTHX_ "setegid() not implemented");
2416 PL_egid = PerlProc_getegid();
2417 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2420 PL_chopset = SvPV_force(sv,len);
2422 #ifndef MACOS_TRADITIONAL
2424 LOCK_DOLLARZERO_MUTEX;
2425 #ifdef HAS_SETPROCTITLE
2426 /* The BSDs don't show the argv[] in ps(1) output, they
2427 * show a string from the process struct and provide
2428 * the setproctitle() routine to manipulate that. */
2431 # if __FreeBSD_version > 410001
2432 /* The leading "-" removes the "perl: " prefix,
2433 * but not the "(perl) suffix from the ps(1)
2434 * output, because that's what ps(1) shows if the
2435 * argv[] is modified. */
2436 setproctitle("-%s", s);
2437 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2438 /* This doesn't really work if you assume that
2439 * $0 = 'foobar'; will wipe out 'perl' from the $0
2440 * because in ps(1) output the result will be like
2441 * sprintf("perl: %s (perl)", s)
2442 * I guess this is a security feature:
2443 * one (a user process) cannot get rid of the original name.
2445 setproctitle("%s", s);
2449 #if defined(__hpux) && defined(PSTAT_SETCMD)
2454 pstat(PSTAT_SETCMD, un, len, 0, 0);
2457 /* PL_origalen is set in perl_parse(). */
2458 s = SvPV_force(sv,len);
2459 if (len >= (STRLEN)PL_origalen-1) {
2460 /* Longer than original, will be truncated. We assume that
2461 * PL_origalen bytes are available. */
2462 Copy(s, PL_origargv[0], PL_origalen-1, char);
2465 /* Shorter than original, will be padded. */
2466 Copy(s, PL_origargv[0], len, char);
2467 PL_origargv[0][len] = 0;
2468 memset(PL_origargv[0] + len + 1,
2469 /* Is the space counterintuitive? Yes.
2470 * (You were expecting \0?)
2471 * Does it work? Seems to. (In Linux 2.4.20 at least.)
2474 PL_origalen - len - 1);
2476 PL_origargv[0][PL_origalen-1] = 0;
2477 for (i = 1; i < PL_origargc; i++)
2479 UNLOCK_DOLLARZERO_MUTEX;
2487 Perl_whichsig(pTHX_ char *sig)
2489 register char **sigv;
2491 for (sigv = PL_sig_name; *sigv; sigv++)
2492 if (strEQ(sig,*sigv))
2493 return PL_sig_num[sigv - PL_sig_name];
2495 if (strEQ(sig,"CHLD"))
2499 if (strEQ(sig,"CLD"))
2505 #if !defined(PERL_IMPLICIT_CONTEXT)
2510 Perl_sighandler(int sig)
2512 #ifdef PERL_GET_SIG_CONTEXT
2513 dTHXa(PERL_GET_SIG_CONTEXT);
2520 SV *sv = Nullsv, *tSv = PL_Sv;
2526 if (PL_savestack_ix + 15 <= PL_savestack_max)
2528 if (PL_markstack_ptr < PL_markstack_max - 2)
2530 if (PL_retstack_ix < PL_retstack_max - 2)
2532 if (PL_scopestack_ix < PL_scopestack_max - 3)
2535 if (!PL_psig_ptr[sig]) {
2536 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2541 /* Max number of items pushed there is 3*n or 4. We cannot fix
2542 infinity, so we fix 4 (in fact 5): */
2544 PL_savestack_ix += 5; /* Protect save in progress. */
2545 SAVEDESTRUCTOR_X(unwind_handler_stack, (void*)&flags);
2548 PL_markstack_ptr++; /* Protect mark. */
2551 PL_retstack[PL_retstack_ix] = NULL;
2554 PL_scopestack_ix += 1;
2555 /* sv_2cv is too complicated, try a simpler variant first: */
2556 if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
2557 || SvTYPE(cv) != SVt_PVCV)
2558 cv = sv_2cv(PL_psig_ptr[sig],&st,&gv,TRUE);
2560 if (!cv || !CvROOT(cv)) {
2561 if (ckWARN(WARN_SIGNAL))
2562 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2563 PL_sig_name[sig], (gv ? GvENAME(gv)
2570 if(PL_psig_name[sig]) {
2571 sv = SvREFCNT_inc(PL_psig_name[sig]);
2573 #if !defined(PERL_IMPLICIT_CONTEXT)
2577 sv = sv_newmortal();
2578 sv_setpv(sv,PL_sig_name[sig]);
2581 PUSHSTACKi(PERLSI_SIGNAL);
2586 call_sv((SV*)cv, G_DISCARD|G_EVAL);
2589 if (SvTRUE(ERRSV)) {
2591 #ifdef HAS_SIGPROCMASK
2592 /* Handler "died", for example to get out of a restart-able read().
2593 * Before we re-do that on its behalf re-enable the signal which was
2594 * blocked by the system when we entered.
2598 sigaddset(&set,sig);
2599 sigprocmask(SIG_UNBLOCK, &set, NULL);
2601 /* Not clear if this will work */
2602 (void)rsignal(sig, SIG_IGN);
2603 (void)rsignal(sig, PL_csighandlerp);
2605 #endif /* !PERL_MICRO */
2606 Perl_die(aTHX_ Nullformat);
2610 PL_savestack_ix -= 8; /* Unprotect save in progress. */
2616 PL_scopestack_ix -= 1;
2619 PL_op = myop; /* Apparently not needed... */
2621 PL_Sv = tSv; /* Restore global temporaries. */
2628 restore_magic(pTHX_ void *p)
2630 MGS* mgs = SSPTR(PTR2IV(p), MGS*);
2631 SV* sv = mgs->mgs_sv;
2636 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2638 #ifdef PERL_COPY_ON_WRITE
2639 /* While magic was saved (and off) sv_setsv may well have seen
2640 this SV as a prime candidate for COW. */
2642 sv_force_normal(sv);
2646 SvFLAGS(sv) |= mgs->mgs_flags;
2650 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
2653 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
2655 /* If we're still on top of the stack, pop us off. (That condition
2656 * will be satisfied if restore_magic was called explicitly, but *not*
2657 * if it's being called via leave_scope.)
2658 * The reason for doing this is that otherwise, things like sv_2cv()
2659 * may leave alloc gunk on the savestack, and some code
2660 * (e.g. sighandler) doesn't expect that...
2662 if (PL_savestack_ix == mgs->mgs_ss_ix)
2664 I32 popval = SSPOPINT;
2665 assert(popval == SAVEt_DESTRUCTOR_X);
2666 PL_savestack_ix -= 2;
2668 assert(popval == SAVEt_ALLOC);
2670 PL_savestack_ix -= popval;
2676 unwind_handler_stack(pTHX_ void *p)
2678 U32 flags = *(U32*)p;
2681 PL_savestack_ix -= 5; /* Unprotect save in progress. */
2682 /* cxstack_ix-- Not needed, die already unwound it. */
2683 #if !defined(PERL_IMPLICIT_CONTEXT)
2685 SvREFCNT_dec(sig_sv);