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