xref: /onnv-gate/usr/src/cmd/perl/5.8.4/distrib/mg.c (revision 11134:8aa0c4ca6639)
1 /*
2  * Copyright 2009 Sun Microsystems, Inc.  All rights reserved.
3  * Use is subject to license terms.
4  */
5 /*    mg.c
6  *
7  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
8  *    2000, 2001, 2002, 2003, 2004, by Larry Wall and others
9  *
10  *    You may distribute under the terms of either the GNU General Public
11  *    License or the Artistic License, as specified in the README file.
12  *
13  */
14 
15 /*
16  * "Sam sat on the ground and put his head in his hands.  'I wish I had never
17  * come here, and I don't want to see no more magic,' he said, and fell silent."
18  */
19 
20 /*
21 =head1 Magical Functions
22 */
23 
24 #include "EXTERN.h"
25 #define PERL_IN_MG_C
26 #include "perl.h"
27 
28 #if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS)
29 #  ifndef NGROUPS
30 #    define NGROUPS 32
31 #  endif
32 #  ifdef I_GRP
33 #    include <grp.h>
34 #  endif
35 #ifdef __sun
36 #include <alloca.h>
37 #include <unistd.h>
38 #endif
39 #endif
40 
41 #ifdef __hpux
42 #  include <sys/pstat.h>
43 #endif
44 
45 Signal_t Perl_csighandler(int sig);
46 
47 /* if you only have signal() and it resets on each signal, FAKE_PERSISTENT_SIGNAL_HANDLERS fixes */
48 #if !defined(HAS_SIGACTION) && defined(VMS)
49 #  define  FAKE_PERSISTENT_SIGNAL_HANDLERS
50 #endif
51 /* if we're doing kill() with sys$sigprc on VMS, FAKE_DEFAULT_SIGNAL_HANDLERS */
52 #if defined(KILL_BY_SIGPRC)
53 #  define  FAKE_DEFAULT_SIGNAL_HANDLERS
54 #endif
55 
56 static void restore_magic(pTHX_ void *p);
57 static void unwind_handler_stack(pTHX_ void *p);
58 
59 #ifdef __Lynx__
60 /* Missing protos on LynxOS */
61 void setruid(uid_t id);
62 void seteuid(uid_t id);
63 void setrgid(uid_t id);
64 void setegid(uid_t id);
65 #endif
66 
67 /*
68  * Use the "DESTRUCTOR" scope cleanup to reinstate magic.
69  */
70 
71 struct magic_state {
72     SV* mgs_sv;
73     U32 mgs_flags;
74     I32 mgs_ss_ix;
75 };
76 /* MGS is typedef'ed to struct magic_state in perl.h */
77 
78 STATIC void
S_save_magic(pTHX_ I32 mgs_ix,SV * sv)79 S_save_magic(pTHX_ I32 mgs_ix, SV *sv)
80 {
81     MGS* mgs;
82     assert(SvMAGICAL(sv));
83 
84     SAVEDESTRUCTOR_X(restore_magic, INT2PTR(void*, (IV)mgs_ix));
85 
86     mgs = SSPTR(mgs_ix, MGS*);
87     mgs->mgs_sv = sv;
88     mgs->mgs_flags = SvMAGICAL(sv) | SvREADONLY(sv);
89     mgs->mgs_ss_ix = PL_savestack_ix;   /* points after the saved destructor */
90 
91     SvMAGICAL_off(sv);
92     SvREADONLY_off(sv);
93     SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
94 }
95 
96 /*
97 =for apidoc mg_magical
98 
99 Turns on the magical status of an SV.  See C<sv_magic>.
100 
101 =cut
102 */
103 
104 void
Perl_mg_magical(pTHX_ SV * sv)105 Perl_mg_magical(pTHX_ SV *sv)
106 {
107     MAGIC* mg;
108     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
109 	MGVTBL* vtbl = mg->mg_virtual;
110 	if (vtbl) {
111 	    if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
112 		SvGMAGICAL_on(sv);
113 	    if (vtbl->svt_set)
114 		SvSMAGICAL_on(sv);
115 	    if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)) || vtbl->svt_clear)
116 		SvRMAGICAL_on(sv);
117 	}
118     }
119 }
120 
121 /*
122 =for apidoc mg_get
123 
124 Do magic after a value is retrieved from the SV.  See C<sv_magic>.
125 
126 =cut
127 */
128 
129 int
Perl_mg_get(pTHX_ SV * sv)130 Perl_mg_get(pTHX_ SV *sv)
131 {
132     int new = 0;
133     MAGIC *newmg, *head, *cur, *mg;
134     I32 mgs_ix = SSNEW(sizeof(MGS));
135 
136     save_magic(mgs_ix, sv);
137 
138     /* We must call svt_get(sv, mg) for each valid entry in the linked
139        list of magic. svt_get() may delete the current entry, add new
140        magic to the head of the list, or upgrade the SV. AMS 20010810 */
141 
142     newmg = cur = head = mg = SvMAGIC(sv);
143     while (mg) {
144 	MGVTBL *vtbl = mg->mg_virtual;
145 
146 	if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
147 	    CALL_FPTR(vtbl->svt_get)(aTHX_ sv, mg);
148 
149 	    /* guard against sv having been freed */
150 	    if (SvTYPE(sv) == SVTYPEMASK) {
151 		Perl_croak(aTHX_ "Tied variable freed while still in use");
152 	    }
153 	    /* guard against magic having been deleted - eg FETCH calling
154 	     * untie */
155 	    if (!SvMAGIC(sv))
156 		break;
157 
158 	    /* Don't restore the flags for this entry if it was deleted. */
159 	    if (mg->mg_flags & MGf_GSKIP)
160 		(SSPTR(mgs_ix, MGS *))->mgs_flags = 0;
161 	}
162 
163 	mg = mg->mg_moremagic;
164 
165 	if (new) {
166 	    /* Have we finished with the new entries we saw? Start again
167 	       where we left off (unless there are more new entries). */
168 	    if (mg == head) {
169 		new  = 0;
170 		mg   = cur;
171 		head = newmg;
172 	    }
173 	}
174 
175 	/* Were any new entries added? */
176 	if (!new && (newmg = SvMAGIC(sv)) != head) {
177 	    new = 1;
178 	    cur = mg;
179 	    mg  = newmg;
180 	}
181     }
182 
183     restore_magic(aTHX_ INT2PTR(void *, (IV)mgs_ix));
184     return 0;
185 }
186 
187 /*
188 =for apidoc mg_set
189 
190 Do magic after a value is assigned to the SV.  See C<sv_magic>.
191 
192 =cut
193 */
194 
195 int
Perl_mg_set(pTHX_ SV * sv)196 Perl_mg_set(pTHX_ SV *sv)
197 {
198     I32 mgs_ix;
199     MAGIC* mg;
200     MAGIC* nextmg;
201 
202     mgs_ix = SSNEW(sizeof(MGS));
203     save_magic(mgs_ix, sv);
204 
205     for (mg = SvMAGIC(sv); mg; mg = nextmg) {
206 	MGVTBL* vtbl = mg->mg_virtual;
207 	nextmg = mg->mg_moremagic;	/* it may delete itself */
208 	if (mg->mg_flags & MGf_GSKIP) {
209 	    mg->mg_flags &= ~MGf_GSKIP;	/* setting requires another read */
210 	    (SSPTR(mgs_ix, MGS*))->mgs_flags = 0;
211 	}
212 	if (vtbl && vtbl->svt_set)
213 	    CALL_FPTR(vtbl->svt_set)(aTHX_ sv, mg);
214     }
215 
216     restore_magic(aTHX_ INT2PTR(void*, (IV)mgs_ix));
217     return 0;
218 }
219 
220 /*
221 =for apidoc mg_length
222 
223 Report on the SV's length.  See C<sv_magic>.
224 
225 =cut
226 */
227 
228 U32
Perl_mg_length(pTHX_ SV * sv)229 Perl_mg_length(pTHX_ SV *sv)
230 {
231     MAGIC* mg;
232     STRLEN len;
233 
234     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
235 	MGVTBL* vtbl = mg->mg_virtual;
236 	if (vtbl && vtbl->svt_len) {
237             I32 mgs_ix;
238 
239 	    mgs_ix = SSNEW(sizeof(MGS));
240 	    save_magic(mgs_ix, sv);
241 	    /* omit MGf_GSKIP -- not changed here */
242 	    len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
243 	    restore_magic(aTHX_ INT2PTR(void*, (IV)mgs_ix));
244 	    return len;
245 	}
246     }
247 
248     if (DO_UTF8(sv))
249     {
250         U8 *s = (U8*)SvPV(sv, len);
251         len = Perl_utf8_length(aTHX_ s, s + len);
252     }
253     else
254         (void)SvPV(sv, len);
255     return len;
256 }
257 
258 I32
Perl_mg_size(pTHX_ SV * sv)259 Perl_mg_size(pTHX_ SV *sv)
260 {
261     MAGIC* mg;
262     I32 len;
263 
264     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
265 	MGVTBL* vtbl = mg->mg_virtual;
266 	if (vtbl && vtbl->svt_len) {
267             I32 mgs_ix;
268 
269 	    mgs_ix = SSNEW(sizeof(MGS));
270 	    save_magic(mgs_ix, sv);
271 	    /* omit MGf_GSKIP -- not changed here */
272 	    len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
273 	    restore_magic(aTHX_ INT2PTR(void*, (IV)mgs_ix));
274 	    return len;
275 	}
276     }
277 
278     switch(SvTYPE(sv)) {
279 	case SVt_PVAV:
280 	    len = AvFILLp((AV *) sv); /* Fallback to non-tied array */
281 	    return len;
282 	case SVt_PVHV:
283 	    /* FIXME */
284 	default:
285 	    Perl_croak(aTHX_ "Size magic not implemented");
286 	    break;
287     }
288     return 0;
289 }
290 
291 /*
292 =for apidoc mg_clear
293 
294 Clear something magical that the SV represents.  See C<sv_magic>.
295 
296 =cut
297 */
298 
299 int
Perl_mg_clear(pTHX_ SV * sv)300 Perl_mg_clear(pTHX_ SV *sv)
301 {
302     I32 mgs_ix;
303     MAGIC* mg;
304 
305     mgs_ix = SSNEW(sizeof(MGS));
306     save_magic(mgs_ix, sv);
307 
308     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
309 	MGVTBL* vtbl = mg->mg_virtual;
310 	/* omit GSKIP -- never set here */
311 
312 	if (vtbl && vtbl->svt_clear)
313 	    CALL_FPTR(vtbl->svt_clear)(aTHX_ sv, mg);
314     }
315 
316     restore_magic(aTHX_ INT2PTR(void*, (IV)mgs_ix));
317     return 0;
318 }
319 
320 /*
321 =for apidoc mg_find
322 
323 Finds the magic pointer for type matching the SV.  See C<sv_magic>.
324 
325 =cut
326 */
327 
328 MAGIC*
Perl_mg_find(pTHX_ SV * sv,int type)329 Perl_mg_find(pTHX_ SV *sv, int type)
330 {
331     MAGIC* mg;
332     if (!sv)
333         return 0;
334     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
335 	if (mg->mg_type == type)
336 	    return mg;
337     }
338     return 0;
339 }
340 
341 /*
342 =for apidoc mg_copy
343 
344 Copies the magic from one SV to another.  See C<sv_magic>.
345 
346 =cut
347 */
348 
349 int
Perl_mg_copy(pTHX_ SV * sv,SV * nsv,const char * key,I32 klen)350 Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
351 {
352     int count = 0;
353     MAGIC* mg;
354     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
355 	MGVTBL* vtbl = mg->mg_virtual;
356 	if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){
357 	    count += CALL_FPTR(vtbl->svt_copy)(aTHX_ sv, mg, nsv, key, klen);
358 	}
359 	else if (isUPPER(mg->mg_type)) {
360 	    sv_magic(nsv,
361 		     mg->mg_type == PERL_MAGIC_tied ? SvTIED_obj(sv, mg) :
362 		     (mg->mg_type == PERL_MAGIC_regdata && mg->mg_obj)
363 							? sv : mg->mg_obj,
364 		     toLOWER(mg->mg_type), key, klen);
365 	    count++;
366 	}
367     }
368     return count;
369 }
370 
371 /*
372 =for apidoc mg_free
373 
374 Free any magic storage used by the SV.  See C<sv_magic>.
375 
376 =cut
377 */
378 
379 int
Perl_mg_free(pTHX_ SV * sv)380 Perl_mg_free(pTHX_ SV *sv)
381 {
382     MAGIC* mg;
383     MAGIC* moremagic;
384     for (mg = SvMAGIC(sv); mg; mg = moremagic) {
385 	MGVTBL* vtbl = mg->mg_virtual;
386 	moremagic = mg->mg_moremagic;
387 	if (vtbl && vtbl->svt_free)
388 	    CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
389 	if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
390 	    if (mg->mg_len > 0 || mg->mg_type == PERL_MAGIC_utf8)
391 		Safefree(mg->mg_ptr);
392 	    else if (mg->mg_len == HEf_SVKEY)
393 		SvREFCNT_dec((SV*)mg->mg_ptr);
394 	}
395 	if (mg->mg_flags & MGf_REFCOUNTED)
396 	    SvREFCNT_dec(mg->mg_obj);
397 	Safefree(mg);
398     }
399     SvMAGIC(sv) = 0;
400     return 0;
401 }
402 
403 #include <signal.h>
404 
405 U32
Perl_magic_regdata_cnt(pTHX_ SV * sv,MAGIC * mg)406 Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
407 {
408     register REGEXP *rx;
409 
410     if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
411 	if (mg->mg_obj)		/* @+ */
412 	    return rx->nparens;
413 	else			/* @- */
414 	    return rx->lastparen;
415     }
416 
417     return (U32)-1;
418 }
419 
420 int
Perl_magic_regdatum_get(pTHX_ SV * sv,MAGIC * mg)421 Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
422 {
423     register I32 paren;
424     register I32 s;
425     register I32 i;
426     register REGEXP *rx;
427     I32 t;
428 
429     if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
430 	paren = mg->mg_len;
431 	if (paren < 0)
432 	    return 0;
433 	if (paren <= (I32)rx->nparens &&
434 	    (s = rx->startp[paren]) != -1 &&
435 	    (t = rx->endp[paren]) != -1)
436 	    {
437 		if (mg->mg_obj)		/* @+ */
438 		    i = t;
439 		else			/* @- */
440 		    i = s;
441 
442 		if (i > 0 && RX_MATCH_UTF8(rx)) {
443 		    char *b = rx->subbeg;
444 		    if (b)
445 		        i = Perl_utf8_length(aTHX_ (U8*)b, (U8*)(b+i));
446 		}
447 
448 		sv_setiv(sv, i);
449 	    }
450     }
451     return 0;
452 }
453 
454 int
Perl_magic_regdatum_set(pTHX_ SV * sv,MAGIC * mg)455 Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
456 {
457     Perl_croak(aTHX_ PL_no_modify);
458     /* NOT REACHED */
459     return 0;
460 }
461 
462 U32
Perl_magic_len(pTHX_ SV * sv,MAGIC * mg)463 Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
464 {
465     register I32 paren;
466     register I32 i;
467     register REGEXP *rx;
468     I32 s1, t1;
469 
470     switch (*mg->mg_ptr) {
471     case '1': case '2': case '3': case '4':
472     case '5': case '6': case '7': case '8': case '9': case '&':
473 	if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
474 
475 	    paren = atoi(mg->mg_ptr); /* $& is in [0] */
476 	  getparen:
477 	    if (paren <= (I32)rx->nparens &&
478 		(s1 = rx->startp[paren]) != -1 &&
479 		(t1 = rx->endp[paren]) != -1)
480 	    {
481 		i = t1 - s1;
482 	      getlen:
483 		if (i > 0 && RX_MATCH_UTF8(rx)) {
484 		    char *s    = rx->subbeg + s1;
485 		    char *send = rx->subbeg + t1;
486 
487                     i = t1 - s1;
488 		    if (is_utf8_string((U8*)s, i))
489 			i = Perl_utf8_length(aTHX_ (U8*)s, (U8*)send);
490 		}
491 		if (i < 0)
492 		    Perl_croak(aTHX_ "panic: magic_len: %"IVdf, (IV)i);
493 		return i;
494 	    }
495 	    else {
496 		if (ckWARN(WARN_UNINITIALIZED))
497 		    report_uninit();
498 	    }
499 	}
500 	else {
501 	    if (ckWARN(WARN_UNINITIALIZED))
502 		report_uninit();
503 	}
504 	return 0;
505     case '+':
506 	if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
507 	    paren = rx->lastparen;
508 	    if (paren)
509 		goto getparen;
510 	}
511 	return 0;
512     case '\016': /* ^N */
513 	if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
514 	    paren = rx->lastcloseparen;
515 	    if (paren)
516 		goto getparen;
517 	}
518 	return 0;
519     case '`':
520 	if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
521 	    if (rx->startp[0] != -1) {
522 		i = rx->startp[0];
523 		if (i > 0) {
524 		    s1 = 0;
525 		    t1 = i;
526 		    goto getlen;
527 		}
528 	    }
529 	}
530 	return 0;
531     case '\'':
532 	if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
533 	    if (rx->endp[0] != -1) {
534 		i = rx->sublen - rx->endp[0];
535 		if (i > 0) {
536 		    s1 = rx->endp[0];
537 		    t1 = rx->sublen;
538 		    goto getlen;
539 		}
540 	    }
541 	}
542 	return 0;
543     }
544     magic_get(sv,mg);
545     if (!SvPOK(sv) && SvNIOK(sv)) {
546 	STRLEN n_a;
547 	sv_2pv(sv, &n_a);
548     }
549     if (SvPOK(sv))
550 	return SvCUR(sv);
551     return 0;
552 }
553 
554 int
Perl_magic_get(pTHX_ SV * sv,MAGIC * mg)555 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
556 {
557     register I32 paren;
558     register char *s = NULL;
559     register I32 i;
560     register REGEXP *rx;
561 
562     switch (*mg->mg_ptr) {
563     case '\001':		/* ^A */
564 	sv_setsv(sv, PL_bodytarget);
565 	break;
566     case '\003':		/* ^C */
567 	sv_setiv(sv, (IV)PL_minus_c);
568 	break;
569 
570     case '\004':		/* ^D */
571 	sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
572 #if defined(YYDEBUG) && defined(DEBUGGING)
573 	PL_yydebug = DEBUG_p_TEST;
574 #endif
575 	break;
576     case '\005':  /* ^E */
577 	 if (*(mg->mg_ptr+1) == '\0') {
578 #ifdef MACOS_TRADITIONAL
579 	     {
580 		  char msg[256];
581 
582 		  sv_setnv(sv,(double)gMacPerl_OSErr);
583 		  sv_setpv(sv, gMacPerl_OSErr ? GetSysErrText(gMacPerl_OSErr, msg) : "");
584 	     }
585 #else
586 #ifdef VMS
587 	     {
588 #	          include <descrip.h>
589 #	          include <starlet.h>
590 		  char msg[255];
591 		  $DESCRIPTOR(msgdsc,msg);
592 		  sv_setnv(sv,(NV) vaxc$errno);
593 		  if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
594 		       sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
595 		  else
596 		       sv_setpv(sv,"");
597 	     }
598 #else
599 #ifdef OS2
600 	     if (!(_emx_env & 0x200)) {	/* Under DOS */
601 		  sv_setnv(sv, (NV)errno);
602 		  sv_setpv(sv, errno ? Strerror(errno) : "");
603 	     } else {
604 		  if (errno != errno_isOS2) {
605 		       int tmp = _syserrno();
606 		       if (tmp)	/* 2nd call to _syserrno() makes it 0 */
607 			    Perl_rc = tmp;
608 		  }
609 		  sv_setnv(sv, (NV)Perl_rc);
610 		  sv_setpv(sv, os2error(Perl_rc));
611 	     }
612 #else
613 #ifdef WIN32
614 	     {
615 		  DWORD dwErr = GetLastError();
616 		  sv_setnv(sv, (NV)dwErr);
617 		  if (dwErr)
618 		  {
619 		       PerlProc_GetOSError(sv, dwErr);
620 		  }
621 		  else
622 		       sv_setpv(sv, "");
623 		  SetLastError(dwErr);
624 	     }
625 #else
626 	     {
627 		 int saveerrno = errno;
628 		 sv_setnv(sv, (NV)errno);
629 		 sv_setpv(sv, errno ? Strerror(errno) : "");
630 		 errno = saveerrno;
631 	     }
632 #endif
633 #endif
634 #endif
635 #endif
636 	     SvNOK_on(sv);	/* what a wonderful hack! */
637 	 }
638 	 else if (strEQ(mg->mg_ptr+1, "NCODING"))
639 	      sv_setsv(sv, PL_encoding);
640 	 break;
641     case '\006':		/* ^F */
642 	sv_setiv(sv, (IV)PL_maxsysfd);
643 	break;
644     case '\010':		/* ^H */
645 	sv_setiv(sv, (IV)PL_hints);
646 	break;
647     case '\011':		/* ^I */ /* NOT \t in EBCDIC */
648 	if (PL_inplace)
649 	    sv_setpv(sv, PL_inplace);
650 	else
651 	    sv_setsv(sv, &PL_sv_undef);
652 	break;
653     case '\017':		/* ^O & ^OPEN */
654 	if (*(mg->mg_ptr+1) == '\0') {
655 	    sv_setpv(sv, PL_osname);
656 	    SvTAINTED_off(sv);
657 	}
658 	else if (strEQ(mg->mg_ptr, "\017PEN")) {
659 	    if (!PL_compiling.cop_io)
660 		sv_setsv(sv, &PL_sv_undef);
661             else {
662 	        sv_setsv(sv, PL_compiling.cop_io);
663 	    }
664 	}
665 	break;
666     case '\020':		/* ^P */
667 	sv_setiv(sv, (IV)PL_perldb);
668 	break;
669     case '\023':		/* ^S */
670         if (*(mg->mg_ptr+1) == '\0') {
671 	    if (PL_lex_state != LEX_NOTPARSING)
672 		(void)SvOK_off(sv);
673 	    else if (PL_in_eval)
674  		sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
675 	    else
676 		sv_setiv(sv, 0);
677 	}
678 	break;
679     case '\024':		/* ^T */
680         if (*(mg->mg_ptr+1) == '\0') {
681 #ifdef BIG_TIME
682             sv_setnv(sv, PL_basetime);
683 #else
684             sv_setiv(sv, (IV)PL_basetime);
685 #endif
686         }
687         else if (strEQ(mg->mg_ptr, "\024AINT"))
688             sv_setiv(sv, PL_tainting
689 		    ? (PL_taint_warn || PL_unsafe ? -1 : 1)
690 		    : 0);
691         break;
692     case '\025':		/* $^UNICODE */
693         if (strEQ(mg->mg_ptr, "\025NICODE"))
694 	    sv_setuv(sv, (UV) PL_unicode);
695         break;
696     case '\027':		/* ^W  & $^WARNING_BITS */
697 	if (*(mg->mg_ptr+1) == '\0')
698 	    sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
699 	else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
700 	    if (PL_compiling.cop_warnings == pWARN_NONE ||
701 	        PL_compiling.cop_warnings == pWARN_STD)
702 	    {
703 	        sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
704             }
705             else if (PL_compiling.cop_warnings == pWARN_ALL) {
706 	        sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
707 	    }
708             else {
709 	        sv_setsv(sv, PL_compiling.cop_warnings);
710 	    }
711 	    SvPOK_only(sv);
712 	}
713 	break;
714     case '1': case '2': case '3': case '4':
715     case '5': case '6': case '7': case '8': case '9': case '&':
716 	if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
717 	    I32 s1, t1;
718 
719 	    /*
720 	     * Pre-threads, this was paren = atoi(GvENAME((GV*)mg->mg_obj));
721 	     * XXX Does the new way break anything?
722 	     */
723 	    paren = atoi(mg->mg_ptr); /* $& is in [0] */
724 	  getparen:
725 	    if (paren <= (I32)rx->nparens &&
726 		(s1 = rx->startp[paren]) != -1 &&
727 		(t1 = rx->endp[paren]) != -1)
728 	    {
729 		i = t1 - s1;
730 		s = rx->subbeg + s1;
731 		if (!rx->subbeg)
732 		    break;
733 
734 	      getrx:
735 		if (i >= 0) {
736 		    sv_setpvn(sv, s, i);
737 		    if (RX_MATCH_UTF8(rx) && is_utf8_string((U8*)s, i))
738 			SvUTF8_on(sv);
739 		    else
740 			SvUTF8_off(sv);
741 		    if (PL_tainting) {
742 			if (RX_MATCH_TAINTED(rx)) {
743 			    MAGIC* mg = SvMAGIC(sv);
744 			    MAGIC* mgt;
745 			    PL_tainted = 1;
746 			    SvMAGIC(sv) = mg->mg_moremagic;
747 			    SvTAINT(sv);
748 			    if ((mgt = SvMAGIC(sv))) {
749 				mg->mg_moremagic = mgt;
750 				SvMAGIC(sv) = mg;
751 			    }
752 			} else
753 			    SvTAINTED_off(sv);
754 		    }
755 		    break;
756 		}
757 	    }
758 	}
759 	sv_setsv(sv,&PL_sv_undef);
760 	break;
761     case '+':
762 	if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
763 	    paren = rx->lastparen;
764 	    if (paren)
765 		goto getparen;
766 	}
767 	sv_setsv(sv,&PL_sv_undef);
768 	break;
769     case '\016':		/* ^N */
770 	if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
771 	    paren = rx->lastcloseparen;
772 	    if (paren)
773 		goto getparen;
774 	}
775 	sv_setsv(sv,&PL_sv_undef);
776 	break;
777     case '`':
778 	if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
779 	    if ((s = rx->subbeg) && rx->startp[0] != -1) {
780 		i = rx->startp[0];
781 		goto getrx;
782 	    }
783 	}
784 	sv_setsv(sv,&PL_sv_undef);
785 	break;
786     case '\'':
787 	if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
788 	    if (rx->subbeg && rx->endp[0] != -1) {
789 		s = rx->subbeg + rx->endp[0];
790 		i = rx->sublen - rx->endp[0];
791 		goto getrx;
792 	    }
793 	}
794 	sv_setsv(sv,&PL_sv_undef);
795 	break;
796     case '.':
797 #ifndef lint
798 	if (GvIO(PL_last_in_gv)) {
799 	    sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
800 	}
801 #endif
802 	break;
803     case '?':
804 	{
805 	    sv_setiv(sv, (IV)STATUS_CURRENT);
806 #ifdef COMPLEX_STATUS
807 	    LvTARGOFF(sv) = PL_statusvalue;
808 	    LvTARGLEN(sv) = PL_statusvalue_vms;
809 #endif
810 	}
811 	break;
812     case '^':
813 	if (GvIOp(PL_defoutgv))
814 	    s = IoTOP_NAME(GvIOp(PL_defoutgv));
815 	if (s)
816 	    sv_setpv(sv,s);
817 	else {
818 	    sv_setpv(sv,GvENAME(PL_defoutgv));
819 	    sv_catpv(sv,"_TOP");
820 	}
821 	break;
822     case '~':
823 	if (GvIOp(PL_defoutgv))
824 	    s = IoFMT_NAME(GvIOp(PL_defoutgv));
825 	if (!s)
826 	    s = GvENAME(PL_defoutgv);
827 	sv_setpv(sv,s);
828 	break;
829 #ifndef lint
830     case '=':
831 	if (GvIOp(PL_defoutgv))
832 	    sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
833 	break;
834     case '-':
835 	if (GvIOp(PL_defoutgv))
836 	    sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
837 	break;
838     case '%':
839 	if (GvIOp(PL_defoutgv))
840 	    sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
841 	break;
842 #endif
843     case ':':
844 	break;
845     case '/':
846 	break;
847     case '[':
848 	WITH_THR(sv_setiv(sv, (IV)PL_curcop->cop_arybase));
849 	break;
850     case '|':
851 	if (GvIOp(PL_defoutgv))
852 	    sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
853 	break;
854     case ',':
855 	break;
856     case '\\':
857 	if (PL_ors_sv)
858 	    sv_copypv(sv, PL_ors_sv);
859 	break;
860     case '#':
861 	sv_setpv(sv,PL_ofmt);
862 	break;
863     case '!':
864 #ifdef VMS
865 	sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
866 	sv_setpv(sv, errno ? Strerror(errno) : "");
867 #else
868 	{
869 	int saveerrno = errno;
870 	sv_setnv(sv, (NV)errno);
871 #ifdef OS2
872 	if (errno == errno_isOS2 || errno == errno_isOS2_set)
873 	    sv_setpv(sv, os2error(Perl_rc));
874 	else
875 #endif
876 	sv_setpv(sv, errno ? Strerror(errno) : "");
877 	errno = saveerrno;
878 	}
879 #endif
880 	SvNOK_on(sv);	/* what a wonderful hack! */
881 	break;
882     case '<':
883 	sv_setiv(sv, (IV)PL_uid);
884 	break;
885     case '>':
886 	sv_setiv(sv, (IV)PL_euid);
887 	break;
888     case '(':
889 	sv_setiv(sv, (IV)PL_gid);
890 #ifdef HAS_GETGROUPS
891 	Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, PL_gid);
892 #endif
893 	goto add_groups;
894     case ')':
895 	sv_setiv(sv, (IV)PL_egid);
896 #ifdef HAS_GETGROUPS
897 	Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, PL_egid);
898 #endif
899       add_groups:
900 #ifdef HAS_GETGROUPS
901 	{
902 #ifdef __sun
903 	    int maxgrp = getgroups(0, NULL);
904 	    Groups_t *gary = alloca(maxgrp * sizeof (Groups_t));
905 	    i = getgroups(maxgrp,gary);
906 #else
907 	    Groups_t gary[NGROUPS];
908 	    i = getgroups(NGROUPS,gary);
909 #endif
910 	    while (--i >= 0)
911 		Perl_sv_catpvf(aTHX_ sv, " %"Gid_t_f, gary[i]);
912 	}
913 #endif
914 	(void)SvIOK_on(sv);	/* what a wonderful hack! */
915 	break;
916     case '*':
917 	break;
918 #ifndef MACOS_TRADITIONAL
919     case '0':
920 	break;
921 #endif
922 #ifdef USE_5005THREADS
923     case '@':
924 	sv_setsv(sv, thr->errsv);
925 	break;
926 #endif /* USE_5005THREADS */
927     }
928     return 0;
929 }
930 
931 int
Perl_magic_getuvar(pTHX_ SV * sv,MAGIC * mg)932 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
933 {
934     struct ufuncs *uf = (struct ufuncs *)mg->mg_ptr;
935 
936     if (uf && uf->uf_val)
937 	(*uf->uf_val)(aTHX_ uf->uf_index, sv);
938     return 0;
939 }
940 
941 int
Perl_magic_setenv(pTHX_ SV * sv,MAGIC * mg)942 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
943 {
944     register char *s;
945     char *ptr;
946     STRLEN len, klen;
947 
948     s = SvPV(sv,len);
949     ptr = MgPV(mg,klen);
950     my_setenv(ptr, s);
951 
952 #ifdef DYNAMIC_ENV_FETCH
953      /* We just undefd an environment var.  Is a replacement */
954      /* waiting in the wings? */
955     if (!len) {
956 	SV **valp;
957 	if ((valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE)))
958 	    s = SvPV(*valp, len);
959     }
960 #endif
961 
962 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
963 			    /* And you'll never guess what the dog had */
964 			    /*   in its mouth... */
965     if (PL_tainting) {
966 	MgTAINTEDDIR_off(mg);
967 #ifdef VMS
968 	if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
969 	    char pathbuf[256], eltbuf[256], *cp, *elt = s;
970 	    Stat_t sbuf;
971 	    int i = 0, j = 0;
972 
973 	    do {          /* DCL$PATH may be a search list */
974 		while (1) {   /* as may dev portion of any element */
975 		    if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
976 			if ( *(cp+1) == '.' || *(cp+1) == '-' ||
977 			     cando_by_name(S_IWUSR,0,elt) ) {
978 			    MgTAINTEDDIR_on(mg);
979 			    return 0;
980 			}
981 		    }
982 		    if ((cp = strchr(elt, ':')) != Nullch)
983 			*cp = '\0';
984 		    if (my_trnlnm(elt, eltbuf, j++))
985 			elt = eltbuf;
986 		    else
987 			break;
988 		}
989 		j = 0;
990 	    } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
991 	}
992 #endif /* VMS */
993 	if (s && klen == 4 && strEQ(ptr,"PATH")) {
994 	    char *strend = s + len;
995 
996 	    while (s < strend) {
997 		char tmpbuf[256];
998 		Stat_t st;
999 		I32 i;
1000 		s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
1001 			     s, strend, ':', &i);
1002 		s++;
1003 		if (i >= sizeof tmpbuf   /* too long -- assume the worst */
1004 		      || *tmpbuf != '/'
1005 		      || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1006 		    MgTAINTEDDIR_on(mg);
1007 		    return 0;
1008 		}
1009 	    }
1010 	}
1011     }
1012 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1013 
1014     return 0;
1015 }
1016 
1017 int
Perl_magic_clearenv(pTHX_ SV * sv,MAGIC * mg)1018 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1019 {
1020     STRLEN n_a;
1021     my_setenv(MgPV(mg,n_a),Nullch);
1022     return 0;
1023 }
1024 
1025 int
Perl_magic_set_all_env(pTHX_ SV * sv,MAGIC * mg)1026 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1027 {
1028 #if defined(VMS)
1029     Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1030 #else
1031     if (PL_localizing) {
1032 	HE* entry;
1033 	STRLEN n_a;
1034 	magic_clear_all_env(sv,mg);
1035 	hv_iterinit((HV*)sv);
1036 	while ((entry = hv_iternext((HV*)sv))) {
1037 	    I32 keylen;
1038 	    my_setenv(hv_iterkey(entry, &keylen),
1039 		      SvPV(hv_iterval((HV*)sv, entry), n_a));
1040 	}
1041     }
1042 #endif
1043     return 0;
1044 }
1045 
1046 int
Perl_magic_clear_all_env(pTHX_ SV * sv,MAGIC * mg)1047 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1048 {
1049 #ifndef PERL_MICRO
1050 #if defined(VMS) || defined(EPOC)
1051     Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1052 #else
1053 #  if defined(PERL_IMPLICIT_SYS) || defined(WIN32)
1054     PerlEnv_clearenv();
1055 #  else
1056 #    ifdef USE_ENVIRON_ARRAY
1057 #      if defined(USE_ITHREADS)
1058     /* only the parent thread can clobber the process environment */
1059     if (PL_curinterp == aTHX)
1060 #      endif
1061     {
1062 #      ifndef PERL_USE_SAFE_PUTENV
1063     I32 i;
1064 
1065     if (environ == PL_origenviron)
1066 	environ = (char**)safesysmalloc(sizeof(char*));
1067     else
1068 	for (i = 0; environ[i]; i++)
1069 	    safesysfree(environ[i]);
1070 #      endif /* PERL_USE_SAFE_PUTENV */
1071 
1072     environ[0] = Nullch;
1073     }
1074 #    endif /* USE_ENVIRON_ARRAY */
1075 #   endif /* PERL_IMPLICIT_SYS || WIN32 */
1076 #endif /* VMS || EPOC */
1077 #endif /* !PERL_MICRO */
1078     return 0;
1079 }
1080 
1081 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS)||defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1082 static int sig_handlers_initted = 0;
1083 #endif
1084 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1085 static int sig_ignoring[SIG_SIZE];      /* which signals we are ignoring */
1086 #endif
1087 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1088 static int sig_defaulting[SIG_SIZE];
1089 #endif
1090 
1091 #ifndef PERL_MICRO
1092 #ifdef HAS_SIGPROCMASK
1093 static void
restore_sigmask(pTHX_ SV * save_sv)1094 restore_sigmask(pTHX_ SV *save_sv)
1095 {
1096     sigset_t *ossetp = (sigset_t *) SvPV_nolen( save_sv );
1097     (void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0);
1098 }
1099 #endif
1100 int
Perl_magic_getsig(pTHX_ SV * sv,MAGIC * mg)1101 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1102 {
1103     I32 i;
1104     STRLEN n_a;
1105     /* Are we fetching a signal entry? */
1106     i = whichsig(MgPV(mg,n_a));
1107     if (i > 0) {
1108     	if(PL_psig_ptr[i])
1109     	    sv_setsv(sv,PL_psig_ptr[i]);
1110     	else {
1111     	    Sighandler_t sigstate;
1112     	    sigstate = rsignal_state(i);
1113 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1114     	    if (sig_handlers_initted && sig_ignoring[i]) sigstate = SIG_IGN;
1115 #endif
1116 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1117     	    if (sig_handlers_initted && sig_defaulting[i]) sigstate = SIG_DFL;
1118 #endif
1119     	    /* cache state so we don't fetch it again */
1120     	    if(sigstate == SIG_IGN)
1121     	    	sv_setpv(sv,"IGNORE");
1122     	    else
1123     	    	sv_setsv(sv,&PL_sv_undef);
1124     	    PL_psig_ptr[i] = SvREFCNT_inc(sv);
1125     	    SvTEMP_off(sv);
1126     	}
1127     }
1128     return 0;
1129 }
1130 int
Perl_magic_clearsig(pTHX_ SV * sv,MAGIC * mg)1131 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1132 {
1133     /* XXX Some of this code was copied from Perl_magic_setsig. A little
1134      * refactoring might be in order.
1135      */
1136     register char *s;
1137     STRLEN n_a;
1138     SV* to_dec;
1139     s = MgPV(mg,n_a);
1140     if (*s == '_') {
1141 	SV** svp;
1142 	if (strEQ(s,"__DIE__"))
1143 	    svp = &PL_diehook;
1144 	else if (strEQ(s,"__WARN__"))
1145 	    svp = &PL_warnhook;
1146 	else
1147 	    Perl_croak(aTHX_ "No such hook: %s", s);
1148 	if (*svp) {
1149 	    to_dec = *svp;
1150 	    *svp = 0;
1151     	    SvREFCNT_dec(to_dec);
1152 	}
1153     }
1154     else {
1155 	I32 i;
1156 	/* Are we clearing a signal entry? */
1157 	i = whichsig(s);
1158 	if (i > 0) {
1159 #ifdef HAS_SIGPROCMASK
1160 	    sigset_t set, save;
1161 	    SV* save_sv;
1162 	    /* Avoid having the signal arrive at a bad time, if possible. */
1163 	    sigemptyset(&set);
1164 	    sigaddset(&set,i);
1165 	    sigprocmask(SIG_BLOCK, &set, &save);
1166 	    ENTER;
1167 	    save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1168 	    SAVEFREESV(save_sv);
1169 	    SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1170 #endif
1171 	    PERL_ASYNC_CHECK();
1172 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1173 	    if (!sig_handlers_initted) Perl_csighandler_init();
1174 #endif
1175 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1176 	    sig_defaulting[i] = 1;
1177 	    (void)rsignal(i, PL_csighandlerp);
1178 #else
1179 	    (void)rsignal(i, SIG_DFL);
1180 #endif
1181     	    if(PL_psig_name[i]) {
1182     		SvREFCNT_dec(PL_psig_name[i]);
1183     		PL_psig_name[i]=0;
1184     	    }
1185     	    if(PL_psig_ptr[i]) {
1186 		to_dec=PL_psig_ptr[i];
1187     		PL_psig_ptr[i]=0;
1188 		LEAVE;
1189     		SvREFCNT_dec(to_dec);
1190     	    }
1191 	    else
1192 		LEAVE;
1193 	}
1194     }
1195     return 0;
1196 }
1197 
1198 void
Perl_raise_signal(pTHX_ int sig)1199 Perl_raise_signal(pTHX_ int sig)
1200 {
1201     /* Set a flag to say this signal is pending */
1202     PL_psig_pend[sig]++;
1203     /* And one to say _a_ signal is pending */
1204     PL_sig_pending = 1;
1205 }
1206 
1207 Signal_t
Perl_csighandler(int sig)1208 Perl_csighandler(int sig)
1209 {
1210 #ifdef PERL_GET_SIG_CONTEXT
1211     dTHXa(PERL_GET_SIG_CONTEXT);
1212 #else
1213     dTHX;
1214 #endif
1215 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1216     (void) rsignal(sig, PL_csighandlerp);
1217     if (sig_ignoring[sig]) return;
1218 #endif
1219 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1220     if (sig_defaulting[sig])
1221 #ifdef KILL_BY_SIGPRC
1222             exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1223 #else
1224             exit(1);
1225 #endif
1226 #endif
1227    if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
1228 	/* Call the perl level handler now--
1229 	 * with risk we may be in malloc() etc. */
1230 	(*PL_sighandlerp)(sig);
1231    else
1232 	Perl_raise_signal(aTHX_ sig);
1233 }
1234 
1235 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1236 void
Perl_csighandler_init(void)1237 Perl_csighandler_init(void)
1238 {
1239     int sig;
1240     if (sig_handlers_initted) return;
1241 
1242     for (sig = 1; sig < SIG_SIZE; sig++) {
1243 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1244         dTHX;
1245         sig_defaulting[sig] = 1;
1246         (void) rsignal(sig, PL_csighandlerp);
1247 #endif
1248 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1249         sig_ignoring[sig] = 0;
1250 #endif
1251     }
1252     sig_handlers_initted = 1;
1253 }
1254 #endif
1255 
1256 void
Perl_despatch_signals(pTHX)1257 Perl_despatch_signals(pTHX)
1258 {
1259     int sig;
1260     PL_sig_pending = 0;
1261     for (sig = 1; sig < SIG_SIZE; sig++) {
1262 	if (PL_psig_pend[sig]) {
1263 	    PERL_BLOCKSIG_ADD(set, sig);
1264  	    PL_psig_pend[sig] = 0;
1265 	    PERL_BLOCKSIG_BLOCK(set);
1266 	    (*PL_sighandlerp)(sig);
1267 	    PERL_BLOCKSIG_UNBLOCK(set);
1268 	}
1269     }
1270 }
1271 
1272 int
Perl_magic_setsig(pTHX_ SV * sv,MAGIC * mg)1273 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1274 {
1275     register char *s;
1276     I32 i;
1277     SV** svp = 0;
1278     /* Need to be careful with SvREFCNT_dec(), because that can have side
1279      * effects (due to closures). We must make sure that the new disposition
1280      * is in place before it is called.
1281      */
1282     SV* to_dec = 0;
1283     STRLEN len;
1284 #ifdef HAS_SIGPROCMASK
1285     sigset_t set, save;
1286     SV* save_sv;
1287 #endif
1288 
1289     s = MgPV(mg,len);
1290     if (*s == '_') {
1291 	if (strEQ(s,"__DIE__"))
1292 	    svp = &PL_diehook;
1293 	else if (strEQ(s,"__WARN__"))
1294 	    svp = &PL_warnhook;
1295 	else
1296 	    Perl_croak(aTHX_ "No such hook: %s", s);
1297 	i = 0;
1298 	if (*svp) {
1299 	    to_dec = *svp;
1300 	    *svp = 0;
1301 	}
1302     }
1303     else {
1304 	i = whichsig(s);	/* ...no, a brick */
1305 	if (i < 0) {
1306 	    if (ckWARN(WARN_SIGNAL))
1307 		Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
1308 	    return 0;
1309 	}
1310 #ifdef HAS_SIGPROCMASK
1311 	/* Avoid having the signal arrive at a bad time, if possible. */
1312 	sigemptyset(&set);
1313 	sigaddset(&set,i);
1314 	sigprocmask(SIG_BLOCK, &set, &save);
1315 	ENTER;
1316 	save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1317 	SAVEFREESV(save_sv);
1318 	SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1319 #endif
1320 	PERL_ASYNC_CHECK();
1321 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1322 	if (!sig_handlers_initted) Perl_csighandler_init();
1323 #endif
1324 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1325 	sig_ignoring[i] = 0;
1326 #endif
1327 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1328 	sig_defaulting[i] = 0;
1329 #endif
1330 	SvREFCNT_dec(PL_psig_name[i]);
1331 	to_dec = PL_psig_ptr[i];
1332 	PL_psig_ptr[i] = SvREFCNT_inc(sv);
1333 	SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1334 	PL_psig_name[i] = newSVpvn(s, len);
1335 	SvREADONLY_on(PL_psig_name[i]);
1336     }
1337     if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
1338 	if (i) {
1339 	    (void)rsignal(i, PL_csighandlerp);
1340 #ifdef HAS_SIGPROCMASK
1341 	    LEAVE;
1342 #endif
1343 	}
1344 	else
1345 	    *svp = SvREFCNT_inc(sv);
1346 	if(to_dec)
1347 	    SvREFCNT_dec(to_dec);
1348 	return 0;
1349     }
1350     s = SvPV_force(sv,len);
1351     if (strEQ(s,"IGNORE")) {
1352 	if (i) {
1353 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1354 	    sig_ignoring[i] = 1;
1355 	    (void)rsignal(i, PL_csighandlerp);
1356 #else
1357 	    (void)rsignal(i, SIG_IGN);
1358 #endif
1359 	}
1360     }
1361     else if (strEQ(s,"DEFAULT") || !*s) {
1362 	if (i)
1363 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1364 	  {
1365 	    sig_defaulting[i] = 1;
1366 	    (void)rsignal(i, PL_csighandlerp);
1367 	  }
1368 #else
1369 	    (void)rsignal(i, SIG_DFL);
1370 #endif
1371     }
1372     else {
1373 	/*
1374 	 * We should warn if HINT_STRICT_REFS, but without
1375 	 * access to a known hint bit in a known OP, we can't
1376 	 * tell whether HINT_STRICT_REFS is in force or not.
1377 	 */
1378 	if (!strchr(s,':') && !strchr(s,'\''))
1379 	    sv_insert(sv, 0, 0, "main::", 6);
1380 	if (i)
1381 	    (void)rsignal(i, PL_csighandlerp);
1382 	else
1383 	    *svp = SvREFCNT_inc(sv);
1384     }
1385 #ifdef HAS_SIGPROCMASK
1386     if(i)
1387 	LEAVE;
1388 #endif
1389     if(to_dec)
1390 	SvREFCNT_dec(to_dec);
1391     return 0;
1392 }
1393 #endif /* !PERL_MICRO */
1394 
1395 int
Perl_magic_setisa(pTHX_ SV * sv,MAGIC * mg)1396 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1397 {
1398     PL_sub_generation++;
1399     return 0;
1400 }
1401 
1402 int
Perl_magic_setamagic(pTHX_ SV * sv,MAGIC * mg)1403 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
1404 {
1405     /* HV_badAMAGIC_on(Sv_STASH(sv)); */
1406     PL_amagic_generation++;
1407 
1408     return 0;
1409 }
1410 
1411 int
Perl_magic_getnkeys(pTHX_ SV * sv,MAGIC * mg)1412 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1413 {
1414     HV *hv = (HV*)LvTARG(sv);
1415     I32 i = 0;
1416 
1417     if (hv) {
1418          (void) hv_iterinit(hv);
1419          if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
1420 	     i = HvKEYS(hv);
1421          else {
1422 	     while (hv_iternext(hv))
1423 	         i++;
1424          }
1425     }
1426 
1427     sv_setiv(sv, (IV)i);
1428     return 0;
1429 }
1430 
1431 int
Perl_magic_setnkeys(pTHX_ SV * sv,MAGIC * mg)1432 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1433 {
1434     if (LvTARG(sv)) {
1435 	hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
1436     }
1437     return 0;
1438 }
1439 
1440 /* caller is responsible for stack switching/cleanup */
1441 STATIC int
S_magic_methcall(pTHX_ SV * sv,MAGIC * mg,char * meth,I32 flags,int n,SV * val)1442 S_magic_methcall(pTHX_ SV *sv, MAGIC *mg, char *meth, I32 flags, int n, SV *val)
1443 {
1444     dSP;
1445 
1446     PUSHMARK(SP);
1447     EXTEND(SP, n);
1448     PUSHs(SvTIED_obj(sv, mg));
1449     if (n > 1) {
1450 	if (mg->mg_ptr) {
1451 	    if (mg->mg_len >= 0)
1452 		PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len)));
1453 	    else if (mg->mg_len == HEf_SVKEY)
1454 		PUSHs((SV*)mg->mg_ptr);
1455 	}
1456 	else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1457 	    PUSHs(sv_2mortal(newSViv(mg->mg_len)));
1458 	}
1459     }
1460     if (n > 2) {
1461 	PUSHs(val);
1462     }
1463     PUTBACK;
1464 
1465     return call_method(meth, flags);
1466 }
1467 
1468 STATIC int
S_magic_methpack(pTHX_ SV * sv,MAGIC * mg,char * meth)1469 S_magic_methpack(pTHX_ SV *sv, MAGIC *mg, char *meth)
1470 {
1471     dSP;
1472 
1473     ENTER;
1474     SAVETMPS;
1475     PUSHSTACKi(PERLSI_MAGIC);
1476 
1477     if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
1478 	sv_setsv(sv, *PL_stack_sp--);
1479     }
1480 
1481     POPSTACK;
1482     FREETMPS;
1483     LEAVE;
1484     return 0;
1485 }
1486 
1487 int
Perl_magic_getpack(pTHX_ SV * sv,MAGIC * mg)1488 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1489 {
1490     if (mg->mg_ptr)
1491 	mg->mg_flags |= MGf_GSKIP;
1492     magic_methpack(sv,mg,"FETCH");
1493     return 0;
1494 }
1495 
1496 int
Perl_magic_setpack(pTHX_ SV * sv,MAGIC * mg)1497 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1498 {
1499     dSP;
1500     ENTER;
1501     PUSHSTACKi(PERLSI_MAGIC);
1502     magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
1503     POPSTACK;
1504     LEAVE;
1505     return 0;
1506 }
1507 
1508 int
Perl_magic_clearpack(pTHX_ SV * sv,MAGIC * mg)1509 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1510 {
1511     return magic_methpack(sv,mg,"DELETE");
1512 }
1513 
1514 
1515 U32
Perl_magic_sizepack(pTHX_ SV * sv,MAGIC * mg)1516 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1517 {
1518     dSP;
1519     U32 retval = 0;
1520 
1521     ENTER;
1522     SAVETMPS;
1523     PUSHSTACKi(PERLSI_MAGIC);
1524     if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
1525 	sv = *PL_stack_sp--;
1526 	retval = (U32) SvIV(sv)-1;
1527     }
1528     POPSTACK;
1529     FREETMPS;
1530     LEAVE;
1531     return retval;
1532 }
1533 
1534 int
Perl_magic_wipepack(pTHX_ SV * sv,MAGIC * mg)1535 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1536 {
1537     dSP;
1538 
1539     ENTER;
1540     PUSHSTACKi(PERLSI_MAGIC);
1541     PUSHMARK(SP);
1542     XPUSHs(SvTIED_obj(sv, mg));
1543     PUTBACK;
1544     call_method("CLEAR", G_SCALAR|G_DISCARD);
1545     POPSTACK;
1546     LEAVE;
1547 
1548     return 0;
1549 }
1550 
1551 int
Perl_magic_nextpack(pTHX_ SV * sv,MAGIC * mg,SV * key)1552 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1553 {
1554     dSP;
1555     const char *meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
1556 
1557     ENTER;
1558     SAVETMPS;
1559     PUSHSTACKi(PERLSI_MAGIC);
1560     PUSHMARK(SP);
1561     EXTEND(SP, 2);
1562     PUSHs(SvTIED_obj(sv, mg));
1563     if (SvOK(key))
1564 	PUSHs(key);
1565     PUTBACK;
1566 
1567     if (call_method(meth, G_SCALAR))
1568 	sv_setsv(key, *PL_stack_sp--);
1569 
1570     POPSTACK;
1571     FREETMPS;
1572     LEAVE;
1573     return 0;
1574 }
1575 
1576 int
Perl_magic_existspack(pTHX_ SV * sv,MAGIC * mg)1577 Perl_magic_existspack(pTHX_ SV *sv, MAGIC *mg)
1578 {
1579     return magic_methpack(sv,mg,"EXISTS");
1580 }
1581 
1582 SV *
Perl_magic_scalarpack(pTHX_ HV * hv,MAGIC * mg)1583 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1584 {
1585     dSP;
1586     SV *retval = &PL_sv_undef;
1587     SV *tied = SvTIED_obj((SV*)hv, mg);
1588     HV *pkg = SvSTASH((SV*)SvRV(tied));
1589 
1590     if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1591         SV *key;
1592         if (HvEITER(hv))
1593             /* we are in an iteration so the hash cannot be empty */
1594             return &PL_sv_yes;
1595         /* no xhv_eiter so now use FIRSTKEY */
1596         key = sv_newmortal();
1597         magic_nextpack((SV*)hv, mg, key);
1598         HvEITER(hv) = NULL;     /* need to reset iterator */
1599         return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1600     }
1601 
1602     /* there is a SCALAR method that we can call */
1603     ENTER;
1604     PUSHSTACKi(PERLSI_MAGIC);
1605     PUSHMARK(SP);
1606     EXTEND(SP, 1);
1607     PUSHs(tied);
1608     PUTBACK;
1609 
1610     if (call_method("SCALAR", G_SCALAR))
1611         retval = *PL_stack_sp--;
1612     POPSTACK;
1613     LEAVE;
1614     return retval;
1615 }
1616 
1617 int
Perl_magic_setdbline(pTHX_ SV * sv,MAGIC * mg)1618 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1619 {
1620     OP *o;
1621     I32 i;
1622     GV* gv;
1623     SV** svp;
1624     STRLEN n_a;
1625 
1626     gv = PL_DBline;
1627     i = SvTRUE(sv);
1628     svp = av_fetch(GvAV(gv),
1629 		     atoi(MgPV(mg,n_a)), FALSE);
1630     if (svp && SvIOKp(*svp) && (o = INT2PTR(OP*,SvIVX(*svp)))) {
1631 	/* set or clear breakpoint in the relevant control op */
1632 	if (i)
1633 	    o->op_flags |= OPf_SPECIAL;
1634 	else
1635 	    o->op_flags &= ~OPf_SPECIAL;
1636     }
1637     return 0;
1638 }
1639 
1640 int
Perl_magic_getarylen(pTHX_ SV * sv,MAGIC * mg)1641 Perl_magic_getarylen(pTHX_ SV *sv, MAGIC *mg)
1642 {
1643     sv_setiv(sv, AvFILL((AV*)mg->mg_obj) + PL_curcop->cop_arybase);
1644     return 0;
1645 }
1646 
1647 int
Perl_magic_setarylen(pTHX_ SV * sv,MAGIC * mg)1648 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
1649 {
1650     av_fill((AV*)mg->mg_obj, SvIV(sv) - PL_curcop->cop_arybase);
1651     return 0;
1652 }
1653 
1654 int
Perl_magic_getpos(pTHX_ SV * sv,MAGIC * mg)1655 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
1656 {
1657     SV* lsv = LvTARG(sv);
1658 
1659     if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1660 	mg = mg_find(lsv, PERL_MAGIC_regex_global);
1661 	if (mg && mg->mg_len >= 0) {
1662 	    I32 i = mg->mg_len;
1663 	    if (DO_UTF8(lsv))
1664 		sv_pos_b2u(lsv, &i);
1665 	    sv_setiv(sv, i + PL_curcop->cop_arybase);
1666 	    return 0;
1667 	}
1668     }
1669     (void)SvOK_off(sv);
1670     return 0;
1671 }
1672 
1673 int
Perl_magic_setpos(pTHX_ SV * sv,MAGIC * mg)1674 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
1675 {
1676     SV* lsv = LvTARG(sv);
1677     SSize_t pos;
1678     STRLEN len;
1679     STRLEN ulen = 0;
1680 
1681     mg = 0;
1682 
1683     if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
1684 	mg = mg_find(lsv, PERL_MAGIC_regex_global);
1685     if (!mg) {
1686 	if (!SvOK(sv))
1687 	    return 0;
1688 	sv_magic(lsv, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1689 	mg = mg_find(lsv, PERL_MAGIC_regex_global);
1690     }
1691     else if (!SvOK(sv)) {
1692 	mg->mg_len = -1;
1693 	return 0;
1694     }
1695     len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1696 
1697     pos = SvIV(sv) - PL_curcop->cop_arybase;
1698 
1699     if (DO_UTF8(lsv)) {
1700 	ulen = sv_len_utf8(lsv);
1701 	if (ulen)
1702 	    len = ulen;
1703     }
1704 
1705     if (pos < 0) {
1706 	pos += len;
1707 	if (pos < 0)
1708 	    pos = 0;
1709     }
1710     else if (pos > (SSize_t)len)
1711 	pos = len;
1712 
1713     if (ulen) {
1714 	I32 p = pos;
1715 	sv_pos_u2b(lsv, &p, 0);
1716 	pos = p;
1717     }
1718 
1719     mg->mg_len = pos;
1720     mg->mg_flags &= ~MGf_MINMATCH;
1721 
1722     return 0;
1723 }
1724 
1725 int
Perl_magic_getglob(pTHX_ SV * sv,MAGIC * mg)1726 Perl_magic_getglob(pTHX_ SV *sv, MAGIC *mg)
1727 {
1728     if (SvFAKE(sv)) {			/* FAKE globs can get coerced */
1729 	SvFAKE_off(sv);
1730 	gv_efullname3(sv,((GV*)sv), "*");
1731 	SvFAKE_on(sv);
1732     }
1733     else
1734 	gv_efullname3(sv,((GV*)sv), "*");	/* a gv value, be nice */
1735     return 0;
1736 }
1737 
1738 int
Perl_magic_setglob(pTHX_ SV * sv,MAGIC * mg)1739 Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg)
1740 {
1741     register char *s;
1742     GV* gv;
1743     STRLEN n_a;
1744 
1745     if (!SvOK(sv))
1746 	return 0;
1747     s = SvPV(sv, n_a);
1748     if (*s == '*' && s[1])
1749 	s++;
1750     gv = gv_fetchpv(s,TRUE, SVt_PVGV);
1751     if (sv == (SV*)gv)
1752 	return 0;
1753     if (GvGP(sv))
1754 	gp_free((GV*)sv);
1755     GvGP(sv) = gp_ref(GvGP(gv));
1756     return 0;
1757 }
1758 
1759 int
Perl_magic_getsubstr(pTHX_ SV * sv,MAGIC * mg)1760 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
1761 {
1762     STRLEN len;
1763     SV *lsv = LvTARG(sv);
1764     char *tmps = SvPV(lsv,len);
1765     I32 offs = LvTARGOFF(sv);
1766     I32 rem = LvTARGLEN(sv);
1767 
1768     if (SvUTF8(lsv))
1769 	sv_pos_u2b(lsv, &offs, &rem);
1770     if (offs > (I32)len)
1771 	offs = len;
1772     if (rem + offs > (I32)len)
1773 	rem = len - offs;
1774     sv_setpvn(sv, tmps + offs, (STRLEN)rem);
1775     if (SvUTF8(lsv))
1776         SvUTF8_on(sv);
1777     return 0;
1778 }
1779 
1780 int
Perl_magic_setsubstr(pTHX_ SV * sv,MAGIC * mg)1781 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
1782 {
1783     STRLEN len;
1784     char *tmps = SvPV(sv, len);
1785     SV *lsv = LvTARG(sv);
1786     I32 lvoff = LvTARGOFF(sv);
1787     I32 lvlen = LvTARGLEN(sv);
1788 
1789     if (DO_UTF8(sv)) {
1790 	sv_utf8_upgrade(lsv);
1791  	sv_pos_u2b(lsv, &lvoff, &lvlen);
1792 	sv_insert(lsv, lvoff, lvlen, tmps, len);
1793 	SvUTF8_on(lsv);
1794     }
1795     else if (lsv && SvUTF8(lsv)) {
1796 	sv_pos_u2b(lsv, &lvoff, &lvlen);
1797 	tmps = (char*)bytes_to_utf8((U8*)tmps, &len);
1798 	sv_insert(lsv, lvoff, lvlen, tmps, len);
1799 	Safefree(tmps);
1800     }
1801     else
1802         sv_insert(lsv, lvoff, lvlen, tmps, len);
1803 
1804     return 0;
1805 }
1806 
1807 int
Perl_magic_gettaint(pTHX_ SV * sv,MAGIC * mg)1808 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
1809 {
1810     TAINT_IF((mg->mg_len & 1) ||
1811 	     ((mg->mg_len & 2) && mg->mg_obj == sv));	/* kludge */
1812     return 0;
1813 }
1814 
1815 int
Perl_magic_settaint(pTHX_ SV * sv,MAGIC * mg)1816 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
1817 {
1818     if (PL_localizing) {
1819 	if (PL_localizing == 1)
1820 	    mg->mg_len <<= 1;
1821 	else
1822 	    mg->mg_len >>= 1;
1823     }
1824     else if (PL_tainted)
1825 	mg->mg_len |= 1;
1826     else
1827 	mg->mg_len &= ~1;
1828     return 0;
1829 }
1830 
1831 int
Perl_magic_getvec(pTHX_ SV * sv,MAGIC * mg)1832 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
1833 {
1834     SV *lsv = LvTARG(sv);
1835 
1836     if (!lsv) {
1837 	(void)SvOK_off(sv);
1838 	return 0;
1839     }
1840 
1841     sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
1842     return 0;
1843 }
1844 
1845 int
Perl_magic_setvec(pTHX_ SV * sv,MAGIC * mg)1846 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
1847 {
1848     do_vecset(sv);	/* XXX slurp this routine */
1849     return 0;
1850 }
1851 
1852 int
Perl_magic_getdefelem(pTHX_ SV * sv,MAGIC * mg)1853 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
1854 {
1855     SV *targ = Nullsv;
1856     if (LvTARGLEN(sv)) {
1857 	if (mg->mg_obj) {
1858 	    SV *ahv = LvTARG(sv);
1859 	    if (SvTYPE(ahv) == SVt_PVHV) {
1860 		HE *he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
1861 		if (he)
1862 		    targ = HeVAL(he);
1863 	    }
1864 	    else {
1865 		SV **svp = avhv_fetch_ent((AV*)ahv, mg->mg_obj, FALSE, 0);
1866 		if (svp)
1867 		    targ = *svp;
1868 	    }
1869 	}
1870 	else {
1871 	    AV* av = (AV*)LvTARG(sv);
1872 	    if ((I32)LvTARGOFF(sv) <= AvFILL(av))
1873 		targ = AvARRAY(av)[LvTARGOFF(sv)];
1874 	}
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);
1879 	    LvTARGLEN(sv) = 0;
1880 	    SvREFCNT_dec(mg->mg_obj);
1881 	    mg->mg_obj = Nullsv;
1882 	    mg->mg_flags &= ~MGf_REFCOUNTED;
1883 	}
1884     }
1885     else
1886 	targ = LvTARG(sv);
1887     sv_setsv(sv, targ ? targ : &PL_sv_undef);
1888     return 0;
1889 }
1890 
1891 int
Perl_magic_setdefelem(pTHX_ SV * sv,MAGIC * mg)1892 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
1893 {
1894     if (LvTARGLEN(sv))
1895 	vivify_defelem(sv);
1896     if (LvTARG(sv)) {
1897 	sv_setsv(LvTARG(sv), sv);
1898 	SvSETMAGIC(LvTARG(sv));
1899     }
1900     return 0;
1901 }
1902 
1903 void
Perl_vivify_defelem(pTHX_ SV * sv)1904 Perl_vivify_defelem(pTHX_ SV *sv)
1905 {
1906     MAGIC *mg;
1907     SV *value = Nullsv;
1908 
1909     if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
1910 	return;
1911     if (mg->mg_obj) {
1912 	SV *ahv = LvTARG(sv);
1913 	STRLEN n_a;
1914 	if (SvTYPE(ahv) == SVt_PVHV) {
1915 	    HE *he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
1916 	    if (he)
1917 		value = HeVAL(he);
1918 	}
1919 	else {
1920 	    SV **svp = avhv_fetch_ent((AV*)ahv, mg->mg_obj, TRUE, 0);
1921 	    if (svp)
1922 		value = *svp;
1923 	}
1924 	if (!value || value == &PL_sv_undef)
1925 	    Perl_croak(aTHX_ PL_no_helem, SvPV(mg->mg_obj, n_a));
1926     }
1927     else {
1928 	AV* av = (AV*)LvTARG(sv);
1929 	if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
1930 	    LvTARG(sv) = Nullsv;	/* array can't be extended */
1931 	else {
1932 	    SV** svp = av_fetch(av, LvTARGOFF(sv), TRUE);
1933 	    if (!svp || (value = *svp) == &PL_sv_undef)
1934 		Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
1935 	}
1936     }
1937     (void)SvREFCNT_inc(value);
1938     SvREFCNT_dec(LvTARG(sv));
1939     LvTARG(sv) = value;
1940     LvTARGLEN(sv) = 0;
1941     SvREFCNT_dec(mg->mg_obj);
1942     mg->mg_obj = Nullsv;
1943     mg->mg_flags &= ~MGf_REFCOUNTED;
1944 }
1945 
1946 int
Perl_magic_killbackrefs(pTHX_ SV * sv,MAGIC * mg)1947 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
1948 {
1949     AV *av = (AV*)mg->mg_obj;
1950     SV **svp = AvARRAY(av);
1951     I32 i = AvFILLp(av);
1952     while (i >= 0) {
1953 	if (svp[i] && svp[i] != &PL_sv_undef) {
1954 	    if (!SvWEAKREF(svp[i]))
1955 		Perl_croak(aTHX_ "panic: magic_killbackrefs");
1956 	    /* XXX Should we check that it hasn't changed? */
1957 	    SvRV(svp[i]) = 0;
1958 	    (void)SvOK_off(svp[i]);
1959 	    SvWEAKREF_off(svp[i]);
1960 	    svp[i] = &PL_sv_undef;
1961 	}
1962 	i--;
1963     }
1964     SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */
1965     return 0;
1966 }
1967 
1968 int
Perl_magic_setmglob(pTHX_ SV * sv,MAGIC * mg)1969 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
1970 {
1971     mg->mg_len = -1;
1972     SvSCREAM_off(sv);
1973     return 0;
1974 }
1975 
1976 int
Perl_magic_setbm(pTHX_ SV * sv,MAGIC * mg)1977 Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
1978 {
1979     sv_unmagic(sv, PERL_MAGIC_bm);
1980     SvVALID_off(sv);
1981     return 0;
1982 }
1983 
1984 int
Perl_magic_setfm(pTHX_ SV * sv,MAGIC * mg)1985 Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
1986 {
1987     sv_unmagic(sv, PERL_MAGIC_fm);
1988     SvCOMPILED_off(sv);
1989     return 0;
1990 }
1991 
1992 int
Perl_magic_setuvar(pTHX_ SV * sv,MAGIC * mg)1993 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
1994 {
1995     struct ufuncs *uf = (struct ufuncs *)mg->mg_ptr;
1996 
1997     if (uf && uf->uf_set)
1998 	(*uf->uf_set)(aTHX_ uf->uf_index, sv);
1999     return 0;
2000 }
2001 
2002 int
Perl_magic_setregexp(pTHX_ SV * sv,MAGIC * mg)2003 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2004 {
2005     sv_unmagic(sv, PERL_MAGIC_qr);
2006     return 0;
2007 }
2008 
2009 int
Perl_magic_freeregexp(pTHX_ SV * sv,MAGIC * mg)2010 Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
2011 {
2012     regexp *re = (regexp *)mg->mg_obj;
2013     ReREFCNT_dec(re);
2014     return 0;
2015 }
2016 
2017 #ifdef USE_LOCALE_COLLATE
2018 int
Perl_magic_setcollxfrm(pTHX_ SV * sv,MAGIC * mg)2019 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2020 {
2021     /*
2022      * RenE<eacute> Descartes said "I think not."
2023      * and vanished with a faint plop.
2024      */
2025     if (mg->mg_ptr) {
2026 	Safefree(mg->mg_ptr);
2027 	mg->mg_ptr = NULL;
2028 	mg->mg_len = -1;
2029     }
2030     return 0;
2031 }
2032 #endif /* USE_LOCALE_COLLATE */
2033 
2034 /* Just clear the UTF-8 cache data. */
2035 int
Perl_magic_setutf8(pTHX_ SV * sv,MAGIC * mg)2036 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2037 {
2038      Safefree(mg->mg_ptr);	/* The mg_ptr holds the pos cache. */
2039      mg->mg_ptr = 0;
2040      mg->mg_len = -1; 		/* The mg_len holds the len cache. */
2041      return 0;
2042 }
2043 
2044 int
Perl_magic_set(pTHX_ SV * sv,MAGIC * mg)2045 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2046 {
2047     register char *s;
2048     I32 i;
2049     STRLEN len;
2050     switch (*mg->mg_ptr) {
2051     case '\001':	/* ^A */
2052 	sv_setsv(PL_bodytarget, sv);
2053 	break;
2054     case '\003':	/* ^C */
2055 	PL_minus_c = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2056 	break;
2057 
2058     case '\004':	/* ^D */
2059 #ifdef DEBUGGING
2060 	s = SvPV_nolen(sv);
2061 	PL_debug = get_debug_opts(&s) | DEBUG_TOP_FLAG;
2062 	DEBUG_x(dump_all());
2063 #else
2064 	PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | DEBUG_TOP_FLAG;
2065 #endif
2066 	break;
2067     case '\005':  /* ^E */
2068 	if (*(mg->mg_ptr+1) == '\0') {
2069 #ifdef MACOS_TRADITIONAL
2070 	    gMacPerl_OSErr = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2071 #else
2072 #  ifdef VMS
2073 	    set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2074 #  else
2075 #    ifdef WIN32
2076 	    SetLastError( SvIV(sv) );
2077 #    else
2078 #      ifdef OS2
2079 	    os2_setsyserrno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2080 #      else
2081 	    /* will anyone ever use this? */
2082 	    SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4);
2083 #      endif
2084 #    endif
2085 #  endif
2086 #endif
2087 	}
2088 	else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2089 	    if (PL_encoding)
2090 		SvREFCNT_dec(PL_encoding);
2091 	    if (SvOK(sv) || SvGMAGICAL(sv)) {
2092 		PL_encoding = newSVsv(sv);
2093 	    }
2094 	    else {
2095 		PL_encoding = Nullsv;
2096 	    }
2097 	}
2098 	break;
2099     case '\006':	/* ^F */
2100 	PL_maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2101 	break;
2102     case '\010':	/* ^H */
2103 	PL_hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2104 	break;
2105     case '\011':	/* ^I */ /* NOT \t in EBCDIC */
2106 	if (PL_inplace)
2107 	    Safefree(PL_inplace);
2108 	if (SvOK(sv))
2109 	    PL_inplace = savepv(SvPV(sv,len));
2110 	else
2111 	    PL_inplace = Nullch;
2112 	break;
2113     case '\017':	/* ^O */
2114 	if (*(mg->mg_ptr+1) == '\0') {
2115 	    if (PL_osname) {
2116 		Safefree(PL_osname);
2117 		PL_osname = Nullch;
2118 	    }
2119 	    if (SvOK(sv)) {
2120 		TAINT_PROPER("assigning to $^O");
2121 		PL_osname = savepv(SvPV(sv,len));
2122 	    }
2123 	}
2124 	else if (strEQ(mg->mg_ptr, "\017PEN")) {
2125 	    if (!PL_compiling.cop_io)
2126 		PL_compiling.cop_io = newSVsv(sv);
2127 	    else
2128 		sv_setsv(PL_compiling.cop_io,sv);
2129 	}
2130 	break;
2131     case '\020':	/* ^P */
2132 	PL_perldb = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2133 	if ((PERLDB_SUB || PERLDB_LINE || PERLDB_SUBLINE)
2134 		&& !PL_DBsingle)
2135 	    init_debugger();
2136 	break;
2137     case '\024':	/* ^T */
2138 #ifdef BIG_TIME
2139 	PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2140 #else
2141 	PL_basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2142 #endif
2143 	break;
2144     case '\027':	/* ^W & $^WARNING_BITS */
2145 	if (*(mg->mg_ptr+1) == '\0') {
2146 	    if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2147 	        i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2148 	        PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2149 		    		| (i ? G_WARN_ON : G_WARN_OFF) ;
2150 	    }
2151 	}
2152 	else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2153 	    if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2154 		if (!SvPOK(sv) && PL_localizing) {
2155 	            sv_setpvn(sv, WARN_NONEstring, WARNsize);
2156 	            PL_compiling.cop_warnings = pWARN_NONE;
2157 		    break;
2158 		}
2159 		{
2160 		    STRLEN len, i;
2161 		    int accumulate = 0 ;
2162 		    int any_fatals = 0 ;
2163 		    char * ptr = (char*)SvPV(sv, len) ;
2164 		    for (i = 0 ; i < len ; ++i) {
2165 		        accumulate |= ptr[i] ;
2166 		        any_fatals |= (ptr[i] & 0xAA) ;
2167 		    }
2168 		    if (!accumulate)
2169 	                PL_compiling.cop_warnings = pWARN_NONE;
2170 		    else if (isWARN_on(sv, WARN_ALL) && !any_fatals) {
2171 	                PL_compiling.cop_warnings = pWARN_ALL;
2172 	                PL_dowarn |= G_WARN_ONCE ;
2173 	            }
2174                     else {
2175 	                if (specialWARN(PL_compiling.cop_warnings))
2176 		            PL_compiling.cop_warnings = newSVsv(sv) ;
2177 	                else
2178 	                    sv_setsv(PL_compiling.cop_warnings, sv);
2179 	                if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2180 	                    PL_dowarn |= G_WARN_ONCE ;
2181 	            }
2182 
2183 		}
2184 	    }
2185 	}
2186 	break;
2187     case '.':
2188 	if (PL_localizing) {
2189 	    if (PL_localizing == 1)
2190 		SAVESPTR(PL_last_in_gv);
2191 	}
2192 	else if (SvOK(sv) && GvIO(PL_last_in_gv))
2193 	    IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2194 	break;
2195     case '^':
2196 	Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2197 	IoTOP_NAME(GvIOp(PL_defoutgv)) = s = savepv(SvPV(sv,len));
2198 	IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchpv(s,TRUE, SVt_PVIO);
2199 	break;
2200     case '~':
2201 	Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2202 	IoFMT_NAME(GvIOp(PL_defoutgv)) = s = savepv(SvPV(sv,len));
2203 	IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchpv(s,TRUE, SVt_PVIO);
2204 	break;
2205     case '=':
2206 	IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2207 	break;
2208     case '-':
2209 	IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2210 	if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2211 	    IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2212 	break;
2213     case '%':
2214 	IoPAGE(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2215 	break;
2216     case '|':
2217 	{
2218 	    IO *io = GvIOp(PL_defoutgv);
2219 	    if(!io)
2220 	      break;
2221 	    if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) == 0)
2222 		IoFLAGS(io) &= ~IOf_FLUSH;
2223 	    else {
2224 		if (!(IoFLAGS(io) & IOf_FLUSH)) {
2225 		    PerlIO *ofp = IoOFP(io);
2226 		    if (ofp)
2227 			(void)PerlIO_flush(ofp);
2228 		    IoFLAGS(io) |= IOf_FLUSH;
2229 		}
2230 	    }
2231 	}
2232 	break;
2233     case '*':
2234 	i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2235 	PL_multiline = (i != 0);
2236 	break;
2237     case '/':
2238 	SvREFCNT_dec(PL_rs);
2239 	PL_rs = newSVsv(sv);
2240 	break;
2241     case '\\':
2242 	if (PL_ors_sv)
2243 	    SvREFCNT_dec(PL_ors_sv);
2244 	if (SvOK(sv) || SvGMAGICAL(sv)) {
2245 	    PL_ors_sv = newSVsv(sv);
2246 	}
2247 	else {
2248 	    PL_ors_sv = Nullsv;
2249 	}
2250 	break;
2251     case ',':
2252 	if (PL_ofs_sv)
2253 	    SvREFCNT_dec(PL_ofs_sv);
2254 	if (SvOK(sv) || SvGMAGICAL(sv)) {
2255 	    PL_ofs_sv = newSVsv(sv);
2256 	}
2257 	else {
2258 	    PL_ofs_sv = Nullsv;
2259 	}
2260 	break;
2261     case '#':
2262 	if (PL_ofmt)
2263 	    Safefree(PL_ofmt);
2264 	PL_ofmt = savepv(SvPV(sv,len));
2265 	break;
2266     case '[':
2267 	PL_compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2268 	break;
2269     case '?':
2270 #ifdef COMPLEX_STATUS
2271 	if (PL_localizing == 2) {
2272 	    PL_statusvalue = LvTARGOFF(sv);
2273 	    PL_statusvalue_vms = LvTARGLEN(sv);
2274 	}
2275 	else
2276 #endif
2277 #ifdef VMSISH_STATUS
2278 	if (VMSISH_STATUS)
2279 	    STATUS_NATIVE_SET((U32)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)));
2280 	else
2281 #endif
2282 	    STATUS_POSIX_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2283 	break;
2284     case '!':
2285         {
2286 #ifdef VMS
2287 #   define PERL_VMS_BANG vaxc$errno
2288 #else
2289 #   define PERL_VMS_BANG 0
2290 #endif
2291 	SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2292 		 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2293 	}
2294 	break;
2295     case '<':
2296 	PL_uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2297 	if (PL_delaymagic) {
2298 	    PL_delaymagic |= DM_RUID;
2299 	    break;				/* don't do magic till later */
2300 	}
2301 #ifdef HAS_SETRUID
2302 	(void)setruid((Uid_t)PL_uid);
2303 #else
2304 #ifdef HAS_SETREUID
2305 	(void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2306 #else
2307 #ifdef HAS_SETRESUID
2308       (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2309 #else
2310 	if (PL_uid == PL_euid) {		/* special case $< = $> */
2311 #ifdef PERL_DARWIN
2312 	    /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2313 	    if (PL_uid != 0 && PerlProc_getuid() == 0)
2314 		(void)PerlProc_setuid(0);
2315 #endif
2316 	    (void)PerlProc_setuid(PL_uid);
2317 	} else {
2318 	    PL_uid = PerlProc_getuid();
2319 	    Perl_croak(aTHX_ "setruid() not implemented");
2320 	}
2321 #endif
2322 #endif
2323 #endif
2324 	PL_uid = PerlProc_getuid();
2325 	PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2326 	break;
2327     case '>':
2328 	PL_euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2329 	if (PL_delaymagic) {
2330 	    PL_delaymagic |= DM_EUID;
2331 	    break;				/* don't do magic till later */
2332 	}
2333 #ifdef HAS_SETEUID
2334 	(void)seteuid((Uid_t)PL_euid);
2335 #else
2336 #ifdef HAS_SETREUID
2337 	(void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2338 #else
2339 #ifdef HAS_SETRESUID
2340 	(void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2341 #else
2342 	if (PL_euid == PL_uid)		/* special case $> = $< */
2343 	    PerlProc_setuid(PL_euid);
2344 	else {
2345 	    PL_euid = PerlProc_geteuid();
2346 	    Perl_croak(aTHX_ "seteuid() not implemented");
2347 	}
2348 #endif
2349 #endif
2350 #endif
2351 	PL_euid = PerlProc_geteuid();
2352 	PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2353 	break;
2354     case '(':
2355 	PL_gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2356 	if (PL_delaymagic) {
2357 	    PL_delaymagic |= DM_RGID;
2358 	    break;				/* don't do magic till later */
2359 	}
2360 #ifdef HAS_SETRGID
2361 	(void)setrgid((Gid_t)PL_gid);
2362 #else
2363 #ifdef HAS_SETREGID
2364 	(void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2365 #else
2366 #ifdef HAS_SETRESGID
2367       (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2368 #else
2369 	if (PL_gid == PL_egid)			/* special case $( = $) */
2370 	    (void)PerlProc_setgid(PL_gid);
2371 	else {
2372 	    PL_gid = PerlProc_getgid();
2373 	    Perl_croak(aTHX_ "setrgid() not implemented");
2374 	}
2375 #endif
2376 #endif
2377 #endif
2378 	PL_gid = PerlProc_getgid();
2379 	PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2380 	break;
2381     case ')':
2382 #ifdef HAS_SETGROUPS
2383 	{
2384 	    char *p = SvPV(sv, len);
2385 #ifdef _SC_NGROUPS_MAX
2386 	    int maxgrp = sysconf(_SC_NGROUPS_MAX);
2387 	    Groups_t *gary = alloca(maxgrp * sizeof (Groups_t));
2388 #else
2389 	    int maxgrp = NGROUPS;
2390 	    Groups_t gary[NGROUPS];
2391 #endif
2392 
2393 	    while (isSPACE(*p))
2394 		++p;
2395 	    PL_egid = Atol(p);
2396 	    for (i = 0; i < maxgrp; ++i) {
2397 		while (*p && !isSPACE(*p))
2398 		    ++p;
2399 		while (isSPACE(*p))
2400 		    ++p;
2401 		if (!*p)
2402 		    break;
2403 		gary[i] = Atol(p);
2404 	    }
2405 	    if (i)
2406 		(void)setgroups(i, gary);
2407 	}
2408 #else  /* HAS_SETGROUPS */
2409 	PL_egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2410 #endif /* HAS_SETGROUPS */
2411 	if (PL_delaymagic) {
2412 	    PL_delaymagic |= DM_EGID;
2413 	    break;				/* don't do magic till later */
2414 	}
2415 #ifdef HAS_SETEGID
2416 	(void)setegid((Gid_t)PL_egid);
2417 #else
2418 #ifdef HAS_SETREGID
2419 	(void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2420 #else
2421 #ifdef HAS_SETRESGID
2422 	(void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2423 #else
2424 	if (PL_egid == PL_gid)			/* special case $) = $( */
2425 	    (void)PerlProc_setgid(PL_egid);
2426 	else {
2427 	    PL_egid = PerlProc_getegid();
2428 	    Perl_croak(aTHX_ "setegid() not implemented");
2429 	}
2430 #endif
2431 #endif
2432 #endif
2433 	PL_egid = PerlProc_getegid();
2434 	PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2435 	break;
2436     case ':':
2437 	PL_chopset = SvPV_force(sv,len);
2438 	break;
2439 #ifndef MACOS_TRADITIONAL
2440     case '0':
2441 	LOCK_DOLLARZERO_MUTEX;
2442 #ifdef HAS_SETPROCTITLE
2443 	/* The BSDs don't show the argv[] in ps(1) output, they
2444 	 * show a string from the process struct and provide
2445 	 * the setproctitle() routine to manipulate that. */
2446 	{
2447 	    s = SvPV(sv, len);
2448 #   if __FreeBSD_version > 410001
2449 	    /* The leading "-" removes the "perl: " prefix,
2450 	     * but not the "(perl) suffix from the ps(1)
2451 	     * output, because that's what ps(1) shows if the
2452 	     * argv[] is modified. */
2453 	    setproctitle("-%s", s);
2454 #   else	/* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2455 	    /* This doesn't really work if you assume that
2456 	     * $0 = 'foobar'; will wipe out 'perl' from the $0
2457 	     * because in ps(1) output the result will be like
2458 	     * sprintf("perl: %s (perl)", s)
2459 	     * I guess this is a security feature:
2460 	     * one (a user process) cannot get rid of the original name.
2461 	     * --jhi */
2462 	    setproctitle("%s", s);
2463 #   endif
2464 	}
2465 #endif
2466 #if defined(__hpux) && defined(PSTAT_SETCMD)
2467 	{
2468 	     union pstun un;
2469 	     s = SvPV(sv, len);
2470 	     un.pst_command = s;
2471 	     pstat(PSTAT_SETCMD, un, len, 0, 0);
2472 	}
2473 #endif
2474 	/* PL_origalen is set in perl_parse(). */
2475 	s = SvPV_force(sv,len);
2476 	if (len >= (STRLEN)PL_origalen) {
2477 	    /* Longer than original, will be truncated. */
2478 	    Copy(s, PL_origargv[0], PL_origalen, char);
2479 	    PL_origargv[0][PL_origalen - 1] = 0;
2480 	}
2481 	else {
2482 	    /* Shorter than original, will be padded. */
2483 	    Copy(s, PL_origargv[0], len, char);
2484 	    PL_origargv[0][len] = 0;
2485 	    memset(PL_origargv[0] + len + 1,
2486 		   /* Is the space counterintuitive?  Yes.
2487 		    * (You were expecting \0?)
2488 		    * Does it work?  Seems to.  (In Linux 2.4.20 at least.)
2489 		    * --jhi */
2490 		   (int)' ',
2491 		   PL_origalen - len - 1);
2492 	    for (i = 1; i < PL_origargc; i++)
2493 		 PL_origargv[i] = 0;
2494 	}
2495 	UNLOCK_DOLLARZERO_MUTEX;
2496 	break;
2497 #endif
2498 #ifdef USE_5005THREADS
2499     case '@':
2500 	sv_setsv(thr->errsv, sv);
2501 	break;
2502 #endif /* USE_5005THREADS */
2503     }
2504     return 0;
2505 }
2506 
2507 #ifdef USE_5005THREADS
2508 int
Perl_magic_mutexfree(pTHX_ SV * sv,MAGIC * mg)2509 Perl_magic_mutexfree(pTHX_ SV *sv, MAGIC *mg)
2510 {
2511     DEBUG_S(PerlIO_printf(Perl_debug_log,
2512 			  "0x%"UVxf": magic_mutexfree 0x%"UVxf"\n",
2513 			  PTR2UV(thr), PTR2UV(sv)));
2514     if (MgOWNER(mg))
2515 	Perl_croak(aTHX_ "panic: magic_mutexfree");
2516     MUTEX_DESTROY(MgMUTEXP(mg));
2517     COND_DESTROY(MgCONDP(mg));
2518     return 0;
2519 }
2520 #endif /* USE_5005THREADS */
2521 
2522 I32
Perl_whichsig(pTHX_ char * sig)2523 Perl_whichsig(pTHX_ char *sig)
2524 {
2525     register char **sigv;
2526 
2527     for (sigv = PL_sig_name; *sigv; sigv++)
2528 	if (strEQ(sig,*sigv))
2529 	    return PL_sig_num[sigv - PL_sig_name];
2530 #ifdef SIGCLD
2531     if (strEQ(sig,"CHLD"))
2532 	return SIGCLD;
2533 #endif
2534 #ifdef SIGCHLD
2535     if (strEQ(sig,"CLD"))
2536 	return SIGCHLD;
2537 #endif
2538     return -1;
2539 }
2540 
2541 #if !defined(PERL_IMPLICIT_CONTEXT)
2542 static SV* sig_sv;
2543 #endif
2544 
2545 Signal_t
Perl_sighandler(int sig)2546 Perl_sighandler(int sig)
2547 {
2548 #ifdef PERL_GET_SIG_CONTEXT
2549     dTHXa(PERL_GET_SIG_CONTEXT);
2550 #else
2551     dTHX;
2552 #endif
2553     dSP;
2554     GV *gv = Nullgv;
2555     HV *st;
2556     SV *sv = Nullsv, *tSv = PL_Sv;
2557     CV *cv = Nullcv;
2558     OP *myop = PL_op;
2559     U32 flags = 0;
2560     XPV *tXpv = PL_Xpv;
2561 
2562     if (PL_savestack_ix + 15 <= PL_savestack_max)
2563 	flags |= 1;
2564     if (PL_markstack_ptr < PL_markstack_max - 2)
2565 	flags |= 4;
2566     if (PL_retstack_ix < PL_retstack_max - 2)
2567 	flags |= 8;
2568     if (PL_scopestack_ix < PL_scopestack_max - 3)
2569 	flags |= 16;
2570 
2571     if (!PL_psig_ptr[sig]) {
2572 		PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2573 				 PL_sig_name[sig]);
2574 		exit(sig);
2575 	}
2576 
2577     /* Max number of items pushed there is 3*n or 4. We cannot fix
2578        infinity, so we fix 4 (in fact 5): */
2579     if (flags & 1) {
2580 	PL_savestack_ix += 5;		/* Protect save in progress. */
2581 	SAVEDESTRUCTOR_X(unwind_handler_stack, (void*)&flags);
2582     }
2583     if (flags & 4)
2584 	PL_markstack_ptr++;		/* Protect mark. */
2585     if (flags & 8) {
2586 	PL_retstack_ix++;
2587 	PL_retstack[PL_retstack_ix] = NULL;
2588     }
2589     if (flags & 16)
2590 	PL_scopestack_ix += 1;
2591     /* sv_2cv is too complicated, try a simpler variant first: */
2592     if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
2593 	|| SvTYPE(cv) != SVt_PVCV)
2594 	cv = sv_2cv(PL_psig_ptr[sig],&st,&gv,TRUE);
2595 
2596     if (!cv || !CvROOT(cv)) {
2597 	if (ckWARN(WARN_SIGNAL))
2598 	    Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2599 		PL_sig_name[sig], (gv ? GvENAME(gv)
2600 				: ((cv && CvGV(cv))
2601 				   ? GvENAME(CvGV(cv))
2602 				   : "__ANON__")));
2603 	goto cleanup;
2604     }
2605 
2606     if(PL_psig_name[sig]) {
2607     	sv = SvREFCNT_inc(PL_psig_name[sig]);
2608 	flags |= 64;
2609 #if !defined(PERL_IMPLICIT_CONTEXT)
2610 	sig_sv = sv;
2611 #endif
2612     } else {
2613 	sv = sv_newmortal();
2614 	sv_setpv(sv,PL_sig_name[sig]);
2615     }
2616 
2617     PUSHSTACKi(PERLSI_SIGNAL);
2618     PUSHMARK(SP);
2619     PUSHs(sv);
2620     PUTBACK;
2621 
2622     call_sv((SV*)cv, G_DISCARD|G_EVAL);
2623 
2624     POPSTACK;
2625     if (SvTRUE(ERRSV)) {
2626 #ifndef PERL_MICRO
2627 #ifdef HAS_SIGPROCMASK
2628 	/* Handler "died", for example to get out of a restart-able read().
2629 	 * Before we re-do that on its behalf re-enable the signal which was
2630 	 * blocked by the system when we entered.
2631 	 */
2632 	sigset_t set;
2633 	sigemptyset(&set);
2634 	sigaddset(&set,sig);
2635 	sigprocmask(SIG_UNBLOCK, &set, NULL);
2636 #else
2637 	/* Not clear if this will work */
2638 	(void)rsignal(sig, SIG_IGN);
2639 	(void)rsignal(sig, PL_csighandlerp);
2640 #endif
2641 #endif /* !PERL_MICRO */
2642 	Perl_die(aTHX_ Nullformat);
2643     }
2644 cleanup:
2645     if (flags & 1)
2646 	PL_savestack_ix -= 8; /* Unprotect save in progress. */
2647     if (flags & 4)
2648 	PL_markstack_ptr--;
2649     if (flags & 8)
2650 	PL_retstack_ix--;
2651     if (flags & 16)
2652 	PL_scopestack_ix -= 1;
2653     if (flags & 64)
2654 	SvREFCNT_dec(sv);
2655     PL_op = myop;			/* Apparently not needed... */
2656 
2657     PL_Sv = tSv;			/* Restore global temporaries. */
2658     PL_Xpv = tXpv;
2659     return;
2660 }
2661 
2662 
2663 static void
restore_magic(pTHX_ void * p)2664 restore_magic(pTHX_ void *p)
2665 {
2666     MGS* mgs = SSPTR(PTR2IV(p), MGS*);
2667     SV* sv = mgs->mgs_sv;
2668 
2669     if (!sv)
2670         return;
2671 
2672     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2673     {
2674 	if (mgs->mgs_flags)
2675 	    SvFLAGS(sv) |= mgs->mgs_flags;
2676 	else
2677 	    mg_magical(sv);
2678 	if (SvGMAGICAL(sv))
2679 	    SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
2680     }
2681 
2682     mgs->mgs_sv = NULL;  /* mark the MGS structure as restored */
2683 
2684     /* If we're still on top of the stack, pop us off.  (That condition
2685      * will be satisfied if restore_magic was called explicitly, but *not*
2686      * if it's being called via leave_scope.)
2687      * The reason for doing this is that otherwise, things like sv_2cv()
2688      * may leave alloc gunk on the savestack, and some code
2689      * (e.g. sighandler) doesn't expect that...
2690      */
2691     if (PL_savestack_ix == mgs->mgs_ss_ix)
2692     {
2693 	I32 popval = SSPOPINT;
2694         assert(popval == SAVEt_DESTRUCTOR_X);
2695         PL_savestack_ix -= 2;
2696 	popval = SSPOPINT;
2697         assert(popval == SAVEt_ALLOC);
2698 	popval = SSPOPINT;
2699         PL_savestack_ix -= popval;
2700     }
2701 
2702 }
2703 
2704 static void
unwind_handler_stack(pTHX_ void * p)2705 unwind_handler_stack(pTHX_ void *p)
2706 {
2707     U32 flags = *(U32*)p;
2708 
2709     if (flags & 1)
2710 	PL_savestack_ix -= 5; /* Unprotect save in progress. */
2711     /* cxstack_ix-- Not needed, die already unwound it. */
2712 #if !defined(PERL_IMPLICIT_CONTEXT)
2713     if (flags & 64)
2714 	SvREFCNT_dec(sig_sv);
2715 #endif
2716 }
2717 
2718 
2719