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