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