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