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