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