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