This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[perl #32332] Perl segfaults; test case available
[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);
5636d518
DB
275 len = Perl_utf8_length(aTHX_ s, s + len);
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;
382 if (isUPPER(type)) {
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)
534 i = Perl_utf8_length(aTHX_ (U8*)b, (U8*)(b+i));
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
RGS
732 sv_setnv(sv, (NV)errno);
733 sv_setpv(sv, errno ? Strerror(errno) : "");
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")) {
ac27b0f5
NIS
761 if (!PL_compiling.cop_io)
762 sv_setsv(sv, &PL_sv_undef);
763 else {
764 sv_setsv(sv, PL_compiling.cop_io);
765 }
766 }
28f23441 767 break;
79072805 768 case '\020': /* ^P */
3280af22 769 sv_setiv(sv, (IV)PL_perldb);
79072805 770 break;
fb73857a 771 case '\023': /* ^S */
823a54a3 772 if (nextchar == '\0') {
3280af22 773 if (PL_lex_state != LEX_NOTPARSING)
0c34ef67 774 SvOK_off(sv);
3280af22 775 else if (PL_in_eval)
6dc8a9e4 776 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
a4268c0a
AMS
777 else
778 sv_setiv(sv, 0);
d58bf5aa 779 }
fb73857a 780 break;
79072805 781 case '\024': /* ^T */
823a54a3 782 if (nextchar == '\0') {
88e89b8a 783#ifdef BIG_TIME
7c36658b 784 sv_setnv(sv, PL_basetime);
88e89b8a 785#else
7c36658b 786 sv_setiv(sv, (IV)PL_basetime);
88e89b8a 787#endif
7c36658b 788 }
823a54a3 789 else if (strEQ(remaining, "AINT"))
9aa05f58
RGS
790 sv_setiv(sv, PL_tainting
791 ? (PL_taint_warn || PL_unsafe ? -1 : 1)
792 : 0);
7c36658b 793 break;
e07ea26a 794 case '\025': /* $^UNICODE, $^UTF8LOCALE, $^UTF8CACHE */
823a54a3 795 if (strEQ(remaining, "NICODE"))
a05d7ebb 796 sv_setuv(sv, (UV) PL_unicode);
823a54a3 797 else if (strEQ(remaining, "TF8LOCALE"))
7cebcbc0 798 sv_setuv(sv, (UV) PL_utf8locale);
e07ea26a
NC
799 else if (strEQ(remaining, "TF8CACHE"))
800 sv_setiv(sv, (IV) PL_utf8cache);
fde18df1
JH
801 break;
802 case '\027': /* ^W & $^WARNING_BITS */
823a54a3 803 if (nextchar == '\0')
4438c4b7 804 sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
823a54a3 805 else if (strEQ(remaining, "ARNING_BITS")) {
013b78e8 806 if (PL_compiling.cop_warnings == pWARN_NONE) {
4438c4b7 807 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
013b78e8
RGS
808 }
809 else if (PL_compiling.cop_warnings == pWARN_STD) {
810 sv_setpvn(
811 sv,
812 (PL_dowarn & G_WARN_ON) ? WARN_ALLstring : WARN_NONEstring,
813 WARNsize
814 );
815 }
d3a7d8c7 816 else if (PL_compiling.cop_warnings == pWARN_ALL) {
75b6c4ca
RGS
817 /* Get the bit mask for $warnings::Bits{all}, because
818 * it could have been extended by warnings::register */
819 SV **bits_all;
823a54a3 820 HV * const bits=get_hv("warnings::Bits", FALSE);
017a3ce5 821 if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
75b6c4ca
RGS
822 sv_setsv(sv, *bits_all);
823 }
824 else {
825 sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
826 }
ac27b0f5 827 }
4438c4b7 828 else {
72dc9ed5
NC
829 sv_setpvn(sv, (char *) (PL_compiling.cop_warnings + 1),
830 *PL_compiling.cop_warnings);
ac27b0f5 831 }
d3a7d8c7 832 SvPOK_only(sv);
4438c4b7 833 }
79072805
LW
834 break;
835 case '1': case '2': case '3': case '4':
836 case '5': case '6': case '7': case '8': case '9': case '&':
aaa362c4 837 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
cf93c79d
IZ
838 I32 s1, t1;
839
a863c7d1
MB
840 /*
841 * Pre-threads, this was paren = atoi(GvENAME((GV*)mg->mg_obj));
842 * XXX Does the new way break anything?
843 */
ffc61ed2 844 paren = atoi(mg->mg_ptr); /* $& is in [0] */
79072805 845 getparen:
eb160463 846 if (paren <= (I32)rx->nparens &&
cf93c79d
IZ
847 (s1 = rx->startp[paren]) != -1 &&
848 (t1 = rx->endp[paren]) != -1)
bbce6d69 849 {
cf93c79d
IZ
850 i = t1 - s1;
851 s = rx->subbeg + s1;
c2b4a044 852 assert(rx->subbeg);
c2e66d9e 853
13f57bf8 854 getrx:
748a9306 855 if (i >= 0) {
fabdb6c0 856 const int oldtainted = PL_tainted;
f6ba9920 857 TAINT_NOT;
cf93c79d 858 sv_setpvn(sv, s, i);
f6ba9920 859 PL_tainted = oldtainted;
a30b2f1f 860 if (RX_MATCH_UTF8(rx) && is_utf8_string((U8*)s, i))
7e2040f0
GS
861 SvUTF8_on(sv);
862 else
863 SvUTF8_off(sv);
e9814ee1
HS
864 if (PL_tainting) {
865 if (RX_MATCH_TAINTED(rx)) {
823a54a3 866 MAGIC* const mg = SvMAGIC(sv);
e9814ee1
HS
867 MAGIC* mgt;
868 PL_tainted = 1;
b162af07 869 SvMAGIC_set(sv, mg->mg_moremagic);
e9814ee1
HS
870 SvTAINT(sv);
871 if ((mgt = SvMAGIC(sv))) {
872 mg->mg_moremagic = mgt;
b162af07 873 SvMAGIC_set(sv, mg);
e9814ee1
HS
874 }
875 } else
876 SvTAINTED_off(sv);
877 }
748a9306
LW
878 break;
879 }
79072805 880 }
79072805 881 }
3280af22 882 sv_setsv(sv,&PL_sv_undef);
79072805
LW
883 break;
884 case '+':
aaa362c4 885 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
d9f97599 886 paren = rx->lastparen;
a0d0e21e
LW
887 if (paren)
888 goto getparen;
79072805 889 }
3280af22 890 sv_setsv(sv,&PL_sv_undef);
79072805 891 break;
a01268b5
JH
892 case '\016': /* ^N */
893 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
894 paren = rx->lastcloseparen;
895 if (paren)
896 goto getparen;
897 }
898 sv_setsv(sv,&PL_sv_undef);
899 break;
79072805 900 case '`':
aaa362c4 901 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
cf93c79d
IZ
902 if ((s = rx->subbeg) && rx->startp[0] != -1) {
903 i = rx->startp[0];
13f57bf8 904 goto getrx;
79072805 905 }
79072805 906 }
3280af22 907 sv_setsv(sv,&PL_sv_undef);
79072805
LW
908 break;
909 case '\'':
aaa362c4 910 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
cf93c79d
IZ
911 if (rx->subbeg && rx->endp[0] != -1) {
912 s = rx->subbeg + rx->endp[0];
913 i = rx->sublen - rx->endp[0];
13f57bf8 914 goto getrx;
79072805 915 }
79072805 916 }
3280af22 917 sv_setsv(sv,&PL_sv_undef);
79072805
LW
918 break;
919 case '.':
3280af22 920 if (GvIO(PL_last_in_gv)) {
357c8808 921 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
79072805 922 }
79072805
LW
923 break;
924 case '?':
809a5acc 925 {
809a5acc 926 sv_setiv(sv, (IV)STATUS_CURRENT);
ff0cee69 927#ifdef COMPLEX_STATUS
6b88bc9c
GS
928 LvTARGOFF(sv) = PL_statusvalue;
929 LvTARGLEN(sv) = PL_statusvalue_vms;
ff0cee69 930#endif
809a5acc 931 }
79072805
LW
932 break;
933 case '^':
0daa599b
RGS
934 if (GvIOp(PL_defoutgv))
935 s = IoTOP_NAME(GvIOp(PL_defoutgv));
79072805
LW
936 if (s)
937 sv_setpv(sv,s);
938 else {
3280af22 939 sv_setpv(sv,GvENAME(PL_defoutgv));
79072805
LW
940 sv_catpv(sv,"_TOP");
941 }
942 break;
943 case '~':
0daa599b
RGS
944 if (GvIOp(PL_defoutgv))
945 s = IoFMT_NAME(GvIOp(PL_defoutgv));
79072805 946 if (!s)
3280af22 947 s = GvENAME(PL_defoutgv);
79072805
LW
948 sv_setpv(sv,s);
949 break;
79072805 950 case '=':
0daa599b
RGS
951 if (GvIOp(PL_defoutgv))
952 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
79072805
LW
953 break;
954 case '-':
0daa599b
RGS
955 if (GvIOp(PL_defoutgv))
956 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
79072805
LW
957 break;
958 case '%':
0daa599b
RGS
959 if (GvIOp(PL_defoutgv))
960 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
79072805 961 break;
79072805
LW
962 case ':':
963 break;
964 case '/':
965 break;
966 case '[':
fc15ae8f 967 WITH_THR(sv_setiv(sv, (IV)CopARYBASE_get(PL_curcop)));
79072805
LW
968 break;
969 case '|':
0daa599b
RGS
970 if (GvIOp(PL_defoutgv))
971 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
79072805
LW
972 break;
973 case ',':
79072805
LW
974 break;
975 case '\\':
b2ce0fda 976 if (PL_ors_sv)
f28098ff 977 sv_copypv(sv, PL_ors_sv);
79072805 978 break;
79072805 979 case '!':
a5f75d66 980#ifdef VMS
65202027 981 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
88e89b8a 982 sv_setpv(sv, errno ? Strerror(errno) : "");
a5f75d66 983#else
88e89b8a 984 {
8772537c 985 const int saveerrno = errno;
65202027 986 sv_setnv(sv, (NV)errno);
88e89b8a 987#ifdef OS2
ed344e4f
IZ
988 if (errno == errno_isOS2 || errno == errno_isOS2_set)
989 sv_setpv(sv, os2error(Perl_rc));
88e89b8a 990 else
a5f75d66 991#endif
2304df62 992 sv_setpv(sv, errno ? Strerror(errno) : "");
88e89b8a
PP
993 errno = saveerrno;
994 }
995#endif
ad3296c6 996 SvRTRIM(sv);
946ec16e 997 SvNOK_on(sv); /* what a wonderful hack! */
79072805
LW
998 break;
999 case '<':
3280af22 1000 sv_setiv(sv, (IV)PL_uid);
79072805
LW
1001 break;
1002 case '>':
3280af22 1003 sv_setiv(sv, (IV)PL_euid);
79072805
LW
1004 break;
1005 case '(':
3280af22 1006 sv_setiv(sv, (IV)PL_gid);
79072805
LW
1007 goto add_groups;
1008 case ')':
3280af22 1009 sv_setiv(sv, (IV)PL_egid);
79072805 1010 add_groups:
79072805 1011#ifdef HAS_GETGROUPS
79072805 1012 {
57d7c65e 1013 Groups_t *gary = NULL;
fb45abb2 1014 I32 i, num_groups = getgroups(0, gary);
57d7c65e
JC
1015 Newx(gary, num_groups, Groups_t);
1016 num_groups = getgroups(num_groups, gary);
fb45abb2
GA
1017 for (i = 0; i < num_groups; i++)
1018 Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]);
57d7c65e 1019 Safefree(gary);
79072805 1020 }
155aba94 1021 (void)SvIOK_on(sv); /* what a wonderful hack! */
cd70abae 1022#endif
79072805 1023 break;
cd39f2b6 1024#ifndef MACOS_TRADITIONAL
79072805
LW
1025 case '0':
1026 break;
cd39f2b6 1027#endif
79072805 1028 }
a0d0e21e 1029 return 0;
79072805
LW
1030}
1031
1032int
864dbfa3 1033Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
79072805 1034{
8772537c 1035 struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
79072805
LW
1036
1037 if (uf && uf->uf_val)
24f81a43 1038 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
79072805
LW
1039 return 0;
1040}
1041
1042int
864dbfa3 1043Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
79072805 1044{
27da23d5 1045 dVAR;
9ae3433d
RGS
1046 STRLEN len = 0, klen;
1047 const char *s = SvOK(sv) ? SvPV_const(sv,len) : "";
fabdb6c0 1048 const char * const ptr = MgPV_const(mg,klen);
88e89b8a 1049 my_setenv(ptr, s);
1e422769 1050
a0d0e21e
LW
1051#ifdef DYNAMIC_ENV_FETCH
1052 /* We just undefd an environment var. Is a replacement */
1053 /* waiting in the wings? */
1054 if (!len) {
fabdb6c0
AL
1055 SV ** const valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE);
1056 if (valp)
4ab59fcc 1057 s = SvOK(*valp) ? SvPV_const(*valp, len) : "";
a0d0e21e
LW
1058 }
1059#endif
1e422769 1060
39e571d4 1061#if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
79072805
LW
1062 /* And you'll never guess what the dog had */
1063 /* in its mouth... */
3280af22 1064 if (PL_tainting) {
1e422769
PP
1065 MgTAINTEDDIR_off(mg);
1066#ifdef VMS
5aabfad6 1067 if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
b8ffc8df 1068 char pathbuf[256], eltbuf[256], *cp, *elt;
c623ac67 1069 Stat_t sbuf;
1e422769
PP
1070 int i = 0, j = 0;
1071
b8ffc8df
RGS
1072 strncpy(eltbuf, s, 255);
1073 eltbuf[255] = 0;
1074 elt = eltbuf;
1e422769
PP
1075 do { /* DCL$PATH may be a search list */
1076 while (1) { /* as may dev portion of any element */
1077 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1078 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1079 cando_by_name(S_IWUSR,0,elt) ) {
1080 MgTAINTEDDIR_on(mg);
1081 return 0;
1082 }
1083 }
bd61b366 1084 if ((cp = strchr(elt, ':')) != NULL)
1e422769
PP
1085 *cp = '\0';
1086 if (my_trnlnm(elt, eltbuf, j++))
1087 elt = eltbuf;
1088 else
1089 break;
1090 }
1091 j = 0;
1092 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1093 }
1094#endif /* VMS */
5aabfad6 1095 if (s && klen == 4 && strEQ(ptr,"PATH")) {
8772537c 1096 const char * const strend = s + len;
463ee0b2
LW
1097
1098 while (s < strend) {
96827780 1099 char tmpbuf[256];
c623ac67 1100 Stat_t st;
5f74f29c 1101 I32 i;
96827780 1102 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
fc36a67e 1103 s, strend, ':', &i);
463ee0b2 1104 s++;
bb7a0f54 1105 if (i >= (I32)sizeof tmpbuf /* too long -- assume the worst */
96827780 1106 || *tmpbuf != '/'
c6ed36e1 1107 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
8990e307 1108 MgTAINTEDDIR_on(mg);
1e422769
PP
1109 return 0;
1110 }
463ee0b2 1111 }
79072805
LW
1112 }
1113 }
39e571d4 1114#endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1e422769 1115
79072805
LW
1116 return 0;
1117}
1118
1119int
864dbfa3 1120Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
85e6fe83 1121{
8772537c 1122 PERL_UNUSED_ARG(sv);
bd61b366 1123 my_setenv(MgPV_nolen_const(mg),NULL);
85e6fe83
LW
1124 return 0;
1125}
1126
88e89b8a 1127int
864dbfa3 1128Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
fb73857a 1129{
97aff369 1130 dVAR;
65e66c80 1131 PERL_UNUSED_ARG(mg);
b0269e46 1132#if defined(VMS)
cea2e8a9 1133 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
fb73857a 1134#else
3280af22 1135 if (PL_localizing) {
fb73857a 1136 HE* entry;
b0269e46 1137 my_clearenv();
fb73857a 1138 hv_iterinit((HV*)sv);
155aba94 1139 while ((entry = hv_iternext((HV*)sv))) {
fb73857a
PP
1140 I32 keylen;
1141 my_setenv(hv_iterkey(entry, &keylen),
b83604b4 1142 SvPV_nolen_const(hv_iterval((HV*)sv, entry)));
fb73857a
PP
1143 }
1144 }
1145#endif
1146 return 0;
1147}
1148
1149int
864dbfa3 1150Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
66b1d557 1151{
27da23d5 1152 dVAR;
8772537c
AL
1153 PERL_UNUSED_ARG(sv);
1154 PERL_UNUSED_ARG(mg);
b0269e46
AB
1155#if defined(VMS)
1156 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1157#else
1158 my_clearenv();
1159#endif
3e3baf6d 1160 return 0;
66b1d557
HM
1161}
1162
64ca3a65 1163#ifndef PERL_MICRO
2d4fcd5e
AJ
1164#ifdef HAS_SIGPROCMASK
1165static void
1166restore_sigmask(pTHX_ SV *save_sv)
1167{
0bd48802 1168 const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
2d4fcd5e
AJ
1169 (void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0);
1170}
1171#endif
66b1d557 1172int
864dbfa3 1173Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
88e89b8a 1174{
97aff369 1175 dVAR;
88e89b8a 1176 /* Are we fetching a signal entry? */
8772537c 1177 const I32 i = whichsig(MgPV_nolen_const(mg));
e02bfb16 1178 if (i > 0) {
22c35a8c
GS
1179 if(PL_psig_ptr[i])
1180 sv_setsv(sv,PL_psig_ptr[i]);
88e89b8a 1181 else {
46da273f 1182 Sighandler_t sigstate = rsignal_state(i);
23ada85b 1183#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
46da273f
AL
1184 if (PL_sig_handlers_initted && PL_sig_ignoring[i])
1185 sigstate = SIG_IGN;
2e34cc90
CL
1186#endif
1187#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
46da273f
AL
1188 if (PL_sig_handlers_initted && PL_sig_defaulting[i])
1189 sigstate = SIG_DFL;
85b332e2 1190#endif
88e89b8a 1191 /* cache state so we don't fetch it again */
8aad04aa 1192 if(sigstate == (Sighandler_t) SIG_IGN)
88e89b8a
PP
1193 sv_setpv(sv,"IGNORE");
1194 else
3280af22 1195 sv_setsv(sv,&PL_sv_undef);
46da273f 1196 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
88e89b8a
PP
1197 SvTEMP_off(sv);
1198 }
1199 }
1200 return 0;
1201}
1202int
864dbfa3 1203Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
88e89b8a 1204{
2d4fcd5e
AJ
1205 /* XXX Some of this code was copied from Perl_magic_setsig. A little
1206 * refactoring might be in order.
1207 */
27da23d5 1208 dVAR;
8772537c
AL
1209 register const char * const s = MgPV_nolen_const(mg);
1210 PERL_UNUSED_ARG(sv);
2d4fcd5e 1211 if (*s == '_') {
cbbf8932 1212 SV** svp = NULL;
2d4fcd5e
AJ
1213 if (strEQ(s,"__DIE__"))
1214 svp = &PL_diehook;
1215 else if (strEQ(s,"__WARN__"))
1216 svp = &PL_warnhook;
1217 else
1218 Perl_croak(aTHX_ "No such hook: %s", s);
27da23d5 1219 if (svp && *svp) {
8772537c 1220 SV * const to_dec = *svp;
cbbf8932 1221 *svp = NULL;
2d4fcd5e
AJ
1222 SvREFCNT_dec(to_dec);
1223 }
1224 }
1225 else {
2d4fcd5e 1226 /* Are we clearing a signal entry? */
8772537c 1227 const I32 i = whichsig(s);
e02bfb16 1228 if (i > 0) {
2d4fcd5e
AJ
1229#ifdef HAS_SIGPROCMASK
1230 sigset_t set, save;
1231 SV* save_sv;
1232 /* Avoid having the signal arrive at a bad time, if possible. */
1233 sigemptyset(&set);
1234 sigaddset(&set,i);
1235 sigprocmask(SIG_BLOCK, &set, &save);
1236 ENTER;
1237 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1238 SAVEFREESV(save_sv);
1239 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1240#endif
1241 PERL_ASYNC_CHECK();
1242#if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
27da23d5 1243 if (!PL_sig_handlers_initted) Perl_csighandler_init();
2d4fcd5e
AJ
1244#endif
1245#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
27da23d5 1246 PL_sig_defaulting[i] = 1;
5c1546dc 1247 (void)rsignal(i, PL_csighandlerp);
2d4fcd5e 1248#else
8aad04aa 1249 (void)rsignal(i, (Sighandler_t) SIG_DFL);
2d4fcd5e
AJ
1250#endif
1251 if(PL_psig_name[i]) {
1252 SvREFCNT_dec(PL_psig_name[i]);
1253 PL_psig_name[i]=0;
1254 }
1255 if(PL_psig_ptr[i]) {
6136c704 1256 SV * const to_dec=PL_psig_ptr[i];
2d4fcd5e
AJ
1257 PL_psig_ptr[i]=0;
1258 LEAVE;
1259 SvREFCNT_dec(to_dec);
1260 }
1261 else
1262 LEAVE;
1263 }
88e89b8a
PP
1264 }
1265 return 0;
1266}
3d37d572 1267
dd374669
AL
1268static void
1269S_raise_signal(pTHX_ int sig)
0a8e0eff 1270{
97aff369 1271 dVAR;
0a8e0eff
NIS
1272 /* Set a flag to say this signal is pending */
1273 PL_psig_pend[sig]++;
1274 /* And one to say _a_ signal is pending */
1275 PL_sig_pending = 1;
1276}
1277
1278Signal_t
8aad04aa
JH
1279#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1280Perl_csighandler(int sig, ...)
1281#else
0a8e0eff 1282Perl_csighandler(int sig)
8aad04aa 1283#endif
0a8e0eff 1284{
1018e26f
NIS
1285#ifdef PERL_GET_SIG_CONTEXT
1286 dTHXa(PERL_GET_SIG_CONTEXT);
1287#else
85b332e2
CL
1288 dTHX;
1289#endif
23ada85b 1290#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
5c1546dc 1291 (void) rsignal(sig, PL_csighandlerp);
27da23d5 1292 if (PL_sig_ignoring[sig]) return;
85b332e2 1293#endif
2e34cc90 1294#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
27da23d5 1295 if (PL_sig_defaulting[sig])
2e34cc90
CL
1296#ifdef KILL_BY_SIGPRC
1297 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1298#else
1299 exit(1);
1300#endif
1301#endif
4ffa73a3
JH
1302 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
1303 /* Call the perl level handler now--
1304 * with risk we may be in malloc() etc. */
1305 (*PL_sighandlerp)(sig);
1306 else
dd374669 1307 S_raise_signal(aTHX_ sig);
0a8e0eff
NIS
1308}
1309
2e34cc90
CL
1310#if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1311void
1312Perl_csighandler_init(void)
1313{
1314 int sig;
27da23d5 1315 if (PL_sig_handlers_initted) return;
2e34cc90
CL
1316
1317 for (sig = 1; sig < SIG_SIZE; sig++) {
1318#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
218fdd94 1319 dTHX;
27da23d5 1320 PL_sig_defaulting[sig] = 1;
5c1546dc 1321 (void) rsignal(sig, PL_csighandlerp);
2e34cc90
CL
1322#endif
1323#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
27da23d5 1324 PL_sig_ignoring[sig] = 0;
2e34cc90
CL
1325#endif
1326 }
27da23d5 1327 PL_sig_handlers_initted = 1;
2e34cc90
CL
1328}
1329#endif
1330
0a8e0eff
NIS
1331void
1332Perl_despatch_signals(pTHX)
1333{
97aff369 1334 dVAR;
0a8e0eff
NIS
1335 int sig;
1336 PL_sig_pending = 0;
1337 for (sig = 1; sig < SIG_SIZE; sig++) {
1338 if (PL_psig_pend[sig]) {
25da4428
JH
1339 PERL_BLOCKSIG_ADD(set, sig);
1340 PL_psig_pend[sig] = 0;
1341 PERL_BLOCKSIG_BLOCK(set);
f5203343 1342 (*PL_sighandlerp)(sig);
25da4428 1343 PERL_BLOCKSIG_UNBLOCK(set);
0a8e0eff
NIS
1344 }
1345 }
1346}
1347
85e6fe83 1348int
864dbfa3 1349Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
79072805 1350{
27da23d5 1351 dVAR;
79072805 1352 I32 i;
cbbf8932 1353 SV** svp = NULL;
2d4fcd5e
AJ
1354 /* Need to be careful with SvREFCNT_dec(), because that can have side
1355 * effects (due to closures). We must make sure that the new disposition
1356 * is in place before it is called.
1357 */
cbbf8932 1358 SV* to_dec = NULL;
e72dc28c 1359 STRLEN len;
2d4fcd5e
AJ
1360#ifdef HAS_SIGPROCMASK
1361 sigset_t set, save;
1362 SV* save_sv;
1363#endif
a0d0e21e 1364
d5263905 1365 register const char *s = MgPV_const(mg,len);
748a9306
LW
1366 if (*s == '_') {
1367 if (strEQ(s,"__DIE__"))
3280af22 1368 svp = &PL_diehook;
748a9306 1369 else if (strEQ(s,"__WARN__"))
3280af22 1370 svp = &PL_warnhook;
748a9306 1371 else
cea2e8a9 1372 Perl_croak(aTHX_ "No such hook: %s", s);
748a9306 1373 i = 0;
4633a7c4 1374 if (*svp) {
2d4fcd5e 1375 to_dec = *svp;
cbbf8932 1376 *svp = NULL;
4633a7c4 1377 }
748a9306
LW
1378 }
1379 else {
1380 i = whichsig(s); /* ...no, a brick */
86d86cad 1381 if (i <= 0) {
e476b1b5 1382 if (ckWARN(WARN_SIGNAL))
9014280d 1383 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
748a9306
LW
1384 return 0;
1385 }
2d4fcd5e
AJ
1386#ifdef HAS_SIGPROCMASK
1387 /* Avoid having the signal arrive at a bad time, if possible. */
1388 sigemptyset(&set);
1389 sigaddset(&set,i);
1390 sigprocmask(SIG_BLOCK, &set, &save);
1391 ENTER;
1392 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1393 SAVEFREESV(save_sv);
1394 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1395#endif
1396 PERL_ASYNC_CHECK();
2e34cc90 1397#if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
27da23d5 1398 if (!PL_sig_handlers_initted) Perl_csighandler_init();
2e34cc90 1399#endif
23ada85b 1400#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
27da23d5 1401 PL_sig_ignoring[i] = 0;
85b332e2 1402#endif
2e34cc90 1403#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
27da23d5 1404 PL_sig_defaulting[i] = 0;
2e34cc90 1405#endif
22c35a8c 1406 SvREFCNT_dec(PL_psig_name[i]);
2d4fcd5e 1407 to_dec = PL_psig_ptr[i];
46da273f 1408 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
88e89b8a 1409 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
e72dc28c 1410 PL_psig_name[i] = newSVpvn(s, len);
22c35a8c 1411 SvREADONLY_on(PL_psig_name[i]);
748a9306 1412 }
a0d0e21e 1413 if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
2d4fcd5e 1414 if (i) {
5c1546dc 1415 (void)rsignal(i, PL_csighandlerp);
2d4fcd5e
AJ
1416#ifdef HAS_SIGPROCMASK
1417 LEAVE;
1418#endif
1419 }
748a9306 1420 else
b37c2d43 1421 *svp = SvREFCNT_inc_simple_NN(sv);
2d4fcd5e
AJ
1422 if(to_dec)
1423 SvREFCNT_dec(to_dec);
a0d0e21e
LW
1424 return 0;
1425 }
e72dc28c 1426 s = SvPV_force(sv,len);
748a9306 1427 if (strEQ(s,"IGNORE")) {
85b332e2 1428 if (i) {
23ada85b 1429#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
27da23d5 1430 PL_sig_ignoring[i] = 1;
5c1546dc 1431 (void)rsignal(i, PL_csighandlerp);
85b332e2 1432#else
8aad04aa 1433 (void)rsignal(i, (Sighandler_t) SIG_IGN);
85b332e2 1434#endif
2d4fcd5e 1435 }
748a9306
LW
1436 }
1437 else if (strEQ(s,"DEFAULT") || !*s) {
1438 if (i)
2e34cc90
CL
1439#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1440 {
27da23d5 1441 PL_sig_defaulting[i] = 1;
5c1546dc 1442 (void)rsignal(i, PL_csighandlerp);
2e34cc90
CL
1443 }
1444#else
8aad04aa 1445 (void)rsignal(i, (Sighandler_t) SIG_DFL);
2e34cc90 1446#endif
748a9306 1447 }
79072805 1448 else {
5aabfad6
PP
1449 /*
1450 * We should warn if HINT_STRICT_REFS, but without
1451 * access to a known hint bit in a known OP, we can't
1452 * tell whether HINT_STRICT_REFS is in force or not.
1453 */
46fc3d4c 1454 if (!strchr(s,':') && !strchr(s,'\''))
89529cee 1455 Perl_sv_insert(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"));
748a9306 1456 if (i)
5c1546dc 1457 (void)rsignal(i, PL_csighandlerp);
748a9306 1458 else
46da273f 1459 *svp = SvREFCNT_inc_simple_NN(sv);
79072805 1460 }
2d4fcd5e
AJ
1461#ifdef HAS_SIGPROCMASK
1462 if(i)
1463 LEAVE;
1464#endif
1465 if(to_dec)
1466 SvREFCNT_dec(to_dec);
79072805
LW
1467 return 0;
1468}
64ca3a65 1469#endif /* !PERL_MICRO */
79072805
LW
1470
1471int
864dbfa3 1472Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
79072805 1473{
97aff369 1474 dVAR;
8772537c
AL
1475 PERL_UNUSED_ARG(sv);
1476 PERL_UNUSED_ARG(mg);
3280af22 1477 PL_sub_generation++;
463ee0b2
LW
1478 return 0;
1479}
1480
1481int
864dbfa3 1482Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
463ee0b2 1483{
97aff369 1484 dVAR;
8772537c
AL
1485 PERL_UNUSED_ARG(sv);
1486 PERL_UNUSED_ARG(mg);
a0d0e21e 1487 /* HV_badAMAGIC_on(Sv_STASH(sv)); */
3280af22 1488 PL_amagic_generation++;
463ee0b2 1489
a0d0e21e
LW
1490 return 0;
1491}
463ee0b2 1492
946ec16e 1493int
864dbfa3 1494Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
6ff81951 1495{
dd374669 1496 HV * const hv = (HV*)LvTARG(sv);
6ff81951 1497 I32 i = 0;
8772537c 1498 PERL_UNUSED_ARG(mg);
7719e241 1499
6ff81951 1500 if (hv) {
497b47a8
JH
1501 (void) hv_iterinit(hv);
1502 if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
1503 i = HvKEYS(hv);
1504 else {
1505 while (hv_iternext(hv))
1506 i++;
1507 }
6ff81951
GS
1508 }
1509
1510 sv_setiv(sv, (IV)i);
1511 return 0;
1512}
1513
1514int
864dbfa3 1515Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
946ec16e 1516{
8772537c 1517 PERL_UNUSED_ARG(mg);
946ec16e
PP
1518 if (LvTARG(sv)) {
1519 hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
946ec16e
PP
1520 }
1521 return 0;
ac27b0f5 1522}
946ec16e 1523
e336de0d 1524/* caller is responsible for stack switching/cleanup */
565764a8 1525STATIC int
e1ec3a88 1526S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV *val)
a0d0e21e 1527{
97aff369 1528 dVAR;
a0d0e21e 1529 dSP;
463ee0b2 1530
924508f0
GS
1531 PUSHMARK(SP);
1532 EXTEND(SP, n);
33c27489 1533 PUSHs(SvTIED_obj(sv, mg));
ac27b0f5 1534 if (n > 1) {
93965878 1535 if (mg->mg_ptr) {
565764a8 1536 if (mg->mg_len >= 0)
79cb57f6 1537 PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len)));
565764a8 1538 else if (mg->mg_len == HEf_SVKEY)
93965878
NIS
1539 PUSHs((SV*)mg->mg_ptr);
1540 }
14befaf4 1541 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
565764a8 1542 PUSHs(sv_2mortal(newSViv(mg->mg_len)));
93965878
NIS
1543 }
1544 }
1545 if (n > 2) {
1546 PUSHs(val);
88e89b8a 1547 }
463ee0b2
LW
1548 PUTBACK;
1549
864dbfa3 1550 return call_method(meth, flags);
946ec16e
PP
1551}
1552
76e3520e 1553STATIC int
e1ec3a88 1554S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
a0d0e21e 1555{
27da23d5 1556 dVAR; dSP;
463ee0b2 1557
a0d0e21e
LW
1558 ENTER;
1559 SAVETMPS;
e788e7d3 1560 PUSHSTACKi(PERLSI_MAGIC);
463ee0b2 1561
33c27489 1562 if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
3280af22 1563 sv_setsv(sv, *PL_stack_sp--);
93965878 1564 }
463ee0b2 1565
d3acc0f7 1566 POPSTACK;
a0d0e21e
LW
1567 FREETMPS;
1568 LEAVE;
1569 return 0;
1570}
463ee0b2 1571
a0d0e21e 1572int
864dbfa3 1573Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e 1574{
a0d0e21e
LW
1575 if (mg->mg_ptr)
1576 mg->mg_flags |= MGf_GSKIP;
58f82c5c 1577 magic_methpack(sv,mg,"FETCH");
463ee0b2
LW
1578 return 0;
1579}
1580
1581int
864dbfa3 1582Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
e336de0d 1583{
27da23d5 1584 dVAR; dSP;
a60c0954 1585 ENTER;
e788e7d3 1586 PUSHSTACKi(PERLSI_MAGIC);
33c27489 1587 magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
d3acc0f7 1588 POPSTACK;
a60c0954 1589 LEAVE;
463ee0b2
LW
1590 return 0;
1591}
1592
1593int
864dbfa3 1594Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
463ee0b2 1595{
a0d0e21e
LW
1596 return magic_methpack(sv,mg,"DELETE");
1597}
463ee0b2 1598
93965878
NIS
1599
1600U32
864dbfa3 1601Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
ac27b0f5 1602{
27da23d5 1603 dVAR; dSP;
93965878
NIS
1604 U32 retval = 0;
1605
1606 ENTER;
1607 SAVETMPS;
e788e7d3 1608 PUSHSTACKi(PERLSI_MAGIC);
33c27489 1609 if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
3280af22 1610 sv = *PL_stack_sp--;
a60c0954 1611 retval = (U32) SvIV(sv)-1;
93965878 1612 }
d3acc0f7 1613 POPSTACK;
93965878
NIS
1614 FREETMPS;
1615 LEAVE;
1616 return retval;
1617}
1618
cea2e8a9
GS
1619int
1620Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e 1621{
27da23d5 1622 dVAR; dSP;
463ee0b2 1623
e336de0d 1624 ENTER;
e788e7d3 1625 PUSHSTACKi(PERLSI_MAGIC);
924508f0 1626 PUSHMARK(SP);
33c27489 1627 XPUSHs(SvTIED_obj(sv, mg));
463ee0b2 1628 PUTBACK;
864dbfa3 1629 call_method("CLEAR", G_SCALAR|G_DISCARD);
d3acc0f7 1630 POPSTACK;
a60c0954 1631 LEAVE;
a3bcc51e 1632
463ee0b2
LW
1633 return 0;
1634}
1635
1636int
864dbfa3 1637Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
463ee0b2 1638{
27da23d5 1639 dVAR; dSP;
35a4481c 1640 const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
463ee0b2
LW
1641
1642 ENTER;
a0d0e21e 1643 SAVETMPS;
e788e7d3 1644 PUSHSTACKi(PERLSI_MAGIC);
924508f0
GS
1645 PUSHMARK(SP);
1646 EXTEND(SP, 2);
33c27489 1647 PUSHs(SvTIED_obj(sv, mg));
463ee0b2
LW
1648 if (SvOK(key))
1649 PUSHs(key);
1650 PUTBACK;
1651
864dbfa3 1652 if (call_method(meth, G_SCALAR))
3280af22 1653 sv_setsv(key, *PL_stack_sp--);
463ee0b2 1654
d3acc0f7 1655 POPSTACK;
a0d0e21e
LW
1656 FREETMPS;
1657 LEAVE;
79072805
LW
1658 return 0;
1659}
1660
1661int
864dbfa3 1662Perl_magic_existspack(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e
LW
1663{
1664 return magic_methpack(sv,mg,"EXISTS");
ac27b0f5 1665}
a0d0e21e 1666
a3bcc51e
TP
1667SV *
1668Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1669{
27da23d5 1670 dVAR; dSP;
5fcbf73d 1671 SV *retval;
8772537c
AL
1672 SV * const tied = SvTIED_obj((SV*)hv, mg);
1673 HV * const pkg = SvSTASH((SV*)SvRV(tied));
a3bcc51e
TP
1674
1675 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1676 SV *key;
bfcb3514 1677 if (HvEITER_get(hv))
a3bcc51e
TP
1678 /* we are in an iteration so the hash cannot be empty */
1679 return &PL_sv_yes;
1680 /* no xhv_eiter so now use FIRSTKEY */
1681 key = sv_newmortal();
1682 magic_nextpack((SV*)hv, mg, key);
bfcb3514 1683 HvEITER_set(hv, NULL); /* need to reset iterator */
a3bcc51e
TP
1684 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1685 }
1686
1687 /* there is a SCALAR method that we can call */
1688 ENTER;
1689 PUSHSTACKi(PERLSI_MAGIC);
1690 PUSHMARK(SP);
1691 EXTEND(SP, 1);
1692 PUSHs(tied);
1693 PUTBACK;
1694
1695 if (call_method("SCALAR", G_SCALAR))
1696 retval = *PL_stack_sp--;
5fcbf73d
AL
1697 else
1698 retval = &PL_sv_undef;
a3bcc51e
TP
1699 POPSTACK;
1700 LEAVE;
1701 return retval;
1702}
1703
a0d0e21e 1704int
864dbfa3 1705Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
79072805 1706{
97aff369 1707 dVAR;
8772537c
AL
1708 GV * const gv = PL_DBline;
1709 const I32 i = SvTRUE(sv);
1710 SV ** const svp = av_fetch(GvAV(gv),
01b8bcb7 1711 atoi(MgPV_nolen_const(mg)), FALSE);
8772537c
AL
1712 if (svp && SvIOKp(*svp)) {
1713 OP * const o = INT2PTR(OP*,SvIVX(*svp));
1714 if (o) {
1715 /* set or clear breakpoint in the relevant control op */
1716 if (i)
1717 o->op_flags |= OPf_SPECIAL;
1718 else
1719 o->op_flags &= ~OPf_SPECIAL;
1720 }
5df8de69 1721 }
79072805
LW
1722 return 0;
1723}
1724
1725int
8772537c 1726Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
79072805 1727{
97aff369 1728 dVAR;
8772537c 1729 const AV * const obj = (AV*)mg->mg_obj;
83bf042f 1730 if (obj) {
fc15ae8f 1731 sv_setiv(sv, AvFILL(obj) + CopARYBASE_get(PL_curcop));
83bf042f
NC
1732 } else {
1733 SvOK_off(sv);
1734 }
79072805
LW
1735 return 0;
1736}
1737
1738int
864dbfa3 1739Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
79072805 1740{
97aff369 1741 dVAR;
8772537c 1742 AV * const obj = (AV*)mg->mg_obj;
83bf042f 1743 if (obj) {
fc15ae8f 1744 av_fill(obj, SvIV(sv) - CopARYBASE_get(PL_curcop));
83bf042f
NC
1745 } else {
1746 if (ckWARN(WARN_MISC))
1747 Perl_warner(aTHX_ packWARN(WARN_MISC),
1748 "Attempt to set length of freed array");
1749 }
1750 return 0;
1751}
1752
1753int
1754Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
1755{
97aff369 1756 dVAR;
53c1dcc0 1757 PERL_UNUSED_ARG(sv);
94f3782b
DM
1758 /* during global destruction, mg_obj may already have been freed */
1759 if (PL_in_clean_all)
1ea47f64 1760 return 0;
94f3782b 1761
83bf042f
NC
1762 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
1763
1764 if (mg) {
1765 /* arylen scalar holds a pointer back to the array, but doesn't own a
1766 reference. Hence the we (the array) are about to go away with it
1767 still pointing at us. Clear its pointer, else it would be pointing
1768 at free memory. See the comment in sv_magic about reference loops,
1769 and why it can't own a reference to us. */
1770 mg->mg_obj = 0;
1771 }
a0d0e21e
LW
1772 return 0;
1773}
1774
1775int
864dbfa3 1776Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e 1777{
97aff369 1778 dVAR;
8772537c 1779 SV* const lsv = LvTARG(sv);
3881461a 1780 PERL_UNUSED_ARG(mg);
ac27b0f5 1781
a0d0e21e 1782 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
3881461a
AL
1783 MAGIC * const found = mg_find(lsv, PERL_MAGIC_regex_global);
1784 if (found && found->mg_len >= 0) {
1785 I32 i = found->mg_len;
7e2040f0 1786 if (DO_UTF8(lsv))
a0ed51b3 1787 sv_pos_b2u(lsv, &i);
fc15ae8f 1788 sv_setiv(sv, i + CopARYBASE_get(PL_curcop));
a0d0e21e
LW
1789 return 0;
1790 }
1791 }
0c34ef67 1792 SvOK_off(sv);
a0d0e21e
LW
1793 return 0;
1794}
1795
1796int
864dbfa3 1797Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e 1798{
97aff369 1799 dVAR;
8772537c 1800 SV* const lsv = LvTARG(sv);
a0d0e21e
LW
1801 SSize_t pos;
1802 STRLEN len;
c00206c8 1803 STRLEN ulen = 0;
3881461a 1804 MAGIC *found;
a0d0e21e 1805
3881461a 1806 PERL_UNUSED_ARG(mg);
ac27b0f5 1807
a0d0e21e 1808 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
3881461a
AL
1809 found = mg_find(lsv, PERL_MAGIC_regex_global);
1810 else
1811 found = NULL;
1812 if (!found) {
a0d0e21e
LW
1813 if (!SvOK(sv))
1814 return 0;
d83f0a82
NC
1815#ifdef PERL_OLD_COPY_ON_WRITE
1816 if (SvIsCOW(lsv))
1817 sv_force_normal_flags(lsv, 0);
1818#endif
3881461a 1819 found = sv_magicext(lsv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
d83f0a82 1820 NULL, 0);
a0d0e21e
LW
1821 }
1822 else if (!SvOK(sv)) {
3881461a 1823 found->mg_len = -1;
a0d0e21e
LW
1824 return 0;
1825 }
1826 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1827
fc15ae8f 1828 pos = SvIV(sv) - CopARYBASE_get(PL_curcop);
a0ed51b3 1829
7e2040f0 1830 if (DO_UTF8(lsv)) {
a0ed51b3
LW
1831 ulen = sv_len_utf8(lsv);
1832 if (ulen)
1833 len = ulen;
a0ed51b3
LW
1834 }
1835
a0d0e21e
LW
1836 if (pos < 0) {
1837 pos += len;
1838 if (pos < 0)
1839 pos = 0;
1840 }
eb160463 1841 else if (pos > (SSize_t)len)
a0d0e21e 1842 pos = len;
a0ed51b3
LW
1843
1844 if (ulen) {
1845 I32 p = pos;
1846 sv_pos_u2b(lsv, &p, 0);
1847 pos = p;
1848 }
727405f8 1849
3881461a
AL
1850 found->mg_len = pos;
1851 found->mg_flags &= ~MGf_MINMATCH;
a0d0e21e 1852
79072805
LW
1853 return 0;
1854}
1855
1856int
864dbfa3 1857Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg)
79072805 1858{
79072805 1859 GV* gv;
8772537c
AL
1860 PERL_UNUSED_ARG(mg);
1861
79072805
LW
1862 if (!SvOK(sv))
1863 return 0;
180488f8
NC
1864 if (SvFLAGS(sv) & SVp_SCREAM
1865 && (SvTYPE(sv) == SVt_PVGV || SvTYPE(sv) == SVt_PVGV)) {
1866 /* We're actually already a typeglob, so don't need the stuff below.
1867 */
1868 return 0;
1869 }
f776e3cd 1870 gv = gv_fetchsv(sv, GV_ADD, SVt_PVGV);
79072805
LW
1871 if (sv == (SV*)gv)
1872 return 0;
1873 if (GvGP(sv))
88e89b8a 1874 gp_free((GV*)sv);
79072805 1875 GvGP(sv) = gp_ref(GvGP(gv));
79072805
LW
1876 return 0;
1877}
1878
1879int
864dbfa3 1880Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
6ff81951
GS
1881{
1882 STRLEN len;
35a4481c 1883 SV * const lsv = LvTARG(sv);
b83604b4 1884 const char * const tmps = SvPV_const(lsv,len);
6ff81951
GS
1885 I32 offs = LvTARGOFF(sv);
1886 I32 rem = LvTARGLEN(sv);
8772537c 1887 PERL_UNUSED_ARG(mg);
6ff81951 1888
9aa983d2
JH
1889 if (SvUTF8(lsv))
1890 sv_pos_u2b(lsv, &offs, &rem);
eb160463 1891 if (offs > (I32)len)
6ff81951 1892 offs = len;
eb160463 1893 if (rem + offs > (I32)len)
6ff81951
GS
1894 rem = len - offs;
1895 sv_setpvn(sv, tmps + offs, (STRLEN)rem);
9aa983d2 1896 if (SvUTF8(lsv))
2ef4b674 1897 SvUTF8_on(sv);
6ff81951
GS
1898 return 0;
1899}
1900
1901int
864dbfa3 1902Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
79072805 1903{
97aff369 1904 dVAR;
9aa983d2 1905 STRLEN len;
5fcbf73d 1906 const char * const tmps = SvPV_const(sv, len);
dd374669 1907 SV * const lsv = LvTARG(sv);
9aa983d2
JH
1908 I32 lvoff = LvTARGOFF(sv);
1909 I32 lvlen = LvTARGLEN(sv);
8772537c 1910 PERL_UNUSED_ARG(mg);
075a4a2b 1911
1aa99e6b 1912 if (DO_UTF8(sv)) {
9aa983d2
JH
1913 sv_utf8_upgrade(lsv);
1914 sv_pos_u2b(lsv, &lvoff, &lvlen);
1915 sv_insert(lsv, lvoff, lvlen, tmps, len);
b76f3ce2 1916 LvTARGLEN(sv) = sv_len_utf8(sv);
9aa983d2
JH
1917 SvUTF8_on(lsv);
1918 }
9bf12eaf 1919 else if (lsv && SvUTF8(lsv)) {
5fcbf73d 1920 const char *utf8;
9aa983d2 1921 sv_pos_u2b(lsv, &lvoff, &lvlen);
b76f3ce2 1922 LvTARGLEN(sv) = len;
5fcbf73d
AL
1923 utf8 = (char*)bytes_to_utf8((U8*)tmps, &len);
1924 sv_insert(lsv, lvoff, lvlen, utf8, len);
1925 Safefree(utf8);
1aa99e6b 1926 }
b76f3ce2
GB
1927 else {
1928 sv_insert(lsv, lvoff, lvlen, tmps, len);
1929 LvTARGLEN(sv) = len;
1930 }
1931
1aa99e6b 1932
79072805
LW
1933 return 0;
1934}
1935
1936int
864dbfa3 1937Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
463ee0b2 1938{
97aff369 1939 dVAR;
8772537c 1940 PERL_UNUSED_ARG(sv);
27cc343c 1941 TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
463ee0b2
LW
1942 return 0;
1943}
1944
1945int
864dbfa3 1946Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
463ee0b2 1947{
97aff369 1948 dVAR;
8772537c 1949 PERL_UNUSED_ARG(sv);
0a9c116b
DM
1950 /* update taint status unless we're restoring at scope exit */
1951 if (PL_localizing != 2) {
1952 if (PL_tainted)
1953 mg->mg_len |= 1;
1954 else
1955 mg->mg_len &= ~1;
1956 }
463ee0b2
LW
1957 return 0;
1958}
1959
1960int
864dbfa3 1961Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
6ff81951 1962{
35a4481c 1963 SV * const lsv = LvTARG(sv);
8772537c 1964 PERL_UNUSED_ARG(mg);
6ff81951 1965
6136c704
AL
1966 if (lsv)
1967 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
1968 else
0c34ef67 1969 SvOK_off(sv);
6ff81951 1970
6ff81951
GS
1971 return 0;
1972}
1973
1974int
864dbfa3 1975Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
79072805 1976{
8772537c 1977 PERL_UNUSED_ARG(mg);
79072805
LW
1978 do_vecset(sv); /* XXX slurp this routine */
1979 return 0;
1980}
1981
1982int
864dbfa3 1983Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
5f05dabc 1984{
97aff369 1985 dVAR;
a0714e2c 1986 SV *targ = NULL;
5f05dabc 1987 if (LvTARGLEN(sv)) {
68dc0745 1988 if (mg->mg_obj) {
8772537c
AL
1989 SV * const ahv = LvTARG(sv);
1990 HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
6d822dc4
MS
1991 if (he)
1992 targ = HeVAL(he);
68dc0745
PP
1993 }
1994 else {
8772537c 1995 AV* const av = (AV*)LvTARG(sv);
68dc0745
PP
1996 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
1997 targ = AvARRAY(av)[LvTARGOFF(sv)];
1998 }
46da273f 1999 if (targ && (targ != &PL_sv_undef)) {
68dc0745
PP
2000 /* somebody else defined it for us */
2001 SvREFCNT_dec(LvTARG(sv));
b37c2d43 2002 LvTARG(sv) = SvREFCNT_inc_simple_NN(targ);
68dc0745
PP
2003 LvTARGLEN(sv) = 0;
2004 SvREFCNT_dec(mg->mg_obj);
a0714e2c 2005 mg->mg_obj = NULL;
68dc0745
PP
2006 mg->mg_flags &= ~MGf_REFCOUNTED;
2007 }
5f05dabc 2008 }
71be2cbc
PP
2009 else
2010 targ = LvTARG(sv);
3280af22 2011 sv_setsv(sv, targ ? targ : &PL_sv_undef);
71be2cbc
PP
2012 return 0;
2013}
2014
2015int
864dbfa3 2016Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
71be2cbc 2017{
8772537c 2018 PERL_UNUSED_ARG(mg);
71be2cbc 2019 if (LvTARGLEN(sv))
68dc0745
PP
2020 vivify_defelem(sv);
2021 if (LvTARG(sv)) {
5f05dabc 2022 sv_setsv(LvTARG(sv), sv);
68dc0745
PP
2023 SvSETMAGIC(LvTARG(sv));
2024 }
5f05dabc
PP
2025 return 0;
2026}
2027
71be2cbc 2028void
864dbfa3 2029Perl_vivify_defelem(pTHX_ SV *sv)
71be2cbc 2030{
97aff369 2031 dVAR;
74e13ce4 2032 MAGIC *mg;
a0714e2c 2033 SV *value = NULL;
71be2cbc 2034
14befaf4 2035 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
71be2cbc 2036 return;
68dc0745 2037 if (mg->mg_obj) {
8772537c
AL
2038 SV * const ahv = LvTARG(sv);
2039 HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
6d822dc4
MS
2040 if (he)
2041 value = HeVAL(he);
3280af22 2042 if (!value || value == &PL_sv_undef)
ce5030a2 2043 Perl_croak(aTHX_ PL_no_helem_sv, mg->mg_obj);
71be2cbc 2044 }
68dc0745 2045 else {
8772537c 2046 AV* const av = (AV*)LvTARG(sv);
5aabfad6 2047 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
a0714e2c 2048 LvTARG(sv) = NULL; /* array can't be extended */
68dc0745 2049 else {
d4c19fe8 2050 SV* const * const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
3280af22 2051 if (!svp || (value = *svp) == &PL_sv_undef)
cea2e8a9 2052 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
68dc0745
PP
2053 }
2054 }
b37c2d43 2055 SvREFCNT_inc_simple_void(value);
68dc0745
PP
2056 SvREFCNT_dec(LvTARG(sv));
2057 LvTARG(sv) = value;
71be2cbc 2058 LvTARGLEN(sv) = 0;
68dc0745 2059 SvREFCNT_dec(mg->mg_obj);
a0714e2c 2060 mg->mg_obj = NULL;
68dc0745 2061 mg->mg_flags &= ~MGf_REFCOUNTED;
5f05dabc
PP
2062}
2063
2064int
864dbfa3 2065Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
810b8aa5 2066{
86f55936 2067 return Perl_sv_kill_backrefs(aTHX_ sv, (AV*)mg->mg_obj);
810b8aa5
GS
2068}
2069
2070int
864dbfa3 2071Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
93a17b20 2072{
96a5add6 2073 PERL_UNUSED_CONTEXT;
565764a8 2074 mg->mg_len = -1;
c6496cc7 2075 SvSCREAM_off(sv);
93a17b20
LW
2076 return 0;
2077}
2078
2079int
864dbfa3 2080Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
79072805 2081{
8772537c 2082 PERL_UNUSED_ARG(mg);
14befaf4 2083 sv_unmagic(sv, PERL_MAGIC_bm);
79072805
LW
2084 SvVALID_off(sv);
2085 return 0;
2086}
2087
2088int
864dbfa3 2089Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
55497cff 2090{
8772537c 2091 PERL_UNUSED_ARG(mg);
14befaf4 2092 sv_unmagic(sv, PERL_MAGIC_fm);
55497cff
PP
2093 SvCOMPILED_off(sv);
2094 return 0;
2095}
2096
2097int
864dbfa3 2098Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
79072805 2099{
35a4481c 2100 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
79072805
LW
2101
2102 if (uf && uf->uf_set)
24f81a43 2103 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
79072805
LW
2104 return 0;
2105}
2106
c277df42 2107int
faf82a0b
AE
2108Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2109{
8772537c 2110 PERL_UNUSED_ARG(mg);
faf82a0b
AE
2111 sv_unmagic(sv, PERL_MAGIC_qr);
2112 return 0;
2113}
2114
2115int
864dbfa3 2116Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
c277df42 2117{
97aff369 2118 dVAR;
8772537c
AL
2119 regexp * const re = (regexp *)mg->mg_obj;
2120 PERL_UNUSED_ARG(sv);
2121
c277df42
IZ
2122 ReREFCNT_dec(re);
2123 return 0;
2124}
2125
7a4c00b4 2126#ifdef USE_LOCALE_COLLATE
79072805 2127int
864dbfa3 2128Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
bbce6d69
PP
2129{
2130 /*
838b5b74 2131 * RenE<eacute> Descartes said "I think not."
bbce6d69
PP
2132 * and vanished with a faint plop.
2133 */
96a5add6 2134 PERL_UNUSED_CONTEXT;
8772537c 2135 PERL_UNUSED_ARG(sv);
7a4c00b4
PP
2136 if (mg->mg_ptr) {
2137 Safefree(mg->mg_ptr);
2138 mg->mg_ptr = NULL;
565764a8 2139 mg->mg_len = -1;
7a4c00b4 2140 }
bbce6d69
PP
2141 return 0;
2142}
7a4c00b4 2143#endif /* USE_LOCALE_COLLATE */
bbce6d69 2144
7e8c5dac
HS
2145/* Just clear the UTF-8 cache data. */
2146int
2147Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2148{
96a5add6 2149 PERL_UNUSED_CONTEXT;
8772537c 2150 PERL_UNUSED_ARG(sv);
7e8c5dac 2151 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
3881461a 2152 mg->mg_ptr = NULL;
7e8c5dac
HS
2153 mg->mg_len = -1; /* The mg_len holds the len cache. */
2154 return 0;
2155}
2156
bbce6d69 2157int
864dbfa3 2158Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
79072805 2159{
97aff369 2160 dVAR;
e1ec3a88 2161 register const char *s;
79072805 2162 I32 i;
8990e307 2163 STRLEN len;
79072805 2164 switch (*mg->mg_ptr) {
748a9306 2165 case '\001': /* ^A */
3280af22 2166 sv_setsv(PL_bodytarget, sv);
748a9306 2167 break;
49460fe6 2168 case '\003': /* ^C */
38ab35f8 2169 PL_minus_c = (bool)SvIV(sv);
49460fe6
NIS
2170 break;
2171
79072805 2172 case '\004': /* ^D */
b4ab917c 2173#ifdef DEBUGGING
b83604b4 2174 s = SvPV_nolen_const(sv);
ddcf8bc1 2175 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
79072805 2176 DEBUG_x(dump_all());
b4ab917c 2177#else
38ab35f8 2178 PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG;
b4ab917c 2179#endif
79072805 2180 break;
28f23441 2181 case '\005': /* ^E */
d0063567 2182 if (*(mg->mg_ptr+1) == '\0') {
cd39f2b6 2183#ifdef MACOS_TRADITIONAL
38ab35f8 2184 gMacPerl_OSErr = SvIV(sv);
28f23441 2185#else
cd39f2b6 2186# ifdef VMS
38ab35f8 2187 set_vaxc_errno(SvIV(sv));
048c1ddf 2188# else
cd39f2b6 2189# ifdef WIN32
d0063567 2190 SetLastError( SvIV(sv) );
cd39f2b6 2191# else
9fed8b87 2192# ifdef OS2
38ab35f8 2193 os2_setsyserrno(SvIV(sv));
9fed8b87 2194# else
d0063567 2195 /* will anyone ever use this? */
38ab35f8 2196 SETERRNO(SvIV(sv), 4);
cd39f2b6 2197# endif
048c1ddf
IZ
2198# endif
2199# endif
22fae026 2200#endif
d0063567
DK
2201 }
2202 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2203 if (PL_encoding)
2204 SvREFCNT_dec(PL_encoding);
2205 if (SvOK(sv) || SvGMAGICAL(sv)) {
2206 PL_encoding = newSVsv(sv);
2207 }
2208 else {
a0714e2c 2209 PL_encoding = NULL;
d0063567
DK
2210 }
2211 }
2212 break;
79072805 2213 case '\006': /* ^F */
38ab35f8 2214 PL_maxsysfd = SvIV(sv);
79072805 2215 break;
a0d0e21e 2216 case '\010': /* ^H */
38ab35f8 2217 PL_hints = SvIV(sv);
a0d0e21e 2218 break;
9d116dd7 2219 case '\011': /* ^I */ /* NOT \t in EBCDIC */
43c5f42d 2220 Safefree(PL_inplace);
bd61b366 2221 PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
da78da6e 2222 break;
28f23441 2223 case '\017': /* ^O */
ac27b0f5 2224 if (*(mg->mg_ptr+1) == '\0') {
43c5f42d 2225 Safefree(PL_osname);
bd61b366 2226 PL_osname = NULL;
3511154c
DM
2227 if (SvOK(sv)) {
2228 TAINT_PROPER("assigning to $^O");
2e0de35c 2229 PL_osname = savesvpv(sv);
3511154c 2230 }
ac27b0f5
NIS
2231 }
2232 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2233 if (!PL_compiling.cop_io)
2234 PL_compiling.cop_io = newSVsv(sv);
2235 else
2236 sv_setsv(PL_compiling.cop_io,sv);
2237 }
28f23441 2238 break;
79072805 2239 case '\020': /* ^P */
38ab35f8 2240 PL_perldb = SvIV(sv);
f2a7f298 2241 if (PL_perldb && !PL_DBsingle)
1ee4443e 2242 init_debugger();
79072805
LW
2243 break;
2244 case '\024': /* ^T */
88e89b8a 2245#ifdef BIG_TIME
6b88bc9c 2246 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
88e89b8a 2247#else
38ab35f8 2248 PL_basetime = (Time_t)SvIV(sv);
88e89b8a 2249#endif
79072805 2250 break;
e07ea26a
NC
2251 case '\025': /* ^UTF8CACHE */
2252 if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
2253 PL_utf8cache = (signed char) sv_2iv(sv);
2254 }
2255 break;
fde18df1 2256 case '\027': /* ^W & $^WARNING_BITS */
4438c4b7
JH
2257 if (*(mg->mg_ptr+1) == '\0') {
2258 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
38ab35f8 2259 i = SvIV(sv);
ac27b0f5 2260 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
0453d815 2261 | (i ? G_WARN_ON : G_WARN_OFF) ;
4438c4b7 2262 }
599cee73 2263 }
0a378802 2264 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
4438c4b7 2265 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
d775746e
GS
2266 if (!SvPOK(sv) && PL_localizing) {
2267 sv_setpvn(sv, WARN_NONEstring, WARNsize);
d3a7d8c7 2268 PL_compiling.cop_warnings = pWARN_NONE;
d775746e
GS
2269 break;
2270 }
f4fc7782 2271 {
b5477537 2272 STRLEN len, i;
d3a7d8c7 2273 int accumulate = 0 ;
f4fc7782 2274 int any_fatals = 0 ;
b83604b4 2275 const char * const ptr = SvPV_const(sv, len) ;
f4fc7782
JH
2276 for (i = 0 ; i < len ; ++i) {
2277 accumulate |= ptr[i] ;
2278 any_fatals |= (ptr[i] & 0xAA) ;
2279 }
d3a7d8c7
GS
2280 if (!accumulate)
2281 PL_compiling.cop_warnings = pWARN_NONE;
72dc9ed5
NC
2282 /* Yuck. I can't see how to abstract this: */
2283 else if (isWARN_on(((STRLEN *)SvPV_nolen_const(sv)) - 1,
2284 WARN_ALL) && !any_fatals) {
f4fc7782
JH
2285 PL_compiling.cop_warnings = pWARN_ALL;
2286 PL_dowarn |= G_WARN_ONCE ;
727405f8 2287 }
d3a7d8c7 2288 else {
72dc9ed5
NC
2289 STRLEN len;
2290 const char *const p = SvPV_const(sv, len);
2291
2292 PL_compiling.cop_warnings
8ee4cf24 2293 = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
72dc9ed5
NC
2294 p, len);
2295
d3a7d8c7
GS
2296 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2297 PL_dowarn |= G_WARN_ONCE ;
2298 }
f4fc7782 2299
d3a7d8c7 2300 }
4438c4b7 2301 }
971a9dd3 2302 }
79072805
LW
2303 break;
2304 case '.':
3280af22
NIS
2305 if (PL_localizing) {
2306 if (PL_localizing == 1)
7766f137 2307 SAVESPTR(PL_last_in_gv);
748a9306 2308 }
3280af22 2309 else if (SvOK(sv) && GvIO(PL_last_in_gv))
632db599 2310 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
79072805
LW
2311 break;
2312 case '^':
3280af22 2313 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
e1ec3a88 2314 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
f776e3cd 2315 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
79072805
LW
2316 break;
2317 case '~':
3280af22 2318 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
e1ec3a88 2319 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
f776e3cd 2320 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
79072805
LW
2321 break;
2322 case '=':
38ab35f8 2323 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
79072805
LW
2324 break;
2325 case '-':
38ab35f8 2326 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
3280af22
NIS
2327 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2328 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
79072805
LW
2329 break;
2330 case '%':
38ab35f8 2331 IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
79072805
LW
2332 break;
2333 case '|':
4b65379b 2334 {
8772537c 2335 IO * const io = GvIOp(PL_defoutgv);
720f287d
AB
2336 if(!io)
2337 break;
38ab35f8 2338 if ((SvIV(sv)) == 0)
4b65379b
CS
2339 IoFLAGS(io) &= ~IOf_FLUSH;
2340 else {
2341 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2342 PerlIO *ofp = IoOFP(io);
2343 if (ofp)
2344 (void)PerlIO_flush(ofp);
2345 IoFLAGS(io) |= IOf_FLUSH;
2346 }
2347 }
79072805
LW
2348 }
2349 break;
79072805 2350 case '/':
3280af22 2351 SvREFCNT_dec(PL_rs);
8bfdd7d9 2352 PL_rs = newSVsv(sv);
79072805
LW
2353 break;
2354 case '\\':
7889fe52
NIS
2355 if (PL_ors_sv)
2356 SvREFCNT_dec(PL_ors_sv);
009c130f 2357 if (SvOK(sv) || SvGMAGICAL(sv)) {
7889fe52 2358 PL_ors_sv = newSVsv(sv);
009c130f 2359 }
e3c19b7b 2360 else {
a0714e2c 2361 PL_ors_sv = NULL;
e3c19b7b 2362 }
79072805
LW
2363 break;
2364 case ',':
7889fe52
NIS
2365 if (PL_ofs_sv)
2366 SvREFCNT_dec(PL_ofs_sv);
2367 if (SvOK(sv) || SvGMAGICAL(sv)) {
2368 PL_ofs_sv = newSVsv(sv);
2369 }
2370 else {
a0714e2c 2371 PL_ofs_sv = NULL;
7889fe52 2372 }
79072805 2373 break;
79072805 2374 case '[':
38ab35f8 2375 CopARYBASE_set(&PL_compiling, SvIV(sv));
79072805
LW
2376 break;
2377 case '?':
ff0cee69 2378#ifdef COMPLEX_STATUS
6b88bc9c
GS
2379 if (PL_localizing == 2) {
2380 PL_statusvalue = LvTARGOFF(sv);
2381 PL_statusvalue_vms = LvTARGLEN(sv);
ff0cee69
PP
2382 }
2383 else
2384#endif
2385#ifdef VMSISH_STATUS
2386 if (VMSISH_STATUS)
fb38d079 2387 STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
ff0cee69
PP
2388 else
2389#endif
38ab35f8 2390 STATUS_UNIX_EXIT_SET(SvIV(sv));
79072805
LW
2391 break;
2392 case '!':
93189314
JH
2393 {
2394#ifdef VMS
2395# define PERL_VMS_BANG vaxc$errno
2396#else
2397# define PERL_VMS_BANG 0
2398#endif
91487cfc 2399 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
93189314
JH
2400 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2401 }
79072805
LW
2402 break;
2403 case '<':
38ab35f8 2404 PL_uid = SvIV(sv);
3280af22
NIS
2405 if (PL_delaymagic) {
2406 PL_delaymagic |= DM_RUID;
79072805
LW
2407 break; /* don't do magic till later */
2408 }
2409#ifdef HAS_SETRUID
b28d0864 2410 (void)setruid((Uid_t)PL_uid);
79072805
LW
2411#else
2412#ifdef HAS_SETREUID
3280af22 2413 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
748a9306 2414#else
85e6fe83 2415#ifdef HAS_SETRESUID
b28d0864 2416 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
79072805 2417#else
75870ed3 2418 if (PL_uid == PL_euid) { /* special case $< = $> */
2419#ifdef PERL_DARWIN
2420 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2421 if (PL_uid != 0 && PerlProc_getuid() == 0)
2422 (void)PerlProc_setuid(0);
2423#endif
b28d0864 2424 (void)PerlProc_setuid(PL_uid);
75870ed3 2425 } else {
d8eceb89 2426 PL_uid = PerlProc_getuid();
cea2e8a9 2427 Perl_croak(aTHX_ "setruid() not implemented");
a0d0e21e 2428 }
79072805
LW
2429#endif
2430#endif
85e6fe83 2431#endif
d8eceb89 2432 PL_uid = PerlProc_getuid();
3280af22 2433 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
79072805
LW
2434 break;
2435 case '>':
38ab35f8 2436 PL_euid = SvIV(sv);
3280af22
NIS
2437 if (PL_delaymagic) {
2438 PL_delaymagic |= DM_EUID;
79072805
LW
2439 break; /* don't do magic till later */
2440 }
2441#ifdef HAS_SETEUID
3280af22 2442 (void)seteuid((Uid_t)PL_euid);
79072805
LW
2443#else
2444#ifdef HAS_SETREUID
b28d0864 2445 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
85e6fe83
LW
2446#else
2447#ifdef HAS_SETRESUID
6b88bc9c 2448 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
79072805 2449#else
b28d0864
NIS
2450 if (PL_euid == PL_uid) /* special case $> = $< */
2451 PerlProc_setuid(PL_euid);
a0d0e21e 2452 else {
e8ee3774 2453 PL_euid = PerlProc_geteuid();
cea2e8a9 2454 Perl_croak(aTHX_ "seteuid() not implemented");
a0d0e21e 2455 }
79072805
LW
2456#endif
2457#endif
85e6fe83 2458#endif
d8eceb89 2459 PL_euid = PerlProc_geteuid();
3280af22 2460 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
79072805
LW
2461 break;
2462 case '(':
38ab35f8 2463 PL_gid = SvIV(sv);
3280af22
NIS
2464 if (PL_delaymagic) {
2465 PL_delaymagic |= DM_RGID;
79072805
LW
2466 break; /* don't do magic till later */
2467 }
2468#ifdef HAS_SETRGID
b28d0864 2469 (void)setrgid((Gid_t)PL_gid);
79072805
LW
2470#else
2471#ifdef HAS_SETREGID
3280af22 2472 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
85e6fe83
LW
2473#else
2474#ifdef HAS_SETRESGID
b28d0864 2475 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
79072805 2476#else
b28d0864
NIS
2477 if (PL_gid == PL_egid) /* special case $( = $) */
2478 (void)PerlProc_setgid(PL_gid);
748a9306 2479 else {
d8eceb89 2480 PL_gid = PerlProc_getgid();
cea2e8a9 2481 Perl_croak(aTHX_ "setrgid() not implemented");
748a9306 2482 }
79072805
LW
2483#endif
2484#endif
85e6fe83 2485#endif
d8eceb89 2486 PL_gid = PerlProc_getgid();
3280af22 2487 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
79072805
LW
2488 break;
2489 case ')':
5cd24f17
PP
2490#ifdef HAS_SETGROUPS
2491 {
b83604b4 2492 const char *p = SvPV_const(sv, len);
757f63d8
SP
2493 Groups_t *gary = NULL;
2494
2495 while (isSPACE(*p))
2496 ++p;
2497 PL_egid = Atol(p);
2498 for (i = 0; i < NGROUPS; ++i) {
2499 while (*p && !isSPACE(*p))
2500 ++p;
2501 while (isSPACE(*p))
2502 ++p;
2503 if (!*p)
2504 break;
2505 if(!gary)
2506 Newx(gary, i + 1, Groups_t);
2507 else
2508 Renew(gary, i + 1, Groups_t);
2509 gary[i] = Atol(p);
2510 }
2511 if (i)
2512 (void)setgroups(i, gary);
2513 if (gary)
2514 Safefree(gary);
5cd24f17
PP
2515 }
2516#else /* HAS_SETGROUPS */
38ab35f8 2517 PL_egid = SvIV(sv);
5cd24f17 2518#endif /* HAS_SETGROUPS */
3280af22
NIS
2519 if (PL_delaymagic) {
2520 PL_delaymagic |= DM_EGID;
79072805
LW
2521 break; /* don't do magic till later */
2522 }
2523#ifdef HAS_SETEGID
3280af22 2524 (void)setegid((Gid_t)PL_egid);
79072805
LW
2525#else
2526#ifdef HAS_SETREGID
b28d0864 2527 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
85e6fe83
LW
2528#else
2529#ifdef HAS_SETRESGID
b28d0864 2530 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
79072805 2531#else
b28d0864
NIS
2532 if (PL_egid == PL_gid) /* special case $) = $( */
2533 (void)PerlProc_setgid(PL_egid);
748a9306 2534 else {
d8eceb89 2535 PL_egid = PerlProc_getegid();
cea2e8a9 2536 Perl_croak(aTHX_ "setegid() not implemented");
748a9306 2537 }
79072805
LW
2538#endif
2539#endif
85e6fe83 2540#endif
d8eceb89 2541 PL_egid = PerlProc_getegid();
3280af22 2542 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
79072805
LW
2543 break;
2544 case ':':
2d8e6c8d 2545 PL_chopset = SvPV_force(sv,len);
79072805 2546 break;
cd39f2b6 2547#ifndef MACOS_TRADITIONAL
79072805 2548 case '0':
e2975953 2549 LOCK_DOLLARZERO_MUTEX;
4bc88a62
PS
2550#ifdef HAS_SETPROCTITLE
2551 /* The BSDs don't show the argv[] in ps(1) output, they
2552 * show a string from the process struct and provide
2553 * the setproctitle() routine to manipulate that. */
a2722ac9 2554 if (PL_origalen != 1) {
b83604b4 2555 s = SvPV_const(sv, len);
98b76f99 2556# if __FreeBSD_version > 410001
9aad2c0e 2557 /* The leading "-" removes the "perl: " prefix,
4bc88a62
PS
2558 * but not the "(perl) suffix from the ps(1)
2559 * output, because that's what ps(1) shows if the
2560 * argv[] is modified. */
6f2ad931 2561 setproctitle("-%s", s);
9aad2c0e 2562# else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
4bc88a62
PS
2563 /* This doesn't really work if you assume that
2564 * $0 = 'foobar'; will wipe out 'perl' from the $0
2565 * because in ps(1) output the result will be like
2566 * sprintf("perl: %s (perl)", s)
2567 * I guess this is a security feature:
2568 * one (a user process) cannot get rid of the original name.
2569 * --jhi */
2570 setproctitle("%s", s);
2571# endif
2572 }
2573#endif
17aa7f3d 2574#if defined(__hpux) && defined(PSTAT_SETCMD)
a2722ac9 2575 if (PL_origalen != 1) {
17aa7f3d 2576 union pstun un;
b83604b4 2577 s = SvPV_const(sv, len);
6867be6d 2578 un.pst_command = (char *)s;
17aa7f3d
JH
2579 pstat(PSTAT_SETCMD, un, len, 0, 0);
2580 }
2581#endif
2d2af554
GA
2582 if (PL_origalen > 1) {
2583 /* PL_origalen is set in perl_parse(). */
2584 s = SvPV_force(sv,len);
2585 if (len >= (STRLEN)PL_origalen-1) {
2586 /* Longer than original, will be truncated. We assume that
2587 * PL_origalen bytes are available. */
2588 Copy(s, PL_origargv[0], PL_origalen-1, char);
2589 }
2590 else {
2591 /* Shorter than original, will be padded. */
2592 Copy(s, PL_origargv[0], len, char);
2593 PL_origargv[0][len] = 0;
2594 memset(PL_origargv[0] + len + 1,
2595 /* Is the space counterintuitive? Yes.
2596 * (You were expecting \0?)
2597 * Does it work? Seems to. (In Linux 2.4.20 at least.)
2598 * --jhi */
2599 (int)' ',
2600 PL_origalen - len - 1);
2601 }
2602 PL_origargv[0][PL_origalen-1] = 0;
2603 for (i = 1; i < PL_origargc; i++)
2604 PL_origargv[i] = 0;
79072805 2605 }
e2975953 2606 UNLOCK_DOLLARZERO_MUTEX;
79072805 2607 break;
cd39f2b6 2608#endif
79072805
LW
2609 }
2610 return 0;
2611}
2612
2613I32
35a4481c 2614Perl_whichsig(pTHX_ const char *sig)
79072805 2615{
aadb217d 2616 register char* const* sigv;
96a5add6 2617 PERL_UNUSED_CONTEXT;
79072805 2618
aadb217d 2619 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
79072805 2620 if (strEQ(sig,*sigv))
aadb217d 2621 return PL_sig_num[sigv - (char* const*)PL_sig_name];
79072805
LW
2622#ifdef SIGCLD
2623 if (strEQ(sig,"CHLD"))
2624 return SIGCLD;
2625#endif
2626#ifdef SIGCHLD
2627 if (strEQ(sig,"CLD"))
2628 return SIGCHLD;
2629#endif
7f1236c0 2630 return -1;
79072805
LW
2631}
2632
ecfc5424 2633Signal_t
1e82f5a6 2634#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
8aad04aa 2635Perl_sighandler(int sig, ...)
1e82f5a6
SH
2636#else
2637Perl_sighandler(int sig)
2638#endif
79072805 2639{
1018e26f
NIS
2640#ifdef PERL_GET_SIG_CONTEXT
2641 dTHXa(PERL_GET_SIG_CONTEXT);
71d280e3 2642#else
cea2e8a9 2643 dTHX;
71d280e3 2644#endif
79072805 2645 dSP;
a0714e2c
SS
2646 GV *gv = NULL;
2647 SV *sv = NULL;
8772537c 2648 SV * const tSv = PL_Sv;
601f1833 2649 CV *cv = NULL;
533c011a 2650 OP *myop = PL_op;
84902520 2651 U32 flags = 0;
8772537c 2652 XPV * const tXpv = PL_Xpv;
71d280e3 2653
3280af22 2654 if (PL_savestack_ix + 15 <= PL_savestack_max)
84902520 2655 flags |= 1;
3280af22 2656 if (PL_markstack_ptr < PL_markstack_max - 2)
84902520 2657 flags |= 4;
3280af22 2658 if (PL_scopestack_ix < PL_scopestack_max - 3)
84902520
TB
2659 flags |= 16;
2660
727405f8 2661 if (!PL_psig_ptr[sig]) {
99ef548b 2662 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
727405f8
NIS
2663 PL_sig_name[sig]);
2664 exit(sig);
2665 }
ff0cee69 2666
84902520
TB
2667 /* Max number of items pushed there is 3*n or 4. We cannot fix
2668 infinity, so we fix 4 (in fact 5): */
2669 if (flags & 1) {
3280af22 2670 PL_savestack_ix += 5; /* Protect save in progress. */
8772537c 2671 SAVEDESTRUCTOR_X(S_unwind_handler_stack, (void*)&flags);
84902520 2672 }
ac27b0f5 2673 if (flags & 4)
3280af22 2674 PL_markstack_ptr++; /* Protect mark. */
84902520 2675 if (flags & 16)
3280af22 2676 PL_scopestack_ix += 1;
84902520 2677 /* sv_2cv is too complicated, try a simpler variant first: */
ac27b0f5 2678 if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
8772537c
AL
2679 || SvTYPE(cv) != SVt_PVCV) {
2680 HV *st;
f2c0649b 2681 cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
8772537c 2682 }
84902520 2683
a0d0e21e 2684 if (!cv || !CvROOT(cv)) {
599cee73 2685 if (ckWARN(WARN_SIGNAL))
9014280d 2686 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
22c35a8c 2687 PL_sig_name[sig], (gv ? GvENAME(gv)
00d579c5
GS
2688 : ((cv && CvGV(cv))
2689 ? GvENAME(CvGV(cv))
2690 : "__ANON__")));
2691 goto cleanup;
79072805
LW
2692 }
2693
22c35a8c 2694 if(PL_psig_name[sig]) {
b37c2d43 2695 sv = SvREFCNT_inc_NN(PL_psig_name[sig]);
84902520 2696 flags |= 64;
df3728a2 2697#if !defined(PERL_IMPLICIT_CONTEXT)
27da23d5 2698 PL_sig_sv = sv;
df3728a2 2699#endif
84902520 2700 } else {
ff0cee69 2701 sv = sv_newmortal();
22c35a8c 2702 sv_setpv(sv,PL_sig_name[sig]);
88e89b8a 2703 }
e336de0d 2704
e788e7d3 2705 PUSHSTACKi(PERLSI_SIGNAL);
924508f0 2706 PUSHMARK(SP);
79072805 2707 PUSHs(sv);
8aad04aa
JH
2708#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2709 {
2710 struct sigaction oact;
2711
2712 if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
2713 siginfo_t *sip;
2714 va_list args;
2715
2716 va_start(args, sig);
2717 sip = (siginfo_t*)va_arg(args, siginfo_t*);
2718 if (sip) {
2719 HV *sih = newHV();
2720 SV *rv = newRV_noinc((SV*)sih);
2721 /* The siginfo fields signo, code, errno, pid, uid,
2722 * addr, status, and band are defined by POSIX/SUSv3. */
2723 hv_store(sih, "signo", 5, newSViv(sip->si_signo), 0);
2724 hv_store(sih, "code", 4, newSViv(sip->si_code), 0);
79dec0f4 2725#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 2726 hv_store(sih, "errno", 5, newSViv(sip->si_errno), 0);
79dec0f4 2727 hv_store(sih, "status", 6, newSViv(sip->si_status), 0);
8aad04aa
JH
2728 hv_store(sih, "uid", 3, newSViv(sip->si_uid), 0);
2729 hv_store(sih, "pid", 3, newSViv(sip->si_pid), 0);
2730 hv_store(sih, "addr", 4, newSVuv(PTR2UV(sip->si_addr)), 0);
8aad04aa 2731 hv_store(sih, "band", 4, newSViv(sip->si_band), 0);
79dec0f4 2732#endif
8aad04aa
JH
2733 EXTEND(SP, 2);
2734 PUSHs((SV*)rv);
2735 PUSHs(newSVpv((void*)sip, sizeof(*sip)));
2736 }
b4552a27 2737
31427afe 2738 va_end(args);
8aad04aa
JH
2739 }
2740 }
2741#endif
79072805 2742 PUTBACK;
a0d0e21e 2743
1b266415 2744 call_sv((SV*)cv, G_DISCARD|G_EVAL);
79072805 2745
d3acc0f7 2746 POPSTACK;
1b266415 2747 if (SvTRUE(ERRSV)) {
1d615522 2748#ifndef PERL_MICRO
983dbef6 2749#ifdef HAS_SIGPROCMASK
1b266415
NIS
2750 /* Handler "died", for example to get out of a restart-able read().
2751 * Before we re-do that on its behalf re-enable the signal which was
2752 * blocked by the system when we entered.
2753 */
2754 sigset_t set;
2755 sigemptyset(&set);
2756 sigaddset(&set,sig);
2757 sigprocmask(SIG_UNBLOCK, &set, NULL);
2758#else
2759 /* Not clear if this will work */
2760 (void)rsignal(sig, SIG_IGN);
5c1546dc 2761 (void)rsignal(sig, PL_csighandlerp);
1b266415 2762#endif
1d615522 2763#endif /* !PERL_MICRO */
bd61b366 2764 Perl_die(aTHX_ NULL);
1b266415 2765 }
00d579c5 2766cleanup:
84902520 2767 if (flags & 1)
3280af22 2768 PL_savestack_ix -= 8; /* Unprotect save in progress. */
ac27b0f5 2769 if (flags & 4)
3280af22 2770 PL_markstack_ptr--;
84902520 2771 if (flags & 16)
3280af22 2772 PL_scopestack_ix -= 1;
84902520
TB
2773 if (flags & 64)
2774 SvREFCNT_dec(sv);
533c011a 2775 PL_op = myop; /* Apparently not needed... */
ac27b0f5 2776
3280af22
NIS
2777 PL_Sv = tSv; /* Restore global temporaries. */
2778 PL_Xpv = tXpv;
53bb94e2 2779 return;
79072805 2780}
4e35701f
NIS
2781
2782
51371543 2783static void
8772537c 2784S_restore_magic(pTHX_ const void *p)
51371543 2785{
97aff369 2786 dVAR;
8772537c
AL
2787 MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
2788 SV* const sv = mgs->mgs_sv;
51371543
GS
2789
2790 if (!sv)
2791 return;
2792
2793 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2794 {
f8c7b90f 2795#ifdef PERL_OLD_COPY_ON_WRITE
f9701176
NC
2796 /* While magic was saved (and off) sv_setsv may well have seen
2797 this SV as a prime candidate for COW. */
2798 if (SvIsCOW(sv))
e424a81e 2799 sv_force_normal_flags(sv, 0);
f9701176
NC
2800#endif
2801
51371543
GS
2802 if (mgs->mgs_flags)
2803 SvFLAGS(sv) |= mgs->mgs_flags;
2804 else
2805 mg_magical(sv);
2b77b520
YST
2806 if (SvGMAGICAL(sv)) {
2807 /* downgrade public flags to private,
2808 and discard any other private flags */
2809
2810 U32 public = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
2811 if (public) {
2812 SvFLAGS(sv) &= ~( public | SVp_IOK|SVp_NOK|SVp_POK );
2813 SvFLAGS(sv) |= ( public << PRIVSHIFT );
2814 }
2815 }
51371543
GS
2816 }
2817
2818 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
2819
2820 /* If we're still on top of the stack, pop us off. (That condition
2821 * will be satisfied if restore_magic was called explicitly, but *not*
2822 * if it's being called via leave_scope.)
2823 * The reason for doing this is that otherwise, things like sv_2cv()
2824 * may leave alloc gunk on the savestack, and some code
2825 * (e.g. sighandler) doesn't expect that...
2826 */
2827 if (PL_savestack_ix == mgs->mgs_ss_ix)
2828 {
2829 I32 popval = SSPOPINT;
c76ac1ee 2830 assert(popval == SAVEt_DESTRUCTOR_X);
51371543
GS
2831 PL_savestack_ix -= 2;
2832 popval = SSPOPINT;
2833 assert(popval == SAVEt_ALLOC);
2834 popval = SSPOPINT;
2835 PL_savestack_ix -= popval;
2836 }
2837
2838}
2839
2840static void
8772537c 2841S_unwind_handler_stack(pTHX_ const void *p)
51371543 2842{
27da23d5 2843 dVAR;
e1ec3a88 2844 const U32 flags = *(const U32*)p;
51371543
GS
2845
2846 if (flags & 1)
2847 PL_savestack_ix -= 5; /* Unprotect save in progress. */
df3728a2 2848#if !defined(PERL_IMPLICIT_CONTEXT)
51371543 2849 if (flags & 64)
27da23d5 2850 SvREFCNT_dec(PL_sig_sv);
df3728a2 2851#endif
51371543 2852}
1018e26f 2853
66610fdd 2854/*
b3ca2e83
NC
2855=for apidoc magic_sethint
2856
2857Triggered by a store to %^H, records the key/value pair to
2858C<PL_compiling.cop_hints>. It is assumed that hints aren't storing anything
2859that would need a deep copy. Maybe we should warn if we find a reference.
2860
2861=cut
2862*/
2863int
2864Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
2865{
2866 dVAR;
2867 assert(mg->mg_len == HEf_SVKEY);
2868
e6e3e454
NC
2869 /* mg->mg_obj isn't being used. If needed, it would be possible to store
2870 an alternative leaf in there, with PL_compiling.cop_hints being used if
2871 it's NULL. If needed for threads, the alternative could lock a mutex,
2872 or take other more complex action. */
2873
5b9c0671
NC
2874 /* Something changed in %^H, so it will need to be restored on scope exit.
2875 Doing this here saves a lot of doing it manually in perl code (and
2876 forgetting to do it, and consequent subtle errors. */
2877 PL_hints |= HINT_LOCALIZE_HH;
b3ca2e83
NC
2878 PL_compiling.cop_hints
2879 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints,
ec2a1de7 2880 (SV *)mg->mg_ptr, sv);
b3ca2e83
NC
2881 return 0;
2882}
2883
2884/*
2885=for apidoc magic_sethint
2886
2887Triggered by a delete from %^H, records the key to C<PL_compiling.cop_hints>.
2888
2889=cut
2890*/
2891int
2892Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
2893{
2894 dVAR;
2895 assert(mg->mg_len == HEf_SVKEY);
2896
b3f24c00
MHM
2897 PERL_UNUSED_ARG(sv);
2898
5b9c0671 2899 PL_hints |= HINT_LOCALIZE_HH;
b3ca2e83
NC
2900 PL_compiling.cop_hints
2901 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints,
2902 (SV *)mg->mg_ptr, &PL_sv_placeholder);
2903 return 0;
2904}
2905
2906/*
66610fdd
RGS
2907 * Local variables:
2908 * c-indentation-style: bsd
2909 * c-basic-offset: 4
2910 * indent-tabs-mode: t
2911 * End:
2912 *
37442d52
RGS
2913 * ex: set ts=8 sts=4 sw=4 noet:
2914 */