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