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