3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005 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)
52 # include <sys/pstat.h>
55 Signal_t Perl_csighandler(int sig);
57 static void restore_magic(pTHX_ const void *p);
58 static void unwind_handler_stack(pTHX_ const void *p);
61 /* Missing protos on LynxOS */
62 void setruid(uid_t id);
63 void seteuid(uid_t id);
64 void setrgid(uid_t id);
65 void setegid(uid_t id);
69 * Use the "DESTRUCTOR" scope cleanup to reinstate magic.
77 /* MGS is typedef'ed to struct magic_state in perl.h */
80 S_save_magic(pTHX_ I32 mgs_ix, SV *sv)
83 assert(SvMAGICAL(sv));
84 #ifdef PERL_OLD_COPY_ON_WRITE
85 /* Turning READONLY off for a copy-on-write scalar is a bad idea. */
90 SAVEDESTRUCTOR_X(restore_magic, INT2PTR(void*, (IV)mgs_ix));
92 mgs = SSPTR(mgs_ix, MGS*);
94 mgs->mgs_flags = SvMAGICAL(sv) | SvREADONLY(sv);
95 mgs->mgs_ss_ix = PL_savestack_ix; /* points after the saved destructor */
99 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
103 =for apidoc mg_magical
105 Turns on the magical status of an SV. See C<sv_magic>.
111 Perl_mg_magical(pTHX_ SV *sv)
114 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
115 const MGVTBL* const vtbl = mg->mg_virtual;
117 if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
121 if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)) || vtbl->svt_clear)
130 Do magic after a value is retrieved from the SV. See C<sv_magic>.
136 Perl_mg_get(pTHX_ SV *sv)
138 const I32 mgs_ix = SSNEW(sizeof(MGS));
139 const bool was_temp = (bool)SvTEMP(sv);
141 MAGIC *newmg, *head, *cur, *mg;
142 /* guard against sv having being freed midway by holding a private
145 /* sv_2mortal has this side effect of turning on the TEMP flag, which can
146 cause the SV's buffer to get stolen (and maybe other stuff).
149 sv_2mortal(SvREFCNT_inc(sv));
154 save_magic(mgs_ix, sv);
156 /* We must call svt_get(sv, mg) for each valid entry in the linked
157 list of magic. svt_get() may delete the current entry, add new
158 magic to the head of the list, or upgrade the SV. AMS 20010810 */
160 newmg = cur = head = mg = SvMAGIC(sv);
162 const MGVTBL * const vtbl = mg->mg_virtual;
164 if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
165 CALL_FPTR(vtbl->svt_get)(aTHX_ sv, mg);
167 /* guard against magic having been deleted - eg FETCH calling
172 /* Don't restore the flags for this entry if it was deleted. */
173 if (mg->mg_flags & MGf_GSKIP)
174 (SSPTR(mgs_ix, MGS *))->mgs_flags = 0;
177 mg = mg->mg_moremagic;
180 /* Have we finished with the new entries we saw? Start again
181 where we left off (unless there are more new entries). */
189 /* Were any new entries added? */
190 if (!have_new && (newmg = SvMAGIC(sv)) != head) {
197 restore_magic(aTHX_ INT2PTR(void *, (IV)mgs_ix));
199 if (SvREFCNT(sv) == 1) {
200 /* We hold the last reference to this SV, which implies that the
201 SV was deleted as a side effect of the routines we called. */
210 Do magic after a value is assigned to the SV. See C<sv_magic>.
216 Perl_mg_set(pTHX_ SV *sv)
218 const I32 mgs_ix = SSNEW(sizeof(MGS));
222 save_magic(mgs_ix, sv);
224 for (mg = SvMAGIC(sv); mg; mg = nextmg) {
225 const MGVTBL* vtbl = mg->mg_virtual;
226 nextmg = mg->mg_moremagic; /* it may delete itself */
227 if (mg->mg_flags & MGf_GSKIP) {
228 mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */
229 (SSPTR(mgs_ix, MGS*))->mgs_flags = 0;
231 if (vtbl && vtbl->svt_set)
232 CALL_FPTR(vtbl->svt_set)(aTHX_ sv, mg);
235 restore_magic(aTHX_ INT2PTR(void*, (IV)mgs_ix));
240 =for apidoc mg_length
242 Report on the SV's length. See C<sv_magic>.
248 Perl_mg_length(pTHX_ SV *sv)
253 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
254 const MGVTBL * const vtbl = mg->mg_virtual;
255 if (vtbl && vtbl->svt_len) {
256 const I32 mgs_ix = SSNEW(sizeof(MGS));
257 save_magic(mgs_ix, sv);
258 /* omit MGf_GSKIP -- not changed here */
259 len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
260 restore_magic(aTHX_ INT2PTR(void*, (IV)mgs_ix));
266 const U8 *s = (U8*)SvPV_const(sv, len);
267 len = Perl_utf8_length(aTHX_ s, s + len);
270 (void)SvPV_const(sv, len);
275 Perl_mg_size(pTHX_ SV *sv)
279 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
280 const MGVTBL* const vtbl = mg->mg_virtual;
281 if (vtbl && vtbl->svt_len) {
282 const I32 mgs_ix = SSNEW(sizeof(MGS));
284 save_magic(mgs_ix, sv);
285 /* omit MGf_GSKIP -- not changed here */
286 len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
287 restore_magic(aTHX_ INT2PTR(void*, (IV)mgs_ix));
294 return AvFILLp((AV *) sv); /* Fallback to non-tied array */
298 Perl_croak(aTHX_ "Size magic not implemented");
307 Clear something magical that the SV represents. See C<sv_magic>.
313 Perl_mg_clear(pTHX_ SV *sv)
315 const I32 mgs_ix = SSNEW(sizeof(MGS));
318 save_magic(mgs_ix, sv);
320 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
321 const MGVTBL* const vtbl = mg->mg_virtual;
322 /* omit GSKIP -- never set here */
324 if (vtbl && vtbl->svt_clear)
325 CALL_FPTR(vtbl->svt_clear)(aTHX_ sv, mg);
328 restore_magic(aTHX_ INT2PTR(void*, (IV)mgs_ix));
335 Finds the magic pointer for type matching the SV. See C<sv_magic>.
341 Perl_mg_find(pTHX_ const SV *sv, int type)
345 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
346 if (mg->mg_type == type)
356 Copies the magic from one SV to another. See C<sv_magic>.
362 Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
366 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
367 const MGVTBL* const vtbl = mg->mg_virtual;
368 if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){
369 count += CALL_FPTR(vtbl->svt_copy)(aTHX_ sv, mg, nsv, key, klen);
371 else if (isUPPER(mg->mg_type)) {
373 mg->mg_type == PERL_MAGIC_tied ? SvTIED_obj(sv, mg) :
374 (mg->mg_type == PERL_MAGIC_regdata && mg->mg_obj)
376 toLOWER(mg->mg_type), key, klen);
384 =for apidoc mg_localize
386 Copy some of the magic from an existing SV to new localized version of
387 that SV. Container magic (eg %ENV, $1, tie) gets copied, value magic
388 doesn't (eg taint, pos).
394 Perl_mg_localize(pTHX_ SV *sv, SV *nsv)
397 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
398 const MGVTBL* const vtbl = mg->mg_virtual;
399 switch (mg->mg_type) {
400 /* value magic types: don't copy */
403 case PERL_MAGIC_regex_global:
404 case PERL_MAGIC_nkeys:
405 #ifdef USE_LOCALE_COLLATE
406 case PERL_MAGIC_collxfrm:
409 case PERL_MAGIC_taint:
411 case PERL_MAGIC_vstring:
412 case PERL_MAGIC_utf8:
413 case PERL_MAGIC_substr:
414 case PERL_MAGIC_defelem:
415 case PERL_MAGIC_arylen:
417 case PERL_MAGIC_backref:
418 case PERL_MAGIC_arylen_p:
419 case PERL_MAGIC_rhash:
420 case PERL_MAGIC_symtab:
424 if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy) {
425 /* XXX calling the copy method is probably not correct. DAPM */
426 (void)CALL_FPTR(vtbl->svt_copy)(aTHX_ sv, mg, nsv,
427 mg->mg_ptr, mg->mg_len);
430 sv_magicext(nsv, mg->mg_obj, mg->mg_type, vtbl,
431 mg->mg_ptr, mg->mg_len);
433 /* container types should remain read-only across localization */
434 SvFLAGS(nsv) |= SvREADONLY(sv);
437 if (SvTYPE(nsv) >= SVt_PVMG && SvMAGIC(nsv)) {
438 SvFLAGS(nsv) |= SvMAGICAL(sv);
448 Free any magic storage used by the SV. See C<sv_magic>.
454 Perl_mg_free(pTHX_ SV *sv)
458 for (mg = SvMAGIC(sv); mg; mg = moremagic) {
459 const MGVTBL* const vtbl = mg->mg_virtual;
460 moremagic = mg->mg_moremagic;
461 if (vtbl && vtbl->svt_free)
462 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
463 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
464 if (mg->mg_len > 0 || mg->mg_type == PERL_MAGIC_utf8)
465 Safefree(mg->mg_ptr);
466 else if (mg->mg_len == HEf_SVKEY)
467 SvREFCNT_dec((SV*)mg->mg_ptr);
469 if (mg->mg_flags & MGf_REFCOUNTED)
470 SvREFCNT_dec(mg->mg_obj);
473 SvMAGIC_set(sv, NULL);
480 Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
482 register const REGEXP *rx;
485 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
486 if (mg->mg_obj) /* @+ */
489 return rx->lastparen;
496 Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
500 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
501 register const I32 paren = mg->mg_len;
506 if (paren <= (I32)rx->nparens &&
507 (s = rx->startp[paren]) != -1 &&
508 (t = rx->endp[paren]) != -1)
511 if (mg->mg_obj) /* @+ */
516 if (i > 0 && RX_MATCH_UTF8(rx)) {
517 char *b = rx->subbeg;
519 i = Perl_utf8_length(aTHX_ (U8*)b, (U8*)(b+i));
529 Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
532 Perl_croak(aTHX_ PL_no_modify);
533 NORETURN_FUNCTION_END;
537 Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
541 register const REGEXP *rx;
544 switch (*mg->mg_ptr) {
545 case '1': case '2': case '3': case '4':
546 case '5': case '6': case '7': case '8': case '9': case '&':
547 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
549 paren = atoi(mg->mg_ptr); /* $& is in [0] */
551 if (paren <= (I32)rx->nparens &&
552 (s1 = rx->startp[paren]) != -1 &&
553 (t1 = rx->endp[paren]) != -1)
557 if (i > 0 && RX_MATCH_UTF8(rx)) {
558 const char * const s = rx->subbeg + s1;
563 if (is_utf8_string_loclen((U8*)s, i, &ep, &el))
567 Perl_croak(aTHX_ "panic: magic_len: %"IVdf, (IV)i);
571 if (ckWARN(WARN_UNINITIALIZED))
576 if (ckWARN(WARN_UNINITIALIZED))
581 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
582 paren = rx->lastparen;
587 case '\016': /* ^N */
588 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
589 paren = rx->lastcloseparen;
595 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
596 if (rx->startp[0] != -1) {
607 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
608 if (rx->endp[0] != -1) {
609 i = rx->sublen - rx->endp[0];
620 if (!SvPOK(sv) && SvNIOK(sv)) {
628 #define SvRTRIM(sv) STMT_START { \
629 STRLEN len = SvCUR(sv); \
630 while (len > 0 && isSPACE(SvPVX(sv)[len-1])) \
632 SvCUR_set(sv, len); \
636 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
640 register char *s = NULL;
644 switch (*mg->mg_ptr) {
645 case '\001': /* ^A */
646 sv_setsv(sv, PL_bodytarget);
648 case '\003': /* ^C, ^CHILD_ERROR_NATIVE */
649 if (*(mg->mg_ptr+1) == '\0') {
650 sv_setiv(sv, (IV)PL_minus_c);
652 else if (strEQ(mg->mg_ptr, "\003HILD_ERROR_NATIVE")) {
653 sv_setiv(sv, (IV)STATUS_NATIVE);
657 case '\004': /* ^D */
658 sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
660 case '\005': /* ^E */
661 if (*(mg->mg_ptr+1) == '\0') {
662 #ifdef MACOS_TRADITIONAL
666 sv_setnv(sv,(double)gMacPerl_OSErr);
667 sv_setpv(sv, gMacPerl_OSErr ? GetSysErrText(gMacPerl_OSErr, msg) : "");
672 # include <descrip.h>
673 # include <starlet.h>
675 $DESCRIPTOR(msgdsc,msg);
676 sv_setnv(sv,(NV) vaxc$errno);
677 if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
678 sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
684 if (!(_emx_env & 0x200)) { /* Under DOS */
685 sv_setnv(sv, (NV)errno);
686 sv_setpv(sv, errno ? Strerror(errno) : "");
688 if (errno != errno_isOS2) {
689 int tmp = _syserrno();
690 if (tmp) /* 2nd call to _syserrno() makes it 0 */
693 sv_setnv(sv, (NV)Perl_rc);
694 sv_setpv(sv, os2error(Perl_rc));
699 DWORD dwErr = GetLastError();
700 sv_setnv(sv, (NV)dwErr);
703 PerlProc_GetOSError(sv, dwErr);
706 sv_setpvn(sv, "", 0);
711 int saveerrno = errno;
712 sv_setnv(sv, (NV)errno);
713 sv_setpv(sv, errno ? Strerror(errno) : "");
721 SvNOK_on(sv); /* what a wonderful hack! */
723 else if (strEQ(mg->mg_ptr+1, "NCODING"))
724 sv_setsv(sv, PL_encoding);
726 case '\006': /* ^F */
727 sv_setiv(sv, (IV)PL_maxsysfd);
729 case '\010': /* ^H */
730 sv_setiv(sv, (IV)PL_hints);
732 case '\011': /* ^I */ /* NOT \t in EBCDIC */
734 sv_setpv(sv, PL_inplace);
736 sv_setsv(sv, &PL_sv_undef);
738 case '\017': /* ^O & ^OPEN */
739 if (*(mg->mg_ptr+1) == '\0') {
740 sv_setpv(sv, PL_osname);
743 else if (strEQ(mg->mg_ptr, "\017PEN")) {
744 if (!PL_compiling.cop_io)
745 sv_setsv(sv, &PL_sv_undef);
747 sv_setsv(sv, PL_compiling.cop_io);
751 case '\020': /* ^P */
752 sv_setiv(sv, (IV)PL_perldb);
754 case '\023': /* ^S */
755 if (*(mg->mg_ptr+1) == '\0') {
756 if (PL_lex_state != LEX_NOTPARSING)
759 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
764 case '\024': /* ^T */
765 if (*(mg->mg_ptr+1) == '\0') {
767 sv_setnv(sv, PL_basetime);
769 sv_setiv(sv, (IV)PL_basetime);
772 else if (strEQ(mg->mg_ptr, "\024AINT"))
773 sv_setiv(sv, PL_tainting
774 ? (PL_taint_warn || PL_unsafe ? -1 : 1)
777 case '\025': /* $^UNICODE, $^UTF8LOCALE */
778 if (strEQ(mg->mg_ptr, "\025NICODE"))
779 sv_setuv(sv, (UV) PL_unicode);
780 else if (strEQ(mg->mg_ptr, "\025TF8LOCALE"))
781 sv_setuv(sv, (UV) PL_utf8locale);
783 case '\027': /* ^W & $^WARNING_BITS */
784 if (*(mg->mg_ptr+1) == '\0')
785 sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
786 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
787 if (PL_compiling.cop_warnings == pWARN_NONE ||
788 PL_compiling.cop_warnings == pWARN_STD)
790 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
792 else if (PL_compiling.cop_warnings == pWARN_ALL) {
793 /* Get the bit mask for $warnings::Bits{all}, because
794 * it could have been extended by warnings::register */
796 HV *bits=get_hv("warnings::Bits", FALSE);
797 if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) {
798 sv_setsv(sv, *bits_all);
801 sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
805 sv_setsv(sv, PL_compiling.cop_warnings);
810 case '1': case '2': case '3': case '4':
811 case '5': case '6': case '7': case '8': case '9': case '&':
812 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
816 * Pre-threads, this was paren = atoi(GvENAME((GV*)mg->mg_obj));
817 * XXX Does the new way break anything?
819 paren = atoi(mg->mg_ptr); /* $& is in [0] */
821 if (paren <= (I32)rx->nparens &&
822 (s1 = rx->startp[paren]) != -1 &&
823 (t1 = rx->endp[paren]) != -1)
833 if (RX_MATCH_UTF8(rx) && is_utf8_string((U8*)s, i))
838 if (RX_MATCH_TAINTED(rx)) {
839 MAGIC* mg = SvMAGIC(sv);
842 SvMAGIC_set(sv, mg->mg_moremagic);
844 if ((mgt = SvMAGIC(sv))) {
845 mg->mg_moremagic = mgt;
855 sv_setsv(sv,&PL_sv_undef);
858 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
859 paren = rx->lastparen;
863 sv_setsv(sv,&PL_sv_undef);
865 case '\016': /* ^N */
866 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
867 paren = rx->lastcloseparen;
871 sv_setsv(sv,&PL_sv_undef);
874 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
875 if ((s = rx->subbeg) && rx->startp[0] != -1) {
880 sv_setsv(sv,&PL_sv_undef);
883 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
884 if (rx->subbeg && rx->endp[0] != -1) {
885 s = rx->subbeg + rx->endp[0];
886 i = rx->sublen - rx->endp[0];
890 sv_setsv(sv,&PL_sv_undef);
893 if (GvIO(PL_last_in_gv)) {
894 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
899 sv_setiv(sv, (IV)STATUS_CURRENT);
900 #ifdef COMPLEX_STATUS
901 LvTARGOFF(sv) = PL_statusvalue;
902 LvTARGLEN(sv) = PL_statusvalue_vms;
907 if (GvIOp(PL_defoutgv))
908 s = IoTOP_NAME(GvIOp(PL_defoutgv));
912 sv_setpv(sv,GvENAME(PL_defoutgv));
917 if (GvIOp(PL_defoutgv))
918 s = IoFMT_NAME(GvIOp(PL_defoutgv));
920 s = GvENAME(PL_defoutgv);
924 if (GvIOp(PL_defoutgv))
925 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
928 if (GvIOp(PL_defoutgv))
929 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
932 if (GvIOp(PL_defoutgv))
933 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
940 WITH_THR(sv_setiv(sv, (IV)PL_curcop->cop_arybase));
943 if (GvIOp(PL_defoutgv))
944 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
950 sv_copypv(sv, PL_ors_sv);
954 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
955 sv_setpv(sv, errno ? Strerror(errno) : "");
958 int saveerrno = errno;
959 sv_setnv(sv, (NV)errno);
961 if (errno == errno_isOS2 || errno == errno_isOS2_set)
962 sv_setpv(sv, os2error(Perl_rc));
965 sv_setpv(sv, errno ? Strerror(errno) : "");
970 SvNOK_on(sv); /* what a wonderful hack! */
973 sv_setiv(sv, (IV)PL_uid);
976 sv_setiv(sv, (IV)PL_euid);
979 sv_setiv(sv, (IV)PL_gid);
981 Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, (long unsigned int)PL_gid);
985 sv_setiv(sv, (IV)PL_egid);
987 Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, (long unsigned int)PL_egid);
992 Groups_t gary[NGROUPS];
993 I32 j = getgroups(NGROUPS,gary);
995 Perl_sv_catpvf(aTHX_ sv, " %"Gid_t_f, (long unsigned int)gary[j]);
998 (void)SvIOK_on(sv); /* what a wonderful hack! */
1000 #ifndef MACOS_TRADITIONAL
1009 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
1011 struct ufuncs *uf = (struct ufuncs *)mg->mg_ptr;
1013 if (uf && uf->uf_val)
1014 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
1019 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
1026 s = SvPV_const(sv,len);
1027 ptr = MgPV_const(mg,klen);
1030 #ifdef DYNAMIC_ENV_FETCH
1031 /* We just undefd an environment var. Is a replacement */
1032 /* waiting in the wings? */
1035 if ((valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE)))
1036 s = SvPV_const(*valp, len);
1040 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
1041 /* And you'll never guess what the dog had */
1042 /* in its mouth... */
1044 MgTAINTEDDIR_off(mg);
1046 if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
1047 char pathbuf[256], eltbuf[256], *cp, *elt = s;
1051 do { /* DCL$PATH may be a search list */
1052 while (1) { /* as may dev portion of any element */
1053 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1054 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1055 cando_by_name(S_IWUSR,0,elt) ) {
1056 MgTAINTEDDIR_on(mg);
1060 if ((cp = strchr(elt, ':')) != Nullch)
1062 if (my_trnlnm(elt, eltbuf, j++))
1068 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1071 if (s && klen == 4 && strEQ(ptr,"PATH")) {
1072 const char *strend = s + len;
1074 while (s < strend) {
1078 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
1079 s, strend, ':', &i);
1081 if (i >= sizeof tmpbuf /* too long -- assume the worst */
1083 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1084 MgTAINTEDDIR_on(mg);
1090 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1096 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1099 my_setenv(MgPV_nolen_const(mg),Nullch);
1104 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1106 #if defined(VMS) || defined(EPOC) || defined(SYMBIAN)
1107 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1109 if (PL_localizing) {
1111 magic_clear_all_env(sv,mg);
1112 hv_iterinit((HV*)sv);
1113 while ((entry = hv_iternext((HV*)sv))) {
1115 my_setenv(hv_iterkey(entry, &keylen),
1116 SvPV_nolen_const(hv_iterval((HV*)sv, entry)));
1124 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1128 #if defined(VMS) || defined(EPOC) || defined(SYMBIAN)
1129 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1131 # if defined(PERL_IMPLICIT_SYS) || defined(WIN32)
1134 # ifdef USE_ENVIRON_ARRAY
1135 # if defined(USE_ITHREADS)
1136 /* only the parent thread can clobber the process environment */
1137 if (PL_curinterp == aTHX)
1140 # ifndef PERL_USE_SAFE_PUTENV
1141 if (!PL_use_safe_putenv) {
1144 if (environ == PL_origenviron)
1145 environ = (char**)safesysmalloc(sizeof(char*));
1147 for (i = 0; environ[i]; i++)
1148 safesysfree(environ[i]);
1150 # endif /* PERL_USE_SAFE_PUTENV */
1152 environ[0] = Nullch;
1154 # endif /* USE_ENVIRON_ARRAY */
1155 # endif /* PERL_IMPLICIT_SYS || WIN32 */
1156 #endif /* VMS || EPOC */
1157 #endif /* !PERL_MICRO */
1164 #ifdef HAS_SIGPROCMASK
1166 restore_sigmask(pTHX_ SV *save_sv)
1168 const sigset_t *ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1169 (void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0);
1173 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1176 /* Are we fetching a signal entry? */
1177 i = whichsig(MgPV_nolen_const(mg));
1180 sv_setsv(sv,PL_psig_ptr[i]);
1182 Sighandler_t sigstate;
1183 sigstate = rsignal_state(i);
1184 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1185 if (PL_sig_handlers_initted && PL_sig_ignoring[i]) sigstate = SIG_IGN;
1187 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1188 if (PL_sig_handlers_initted && PL_sig_defaulting[i]) sigstate = SIG_DFL;
1190 /* cache state so we don't fetch it again */
1191 if(sigstate == SIG_IGN)
1192 sv_setpv(sv,"IGNORE");
1194 sv_setsv(sv,&PL_sv_undef);
1195 PL_psig_ptr[i] = SvREFCNT_inc(sv);
1202 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1204 /* XXX Some of this code was copied from Perl_magic_setsig. A little
1205 * refactoring might be in order.
1208 register const char *s = MgPV_nolen_const(mg);
1212 if (strEQ(s,"__DIE__"))
1214 else if (strEQ(s,"__WARN__"))
1217 Perl_croak(aTHX_ "No such hook: %s", s);
1221 SvREFCNT_dec(to_dec);
1226 /* Are we clearing a signal entry? */
1229 #ifdef HAS_SIGPROCMASK
1232 /* Avoid having the signal arrive at a bad time, if possible. */
1235 sigprocmask(SIG_BLOCK, &set, &save);
1237 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1238 SAVEFREESV(save_sv);
1239 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1242 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1243 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1245 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1246 PL_sig_defaulting[i] = 1;
1247 (void)rsignal(i, PL_csighandlerp);
1249 (void)rsignal(i, SIG_DFL);
1251 if(PL_psig_name[i]) {
1252 SvREFCNT_dec(PL_psig_name[i]);
1255 if(PL_psig_ptr[i]) {
1256 SV *to_dec=PL_psig_ptr[i];
1259 SvREFCNT_dec(to_dec);
1269 S_raise_signal(pTHX_ int sig)
1271 /* Set a flag to say this signal is pending */
1272 PL_psig_pend[sig]++;
1273 /* And one to say _a_ signal is pending */
1278 Perl_csighandler(int sig)
1280 #ifdef PERL_GET_SIG_CONTEXT
1281 dTHXa(PERL_GET_SIG_CONTEXT);
1285 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1286 (void) rsignal(sig, PL_csighandlerp);
1287 if (PL_sig_ignoring[sig]) return;
1289 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1290 if (PL_sig_defaulting[sig])
1291 #ifdef KILL_BY_SIGPRC
1292 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1297 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
1298 /* Call the perl level handler now--
1299 * with risk we may be in malloc() etc. */
1300 (*PL_sighandlerp)(sig);
1302 S_raise_signal(aTHX_ sig);
1305 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1307 Perl_csighandler_init(void)
1310 if (PL_sig_handlers_initted) return;
1312 for (sig = 1; sig < SIG_SIZE; sig++) {
1313 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1315 PL_sig_defaulting[sig] = 1;
1316 (void) rsignal(sig, PL_csighandlerp);
1318 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1319 PL_sig_ignoring[sig] = 0;
1322 PL_sig_handlers_initted = 1;
1327 Perl_despatch_signals(pTHX)
1331 for (sig = 1; sig < SIG_SIZE; sig++) {
1332 if (PL_psig_pend[sig]) {
1333 PERL_BLOCKSIG_ADD(set, sig);
1334 PL_psig_pend[sig] = 0;
1335 PERL_BLOCKSIG_BLOCK(set);
1336 (*PL_sighandlerp)(sig);
1337 PERL_BLOCKSIG_UNBLOCK(set);
1343 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1348 /* Need to be careful with SvREFCNT_dec(), because that can have side
1349 * effects (due to closures). We must make sure that the new disposition
1350 * is in place before it is called.
1354 #ifdef HAS_SIGPROCMASK
1359 register const char *s = MgPV_const(mg,len);
1361 if (strEQ(s,"__DIE__"))
1363 else if (strEQ(s,"__WARN__"))
1366 Perl_croak(aTHX_ "No such hook: %s", s);
1374 i = whichsig(s); /* ...no, a brick */
1376 if (ckWARN(WARN_SIGNAL))
1377 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
1380 #ifdef HAS_SIGPROCMASK
1381 /* Avoid having the signal arrive at a bad time, if possible. */
1384 sigprocmask(SIG_BLOCK, &set, &save);
1386 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1387 SAVEFREESV(save_sv);
1388 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1391 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1392 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1394 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1395 PL_sig_ignoring[i] = 0;
1397 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1398 PL_sig_defaulting[i] = 0;
1400 SvREFCNT_dec(PL_psig_name[i]);
1401 to_dec = PL_psig_ptr[i];
1402 PL_psig_ptr[i] = SvREFCNT_inc(sv);
1403 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1404 PL_psig_name[i] = newSVpvn(s, len);
1405 SvREADONLY_on(PL_psig_name[i]);
1407 if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
1409 (void)rsignal(i, PL_csighandlerp);
1410 #ifdef HAS_SIGPROCMASK
1415 *svp = SvREFCNT_inc(sv);
1417 SvREFCNT_dec(to_dec);
1420 s = SvPV_force(sv,len);
1421 if (strEQ(s,"IGNORE")) {
1423 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1424 PL_sig_ignoring[i] = 1;
1425 (void)rsignal(i, PL_csighandlerp);
1427 (void)rsignal(i, SIG_IGN);
1431 else if (strEQ(s,"DEFAULT") || !*s) {
1433 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1435 PL_sig_defaulting[i] = 1;
1436 (void)rsignal(i, PL_csighandlerp);
1439 (void)rsignal(i, SIG_DFL);
1444 * We should warn if HINT_STRICT_REFS, but without
1445 * access to a known hint bit in a known OP, we can't
1446 * tell whether HINT_STRICT_REFS is in force or not.
1448 if (!strchr(s,':') && !strchr(s,'\''))
1449 sv_insert(sv, 0, 0, "main::", 6);
1451 (void)rsignal(i, PL_csighandlerp);
1453 *svp = SvREFCNT_inc(sv);
1455 #ifdef HAS_SIGPROCMASK
1460 SvREFCNT_dec(to_dec);
1463 #endif /* !PERL_MICRO */
1466 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1470 PL_sub_generation++;
1475 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
1479 /* HV_badAMAGIC_on(Sv_STASH(sv)); */
1480 PL_amagic_generation++;
1486 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1488 HV * const hv = (HV*)LvTARG(sv);
1493 (void) hv_iterinit(hv);
1494 if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
1497 while (hv_iternext(hv))
1502 sv_setiv(sv, (IV)i);
1507 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1511 hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
1516 /* caller is responsible for stack switching/cleanup */
1518 S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV *val)
1524 PUSHs(SvTIED_obj(sv, mg));
1527 if (mg->mg_len >= 0)
1528 PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len)));
1529 else if (mg->mg_len == HEf_SVKEY)
1530 PUSHs((SV*)mg->mg_ptr);
1532 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1533 PUSHs(sv_2mortal(newSViv(mg->mg_len)));
1541 return call_method(meth, flags);
1545 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
1551 PUSHSTACKi(PERLSI_MAGIC);
1553 if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
1554 sv_setsv(sv, *PL_stack_sp--);
1564 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1567 mg->mg_flags |= MGf_GSKIP;
1568 magic_methpack(sv,mg,"FETCH");
1573 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1577 PUSHSTACKi(PERLSI_MAGIC);
1578 magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
1585 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1587 return magic_methpack(sv,mg,"DELETE");
1592 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1599 PUSHSTACKi(PERLSI_MAGIC);
1600 if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
1601 sv = *PL_stack_sp--;
1602 retval = (U32) SvIV(sv)-1;
1611 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1616 PUSHSTACKi(PERLSI_MAGIC);
1618 XPUSHs(SvTIED_obj(sv, mg));
1620 call_method("CLEAR", G_SCALAR|G_DISCARD);
1628 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1631 const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
1635 PUSHSTACKi(PERLSI_MAGIC);
1638 PUSHs(SvTIED_obj(sv, mg));
1643 if (call_method(meth, G_SCALAR))
1644 sv_setsv(key, *PL_stack_sp--);
1653 Perl_magic_existspack(pTHX_ SV *sv, MAGIC *mg)
1655 return magic_methpack(sv,mg,"EXISTS");
1659 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1662 SV *retval = &PL_sv_undef;
1663 SV *tied = SvTIED_obj((SV*)hv, mg);
1664 HV *pkg = SvSTASH((SV*)SvRV(tied));
1666 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1668 if (HvEITER_get(hv))
1669 /* we are in an iteration so the hash cannot be empty */
1671 /* no xhv_eiter so now use FIRSTKEY */
1672 key = sv_newmortal();
1673 magic_nextpack((SV*)hv, mg, key);
1674 HvEITER_set(hv, NULL); /* need to reset iterator */
1675 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1678 /* there is a SCALAR method that we can call */
1680 PUSHSTACKi(PERLSI_MAGIC);
1686 if (call_method("SCALAR", G_SCALAR))
1687 retval = *PL_stack_sp--;
1694 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1703 svp = av_fetch(GvAV(gv),
1704 atoi(MgPV_nolen_const(mg)), FALSE);
1705 if (svp && SvIOKp(*svp) && (o = INT2PTR(OP*,SvIVX(*svp)))) {
1706 /* set or clear breakpoint in the relevant control op */
1708 o->op_flags |= OPf_SPECIAL;
1710 o->op_flags &= ~OPf_SPECIAL;
1716 Perl_magic_getarylen(pTHX_ SV *sv, MAGIC *mg)
1718 AV *obj = (AV*)mg->mg_obj;
1720 sv_setiv(sv, AvFILL(obj) + PL_curcop->cop_arybase);
1728 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
1730 AV *obj = (AV*)mg->mg_obj;
1732 av_fill(obj, SvIV(sv) - PL_curcop->cop_arybase);
1734 if (ckWARN(WARN_MISC))
1735 Perl_warner(aTHX_ packWARN(WARN_MISC),
1736 "Attempt to set length of freed array");
1742 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
1744 PERL_UNUSED_ARG(sv);
1745 /* during global destruction, mg_obj may already have been freed */
1746 if (PL_in_clean_all)
1749 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
1752 /* arylen scalar holds a pointer back to the array, but doesn't own a
1753 reference. Hence the we (the array) are about to go away with it
1754 still pointing at us. Clear its pointer, else it would be pointing
1755 at free memory. See the comment in sv_magic about reference loops,
1756 and why it can't own a reference to us. */
1763 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
1765 SV* lsv = LvTARG(sv);
1767 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1768 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1769 if (mg && mg->mg_len >= 0) {
1772 sv_pos_b2u(lsv, &i);
1773 sv_setiv(sv, i + PL_curcop->cop_arybase);
1782 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
1784 SV* lsv = LvTARG(sv);
1791 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
1792 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1796 sv_magic(lsv, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1797 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1799 else if (!SvOK(sv)) {
1803 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1805 pos = SvIV(sv) - PL_curcop->cop_arybase;
1808 ulen = sv_len_utf8(lsv);
1818 else if (pos > (SSize_t)len)
1823 sv_pos_u2b(lsv, &p, 0);
1828 mg->mg_flags &= ~MGf_MINMATCH;
1834 Perl_magic_getglob(pTHX_ SV *sv, MAGIC *mg)
1837 if (SvFAKE(sv)) { /* FAKE globs can get coerced */
1839 gv_efullname3(sv,((GV*)sv), "*");
1843 gv_efullname3(sv,((GV*)sv), "*"); /* a gv value, be nice */
1848 Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg)
1855 gv = gv_fetchsv(sv,TRUE, SVt_PVGV);
1860 GvGP(sv) = gp_ref(GvGP(gv));
1865 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
1868 SV * const lsv = LvTARG(sv);
1869 const char * const tmps = SvPV_const(lsv,len);
1870 I32 offs = LvTARGOFF(sv);
1871 I32 rem = LvTARGLEN(sv);
1875 sv_pos_u2b(lsv, &offs, &rem);
1876 if (offs > (I32)len)
1878 if (rem + offs > (I32)len)
1880 sv_setpvn(sv, tmps + offs, (STRLEN)rem);
1887 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
1890 const char *tmps = SvPV_const(sv, len);
1891 SV * const lsv = LvTARG(sv);
1892 I32 lvoff = LvTARGOFF(sv);
1893 I32 lvlen = LvTARGLEN(sv);
1897 sv_utf8_upgrade(lsv);
1898 sv_pos_u2b(lsv, &lvoff, &lvlen);
1899 sv_insert(lsv, lvoff, lvlen, tmps, len);
1900 LvTARGLEN(sv) = sv_len_utf8(sv);
1903 else if (lsv && SvUTF8(lsv)) {
1904 sv_pos_u2b(lsv, &lvoff, &lvlen);
1905 LvTARGLEN(sv) = len;
1906 tmps = (char*)bytes_to_utf8((U8*)tmps, &len);
1907 sv_insert(lsv, lvoff, lvlen, tmps, len);
1911 sv_insert(lsv, lvoff, lvlen, tmps, len);
1912 LvTARGLEN(sv) = len;
1920 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
1922 TAINT_IF(mg->mg_len & 1);
1927 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
1938 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
1940 SV * const lsv = LvTARG(sv);
1948 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
1953 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
1956 do_vecset(sv); /* XXX slurp this routine */
1961 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
1964 if (LvTARGLEN(sv)) {
1966 SV *ahv = LvTARG(sv);
1967 HE *he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
1972 AV* av = (AV*)LvTARG(sv);
1973 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
1974 targ = AvARRAY(av)[LvTARGOFF(sv)];
1976 if (targ && targ != &PL_sv_undef) {
1977 /* somebody else defined it for us */
1978 SvREFCNT_dec(LvTARG(sv));
1979 LvTARG(sv) = SvREFCNT_inc(targ);
1981 SvREFCNT_dec(mg->mg_obj);
1982 mg->mg_obj = Nullsv;
1983 mg->mg_flags &= ~MGf_REFCOUNTED;
1988 sv_setsv(sv, targ ? targ : &PL_sv_undef);
1993 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
1999 sv_setsv(LvTARG(sv), sv);
2000 SvSETMAGIC(LvTARG(sv));
2006 Perl_vivify_defelem(pTHX_ SV *sv)
2011 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2014 SV *ahv = LvTARG(sv);
2015 HE *he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
2018 if (!value || value == &PL_sv_undef)
2019 Perl_croak(aTHX_ PL_no_helem_sv, mg->mg_obj);
2022 AV* av = (AV*)LvTARG(sv);
2023 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
2024 LvTARG(sv) = Nullsv; /* array can't be extended */
2026 SV** svp = av_fetch(av, LvTARGOFF(sv), TRUE);
2027 if (!svp || (value = *svp) == &PL_sv_undef)
2028 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
2031 (void)SvREFCNT_inc(value);
2032 SvREFCNT_dec(LvTARG(sv));
2035 SvREFCNT_dec(mg->mg_obj);
2036 mg->mg_obj = Nullsv;
2037 mg->mg_flags &= ~MGf_REFCOUNTED;
2041 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2043 AV *av = (AV*)mg->mg_obj;
2044 SV **svp = AvARRAY(av);
2045 I32 i = AvFILLp(av);
2050 if (!SvWEAKREF(svp[i]))
2051 Perl_croak(aTHX_ "panic: magic_killbackrefs");
2052 /* XXX Should we check that it hasn't changed? */
2053 SvRV_set(svp[i], 0);
2055 SvWEAKREF_off(svp[i]);
2060 SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */
2065 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2073 Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
2076 sv_unmagic(sv, PERL_MAGIC_bm);
2082 Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
2085 sv_unmagic(sv, PERL_MAGIC_fm);
2091 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2093 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2095 if (uf && uf->uf_set)
2096 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2101 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2104 sv_unmagic(sv, PERL_MAGIC_qr);
2109 Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
2111 regexp *re = (regexp *)mg->mg_obj;
2117 #ifdef USE_LOCALE_COLLATE
2119 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2122 * RenE<eacute> Descartes said "I think not."
2123 * and vanished with a faint plop.
2127 Safefree(mg->mg_ptr);
2133 #endif /* USE_LOCALE_COLLATE */
2135 /* Just clear the UTF-8 cache data. */
2137 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2140 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2142 mg->mg_len = -1; /* The mg_len holds the len cache. */
2147 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2149 register const char *s;
2152 switch (*mg->mg_ptr) {
2153 case '\001': /* ^A */
2154 sv_setsv(PL_bodytarget, sv);
2156 case '\003': /* ^C */
2157 PL_minus_c = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2160 case '\004': /* ^D */
2162 s = SvPV_nolen_const(sv);
2163 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2164 DEBUG_x(dump_all());
2166 PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | DEBUG_TOP_FLAG;
2169 case '\005': /* ^E */
2170 if (*(mg->mg_ptr+1) == '\0') {
2171 #ifdef MACOS_TRADITIONAL
2172 gMacPerl_OSErr = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2175 set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2178 SetLastError( SvIV(sv) );
2181 os2_setsyserrno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2183 /* will anyone ever use this? */
2184 SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4);
2190 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2192 SvREFCNT_dec(PL_encoding);
2193 if (SvOK(sv) || SvGMAGICAL(sv)) {
2194 PL_encoding = newSVsv(sv);
2197 PL_encoding = Nullsv;
2201 case '\006': /* ^F */
2202 PL_maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2204 case '\010': /* ^H */
2205 PL_hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2207 case '\011': /* ^I */ /* NOT \t in EBCDIC */
2209 Safefree(PL_inplace);
2211 PL_inplace = savesvpv(sv);
2213 PL_inplace = Nullch;
2215 case '\017': /* ^O */
2216 if (*(mg->mg_ptr+1) == '\0') {
2218 Safefree(PL_osname);
2222 TAINT_PROPER("assigning to $^O");
2223 PL_osname = savesvpv(sv);
2226 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2227 if (!PL_compiling.cop_io)
2228 PL_compiling.cop_io = newSVsv(sv);
2230 sv_setsv(PL_compiling.cop_io,sv);
2233 case '\020': /* ^P */
2234 PL_perldb = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2235 if (PL_perldb && !PL_DBsingle)
2238 case '\024': /* ^T */
2240 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2242 PL_basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2245 case '\027': /* ^W & $^WARNING_BITS */
2246 if (*(mg->mg_ptr+1) == '\0') {
2247 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2248 i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2249 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2250 | (i ? G_WARN_ON : G_WARN_OFF) ;
2253 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2254 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2255 if (!SvPOK(sv) && PL_localizing) {
2256 sv_setpvn(sv, WARN_NONEstring, WARNsize);
2257 PL_compiling.cop_warnings = pWARN_NONE;
2262 int accumulate = 0 ;
2263 int any_fatals = 0 ;
2264 const char * const ptr = SvPV_const(sv, len) ;
2265 for (i = 0 ; i < len ; ++i) {
2266 accumulate |= ptr[i] ;
2267 any_fatals |= (ptr[i] & 0xAA) ;
2270 PL_compiling.cop_warnings = pWARN_NONE;
2271 else if (isWARN_on(sv, WARN_ALL) && !any_fatals) {
2272 PL_compiling.cop_warnings = pWARN_ALL;
2273 PL_dowarn |= G_WARN_ONCE ;
2276 if (specialWARN(PL_compiling.cop_warnings))
2277 PL_compiling.cop_warnings = newSVsv(sv) ;
2279 sv_setsv(PL_compiling.cop_warnings, sv);
2280 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2281 PL_dowarn |= G_WARN_ONCE ;
2289 if (PL_localizing) {
2290 if (PL_localizing == 1)
2291 SAVESPTR(PL_last_in_gv);
2293 else if (SvOK(sv) && GvIO(PL_last_in_gv))
2294 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2297 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2298 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2299 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv,TRUE, SVt_PVIO);
2302 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2303 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2304 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv,TRUE, SVt_PVIO);
2307 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2310 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2311 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2312 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2315 IoPAGE(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2319 IO *io = GvIOp(PL_defoutgv);
2322 if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) == 0)
2323 IoFLAGS(io) &= ~IOf_FLUSH;
2325 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2326 PerlIO *ofp = IoOFP(io);
2328 (void)PerlIO_flush(ofp);
2329 IoFLAGS(io) |= IOf_FLUSH;
2335 SvREFCNT_dec(PL_rs);
2336 PL_rs = newSVsv(sv);
2340 SvREFCNT_dec(PL_ors_sv);
2341 if (SvOK(sv) || SvGMAGICAL(sv)) {
2342 PL_ors_sv = newSVsv(sv);
2350 SvREFCNT_dec(PL_ofs_sv);
2351 if (SvOK(sv) || SvGMAGICAL(sv)) {
2352 PL_ofs_sv = newSVsv(sv);
2359 PL_compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2362 #ifdef COMPLEX_STATUS
2363 if (PL_localizing == 2) {
2364 PL_statusvalue = LvTARGOFF(sv);
2365 PL_statusvalue_vms = LvTARGLEN(sv);
2369 #ifdef VMSISH_STATUS
2371 STATUS_NATIVE_SET((U32)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)));
2374 STATUS_UNIX_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2379 # define PERL_VMS_BANG vaxc$errno
2381 # define PERL_VMS_BANG 0
2383 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2384 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2388 PL_uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2389 if (PL_delaymagic) {
2390 PL_delaymagic |= DM_RUID;
2391 break; /* don't do magic till later */
2394 (void)setruid((Uid_t)PL_uid);
2397 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2399 #ifdef HAS_SETRESUID
2400 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2402 if (PL_uid == PL_euid) { /* special case $< = $> */
2404 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2405 if (PL_uid != 0 && PerlProc_getuid() == 0)
2406 (void)PerlProc_setuid(0);
2408 (void)PerlProc_setuid(PL_uid);
2410 PL_uid = PerlProc_getuid();
2411 Perl_croak(aTHX_ "setruid() not implemented");
2416 PL_uid = PerlProc_getuid();
2417 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2420 PL_euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2421 if (PL_delaymagic) {
2422 PL_delaymagic |= DM_EUID;
2423 break; /* don't do magic till later */
2426 (void)seteuid((Uid_t)PL_euid);
2429 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2431 #ifdef HAS_SETRESUID
2432 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2434 if (PL_euid == PL_uid) /* special case $> = $< */
2435 PerlProc_setuid(PL_euid);
2437 PL_euid = PerlProc_geteuid();
2438 Perl_croak(aTHX_ "seteuid() not implemented");
2443 PL_euid = PerlProc_geteuid();
2444 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2447 PL_gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2448 if (PL_delaymagic) {
2449 PL_delaymagic |= DM_RGID;
2450 break; /* don't do magic till later */
2453 (void)setrgid((Gid_t)PL_gid);
2456 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2458 #ifdef HAS_SETRESGID
2459 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2461 if (PL_gid == PL_egid) /* special case $( = $) */
2462 (void)PerlProc_setgid(PL_gid);
2464 PL_gid = PerlProc_getgid();
2465 Perl_croak(aTHX_ "setrgid() not implemented");
2470 PL_gid = PerlProc_getgid();
2471 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2474 #ifdef HAS_SETGROUPS
2476 const char *p = SvPV_const(sv, len);
2477 Groups_t gary[NGROUPS];
2482 for (i = 0; i < NGROUPS; ++i) {
2483 while (*p && !isSPACE(*p))
2492 (void)setgroups(i, gary);
2494 #else /* HAS_SETGROUPS */
2495 PL_egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2496 #endif /* HAS_SETGROUPS */
2497 if (PL_delaymagic) {
2498 PL_delaymagic |= DM_EGID;
2499 break; /* don't do magic till later */
2502 (void)setegid((Gid_t)PL_egid);
2505 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2507 #ifdef HAS_SETRESGID
2508 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2510 if (PL_egid == PL_gid) /* special case $) = $( */
2511 (void)PerlProc_setgid(PL_egid);
2513 PL_egid = PerlProc_getegid();
2514 Perl_croak(aTHX_ "setegid() not implemented");
2519 PL_egid = PerlProc_getegid();
2520 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2523 PL_chopset = SvPV_force(sv,len);
2525 #ifndef MACOS_TRADITIONAL
2527 LOCK_DOLLARZERO_MUTEX;
2528 #ifdef HAS_SETPROCTITLE
2529 /* The BSDs don't show the argv[] in ps(1) output, they
2530 * show a string from the process struct and provide
2531 * the setproctitle() routine to manipulate that. */
2533 s = SvPV_const(sv, len);
2534 # if __FreeBSD_version > 410001
2535 /* The leading "-" removes the "perl: " prefix,
2536 * but not the "(perl) suffix from the ps(1)
2537 * output, because that's what ps(1) shows if the
2538 * argv[] is modified. */
2539 setproctitle("-%s", s);
2540 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2541 /* This doesn't really work if you assume that
2542 * $0 = 'foobar'; will wipe out 'perl' from the $0
2543 * because in ps(1) output the result will be like
2544 * sprintf("perl: %s (perl)", s)
2545 * I guess this is a security feature:
2546 * one (a user process) cannot get rid of the original name.
2548 setproctitle("%s", s);
2552 #if defined(__hpux) && defined(PSTAT_SETCMD)
2555 s = SvPV_const(sv, len);
2556 un.pst_command = (char *)s;
2557 pstat(PSTAT_SETCMD, un, len, 0, 0);
2560 /* PL_origalen is set in perl_parse(). */
2561 s = SvPV_force(sv,len);
2562 if (len >= (STRLEN)PL_origalen-1) {
2563 /* Longer than original, will be truncated. We assume that
2564 * PL_origalen bytes are available. */
2565 Copy(s, PL_origargv[0], PL_origalen-1, char);
2568 /* Shorter than original, will be padded. */
2569 Copy(s, PL_origargv[0], len, char);
2570 PL_origargv[0][len] = 0;
2571 memset(PL_origargv[0] + len + 1,
2572 /* Is the space counterintuitive? Yes.
2573 * (You were expecting \0?)
2574 * Does it work? Seems to. (In Linux 2.4.20 at least.)
2577 PL_origalen - len - 1);
2579 PL_origargv[0][PL_origalen-1] = 0;
2580 for (i = 1; i < PL_origargc; i++)
2582 UNLOCK_DOLLARZERO_MUTEX;
2590 Perl_whichsig(pTHX_ const char *sig)
2592 register char* const* sigv;
2594 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
2595 if (strEQ(sig,*sigv))
2596 return PL_sig_num[sigv - (char* const*)PL_sig_name];
2598 if (strEQ(sig,"CHLD"))
2602 if (strEQ(sig,"CLD"))
2609 Perl_sighandler(int sig)
2611 #ifdef PERL_GET_SIG_CONTEXT
2612 dTHXa(PERL_GET_SIG_CONTEXT);
2619 SV *sv = Nullsv, *tSv = PL_Sv;
2625 if (PL_savestack_ix + 15 <= PL_savestack_max)
2627 if (PL_markstack_ptr < PL_markstack_max - 2)
2629 if (PL_scopestack_ix < PL_scopestack_max - 3)
2632 if (!PL_psig_ptr[sig]) {
2633 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2638 /* Max number of items pushed there is 3*n or 4. We cannot fix
2639 infinity, so we fix 4 (in fact 5): */
2641 PL_savestack_ix += 5; /* Protect save in progress. */
2642 SAVEDESTRUCTOR_X(unwind_handler_stack, (void*)&flags);
2645 PL_markstack_ptr++; /* Protect mark. */
2647 PL_scopestack_ix += 1;
2648 /* sv_2cv is too complicated, try a simpler variant first: */
2649 if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
2650 || SvTYPE(cv) != SVt_PVCV)
2651 cv = sv_2cv(PL_psig_ptr[sig],&st,&gv,TRUE);
2653 if (!cv || !CvROOT(cv)) {
2654 if (ckWARN(WARN_SIGNAL))
2655 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2656 PL_sig_name[sig], (gv ? GvENAME(gv)
2663 if(PL_psig_name[sig]) {
2664 sv = SvREFCNT_inc(PL_psig_name[sig]);
2666 #if !defined(PERL_IMPLICIT_CONTEXT)
2670 sv = sv_newmortal();
2671 sv_setpv(sv,PL_sig_name[sig]);
2674 PUSHSTACKi(PERLSI_SIGNAL);
2679 call_sv((SV*)cv, G_DISCARD|G_EVAL);
2682 if (SvTRUE(ERRSV)) {
2684 #ifdef HAS_SIGPROCMASK
2685 /* Handler "died", for example to get out of a restart-able read().
2686 * Before we re-do that on its behalf re-enable the signal which was
2687 * blocked by the system when we entered.
2691 sigaddset(&set,sig);
2692 sigprocmask(SIG_UNBLOCK, &set, NULL);
2694 /* Not clear if this will work */
2695 (void)rsignal(sig, SIG_IGN);
2696 (void)rsignal(sig, PL_csighandlerp);
2698 #endif /* !PERL_MICRO */
2703 PL_savestack_ix -= 8; /* Unprotect save in progress. */
2707 PL_scopestack_ix -= 1;
2710 PL_op = myop; /* Apparently not needed... */
2712 PL_Sv = tSv; /* Restore global temporaries. */
2719 restore_magic(pTHX_ const void *p)
2721 MGS* mgs = SSPTR(PTR2IV(p), MGS*);
2722 SV* sv = mgs->mgs_sv;
2727 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2729 #ifdef PERL_OLD_COPY_ON_WRITE
2730 /* While magic was saved (and off) sv_setsv may well have seen
2731 this SV as a prime candidate for COW. */
2733 sv_force_normal(sv);
2737 SvFLAGS(sv) |= mgs->mgs_flags;
2741 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
2744 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
2746 /* If we're still on top of the stack, pop us off. (That condition
2747 * will be satisfied if restore_magic was called explicitly, but *not*
2748 * if it's being called via leave_scope.)
2749 * The reason for doing this is that otherwise, things like sv_2cv()
2750 * may leave alloc gunk on the savestack, and some code
2751 * (e.g. sighandler) doesn't expect that...
2753 if (PL_savestack_ix == mgs->mgs_ss_ix)
2755 I32 popval = SSPOPINT;
2756 assert(popval == SAVEt_DESTRUCTOR_X);
2757 PL_savestack_ix -= 2;
2759 assert(popval == SAVEt_ALLOC);
2761 PL_savestack_ix -= popval;
2767 unwind_handler_stack(pTHX_ const void *p)
2770 const U32 flags = *(const U32*)p;
2773 PL_savestack_ix -= 5; /* Unprotect save in progress. */
2774 /* cxstack_ix-- Not needed, die already unwound it. */
2775 #if !defined(PERL_IMPLICIT_CONTEXT)
2777 SvREFCNT_dec(PL_sig_sv);
2783 * c-indentation-style: bsd
2785 * indent-tabs-mode: t
2788 * ex: set ts=8 sts=4 sw=4 noet: