This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Upgrade to Time::HiRes 1.72
[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);
2ddb8a4f 1916 TAINT_IF(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);
2ddb8a4f 1924 if (PL_tainted)
565764a8 1925 mg->mg_len |= 1;
748a9306 1926 else
565764a8 1927 mg->mg_len &= ~1;
463ee0b2
LW
1928 return 0;
1929}
1930
1931int
864dbfa3 1932Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
6ff81951 1933{
35a4481c 1934 SV * const lsv = LvTARG(sv);
8772537c 1935 PERL_UNUSED_ARG(mg);
6ff81951
GS
1936
1937 if (!lsv) {
0c34ef67 1938 SvOK_off(sv);
6ff81951
GS
1939 return 0;
1940 }
6ff81951 1941
81e118e0 1942 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
6ff81951
GS
1943 return 0;
1944}
1945
1946int
864dbfa3 1947Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
79072805 1948{
8772537c 1949 PERL_UNUSED_ARG(mg);
79072805
LW
1950 do_vecset(sv); /* XXX slurp this routine */
1951 return 0;
1952}
1953
1954int
864dbfa3 1955Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
5f05dabc 1956{
71be2cbc 1957 SV *targ = Nullsv;
5f05dabc 1958 if (LvTARGLEN(sv)) {
68dc0745 1959 if (mg->mg_obj) {
8772537c
AL
1960 SV * const ahv = LvTARG(sv);
1961 HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
6d822dc4
MS
1962 if (he)
1963 targ = HeVAL(he);
68dc0745
PP
1964 }
1965 else {
8772537c 1966 AV* const av = (AV*)LvTARG(sv);
68dc0745
PP
1967 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
1968 targ = AvARRAY(av)[LvTARGOFF(sv)];
1969 }
3280af22 1970 if (targ && targ != &PL_sv_undef) {
68dc0745
PP
1971 /* somebody else defined it for us */
1972 SvREFCNT_dec(LvTARG(sv));
1973 LvTARG(sv) = SvREFCNT_inc(targ);
1974 LvTARGLEN(sv) = 0;
1975 SvREFCNT_dec(mg->mg_obj);
1976 mg->mg_obj = Nullsv;
1977 mg->mg_flags &= ~MGf_REFCOUNTED;
1978 }
5f05dabc 1979 }
71be2cbc
PP
1980 else
1981 targ = LvTARG(sv);
3280af22 1982 sv_setsv(sv, targ ? targ : &PL_sv_undef);
71be2cbc
PP
1983 return 0;
1984}
1985
1986int
864dbfa3 1987Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
71be2cbc 1988{
8772537c 1989 PERL_UNUSED_ARG(mg);
71be2cbc 1990 if (LvTARGLEN(sv))
68dc0745
PP
1991 vivify_defelem(sv);
1992 if (LvTARG(sv)) {
5f05dabc 1993 sv_setsv(LvTARG(sv), sv);
68dc0745
PP
1994 SvSETMAGIC(LvTARG(sv));
1995 }
5f05dabc
PP
1996 return 0;
1997}
1998
71be2cbc 1999void
864dbfa3 2000Perl_vivify_defelem(pTHX_ SV *sv)
71be2cbc 2001{
74e13ce4
GS
2002 MAGIC *mg;
2003 SV *value = Nullsv;
71be2cbc 2004
14befaf4 2005 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
71be2cbc 2006 return;
68dc0745 2007 if (mg->mg_obj) {
8772537c
AL
2008 SV * const ahv = LvTARG(sv);
2009 HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
6d822dc4
MS
2010 if (he)
2011 value = HeVAL(he);
3280af22 2012 if (!value || value == &PL_sv_undef)
ce5030a2 2013 Perl_croak(aTHX_ PL_no_helem_sv, mg->mg_obj);
71be2cbc 2014 }
68dc0745 2015 else {
8772537c 2016 AV* const av = (AV*)LvTARG(sv);
5aabfad6 2017 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
68dc0745
PP
2018 LvTARG(sv) = Nullsv; /* array can't be extended */
2019 else {
2020 SV** svp = av_fetch(av, LvTARGOFF(sv), TRUE);
3280af22 2021 if (!svp || (value = *svp) == &PL_sv_undef)
cea2e8a9 2022 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
68dc0745
PP
2023 }
2024 }
3e3baf6d 2025 (void)SvREFCNT_inc(value);
68dc0745
PP
2026 SvREFCNT_dec(LvTARG(sv));
2027 LvTARG(sv) = value;
71be2cbc 2028 LvTARGLEN(sv) = 0;
68dc0745
PP
2029 SvREFCNT_dec(mg->mg_obj);
2030 mg->mg_obj = Nullsv;
2031 mg->mg_flags &= ~MGf_REFCOUNTED;
5f05dabc
PP
2032}
2033
2034int
864dbfa3 2035Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
810b8aa5 2036{
e15faf7d
NC
2037 AV *const av = (AV*)mg->mg_obj;
2038 SV **svp = AvARRAY(av);
8772537c 2039 PERL_UNUSED_ARG(sv);
dd374669 2040
e15faf7d
NC
2041 if (svp) {
2042 SV *const *const last = svp + AvFILLp(av);
2043
2044 while (svp <= last) {
2045 if (*svp) {
2046 SV *const referrer = *svp;
2047 if (SvWEAKREF(referrer)) {
2048 /* XXX Should we check that it hasn't changed? */
2049 SvRV_set(referrer, 0);
2050 SvOK_off(referrer);
2051 SvWEAKREF_off(referrer);
2052 } else if (SvTYPE(referrer) == SVt_PVGV ||
2053 SvTYPE(referrer) == SVt_PVLV) {
2054 /* You lookin' at me? */
2055 assert(GvSTASH(referrer));
2056 assert(GvSTASH(referrer) == (HV*)sv);
2057 GvSTASH(referrer) = 0;
2058 } else {
2059 Perl_croak(aTHX_
2060 "panic: magic_killbackrefs (flags=%"UVxf")",
2061 SvFLAGS(referrer));
2062 }
2063
2064 *svp = Nullsv;
2065 }
2066 svp++;
810b8aa5 2067 }
810b8aa5 2068 }
d99b02a1 2069 SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */
810b8aa5
GS
2070 return 0;
2071}
2072
2073int
864dbfa3 2074Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
93a17b20 2075{
565764a8 2076 mg->mg_len = -1;
c6496cc7 2077 SvSCREAM_off(sv);
93a17b20
LW
2078 return 0;
2079}
2080
2081int
864dbfa3 2082Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
79072805 2083{
8772537c 2084 PERL_UNUSED_ARG(mg);
14befaf4 2085 sv_unmagic(sv, PERL_MAGIC_bm);
79072805
LW
2086 SvVALID_off(sv);
2087 return 0;
2088}
2089
2090int
864dbfa3 2091Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
55497cff 2092{
8772537c 2093 PERL_UNUSED_ARG(mg);
14befaf4 2094 sv_unmagic(sv, PERL_MAGIC_fm);
55497cff
PP
2095 SvCOMPILED_off(sv);
2096 return 0;
2097}
2098
2099int
864dbfa3 2100Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
79072805 2101{
35a4481c 2102 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
79072805
LW
2103
2104 if (uf && uf->uf_set)
24f81a43 2105 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
79072805
LW
2106 return 0;
2107}
2108
c277df42 2109int
faf82a0b
AE
2110Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2111{
8772537c 2112 PERL_UNUSED_ARG(mg);
faf82a0b
AE
2113 sv_unmagic(sv, PERL_MAGIC_qr);
2114 return 0;
2115}
2116
2117int
864dbfa3 2118Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
c277df42 2119{
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{
e1ec3a88 2159 register const char *s;
79072805 2160 I32 i;
8990e307 2161 STRLEN len;
79072805 2162 switch (*mg->mg_ptr) {
748a9306 2163 case '\001': /* ^A */
3280af22 2164 sv_setsv(PL_bodytarget, sv);
748a9306 2165 break;
49460fe6 2166 case '\003': /* ^C */
eb160463 2167 PL_minus_c = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
49460fe6
NIS
2168 break;
2169
79072805 2170 case '\004': /* ^D */
b4ab917c 2171#ifdef DEBUGGING
b83604b4 2172 s = SvPV_nolen_const(sv);
ddcf8bc1 2173 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
79072805 2174 DEBUG_x(dump_all());
b4ab917c
DM
2175#else
2176 PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | DEBUG_TOP_FLAG;
2177#endif
79072805 2178 break;
28f23441 2179 case '\005': /* ^E */
d0063567 2180 if (*(mg->mg_ptr+1) == '\0') {
cd39f2b6 2181#ifdef MACOS_TRADITIONAL
d0063567 2182 gMacPerl_OSErr = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
28f23441 2183#else
cd39f2b6 2184# ifdef VMS
d0063567 2185 set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
048c1ddf 2186# else
cd39f2b6 2187# ifdef WIN32
d0063567 2188 SetLastError( SvIV(sv) );
cd39f2b6 2189# else
9fed8b87 2190# ifdef OS2
d0063567 2191 os2_setsyserrno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
9fed8b87 2192# else
d0063567
DK
2193 /* will anyone ever use this? */
2194 SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4);
cd39f2b6 2195# endif
048c1ddf
IZ
2196# endif
2197# endif
22fae026 2198#endif
d0063567
DK
2199 }
2200 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2201 if (PL_encoding)
2202 SvREFCNT_dec(PL_encoding);
2203 if (SvOK(sv) || SvGMAGICAL(sv)) {
2204 PL_encoding = newSVsv(sv);
2205 }
2206 else {
2207 PL_encoding = Nullsv;
2208 }
2209 }
2210 break;
79072805 2211 case '\006': /* ^F */
3280af22 2212 PL_maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
79072805 2213 break;
a0d0e21e 2214 case '\010': /* ^H */
3280af22 2215 PL_hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
a0d0e21e 2216 break;
9d116dd7 2217 case '\011': /* ^I */ /* NOT \t in EBCDIC */
3280af22
NIS
2218 if (PL_inplace)
2219 Safefree(PL_inplace);
79072805 2220 if (SvOK(sv))
2e0de35c 2221 PL_inplace = savesvpv(sv);
79072805 2222 else
3280af22 2223 PL_inplace = Nullch;
79072805 2224 break;
28f23441 2225 case '\017': /* ^O */
ac27b0f5 2226 if (*(mg->mg_ptr+1) == '\0') {
1bf29663 2227 if (PL_osname) {
ac27b0f5 2228 Safefree(PL_osname);
1bf29663
DM
2229 PL_osname = Nullch;
2230 }
3511154c
DM
2231 if (SvOK(sv)) {
2232 TAINT_PROPER("assigning to $^O");
2e0de35c 2233 PL_osname = savesvpv(sv);
3511154c 2234 }
ac27b0f5
NIS
2235 }
2236 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2237 if (!PL_compiling.cop_io)
2238 PL_compiling.cop_io = newSVsv(sv);
2239 else
2240 sv_setsv(PL_compiling.cop_io,sv);
2241 }
28f23441 2242 break;
79072805 2243 case '\020': /* ^P */
3280af22 2244 PL_perldb = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
f2a7f298 2245 if (PL_perldb && !PL_DBsingle)
1ee4443e 2246 init_debugger();
79072805
LW
2247 break;
2248 case '\024': /* ^T */
88e89b8a 2249#ifdef BIG_TIME
6b88bc9c 2250 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
88e89b8a 2251#else
3280af22 2252 PL_basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
88e89b8a 2253#endif
79072805 2254 break;
fde18df1 2255 case '\027': /* ^W & $^WARNING_BITS */
4438c4b7
JH
2256 if (*(mg->mg_ptr+1) == '\0') {
2257 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2258 i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
ac27b0f5 2259 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
0453d815 2260 | (i ? G_WARN_ON : G_WARN_OFF) ;
4438c4b7 2261 }
599cee73 2262 }
0a378802 2263 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
4438c4b7 2264 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
d775746e
GS
2265 if (!SvPOK(sv) && PL_localizing) {
2266 sv_setpvn(sv, WARN_NONEstring, WARNsize);
d3a7d8c7 2267 PL_compiling.cop_warnings = pWARN_NONE;
d775746e
GS
2268 break;
2269 }
f4fc7782 2270 {
b5477537 2271 STRLEN len, i;
d3a7d8c7 2272 int accumulate = 0 ;
f4fc7782 2273 int any_fatals = 0 ;
b83604b4 2274 const char * const ptr = SvPV_const(sv, len) ;
f4fc7782
JH
2275 for (i = 0 ; i < len ; ++i) {
2276 accumulate |= ptr[i] ;
2277 any_fatals |= (ptr[i] & 0xAA) ;
2278 }
d3a7d8c7
GS
2279 if (!accumulate)
2280 PL_compiling.cop_warnings = pWARN_NONE;
f4fc7782
JH
2281 else if (isWARN_on(sv, WARN_ALL) && !any_fatals) {
2282 PL_compiling.cop_warnings = pWARN_ALL;
2283 PL_dowarn |= G_WARN_ONCE ;
727405f8 2284 }
d3a7d8c7
GS
2285 else {
2286 if (specialWARN(PL_compiling.cop_warnings))
2287 PL_compiling.cop_warnings = newSVsv(sv) ;
2288 else
2289 sv_setsv(PL_compiling.cop_warnings, sv);
2290 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2291 PL_dowarn |= G_WARN_ONCE ;
2292 }
f4fc7782 2293
d3a7d8c7 2294 }
4438c4b7 2295 }
971a9dd3 2296 }
79072805
LW
2297 break;
2298 case '.':
3280af22
NIS
2299 if (PL_localizing) {
2300 if (PL_localizing == 1)
7766f137 2301 SAVESPTR(PL_last_in_gv);
748a9306 2302 }
3280af22 2303 else if (SvOK(sv) && GvIO(PL_last_in_gv))
632db599 2304 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
79072805
LW
2305 break;
2306 case '^':
3280af22 2307 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
e1ec3a88 2308 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
7a5fd60d 2309 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv,TRUE, SVt_PVIO);
79072805
LW
2310 break;
2311 case '~':
3280af22 2312 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
e1ec3a88 2313 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
7a5fd60d 2314 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv,TRUE, SVt_PVIO);
79072805
LW
2315 break;
2316 case '=':
632db599 2317 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
79072805
LW
2318 break;
2319 case '-':
632db599 2320 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
3280af22
NIS
2321 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2322 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
79072805
LW
2323 break;
2324 case '%':
632db599 2325 IoPAGE(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
79072805
LW
2326 break;
2327 case '|':
4b65379b 2328 {
8772537c 2329 IO * const io = GvIOp(PL_defoutgv);
720f287d
AB
2330 if(!io)
2331 break;
4b65379b
CS
2332 if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) == 0)
2333 IoFLAGS(io) &= ~IOf_FLUSH;
2334 else {
2335 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2336 PerlIO *ofp = IoOFP(io);
2337 if (ofp)
2338 (void)PerlIO_flush(ofp);
2339 IoFLAGS(io) |= IOf_FLUSH;
2340 }
2341 }
79072805
LW
2342 }
2343 break;
79072805 2344 case '/':
3280af22 2345 SvREFCNT_dec(PL_rs);
8bfdd7d9 2346 PL_rs = newSVsv(sv);
79072805
LW
2347 break;
2348 case '\\':
7889fe52
NIS
2349 if (PL_ors_sv)
2350 SvREFCNT_dec(PL_ors_sv);
009c130f 2351 if (SvOK(sv) || SvGMAGICAL(sv)) {
7889fe52 2352 PL_ors_sv = newSVsv(sv);
009c130f 2353 }
e3c19b7b 2354 else {
7889fe52 2355 PL_ors_sv = Nullsv;
e3c19b7b 2356 }
79072805
LW
2357 break;
2358 case ',':
7889fe52
NIS
2359 if (PL_ofs_sv)
2360 SvREFCNT_dec(PL_ofs_sv);
2361 if (SvOK(sv) || SvGMAGICAL(sv)) {
2362 PL_ofs_sv = newSVsv(sv);
2363 }
2364 else {
2365 PL_ofs_sv = Nullsv;
2366 }
79072805 2367 break;
79072805 2368 case '[':
3280af22 2369 PL_compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
79072805
LW
2370 break;
2371 case '?':
ff0cee69 2372#ifdef COMPLEX_STATUS
6b88bc9c
GS
2373 if (PL_localizing == 2) {
2374 PL_statusvalue = LvTARGOFF(sv);
2375 PL_statusvalue_vms = LvTARGLEN(sv);
ff0cee69
PP
2376 }
2377 else
2378#endif
2379#ifdef VMSISH_STATUS
2380 if (VMSISH_STATUS)
2381 STATUS_NATIVE_SET((U32)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)));
2382 else
2383#endif
e5218da5 2384 STATUS_UNIX_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
79072805
LW
2385 break;
2386 case '!':
93189314
JH
2387 {
2388#ifdef VMS
2389# define PERL_VMS_BANG vaxc$errno
2390#else
2391# define PERL_VMS_BANG 0
2392#endif
91487cfc 2393 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
93189314
JH
2394 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2395 }
79072805
LW
2396 break;
2397 case '<':
3280af22
NIS
2398 PL_uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2399 if (PL_delaymagic) {
2400 PL_delaymagic |= DM_RUID;
79072805
LW
2401 break; /* don't do magic till later */
2402 }
2403#ifdef HAS_SETRUID
b28d0864 2404 (void)setruid((Uid_t)PL_uid);
79072805
LW
2405#else
2406#ifdef HAS_SETREUID
3280af22 2407 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
748a9306 2408#else
85e6fe83 2409#ifdef HAS_SETRESUID
b28d0864 2410 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
79072805 2411#else
75870ed3 2412 if (PL_uid == PL_euid) { /* special case $< = $> */
2413#ifdef PERL_DARWIN
2414 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2415 if (PL_uid != 0 && PerlProc_getuid() == 0)
2416 (void)PerlProc_setuid(0);
2417#endif
b28d0864 2418 (void)PerlProc_setuid(PL_uid);
75870ed3 2419 } else {
d8eceb89 2420 PL_uid = PerlProc_getuid();
cea2e8a9 2421 Perl_croak(aTHX_ "setruid() not implemented");
a0d0e21e 2422 }
79072805
LW
2423#endif
2424#endif
85e6fe83 2425#endif
d8eceb89 2426 PL_uid = PerlProc_getuid();
3280af22 2427 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
79072805
LW
2428 break;
2429 case '>':
3280af22
NIS
2430 PL_euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2431 if (PL_delaymagic) {
2432 PL_delaymagic |= DM_EUID;
79072805
LW
2433 break; /* don't do magic till later */
2434 }
2435#ifdef HAS_SETEUID
3280af22 2436 (void)seteuid((Uid_t)PL_euid);
79072805
LW
2437#else
2438#ifdef HAS_SETREUID
b28d0864 2439 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
85e6fe83
LW
2440#else
2441#ifdef HAS_SETRESUID
6b88bc9c 2442 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
79072805 2443#else
b28d0864
NIS
2444 if (PL_euid == PL_uid) /* special case $> = $< */
2445 PerlProc_setuid(PL_euid);
a0d0e21e 2446 else {
e8ee3774 2447 PL_euid = PerlProc_geteuid();
cea2e8a9 2448 Perl_croak(aTHX_ "seteuid() not implemented");
a0d0e21e 2449 }
79072805
LW
2450#endif
2451#endif
85e6fe83 2452#endif
d8eceb89 2453 PL_euid = PerlProc_geteuid();
3280af22 2454 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
79072805
LW
2455 break;
2456 case '(':
3280af22
NIS
2457 PL_gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2458 if (PL_delaymagic) {
2459 PL_delaymagic |= DM_RGID;
79072805
LW
2460 break; /* don't do magic till later */
2461 }
2462#ifdef HAS_SETRGID
b28d0864 2463 (void)setrgid((Gid_t)PL_gid);
79072805
LW
2464#else
2465#ifdef HAS_SETREGID
3280af22 2466 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
85e6fe83
LW
2467#else
2468#ifdef HAS_SETRESGID
b28d0864 2469 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
79072805 2470#else
b28d0864
NIS
2471 if (PL_gid == PL_egid) /* special case $( = $) */
2472 (void)PerlProc_setgid(PL_gid);
748a9306 2473 else {
d8eceb89 2474 PL_gid = PerlProc_getgid();
cea2e8a9 2475 Perl_croak(aTHX_ "setrgid() not implemented");
748a9306 2476 }
79072805
LW
2477#endif
2478#endif
85e6fe83 2479#endif
d8eceb89 2480 PL_gid = PerlProc_getgid();
3280af22 2481 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
79072805
LW
2482 break;
2483 case ')':
5cd24f17
PP
2484#ifdef HAS_SETGROUPS
2485 {
b83604b4 2486 const char *p = SvPV_const(sv, len);
5cd24f17
PP
2487 Groups_t gary[NGROUPS];
2488
5cd24f17
PP
2489 while (isSPACE(*p))
2490 ++p;
2d4389e4 2491 PL_egid = Atol(p);
5cd24f17
PP
2492 for (i = 0; i < NGROUPS; ++i) {
2493 while (*p && !isSPACE(*p))
2494 ++p;
2495 while (isSPACE(*p))
2496 ++p;
2497 if (!*p)
2498 break;
2d4389e4 2499 gary[i] = Atol(p);
5cd24f17 2500 }
8cc95fdb
PP
2501 if (i)
2502 (void)setgroups(i, gary);
5cd24f17
PP
2503 }
2504#else /* HAS_SETGROUPS */
b28d0864 2505 PL_egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
5cd24f17 2506#endif /* HAS_SETGROUPS */
3280af22
NIS
2507 if (PL_delaymagic) {
2508 PL_delaymagic |= DM_EGID;
79072805
LW
2509 break; /* don't do magic till later */
2510 }
2511#ifdef HAS_SETEGID
3280af22 2512 (void)setegid((Gid_t)PL_egid);
79072805
LW
2513#else
2514#ifdef HAS_SETREGID
b28d0864 2515 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
85e6fe83
LW
2516#else
2517#ifdef HAS_SETRESGID
b28d0864 2518 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
79072805 2519#else
b28d0864
NIS
2520 if (PL_egid == PL_gid) /* special case $) = $( */
2521 (void)PerlProc_setgid(PL_egid);
748a9306 2522 else {
d8eceb89 2523 PL_egid = PerlProc_getegid();
cea2e8a9 2524 Perl_croak(aTHX_ "setegid() not implemented");
748a9306 2525 }
79072805
LW
2526#endif
2527#endif
85e6fe83 2528#endif
d8eceb89 2529 PL_egid = PerlProc_getegid();
3280af22 2530 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
79072805
LW
2531 break;
2532 case ':':
2d8e6c8d 2533 PL_chopset = SvPV_force(sv,len);
79072805 2534 break;
cd39f2b6 2535#ifndef MACOS_TRADITIONAL
79072805 2536 case '0':
e2975953 2537 LOCK_DOLLARZERO_MUTEX;
4bc88a62
PS
2538#ifdef HAS_SETPROCTITLE
2539 /* The BSDs don't show the argv[] in ps(1) output, they
2540 * show a string from the process struct and provide
2541 * the setproctitle() routine to manipulate that. */
2542 {
b83604b4 2543 s = SvPV_const(sv, len);
98b76f99 2544# if __FreeBSD_version > 410001
9aad2c0e 2545 /* The leading "-" removes the "perl: " prefix,
4bc88a62
PS
2546 * but not the "(perl) suffix from the ps(1)
2547 * output, because that's what ps(1) shows if the
2548 * argv[] is modified. */
6f2ad931 2549 setproctitle("-%s", s);
9aad2c0e 2550# else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
4bc88a62
PS
2551 /* This doesn't really work if you assume that
2552 * $0 = 'foobar'; will wipe out 'perl' from the $0
2553 * because in ps(1) output the result will be like
2554 * sprintf("perl: %s (perl)", s)
2555 * I guess this is a security feature:
2556 * one (a user process) cannot get rid of the original name.
2557 * --jhi */
2558 setproctitle("%s", s);
2559# endif
2560 }
2561#endif
17aa7f3d
JH
2562#if defined(__hpux) && defined(PSTAT_SETCMD)
2563 {
2564 union pstun un;
b83604b4 2565 s = SvPV_const(sv, len);
6867be6d 2566 un.pst_command = (char *)s;
17aa7f3d
JH
2567 pstat(PSTAT_SETCMD, un, len, 0, 0);
2568 }
2569#endif
3cb9023d 2570 /* PL_origalen is set in perl_parse(). */
a0d0e21e 2571 s = SvPV_force(sv,len);
6f698202
AMS
2572 if (len >= (STRLEN)PL_origalen-1) {
2573 /* Longer than original, will be truncated. We assume that
2574 * PL_origalen bytes are available. */
2575 Copy(s, PL_origargv[0], PL_origalen-1, char);
79072805
LW
2576 }
2577 else {
54bfe034
JH
2578 /* Shorter than original, will be padded. */
2579 Copy(s, PL_origargv[0], len, char);
2580 PL_origargv[0][len] = 0;
2581 memset(PL_origargv[0] + len + 1,
2582 /* Is the space counterintuitive? Yes.
2583 * (You were expecting \0?)
3cb9023d 2584 * Does it work? Seems to. (In Linux 2.4.20 at least.)
54bfe034
JH
2585 * --jhi */
2586 (int)' ',
2587 PL_origalen - len - 1);
79072805 2588 }
ad7eccf4
JD
2589 PL_origargv[0][PL_origalen-1] = 0;
2590 for (i = 1; i < PL_origargc; i++)
2591 PL_origargv[i] = 0;
e2975953 2592 UNLOCK_DOLLARZERO_MUTEX;
79072805 2593 break;
cd39f2b6 2594#endif
79072805
LW
2595 }
2596 return 0;
2597}
2598
2599I32
35a4481c 2600Perl_whichsig(pTHX_ const char *sig)
79072805 2601{
aadb217d 2602 register char* const* sigv;
79072805 2603
aadb217d 2604 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
79072805 2605 if (strEQ(sig,*sigv))
aadb217d 2606 return PL_sig_num[sigv - (char* const*)PL_sig_name];
79072805
LW
2607#ifdef SIGCLD
2608 if (strEQ(sig,"CHLD"))
2609 return SIGCLD;
2610#endif
2611#ifdef SIGCHLD
2612 if (strEQ(sig,"CLD"))
2613 return SIGCHLD;
2614#endif
7f1236c0 2615 return -1;
79072805
LW
2616}
2617
ecfc5424 2618Signal_t
cea2e8a9 2619Perl_sighandler(int sig)
79072805 2620{
1018e26f
NIS
2621#ifdef PERL_GET_SIG_CONTEXT
2622 dTHXa(PERL_GET_SIG_CONTEXT);
71d280e3 2623#else
cea2e8a9 2624 dTHX;
71d280e3 2625#endif
79072805 2626 dSP;
00d579c5 2627 GV *gv = Nullgv;
8772537c
AL
2628 SV *sv = Nullsv;
2629 SV * const tSv = PL_Sv;
00d579c5 2630 CV *cv = Nullcv;
533c011a 2631 OP *myop = PL_op;
84902520 2632 U32 flags = 0;
8772537c 2633 XPV * const tXpv = PL_Xpv;
71d280e3 2634
3280af22 2635 if (PL_savestack_ix + 15 <= PL_savestack_max)
84902520 2636 flags |= 1;
3280af22 2637 if (PL_markstack_ptr < PL_markstack_max - 2)
84902520 2638 flags |= 4;
3280af22 2639 if (PL_scopestack_ix < PL_scopestack_max - 3)
84902520
TB
2640 flags |= 16;
2641
727405f8 2642 if (!PL_psig_ptr[sig]) {
99ef548b 2643 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
727405f8
NIS
2644 PL_sig_name[sig]);
2645 exit(sig);
2646 }
ff0cee69 2647
84902520
TB
2648 /* Max number of items pushed there is 3*n or 4. We cannot fix
2649 infinity, so we fix 4 (in fact 5): */
2650 if (flags & 1) {
3280af22 2651 PL_savestack_ix += 5; /* Protect save in progress. */
8772537c 2652 SAVEDESTRUCTOR_X(S_unwind_handler_stack, (void*)&flags);
84902520 2653 }
ac27b0f5 2654 if (flags & 4)
3280af22 2655 PL_markstack_ptr++; /* Protect mark. */
84902520 2656 if (flags & 16)
3280af22 2657 PL_scopestack_ix += 1;
84902520 2658 /* sv_2cv is too complicated, try a simpler variant first: */
ac27b0f5 2659 if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
8772537c
AL
2660 || SvTYPE(cv) != SVt_PVCV) {
2661 HV *st;
22c35a8c 2662 cv = sv_2cv(PL_psig_ptr[sig],&st,&gv,TRUE);
8772537c 2663 }
84902520 2664
a0d0e21e 2665 if (!cv || !CvROOT(cv)) {
599cee73 2666 if (ckWARN(WARN_SIGNAL))
9014280d 2667 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
22c35a8c 2668 PL_sig_name[sig], (gv ? GvENAME(gv)
00d579c5
GS
2669 : ((cv && CvGV(cv))
2670 ? GvENAME(CvGV(cv))
2671 : "__ANON__")));
2672 goto cleanup;
79072805
LW
2673 }
2674
22c35a8c
GS
2675 if(PL_psig_name[sig]) {
2676 sv = SvREFCNT_inc(PL_psig_name[sig]);
84902520 2677 flags |= 64;
df3728a2 2678#if !defined(PERL_IMPLICIT_CONTEXT)
27da23d5 2679 PL_sig_sv = sv;
df3728a2 2680#endif
84902520 2681 } else {
ff0cee69 2682 sv = sv_newmortal();
22c35a8c 2683 sv_setpv(sv,PL_sig_name[sig]);
88e89b8a 2684 }
e336de0d 2685
e788e7d3 2686 PUSHSTACKi(PERLSI_SIGNAL);
924508f0 2687 PUSHMARK(SP);
79072805 2688 PUSHs(sv);
79072805 2689 PUTBACK;
a0d0e21e 2690
1b266415 2691 call_sv((SV*)cv, G_DISCARD|G_EVAL);
79072805 2692
d3acc0f7 2693 POPSTACK;
1b266415 2694 if (SvTRUE(ERRSV)) {
1d615522 2695#ifndef PERL_MICRO
983dbef6 2696#ifdef HAS_SIGPROCMASK
1b266415
NIS
2697 /* Handler "died", for example to get out of a restart-able read().
2698 * Before we re-do that on its behalf re-enable the signal which was
2699 * blocked by the system when we entered.
2700 */
2701 sigset_t set;
2702 sigemptyset(&set);
2703 sigaddset(&set,sig);
2704 sigprocmask(SIG_UNBLOCK, &set, NULL);
2705#else
2706 /* Not clear if this will work */
2707 (void)rsignal(sig, SIG_IGN);
5c1546dc 2708 (void)rsignal(sig, PL_csighandlerp);
1b266415 2709#endif
1d615522 2710#endif /* !PERL_MICRO */
5df617be 2711 DieNull;
1b266415 2712 }
00d579c5 2713cleanup:
84902520 2714 if (flags & 1)
3280af22 2715 PL_savestack_ix -= 8; /* Unprotect save in progress. */
ac27b0f5 2716 if (flags & 4)
3280af22 2717 PL_markstack_ptr--;
84902520 2718 if (flags & 16)
3280af22 2719 PL_scopestack_ix -= 1;
84902520
TB
2720 if (flags & 64)
2721 SvREFCNT_dec(sv);
533c011a 2722 PL_op = myop; /* Apparently not needed... */
ac27b0f5 2723
3280af22
NIS
2724 PL_Sv = tSv; /* Restore global temporaries. */
2725 PL_Xpv = tXpv;
53bb94e2 2726 return;
79072805 2727}
4e35701f
NIS
2728
2729
51371543 2730static void
8772537c 2731S_restore_magic(pTHX_ const void *p)
51371543 2732{
8772537c
AL
2733 MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
2734 SV* const sv = mgs->mgs_sv;
51371543
GS
2735
2736 if (!sv)
2737 return;
2738
2739 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2740 {
f8c7b90f 2741#ifdef PERL_OLD_COPY_ON_WRITE
f9701176
NC
2742 /* While magic was saved (and off) sv_setsv may well have seen
2743 this SV as a prime candidate for COW. */
2744 if (SvIsCOW(sv))
2745 sv_force_normal(sv);
2746#endif
2747
51371543
GS
2748 if (mgs->mgs_flags)
2749 SvFLAGS(sv) |= mgs->mgs_flags;
2750 else
2751 mg_magical(sv);
2752 if (SvGMAGICAL(sv))
2753 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
2754 }
2755
2756 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
2757
2758 /* If we're still on top of the stack, pop us off. (That condition
2759 * will be satisfied if restore_magic was called explicitly, but *not*
2760 * if it's being called via leave_scope.)
2761 * The reason for doing this is that otherwise, things like sv_2cv()
2762 * may leave alloc gunk on the savestack, and some code
2763 * (e.g. sighandler) doesn't expect that...
2764 */
2765 if (PL_savestack_ix == mgs->mgs_ss_ix)
2766 {
2767 I32 popval = SSPOPINT;
c76ac1ee 2768 assert(popval == SAVEt_DESTRUCTOR_X);
51371543
GS
2769 PL_savestack_ix -= 2;
2770 popval = SSPOPINT;
2771 assert(popval == SAVEt_ALLOC);
2772 popval = SSPOPINT;
2773 PL_savestack_ix -= popval;
2774 }
2775
2776}
2777
2778static void
8772537c 2779S_unwind_handler_stack(pTHX_ const void *p)
51371543 2780{
27da23d5 2781 dVAR;
e1ec3a88 2782 const U32 flags = *(const U32*)p;
51371543
GS
2783
2784 if (flags & 1)
2785 PL_savestack_ix -= 5; /* Unprotect save in progress. */
2786 /* cxstack_ix-- Not needed, die already unwound it. */
df3728a2 2787#if !defined(PERL_IMPLICIT_CONTEXT)
51371543 2788 if (flags & 64)
27da23d5 2789 SvREFCNT_dec(PL_sig_sv);
df3728a2 2790#endif
51371543 2791}
1018e26f 2792
66610fdd
RGS
2793/*
2794 * Local variables:
2795 * c-indentation-style: bsd
2796 * c-basic-offset: 4
2797 * indent-tabs-mode: t
2798 * End:
2799 *
37442d52
RGS
2800 * ex: set ts=8 sts=4 sw=4 noet:
2801 */