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