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