This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Mention the Unicode UTR #18 version referenced.
[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;
550 register char *s;
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 '^':
3280af22 808 s = IoTOP_NAME(GvIOp(PL_defoutgv));
79072805
LW
809 if (s)
810 sv_setpv(sv,s);
811 else {
3280af22 812 sv_setpv(sv,GvENAME(PL_defoutgv));
79072805
LW
813 sv_catpv(sv,"_TOP");
814 }
815 break;
816 case '~':
3280af22 817 s = IoFMT_NAME(GvIOp(PL_defoutgv));
79072805 818 if (!s)
3280af22 819 s = GvENAME(PL_defoutgv);
79072805
LW
820 sv_setpv(sv,s);
821 break;
822#ifndef lint
823 case '=':
3280af22 824 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
79072805
LW
825 break;
826 case '-':
3280af22 827 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
79072805
LW
828 break;
829 case '%':
3280af22 830 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
79072805
LW
831 break;
832#endif
833 case ':':
834 break;
835 case '/':
836 break;
837 case '[':
3280af22 838 WITH_THR(sv_setiv(sv, (IV)PL_curcop->cop_arybase));
79072805
LW
839 break;
840 case '|':
3280af22 841 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
79072805
LW
842 break;
843 case ',':
79072805
LW
844 break;
845 case '\\':
b2ce0fda 846 if (PL_ors_sv)
f28098ff 847 sv_copypv(sv, PL_ors_sv);
79072805
LW
848 break;
849 case '#':
3280af22 850 sv_setpv(sv,PL_ofmt);
79072805
LW
851 break;
852 case '!':
a5f75d66 853#ifdef VMS
65202027 854 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
88e89b8a 855 sv_setpv(sv, errno ? Strerror(errno) : "");
a5f75d66 856#else
88e89b8a
PP
857 {
858 int saveerrno = errno;
65202027 859 sv_setnv(sv, (NV)errno);
88e89b8a 860#ifdef OS2
ed344e4f
IZ
861 if (errno == errno_isOS2 || errno == errno_isOS2_set)
862 sv_setpv(sv, os2error(Perl_rc));
88e89b8a 863 else
a5f75d66 864#endif
2304df62 865 sv_setpv(sv, errno ? Strerror(errno) : "");
88e89b8a
PP
866 errno = saveerrno;
867 }
868#endif
946ec16e 869 SvNOK_on(sv); /* what a wonderful hack! */
79072805
LW
870 break;
871 case '<':
3280af22 872 sv_setiv(sv, (IV)PL_uid);
79072805
LW
873 break;
874 case '>':
3280af22 875 sv_setiv(sv, (IV)PL_euid);
79072805
LW
876 break;
877 case '(':
3280af22 878 sv_setiv(sv, (IV)PL_gid);
a52cb5f7 879#ifdef HAS_GETGROUPS
785fb66b 880 Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, PL_gid);
a52cb5f7 881#endif
79072805
LW
882 goto add_groups;
883 case ')':
3280af22 884 sv_setiv(sv, (IV)PL_egid);
a52cb5f7 885#ifdef HAS_GETGROUPS
785fb66b 886 Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, PL_egid);
a52cb5f7 887#endif
79072805 888 add_groups:
79072805 889#ifdef HAS_GETGROUPS
79072805 890 {
a0d0e21e 891 Groups_t gary[NGROUPS];
79072805 892 i = getgroups(NGROUPS,gary);
46fc3d4c 893 while (--i >= 0)
785fb66b 894 Perl_sv_catpvf(aTHX_ sv, " %"Gid_t_f, gary[i]);
79072805
LW
895 }
896#endif
155aba94 897 (void)SvIOK_on(sv); /* what a wonderful hack! */
79072805 898 break;
cd39f2b6 899#ifndef MACOS_TRADITIONAL
79072805
LW
900 case '0':
901 break;
cd39f2b6 902#endif
79072805 903 }
a0d0e21e 904 return 0;
79072805
LW
905}
906
907int
864dbfa3 908Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
79072805
LW
909{
910 struct ufuncs *uf = (struct ufuncs *)mg->mg_ptr;
911
912 if (uf && uf->uf_val)
24f81a43 913 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
79072805
LW
914 return 0;
915}
916
917int
864dbfa3 918Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
79072805
LW
919{
920 register char *s;
88e89b8a 921 char *ptr;
5aabfad6 922 STRLEN len, klen;
1e422769 923
a0d0e21e 924 s = SvPV(sv,len);
5aabfad6 925 ptr = MgPV(mg,klen);
88e89b8a 926 my_setenv(ptr, s);
1e422769 927
a0d0e21e
LW
928#ifdef DYNAMIC_ENV_FETCH
929 /* We just undefd an environment var. Is a replacement */
930 /* waiting in the wings? */
931 if (!len) {
5aabfad6 932 SV **valp;
6b88bc9c 933 if ((valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE)))
5aabfad6 934 s = SvPV(*valp, len);
a0d0e21e
LW
935 }
936#endif
1e422769 937
39e571d4 938#if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
79072805
LW
939 /* And you'll never guess what the dog had */
940 /* in its mouth... */
3280af22 941 if (PL_tainting) {
1e422769
PP
942 MgTAINTEDDIR_off(mg);
943#ifdef VMS
5aabfad6 944 if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
1e422769 945 char pathbuf[256], eltbuf[256], *cp, *elt = s;
c623ac67 946 Stat_t sbuf;
1e422769
PP
947 int i = 0, j = 0;
948
949 do { /* DCL$PATH may be a search list */
950 while (1) { /* as may dev portion of any element */
951 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
952 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
953 cando_by_name(S_IWUSR,0,elt) ) {
954 MgTAINTEDDIR_on(mg);
955 return 0;
956 }
957 }
958 if ((cp = strchr(elt, ':')) != Nullch)
959 *cp = '\0';
960 if (my_trnlnm(elt, eltbuf, j++))
961 elt = eltbuf;
962 else
963 break;
964 }
965 j = 0;
966 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
967 }
968#endif /* VMS */
5aabfad6 969 if (s && klen == 4 && strEQ(ptr,"PATH")) {
a0d0e21e 970 char *strend = s + len;
463ee0b2
LW
971
972 while (s < strend) {
96827780 973 char tmpbuf[256];
c623ac67 974 Stat_t st;
5f74f29c 975 I32 i;
96827780 976 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
fc36a67e 977 s, strend, ':', &i);
463ee0b2 978 s++;
96827780
MB
979 if (i >= sizeof tmpbuf /* too long -- assume the worst */
980 || *tmpbuf != '/'
c6ed36e1 981 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
8990e307 982 MgTAINTEDDIR_on(mg);
1e422769
PP
983 return 0;
984 }
463ee0b2 985 }
79072805
LW
986 }
987 }
39e571d4 988#endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1e422769 989
79072805
LW
990 return 0;
991}
992
993int
864dbfa3 994Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
85e6fe83 995{
2d8e6c8d
GS
996 STRLEN n_a;
997 my_setenv(MgPV(mg,n_a),Nullch);
85e6fe83
LW
998 return 0;
999}
1000
88e89b8a 1001int
864dbfa3 1002Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
fb73857a
PP
1003{
1004#if defined(VMS)
cea2e8a9 1005 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
fb73857a 1006#else
3280af22 1007 if (PL_localizing) {
fb73857a 1008 HE* entry;
2d8e6c8d 1009 STRLEN n_a;
fb73857a
PP
1010 magic_clear_all_env(sv,mg);
1011 hv_iterinit((HV*)sv);
155aba94 1012 while ((entry = hv_iternext((HV*)sv))) {
fb73857a
PP
1013 I32 keylen;
1014 my_setenv(hv_iterkey(entry, &keylen),
2d8e6c8d 1015 SvPV(hv_iterval((HV*)sv, entry), n_a));
fb73857a
PP
1016 }
1017 }
1018#endif
1019 return 0;
1020}
1021
1022int
864dbfa3 1023Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
66b1d557 1024{
2f42fcb0 1025#ifndef PERL_MICRO
ed79a026 1026#if defined(VMS) || defined(EPOC)
cea2e8a9 1027 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
3e3baf6d 1028#else
4efc5df6 1029# if defined(PERL_IMPLICIT_SYS) || defined(WIN32)
7766f137 1030 PerlEnv_clearenv();
4efc5df6
GS
1031# else
1032# ifdef USE_ENVIRON_ARRAY
1033# if defined(USE_ITHREADS)
1034 /* only the parent thread can clobber the process environment */
1035 if (PL_curinterp == aTHX)
1036# endif
1037 {
1038# ifndef PERL_USE_SAFE_PUTENV
66b1d557
HM
1039 I32 i;
1040
3280af22 1041 if (environ == PL_origenviron)
f2517201 1042 environ = (char**)safesysmalloc(sizeof(char*));
66b1d557
HM
1043 else
1044 for (i = 0; environ[i]; i++)
f2517201 1045 safesysfree(environ[i]);
4efc5df6 1046# endif /* PERL_USE_SAFE_PUTENV */
f2517201 1047
66b1d557 1048 environ[0] = Nullch;
4efc5df6
GS
1049 }
1050# endif /* USE_ENVIRON_ARRAY */
052c2dc6 1051# endif /* PERL_IMPLICIT_SYS || WIN32 */
2f42fcb0
JH
1052#endif /* VMS || EPOC */
1053#endif /* !PERL_MICRO */
3e3baf6d 1054 return 0;
66b1d557
HM
1055}
1056
2e34cc90
CL
1057#if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS)||defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1058static int sig_handlers_initted = 0;
1059#endif
7719e241 1060#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
85b332e2
CL
1061static int sig_ignoring[SIG_SIZE]; /* which signals we are ignoring */
1062#endif
2e34cc90
CL
1063#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1064static int sig_defaulting[SIG_SIZE];
1065#endif
85b332e2 1066
64ca3a65 1067#ifndef PERL_MICRO
2d4fcd5e
AJ
1068#ifdef HAS_SIGPROCMASK
1069static void
1070restore_sigmask(pTHX_ SV *save_sv)
1071{
1072 sigset_t *ossetp = (sigset_t *) SvPV_nolen( save_sv );
1073 (void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0);
1074}
1075#endif
66b1d557 1076int
864dbfa3 1077Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
88e89b8a
PP
1078{
1079 I32 i;
2d8e6c8d 1080 STRLEN n_a;
88e89b8a 1081 /* Are we fetching a signal entry? */
2d8e6c8d 1082 i = whichsig(MgPV(mg,n_a));
e02bfb16 1083 if (i > 0) {
22c35a8c
GS
1084 if(PL_psig_ptr[i])
1085 sv_setsv(sv,PL_psig_ptr[i]);
88e89b8a 1086 else {
85b332e2 1087 Sighandler_t sigstate;
2e34cc90 1088 sigstate = rsignal_state(i);
23ada85b 1089#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
2e34cc90
CL
1090 if (sig_handlers_initted && sig_ignoring[i]) sigstate = SIG_IGN;
1091#endif
1092#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1093 if (sig_handlers_initted && sig_defaulting[i]) sigstate = SIG_DFL;
85b332e2 1094#endif
88e89b8a 1095 /* cache state so we don't fetch it again */
ff68c719 1096 if(sigstate == SIG_IGN)
88e89b8a
PP
1097 sv_setpv(sv,"IGNORE");
1098 else
3280af22 1099 sv_setsv(sv,&PL_sv_undef);
22c35a8c 1100 PL_psig_ptr[i] = SvREFCNT_inc(sv);
88e89b8a
PP
1101 SvTEMP_off(sv);
1102 }
1103 }
1104 return 0;
1105}
1106int
864dbfa3 1107Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
88e89b8a 1108{
2d4fcd5e
AJ
1109 /* XXX Some of this code was copied from Perl_magic_setsig. A little
1110 * refactoring might be in order.
1111 */
1112 register char *s;
2d8e6c8d 1113 STRLEN n_a;
2d4fcd5e
AJ
1114 SV* to_dec;
1115 s = MgPV(mg,n_a);
1116 if (*s == '_') {
1117 SV** svp;
1118 if (strEQ(s,"__DIE__"))
1119 svp = &PL_diehook;
1120 else if (strEQ(s,"__WARN__"))
1121 svp = &PL_warnhook;
1122 else
1123 Perl_croak(aTHX_ "No such hook: %s", s);
1124 if (*svp) {
1125 to_dec = *svp;
1126 *svp = 0;
1127 SvREFCNT_dec(to_dec);
1128 }
1129 }
1130 else {
1131 I32 i;
1132 /* Are we clearing a signal entry? */
1133 i = whichsig(s);
e02bfb16 1134 if (i > 0) {
2d4fcd5e
AJ
1135#ifdef HAS_SIGPROCMASK
1136 sigset_t set, save;
1137 SV* save_sv;
1138 /* Avoid having the signal arrive at a bad time, if possible. */
1139 sigemptyset(&set);
1140 sigaddset(&set,i);
1141 sigprocmask(SIG_BLOCK, &set, &save);
1142 ENTER;
1143 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1144 SAVEFREESV(save_sv);
1145 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1146#endif
1147 PERL_ASYNC_CHECK();
1148#if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1149 if (!sig_handlers_initted) Perl_csighandler_init();
1150#endif
1151#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1152 sig_defaulting[i] = 1;
5c1546dc 1153 (void)rsignal(i, PL_csighandlerp);
2d4fcd5e
AJ
1154#else
1155 (void)rsignal(i, SIG_DFL);
1156#endif
1157 if(PL_psig_name[i]) {
1158 SvREFCNT_dec(PL_psig_name[i]);
1159 PL_psig_name[i]=0;
1160 }
1161 if(PL_psig_ptr[i]) {
1162 to_dec=PL_psig_ptr[i];
1163 PL_psig_ptr[i]=0;
1164 LEAVE;
1165 SvREFCNT_dec(to_dec);
1166 }
1167 else
1168 LEAVE;
1169 }
88e89b8a
PP
1170 }
1171 return 0;
1172}
3d37d572 1173
0a8e0eff
NIS
1174void
1175Perl_raise_signal(pTHX_ int sig)
1176{
1177 /* Set a flag to say this signal is pending */
1178 PL_psig_pend[sig]++;
1179 /* And one to say _a_ signal is pending */
1180 PL_sig_pending = 1;
1181}
1182
1183Signal_t
1184Perl_csighandler(int sig)
1185{
1018e26f
NIS
1186#ifdef PERL_GET_SIG_CONTEXT
1187 dTHXa(PERL_GET_SIG_CONTEXT);
1188#else
85b332e2
CL
1189 dTHX;
1190#endif
23ada85b 1191#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
5c1546dc 1192 (void) rsignal(sig, PL_csighandlerp);
85b332e2
CL
1193 if (sig_ignoring[sig]) return;
1194#endif
2e34cc90 1195#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
7719e241 1196 if (sig_defaulting[sig])
2e34cc90
CL
1197#ifdef KILL_BY_SIGPRC
1198 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1199#else
1200 exit(1);
1201#endif
1202#endif
4ffa73a3
JH
1203 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
1204 /* Call the perl level handler now--
1205 * with risk we may be in malloc() etc. */
1206 (*PL_sighandlerp)(sig);
1207 else
1208 Perl_raise_signal(aTHX_ sig);
0a8e0eff
NIS
1209}
1210
2e34cc90
CL
1211#if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1212void
1213Perl_csighandler_init(void)
1214{
1215 int sig;
1216 if (sig_handlers_initted) return;
1217
1218 for (sig = 1; sig < SIG_SIZE; sig++) {
1219#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
218fdd94 1220 dTHX;
2e34cc90 1221 sig_defaulting[sig] = 1;
5c1546dc 1222 (void) rsignal(sig, PL_csighandlerp);
2e34cc90
CL
1223#endif
1224#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1225 sig_ignoring[sig] = 0;
1226#endif
1227 }
1228 sig_handlers_initted = 1;
1229}
1230#endif
1231
0a8e0eff
NIS
1232void
1233Perl_despatch_signals(pTHX)
1234{
1235 int sig;
1236 PL_sig_pending = 0;
1237 for (sig = 1; sig < SIG_SIZE; sig++) {
1238 if (PL_psig_pend[sig]) {
25da4428
JH
1239 PERL_BLOCKSIG_ADD(set, sig);
1240 PL_psig_pend[sig] = 0;
1241 PERL_BLOCKSIG_BLOCK(set);
f5203343 1242 (*PL_sighandlerp)(sig);
25da4428 1243 PERL_BLOCKSIG_UNBLOCK(set);
0a8e0eff
NIS
1244 }
1245 }
1246}
1247
85e6fe83 1248int
864dbfa3 1249Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
79072805
LW
1250{
1251 register char *s;
1252 I32 i;
b7953727 1253 SV** svp = 0;
2d4fcd5e
AJ
1254 /* Need to be careful with SvREFCNT_dec(), because that can have side
1255 * effects (due to closures). We must make sure that the new disposition
1256 * is in place before it is called.
1257 */
1258 SV* to_dec = 0;
e72dc28c 1259 STRLEN len;
2d4fcd5e
AJ
1260#ifdef HAS_SIGPROCMASK
1261 sigset_t set, save;
1262 SV* save_sv;
1263#endif
a0d0e21e 1264
e72dc28c 1265 s = MgPV(mg,len);
748a9306
LW
1266 if (*s == '_') {
1267 if (strEQ(s,"__DIE__"))
3280af22 1268 svp = &PL_diehook;
748a9306 1269 else if (strEQ(s,"__WARN__"))
3280af22 1270 svp = &PL_warnhook;
748a9306 1271 else
cea2e8a9 1272 Perl_croak(aTHX_ "No such hook: %s", s);
748a9306 1273 i = 0;
4633a7c4 1274 if (*svp) {
2d4fcd5e 1275 to_dec = *svp;
4633a7c4
LW
1276 *svp = 0;
1277 }
748a9306
LW
1278 }
1279 else {
1280 i = whichsig(s); /* ...no, a brick */
e02bfb16 1281 if (i < 0) {
e476b1b5 1282 if (ckWARN(WARN_SIGNAL))
9014280d 1283 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
748a9306
LW
1284 return 0;
1285 }
2d4fcd5e
AJ
1286#ifdef HAS_SIGPROCMASK
1287 /* Avoid having the signal arrive at a bad time, if possible. */
1288 sigemptyset(&set);
1289 sigaddset(&set,i);
1290 sigprocmask(SIG_BLOCK, &set, &save);
1291 ENTER;
1292 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1293 SAVEFREESV(save_sv);
1294 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1295#endif
1296 PERL_ASYNC_CHECK();
2e34cc90
CL
1297#if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1298 if (!sig_handlers_initted) Perl_csighandler_init();
1299#endif
23ada85b 1300#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
85b332e2
CL
1301 sig_ignoring[i] = 0;
1302#endif
2e34cc90 1303#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
2d4fcd5e 1304 sig_defaulting[i] = 0;
2e34cc90 1305#endif
22c35a8c 1306 SvREFCNT_dec(PL_psig_name[i]);
2d4fcd5e 1307 to_dec = PL_psig_ptr[i];
22c35a8c 1308 PL_psig_ptr[i] = SvREFCNT_inc(sv);
88e89b8a 1309 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
e72dc28c 1310 PL_psig_name[i] = newSVpvn(s, len);
22c35a8c 1311 SvREADONLY_on(PL_psig_name[i]);
748a9306 1312 }
a0d0e21e 1313 if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
2d4fcd5e 1314 if (i) {
5c1546dc 1315 (void)rsignal(i, PL_csighandlerp);
2d4fcd5e
AJ
1316#ifdef HAS_SIGPROCMASK
1317 LEAVE;
1318#endif
1319 }
748a9306
LW
1320 else
1321 *svp = SvREFCNT_inc(sv);
2d4fcd5e
AJ
1322 if(to_dec)
1323 SvREFCNT_dec(to_dec);
a0d0e21e
LW
1324 return 0;
1325 }
e72dc28c 1326 s = SvPV_force(sv,len);
748a9306 1327 if (strEQ(s,"IGNORE")) {
85b332e2 1328 if (i) {
23ada85b 1329#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
85b332e2 1330 sig_ignoring[i] = 1;
5c1546dc 1331 (void)rsignal(i, PL_csighandlerp);
85b332e2 1332#else
ff68c719 1333 (void)rsignal(i, SIG_IGN);
85b332e2 1334#endif
2d4fcd5e 1335 }
748a9306
LW
1336 }
1337 else if (strEQ(s,"DEFAULT") || !*s) {
1338 if (i)
2e34cc90
CL
1339#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1340 {
1341 sig_defaulting[i] = 1;
5c1546dc 1342 (void)rsignal(i, PL_csighandlerp);
2e34cc90
CL
1343 }
1344#else
ff68c719 1345 (void)rsignal(i, SIG_DFL);
2e34cc90 1346#endif
748a9306 1347 }
79072805 1348 else {
5aabfad6
PP
1349 /*
1350 * We should warn if HINT_STRICT_REFS, but without
1351 * access to a known hint bit in a known OP, we can't
1352 * tell whether HINT_STRICT_REFS is in force or not.
1353 */
46fc3d4c 1354 if (!strchr(s,':') && !strchr(s,'\''))
e72dc28c 1355 sv_insert(sv, 0, 0, "main::", 6);
748a9306 1356 if (i)
5c1546dc 1357 (void)rsignal(i, PL_csighandlerp);
748a9306
LW
1358 else
1359 *svp = SvREFCNT_inc(sv);
79072805 1360 }
2d4fcd5e
AJ
1361#ifdef HAS_SIGPROCMASK
1362 if(i)
1363 LEAVE;
1364#endif
1365 if(to_dec)
1366 SvREFCNT_dec(to_dec);
79072805
LW
1367 return 0;
1368}
64ca3a65 1369#endif /* !PERL_MICRO */
79072805
LW
1370
1371int
864dbfa3 1372Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
79072805 1373{
3280af22 1374 PL_sub_generation++;
463ee0b2
LW
1375 return 0;
1376}
1377
1378int
864dbfa3 1379Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
463ee0b2 1380{
a0d0e21e 1381 /* HV_badAMAGIC_on(Sv_STASH(sv)); */
3280af22 1382 PL_amagic_generation++;
463ee0b2 1383
a0d0e21e
LW
1384 return 0;
1385}
463ee0b2 1386
946ec16e 1387int
864dbfa3 1388Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
6ff81951
GS
1389{
1390 HV *hv = (HV*)LvTARG(sv);
6ff81951 1391 I32 i = 0;
7719e241 1392
6ff81951 1393 if (hv) {
497b47a8
JH
1394 (void) hv_iterinit(hv);
1395 if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
1396 i = HvKEYS(hv);
1397 else {
1398 while (hv_iternext(hv))
1399 i++;
1400 }
6ff81951
GS
1401 }
1402
1403 sv_setiv(sv, (IV)i);
1404 return 0;
1405}
1406
1407int
864dbfa3 1408Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
946ec16e
PP
1409{
1410 if (LvTARG(sv)) {
1411 hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
946ec16e
PP
1412 }
1413 return 0;
ac27b0f5 1414}
946ec16e 1415
e336de0d 1416/* caller is responsible for stack switching/cleanup */
565764a8 1417STATIC int
cea2e8a9 1418S_magic_methcall(pTHX_ SV *sv, MAGIC *mg, char *meth, I32 flags, int n, SV *val)
a0d0e21e
LW
1419{
1420 dSP;
463ee0b2 1421
924508f0
GS
1422 PUSHMARK(SP);
1423 EXTEND(SP, n);
33c27489 1424 PUSHs(SvTIED_obj(sv, mg));
ac27b0f5 1425 if (n > 1) {
93965878 1426 if (mg->mg_ptr) {
565764a8 1427 if (mg->mg_len >= 0)
79cb57f6 1428 PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len)));
565764a8 1429 else if (mg->mg_len == HEf_SVKEY)
93965878
NIS
1430 PUSHs((SV*)mg->mg_ptr);
1431 }
14befaf4 1432 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
565764a8 1433 PUSHs(sv_2mortal(newSViv(mg->mg_len)));
93965878
NIS
1434 }
1435 }
1436 if (n > 2) {
1437 PUSHs(val);
88e89b8a 1438 }
463ee0b2
LW
1439 PUTBACK;
1440
864dbfa3 1441 return call_method(meth, flags);
946ec16e
PP
1442}
1443
76e3520e 1444STATIC int
cea2e8a9 1445S_magic_methpack(pTHX_ SV *sv, MAGIC *mg, char *meth)
a0d0e21e
LW
1446{
1447 dSP;
463ee0b2 1448
a0d0e21e
LW
1449 ENTER;
1450 SAVETMPS;
e788e7d3 1451 PUSHSTACKi(PERLSI_MAGIC);
463ee0b2 1452
33c27489 1453 if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
3280af22 1454 sv_setsv(sv, *PL_stack_sp--);
93965878 1455 }
463ee0b2 1456
d3acc0f7 1457 POPSTACK;
a0d0e21e
LW
1458 FREETMPS;
1459 LEAVE;
1460 return 0;
1461}
463ee0b2 1462
a0d0e21e 1463int
864dbfa3 1464Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e 1465{
a0d0e21e
LW
1466 if (mg->mg_ptr)
1467 mg->mg_flags |= MGf_GSKIP;
58f82c5c 1468 magic_methpack(sv,mg,"FETCH");
463ee0b2
LW
1469 return 0;
1470}
1471
1472int
864dbfa3 1473Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
e336de0d
GS
1474{
1475 dSP;
a60c0954 1476 ENTER;
e788e7d3 1477 PUSHSTACKi(PERLSI_MAGIC);
33c27489 1478 magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
d3acc0f7 1479 POPSTACK;
a60c0954 1480 LEAVE;
463ee0b2
LW
1481 return 0;
1482}
1483
1484int
864dbfa3 1485Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
463ee0b2 1486{
a0d0e21e
LW
1487 return magic_methpack(sv,mg,"DELETE");
1488}
463ee0b2 1489
93965878
NIS
1490
1491U32
864dbfa3 1492Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
ac27b0f5 1493{
e336de0d 1494 dSP;
93965878
NIS
1495 U32 retval = 0;
1496
1497 ENTER;
1498 SAVETMPS;
e788e7d3 1499 PUSHSTACKi(PERLSI_MAGIC);
33c27489 1500 if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
3280af22 1501 sv = *PL_stack_sp--;
a60c0954 1502 retval = (U32) SvIV(sv)-1;
93965878 1503 }
d3acc0f7 1504 POPSTACK;
93965878
NIS
1505 FREETMPS;
1506 LEAVE;
1507 return retval;
1508}
1509
cea2e8a9
GS
1510int
1511Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e
LW
1512{
1513 dSP;
463ee0b2 1514
e336de0d 1515 ENTER;
e788e7d3 1516 PUSHSTACKi(PERLSI_MAGIC);
924508f0 1517 PUSHMARK(SP);
33c27489 1518 XPUSHs(SvTIED_obj(sv, mg));
463ee0b2 1519 PUTBACK;
864dbfa3 1520 call_method("CLEAR", G_SCALAR|G_DISCARD);
d3acc0f7 1521 POPSTACK;
a60c0954 1522 LEAVE;
463ee0b2
LW
1523 return 0;
1524}
1525
1526int
864dbfa3 1527Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
463ee0b2 1528{
463ee0b2 1529 dSP;
dff6d3cd 1530 const char *meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
463ee0b2
LW
1531
1532 ENTER;
a0d0e21e 1533 SAVETMPS;
e788e7d3 1534 PUSHSTACKi(PERLSI_MAGIC);
924508f0
GS
1535 PUSHMARK(SP);
1536 EXTEND(SP, 2);
33c27489 1537 PUSHs(SvTIED_obj(sv, mg));
463ee0b2
LW
1538 if (SvOK(key))
1539 PUSHs(key);
1540 PUTBACK;
1541
864dbfa3 1542 if (call_method(meth, G_SCALAR))
3280af22 1543 sv_setsv(key, *PL_stack_sp--);
463ee0b2 1544
d3acc0f7 1545 POPSTACK;
a0d0e21e
LW
1546 FREETMPS;
1547 LEAVE;
79072805
LW
1548 return 0;
1549}
1550
1551int
864dbfa3 1552Perl_magic_existspack(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e
LW
1553{
1554 return magic_methpack(sv,mg,"EXISTS");
ac27b0f5 1555}
a0d0e21e
LW
1556
1557int
864dbfa3 1558Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
79072805
LW
1559{
1560 OP *o;
1561 I32 i;
1562 GV* gv;
1563 SV** svp;
2d8e6c8d 1564 STRLEN n_a;
79072805 1565
3280af22 1566 gv = PL_DBline;
79072805 1567 i = SvTRUE(sv);
188ea221 1568 svp = av_fetch(GvAV(gv),
2d8e6c8d 1569 atoi(MgPV(mg,n_a)), FALSE);
5df8de69
DM
1570 if (svp && SvIOKp(*svp) && (o = INT2PTR(OP*,SvIVX(*svp)))) {
1571 /* set or clear breakpoint in the relevant control op */
1572 if (i)
1573 o->op_flags |= OPf_SPECIAL;
1574 else
1575 o->op_flags &= ~OPf_SPECIAL;
1576 }
79072805
LW
1577 return 0;
1578}
1579
1580int
864dbfa3 1581Perl_magic_getarylen(pTHX_ SV *sv, MAGIC *mg)
79072805 1582{
3280af22 1583 sv_setiv(sv, AvFILL((AV*)mg->mg_obj) + PL_curcop->cop_arybase);
79072805
LW
1584 return 0;
1585}
1586
1587int
864dbfa3 1588Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
79072805 1589{
3280af22 1590 av_fill((AV*)mg->mg_obj, SvIV(sv) - PL_curcop->cop_arybase);
a0d0e21e
LW
1591 return 0;
1592}
1593
1594int
864dbfa3 1595Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e
LW
1596{
1597 SV* lsv = LvTARG(sv);
ac27b0f5 1598
a0d0e21e 1599 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
14befaf4 1600 mg = mg_find(lsv, PERL_MAGIC_regex_global);
565764a8 1601 if (mg && mg->mg_len >= 0) {
a0ed51b3 1602 I32 i = mg->mg_len;
7e2040f0 1603 if (DO_UTF8(lsv))
a0ed51b3
LW
1604 sv_pos_b2u(lsv, &i);
1605 sv_setiv(sv, i + PL_curcop->cop_arybase);
a0d0e21e
LW
1606 return 0;
1607 }
1608 }
1609 (void)SvOK_off(sv);
1610 return 0;
1611}
1612
1613int
864dbfa3 1614Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e
LW
1615{
1616 SV* lsv = LvTARG(sv);
1617 SSize_t pos;
1618 STRLEN len;
c00206c8 1619 STRLEN ulen = 0;
a0d0e21e
LW
1620
1621 mg = 0;
ac27b0f5 1622
a0d0e21e 1623 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
14befaf4 1624 mg = mg_find(lsv, PERL_MAGIC_regex_global);
a0d0e21e
LW
1625 if (!mg) {
1626 if (!SvOK(sv))
1627 return 0;
14befaf4
DM
1628 sv_magic(lsv, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1629 mg = mg_find(lsv, PERL_MAGIC_regex_global);
a0d0e21e
LW
1630 }
1631 else if (!SvOK(sv)) {
565764a8 1632 mg->mg_len = -1;
a0d0e21e
LW
1633 return 0;
1634 }
1635 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1636
c485e607 1637 pos = SvIV(sv) - PL_curcop->cop_arybase;
a0ed51b3 1638
7e2040f0 1639 if (DO_UTF8(lsv)) {
a0ed51b3
LW
1640 ulen = sv_len_utf8(lsv);
1641 if (ulen)
1642 len = ulen;
a0ed51b3
LW
1643 }
1644
a0d0e21e
LW
1645 if (pos < 0) {
1646 pos += len;
1647 if (pos < 0)
1648 pos = 0;
1649 }
eb160463 1650 else if (pos > (SSize_t)len)
a0d0e21e 1651 pos = len;
a0ed51b3
LW
1652
1653 if (ulen) {
1654 I32 p = pos;
1655 sv_pos_u2b(lsv, &p, 0);
1656 pos = p;
1657 }
727405f8 1658
565764a8 1659 mg->mg_len = pos;
71be2cbc 1660 mg->mg_flags &= ~MGf_MINMATCH;
a0d0e21e 1661
79072805
LW
1662 return 0;
1663}
1664
1665int
864dbfa3 1666Perl_magic_getglob(pTHX_ SV *sv, MAGIC *mg)
79072805 1667{
8646b087
PP
1668 if (SvFAKE(sv)) { /* FAKE globs can get coerced */
1669 SvFAKE_off(sv);
946ec16e 1670 gv_efullname3(sv,((GV*)sv), "*");
8646b087
PP
1671 SvFAKE_on(sv);
1672 }
1673 else
946ec16e 1674 gv_efullname3(sv,((GV*)sv), "*"); /* a gv value, be nice */
79072805
LW
1675 return 0;
1676}
1677
1678int
864dbfa3 1679Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg)
79072805
LW
1680{
1681 register char *s;
1682 GV* gv;
2d8e6c8d 1683 STRLEN n_a;
79072805
LW
1684
1685 if (!SvOK(sv))
1686 return 0;
2d8e6c8d 1687 s = SvPV(sv, n_a);
79072805
LW
1688 if (*s == '*' && s[1])
1689 s++;
85e6fe83 1690 gv = gv_fetchpv(s,TRUE, SVt_PVGV);
79072805
LW
1691 if (sv == (SV*)gv)
1692 return 0;
1693 if (GvGP(sv))
88e89b8a 1694 gp_free((GV*)sv);
79072805 1695 GvGP(sv) = gp_ref(GvGP(gv));
79072805
LW
1696 return 0;
1697}
1698
1699int
864dbfa3 1700Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
6ff81951
GS
1701{
1702 STRLEN len;
1703 SV *lsv = LvTARG(sv);
1704 char *tmps = SvPV(lsv,len);
1705 I32 offs = LvTARGOFF(sv);
1706 I32 rem = LvTARGLEN(sv);
1707
9aa983d2
JH
1708 if (SvUTF8(lsv))
1709 sv_pos_u2b(lsv, &offs, &rem);
eb160463 1710 if (offs > (I32)len)
6ff81951 1711 offs = len;
eb160463 1712 if (rem + offs > (I32)len)
6ff81951
GS
1713 rem = len - offs;
1714 sv_setpvn(sv, tmps + offs, (STRLEN)rem);
9aa983d2 1715 if (SvUTF8(lsv))
2ef4b674 1716 SvUTF8_on(sv);
6ff81951
GS
1717 return 0;
1718}
1719
1720int
864dbfa3 1721Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
79072805 1722{
9aa983d2
JH
1723 STRLEN len;
1724 char *tmps = SvPV(sv, len);
1725 SV *lsv = LvTARG(sv);
1726 I32 lvoff = LvTARGOFF(sv);
1727 I32 lvlen = LvTARGLEN(sv);
075a4a2b 1728
1aa99e6b 1729 if (DO_UTF8(sv)) {
9aa983d2
JH
1730 sv_utf8_upgrade(lsv);
1731 sv_pos_u2b(lsv, &lvoff, &lvlen);
1732 sv_insert(lsv, lvoff, lvlen, tmps, len);
1733 SvUTF8_on(lsv);
1734 }
9bf12eaf 1735 else if (lsv && SvUTF8(lsv)) {
9aa983d2 1736 sv_pos_u2b(lsv, &lvoff, &lvlen);
e95af362 1737 tmps = (char*)bytes_to_utf8((U8*)tmps, &len);
9aa983d2
JH
1738 sv_insert(lsv, lvoff, lvlen, tmps, len);
1739 Safefree(tmps);
1aa99e6b
IH
1740 }
1741 else
9aa983d2 1742 sv_insert(lsv, lvoff, lvlen, tmps, len);
1aa99e6b 1743
79072805
LW
1744 return 0;
1745}
1746
1747int
864dbfa3 1748Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
463ee0b2 1749{
565764a8 1750 TAINT_IF((mg->mg_len & 1) ||
155aba94 1751 ((mg->mg_len & 2) && mg->mg_obj == sv)); /* kludge */
463ee0b2
LW
1752 return 0;
1753}
1754
1755int
864dbfa3 1756Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
463ee0b2 1757{
3280af22
NIS
1758 if (PL_localizing) {
1759 if (PL_localizing == 1)
565764a8 1760 mg->mg_len <<= 1;
748a9306 1761 else
565764a8 1762 mg->mg_len >>= 1;
a0d0e21e 1763 }
3280af22 1764 else if (PL_tainted)
565764a8 1765 mg->mg_len |= 1;
748a9306 1766 else
565764a8 1767 mg->mg_len &= ~1;
463ee0b2
LW
1768 return 0;
1769}
1770
1771int
864dbfa3 1772Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
6ff81951
GS
1773{
1774 SV *lsv = LvTARG(sv);
6ff81951
GS
1775
1776 if (!lsv) {
155aba94 1777 (void)SvOK_off(sv);
6ff81951
GS
1778 return 0;
1779 }
6ff81951 1780
81e118e0 1781 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
6ff81951
GS
1782 return 0;
1783}
1784
1785int
864dbfa3 1786Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
79072805
LW
1787{
1788 do_vecset(sv); /* XXX slurp this routine */
1789 return 0;
1790}
1791
1792int
864dbfa3 1793Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
5f05dabc 1794{
71be2cbc 1795 SV *targ = Nullsv;
5f05dabc 1796 if (LvTARGLEN(sv)) {
68dc0745 1797 if (mg->mg_obj) {
74e13ce4 1798 SV *ahv = LvTARG(sv);
6d822dc4
MS
1799 HE *he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
1800 if (he)
1801 targ = HeVAL(he);
68dc0745
PP
1802 }
1803 else {
3c78fafa 1804 AV* av = (AV*)LvTARG(sv);
68dc0745
PP
1805 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
1806 targ = AvARRAY(av)[LvTARGOFF(sv)];
1807 }
3280af22 1808 if (targ && targ != &PL_sv_undef) {
68dc0745
PP
1809 /* somebody else defined it for us */
1810 SvREFCNT_dec(LvTARG(sv));
1811 LvTARG(sv) = SvREFCNT_inc(targ);
1812 LvTARGLEN(sv) = 0;
1813 SvREFCNT_dec(mg->mg_obj);
1814 mg->mg_obj = Nullsv;
1815 mg->mg_flags &= ~MGf_REFCOUNTED;
1816 }
5f05dabc 1817 }
71be2cbc
PP
1818 else
1819 targ = LvTARG(sv);
3280af22 1820 sv_setsv(sv, targ ? targ : &PL_sv_undef);
71be2cbc
PP
1821 return 0;
1822}
1823
1824int
864dbfa3 1825Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
71be2cbc
PP
1826{
1827 if (LvTARGLEN(sv))
68dc0745
PP
1828 vivify_defelem(sv);
1829 if (LvTARG(sv)) {
5f05dabc 1830 sv_setsv(LvTARG(sv), sv);
68dc0745
PP
1831 SvSETMAGIC(LvTARG(sv));
1832 }
5f05dabc
PP
1833 return 0;
1834}
1835
71be2cbc 1836void
864dbfa3 1837Perl_vivify_defelem(pTHX_ SV *sv)
71be2cbc 1838{
74e13ce4
GS
1839 MAGIC *mg;
1840 SV *value = Nullsv;
71be2cbc 1841
14befaf4 1842 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
71be2cbc 1843 return;
68dc0745 1844 if (mg->mg_obj) {
74e13ce4 1845 SV *ahv = LvTARG(sv);
2d8e6c8d 1846 STRLEN n_a;
6d822dc4
MS
1847 HE *he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
1848 if (he)
1849 value = HeVAL(he);
3280af22 1850 if (!value || value == &PL_sv_undef)
cea2e8a9 1851 Perl_croak(aTHX_ PL_no_helem, SvPV(mg->mg_obj, n_a));
71be2cbc 1852 }
68dc0745
PP
1853 else {
1854 AV* av = (AV*)LvTARG(sv);
5aabfad6 1855 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
68dc0745
PP
1856 LvTARG(sv) = Nullsv; /* array can't be extended */
1857 else {
1858 SV** svp = av_fetch(av, LvTARGOFF(sv), TRUE);
3280af22 1859 if (!svp || (value = *svp) == &PL_sv_undef)
cea2e8a9 1860 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
68dc0745
PP
1861 }
1862 }
3e3baf6d 1863 (void)SvREFCNT_inc(value);
68dc0745
PP
1864 SvREFCNT_dec(LvTARG(sv));
1865 LvTARG(sv) = value;
71be2cbc 1866 LvTARGLEN(sv) = 0;
68dc0745
PP
1867 SvREFCNT_dec(mg->mg_obj);
1868 mg->mg_obj = Nullsv;
1869 mg->mg_flags &= ~MGf_REFCOUNTED;
5f05dabc
PP
1870}
1871
1872int
864dbfa3 1873Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
810b8aa5
GS
1874{
1875 AV *av = (AV*)mg->mg_obj;
1876 SV **svp = AvARRAY(av);
1877 I32 i = AvFILLp(av);
1878 while (i >= 0) {
1879 if (svp[i] && svp[i] != &PL_sv_undef) {
1880 if (!SvWEAKREF(svp[i]))
cea2e8a9 1881 Perl_croak(aTHX_ "panic: magic_killbackrefs");
810b8aa5
GS
1882 /* XXX Should we check that it hasn't changed? */
1883 SvRV(svp[i]) = 0;
155aba94 1884 (void)SvOK_off(svp[i]);
810b8aa5
GS
1885 SvWEAKREF_off(svp[i]);
1886 svp[i] = &PL_sv_undef;
1887 }
1888 i--;
1889 }
d99b02a1 1890 SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */
810b8aa5
GS
1891 return 0;
1892}
1893
1894int
864dbfa3 1895Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
93a17b20 1896{
565764a8 1897 mg->mg_len = -1;
c6496cc7 1898 SvSCREAM_off(sv);
93a17b20
LW
1899 return 0;
1900}
1901
1902int
864dbfa3 1903Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
79072805 1904{
14befaf4 1905 sv_unmagic(sv, PERL_MAGIC_bm);
79072805
LW
1906 SvVALID_off(sv);
1907 return 0;
1908}
1909
1910int
864dbfa3 1911Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
55497cff 1912{
14befaf4 1913 sv_unmagic(sv, PERL_MAGIC_fm);
55497cff
PP
1914 SvCOMPILED_off(sv);
1915 return 0;
1916}
1917
1918int
864dbfa3 1919Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
79072805
LW
1920{
1921 struct ufuncs *uf = (struct ufuncs *)mg->mg_ptr;
1922
1923 if (uf && uf->uf_set)
24f81a43 1924 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
79072805
LW
1925 return 0;
1926}
1927
c277df42 1928int
faf82a0b
AE
1929Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
1930{
1931 sv_unmagic(sv, PERL_MAGIC_qr);
1932 return 0;
1933}
1934
1935int
864dbfa3 1936Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
c277df42
IZ
1937{
1938 regexp *re = (regexp *)mg->mg_obj;
1939 ReREFCNT_dec(re);
1940 return 0;
1941}
1942
7a4c00b4 1943#ifdef USE_LOCALE_COLLATE
79072805 1944int
864dbfa3 1945Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
bbce6d69
PP
1946{
1947 /*
838b5b74 1948 * RenE<eacute> Descartes said "I think not."
bbce6d69
PP
1949 * and vanished with a faint plop.
1950 */
7a4c00b4
PP
1951 if (mg->mg_ptr) {
1952 Safefree(mg->mg_ptr);
1953 mg->mg_ptr = NULL;
565764a8 1954 mg->mg_len = -1;
7a4c00b4 1955 }
bbce6d69
PP
1956 return 0;
1957}
7a4c00b4 1958#endif /* USE_LOCALE_COLLATE */
bbce6d69 1959
7e8c5dac
HS
1960/* Just clear the UTF-8 cache data. */
1961int
1962Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
1963{
1964 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
1965 mg->mg_ptr = 0;
1966 mg->mg_len = -1; /* The mg_len holds the len cache. */
1967 return 0;
1968}
1969
bbce6d69 1970int
864dbfa3 1971Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
79072805
LW
1972{
1973 register char *s;
1974 I32 i;
8990e307 1975 STRLEN len;
79072805 1976 switch (*mg->mg_ptr) {
748a9306 1977 case '\001': /* ^A */
3280af22 1978 sv_setsv(PL_bodytarget, sv);
748a9306 1979 break;
49460fe6 1980 case '\003': /* ^C */
eb160463 1981 PL_minus_c = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
49460fe6
NIS
1982 break;
1983
79072805 1984 case '\004': /* ^D */
b4ab917c
DM
1985#ifdef DEBUGGING
1986 s = SvPV_nolen(sv);
1987 PL_debug = get_debug_opts(&s) | DEBUG_TOP_FLAG;
79072805 1988 DEBUG_x(dump_all());
b4ab917c
DM
1989#else
1990 PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | DEBUG_TOP_FLAG;
1991#endif
79072805 1992 break;
28f23441 1993 case '\005': /* ^E */
d0063567 1994 if (*(mg->mg_ptr+1) == '\0') {
cd39f2b6 1995#ifdef MACOS_TRADITIONAL
d0063567 1996 gMacPerl_OSErr = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
28f23441 1997#else
cd39f2b6 1998# ifdef VMS
d0063567 1999 set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
048c1ddf 2000# else
cd39f2b6 2001# ifdef WIN32
d0063567 2002 SetLastError( SvIV(sv) );
cd39f2b6 2003# else
9fed8b87 2004# ifdef OS2
d0063567 2005 os2_setsyserrno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
9fed8b87 2006# else
d0063567
DK
2007 /* will anyone ever use this? */
2008 SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4);
cd39f2b6 2009# endif
048c1ddf
IZ
2010# endif
2011# endif
22fae026 2012#endif
d0063567
DK
2013 }
2014 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2015 if (PL_encoding)
2016 SvREFCNT_dec(PL_encoding);
2017 if (SvOK(sv) || SvGMAGICAL(sv)) {
2018 PL_encoding = newSVsv(sv);
2019 }
2020 else {
2021 PL_encoding = Nullsv;
2022 }
2023 }
2024 break;
79072805 2025 case '\006': /* ^F */
3280af22 2026 PL_maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
79072805 2027 break;
a0d0e21e 2028 case '\010': /* ^H */
3280af22 2029 PL_hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
a0d0e21e 2030 break;
9d116dd7 2031 case '\011': /* ^I */ /* NOT \t in EBCDIC */
3280af22
NIS
2032 if (PL_inplace)
2033 Safefree(PL_inplace);
79072805 2034 if (SvOK(sv))
2d8e6c8d 2035 PL_inplace = savepv(SvPV(sv,len));
79072805 2036 else
3280af22 2037 PL_inplace = Nullch;
79072805 2038 break;
28f23441 2039 case '\017': /* ^O */
ac27b0f5
NIS
2040 if (*(mg->mg_ptr+1) == '\0') {
2041 if (PL_osname)
2042 Safefree(PL_osname);
2043 if (SvOK(sv))
2044 PL_osname = savepv(SvPV(sv,len));
2045 else
2046 PL_osname = Nullch;
2047 }
2048 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2049 if (!PL_compiling.cop_io)
2050 PL_compiling.cop_io = newSVsv(sv);
2051 else
2052 sv_setsv(PL_compiling.cop_io,sv);
2053 }
28f23441 2054 break;
79072805 2055 case '\020': /* ^P */
3280af22 2056 PL_perldb = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1ee4443e
IZ
2057 if (PL_perldb && !PL_DBsingle)
2058 init_debugger();
79072805
LW
2059 break;
2060 case '\024': /* ^T */
88e89b8a 2061#ifdef BIG_TIME
6b88bc9c 2062 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
88e89b8a 2063#else
3280af22 2064 PL_basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
88e89b8a 2065#endif
79072805 2066 break;
fde18df1 2067 case '\027': /* ^W & $^WARNING_BITS */
4438c4b7
JH
2068 if (*(mg->mg_ptr+1) == '\0') {
2069 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2070 i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
ac27b0f5 2071 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
0453d815 2072 | (i ? G_WARN_ON : G_WARN_OFF) ;
4438c4b7 2073 }
599cee73 2074 }
0a378802 2075 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
4438c4b7 2076 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
d775746e
GS
2077 if (!SvPOK(sv) && PL_localizing) {
2078 sv_setpvn(sv, WARN_NONEstring, WARNsize);
d3a7d8c7 2079 PL_compiling.cop_warnings = pWARN_NONE;
d775746e
GS
2080 break;
2081 }
f4fc7782 2082 {
b5477537 2083 STRLEN len, i;
d3a7d8c7 2084 int accumulate = 0 ;
f4fc7782 2085 int any_fatals = 0 ;
d3a7d8c7 2086 char * ptr = (char*)SvPV(sv, len) ;
f4fc7782
JH
2087 for (i = 0 ; i < len ; ++i) {
2088 accumulate |= ptr[i] ;
2089 any_fatals |= (ptr[i] & 0xAA) ;
2090 }
d3a7d8c7
GS
2091 if (!accumulate)
2092 PL_compiling.cop_warnings = pWARN_NONE;
f4fc7782
JH
2093 else if (isWARN_on(sv, WARN_ALL) && !any_fatals) {
2094 PL_compiling.cop_warnings = pWARN_ALL;
2095 PL_dowarn |= G_WARN_ONCE ;
727405f8 2096 }
d3a7d8c7
GS
2097 else {
2098 if (specialWARN(PL_compiling.cop_warnings))
2099 PL_compiling.cop_warnings = newSVsv(sv) ;
2100 else
2101 sv_setsv(PL_compiling.cop_warnings, sv);
2102 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2103 PL_dowarn |= G_WARN_ONCE ;
2104 }
f4fc7782 2105
d3a7d8c7 2106 }
4438c4b7 2107 }
971a9dd3 2108 }
79072805
LW
2109 break;
2110 case '.':
3280af22
NIS
2111 if (PL_localizing) {
2112 if (PL_localizing == 1)
7766f137 2113 SAVESPTR(PL_last_in_gv);
748a9306 2114 }
3280af22 2115 else if (SvOK(sv) && GvIO(PL_last_in_gv))
632db599 2116 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
79072805
LW
2117 break;
2118 case '^':
3280af22 2119 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2d8e6c8d 2120 IoTOP_NAME(GvIOp(PL_defoutgv)) = s = savepv(SvPV(sv,len));
3280af22 2121 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchpv(s,TRUE, SVt_PVIO);
79072805
LW
2122 break;
2123 case '~':
3280af22 2124 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2d8e6c8d 2125 IoFMT_NAME(GvIOp(PL_defoutgv)) = s = savepv(SvPV(sv,len));
3280af22 2126 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchpv(s,TRUE, SVt_PVIO);
79072805
LW
2127 break;
2128 case '=':
632db599 2129 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
79072805
LW
2130 break;
2131 case '-':
632db599 2132 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
3280af22
NIS
2133 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2134 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
79072805
LW
2135 break;
2136 case '%':
632db599 2137 IoPAGE(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
79072805
LW
2138 break;
2139 case '|':
4b65379b 2140 {
3280af22 2141 IO *io = GvIOp(PL_defoutgv);
720f287d
AB
2142 if(!io)
2143 break;
4b65379b
CS
2144 if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) == 0)
2145 IoFLAGS(io) &= ~IOf_FLUSH;
2146 else {
2147 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2148 PerlIO *ofp = IoOFP(io);
2149 if (ofp)
2150 (void)PerlIO_flush(ofp);
2151 IoFLAGS(io) |= IOf_FLUSH;
2152 }
2153 }
79072805
LW
2154 }
2155 break;
79072805 2156 case '/':
3280af22 2157 SvREFCNT_dec(PL_rs);
8bfdd7d9 2158 PL_rs = newSVsv(sv);
79072805
LW
2159 break;
2160 case '\\':
7889fe52
NIS
2161 if (PL_ors_sv)
2162 SvREFCNT_dec(PL_ors_sv);
009c130f 2163 if (SvOK(sv) || SvGMAGICAL(sv)) {
7889fe52 2164 PL_ors_sv = newSVsv(sv);
009c130f 2165 }
e3c19b7b 2166 else {
7889fe52 2167 PL_ors_sv = Nullsv;
e3c19b7b 2168 }
79072805
LW
2169 break;
2170 case ',':
7889fe52
NIS
2171 if (PL_ofs_sv)
2172 SvREFCNT_dec(PL_ofs_sv);
2173 if (SvOK(sv) || SvGMAGICAL(sv)) {
2174 PL_ofs_sv = newSVsv(sv);
2175 }
2176 else {
2177 PL_ofs_sv = Nullsv;
2178 }
79072805
LW
2179 break;
2180 case '#':
3280af22
NIS
2181 if (PL_ofmt)
2182 Safefree(PL_ofmt);
2d8e6c8d 2183 PL_ofmt = savepv(SvPV(sv,len));
79072805
LW
2184 break;
2185 case '[':
3280af22 2186 PL_compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
79072805
LW
2187 break;
2188 case '?':
ff0cee69 2189#ifdef COMPLEX_STATUS
6b88bc9c
GS
2190 if (PL_localizing == 2) {
2191 PL_statusvalue = LvTARGOFF(sv);
2192 PL_statusvalue_vms = LvTARGLEN(sv);
ff0cee69
PP
2193 }
2194 else
2195#endif
2196#ifdef VMSISH_STATUS
2197 if (VMSISH_STATUS)
2198 STATUS_NATIVE_SET((U32)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)));
2199 else
2200#endif
2201 STATUS_POSIX_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
79072805
LW
2202 break;
2203 case '!':
93189314
JH
2204 {
2205#ifdef VMS
2206# define PERL_VMS_BANG vaxc$errno
2207#else
2208# define PERL_VMS_BANG 0
2209#endif
91487cfc 2210 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
93189314
JH
2211 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2212 }
79072805
LW
2213 break;
2214 case '<':
3280af22
NIS
2215 PL_uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2216 if (PL_delaymagic) {
2217 PL_delaymagic |= DM_RUID;
79072805
LW
2218 break; /* don't do magic till later */
2219 }
2220#ifdef HAS_SETRUID
b28d0864 2221 (void)setruid((Uid_t)PL_uid);
79072805
LW
2222#else
2223#ifdef HAS_SETREUID
3280af22 2224 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
748a9306 2225#else
85e6fe83 2226#ifdef HAS_SETRESUID
b28d0864 2227 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
79072805 2228#else
b28d0864
NIS
2229 if (PL_uid == PL_euid) /* special case $< = $> */
2230 (void)PerlProc_setuid(PL_uid);
a0d0e21e 2231 else {
d8eceb89 2232 PL_uid = PerlProc_getuid();
cea2e8a9 2233 Perl_croak(aTHX_ "setruid() not implemented");
a0d0e21e 2234 }
79072805
LW
2235#endif
2236#endif
85e6fe83 2237#endif
d8eceb89 2238 PL_uid = PerlProc_getuid();
3280af22 2239 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
79072805
LW
2240 break;
2241 case '>':
3280af22
NIS
2242 PL_euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2243 if (PL_delaymagic) {
2244 PL_delaymagic |= DM_EUID;
79072805
LW
2245 break; /* don't do magic till later */
2246 }
2247#ifdef HAS_SETEUID
3280af22 2248 (void)seteuid((Uid_t)PL_euid);
79072805
LW
2249#else
2250#ifdef HAS_SETREUID
b28d0864 2251 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
85e6fe83
LW
2252#else
2253#ifdef HAS_SETRESUID
6b88bc9c 2254 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
79072805 2255#else
b28d0864
NIS
2256 if (PL_euid == PL_uid) /* special case $> = $< */
2257 PerlProc_setuid(PL_euid);
a0d0e21e 2258 else {
e8ee3774 2259 PL_euid = PerlProc_geteuid();
cea2e8a9 2260 Perl_croak(aTHX_ "seteuid() not implemented");
a0d0e21e 2261 }
79072805
LW
2262#endif
2263#endif
85e6fe83 2264#endif
d8eceb89 2265 PL_euid = PerlProc_geteuid();
3280af22 2266 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
79072805
LW
2267 break;
2268 case '(':
3280af22
NIS
2269 PL_gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2270 if (PL_delaymagic) {
2271 PL_delaymagic |= DM_RGID;
79072805
LW
2272 break; /* don't do magic till later */
2273 }
2274#ifdef HAS_SETRGID
b28d0864 2275 (void)setrgid((Gid_t)PL_gid);
79072805
LW
2276#else
2277#ifdef HAS_SETREGID
3280af22 2278 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
85e6fe83
LW
2279#else
2280#ifdef HAS_SETRESGID
b28d0864 2281 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
79072805 2282#else
b28d0864
NIS
2283 if (PL_gid == PL_egid) /* special case $( = $) */
2284 (void)PerlProc_setgid(PL_gid);
748a9306 2285 else {
d8eceb89 2286 PL_gid = PerlProc_getgid();
cea2e8a9 2287 Perl_croak(aTHX_ "setrgid() not implemented");
748a9306 2288 }
79072805
LW
2289#endif
2290#endif
85e6fe83 2291#endif
d8eceb89 2292 PL_gid = PerlProc_getgid();
3280af22 2293 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
79072805
LW
2294 break;
2295 case ')':
5cd24f17
PP
2296#ifdef HAS_SETGROUPS
2297 {
2d8e6c8d 2298 char *p = SvPV(sv, len);
5cd24f17
PP
2299 Groups_t gary[NGROUPS];
2300
5cd24f17
PP
2301 while (isSPACE(*p))
2302 ++p;
2d4389e4 2303 PL_egid = Atol(p);
5cd24f17
PP
2304 for (i = 0; i < NGROUPS; ++i) {
2305 while (*p && !isSPACE(*p))
2306 ++p;
2307 while (isSPACE(*p))
2308 ++p;
2309 if (!*p)
2310 break;
2d4389e4 2311 gary[i] = Atol(p);
5cd24f17 2312 }
8cc95fdb
PP
2313 if (i)
2314 (void)setgroups(i, gary);
5cd24f17
PP
2315 }
2316#else /* HAS_SETGROUPS */
b28d0864 2317 PL_egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
5cd24f17 2318#endif /* HAS_SETGROUPS */
3280af22
NIS
2319 if (PL_delaymagic) {
2320 PL_delaymagic |= DM_EGID;
79072805
LW
2321 break; /* don't do magic till later */
2322 }
2323#ifdef HAS_SETEGID
3280af22 2324 (void)setegid((Gid_t)PL_egid);
79072805
LW
2325#else
2326#ifdef HAS_SETREGID
b28d0864 2327 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
85e6fe83
LW
2328#else
2329#ifdef HAS_SETRESGID
b28d0864 2330 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
79072805 2331#else
b28d0864
NIS
2332 if (PL_egid == PL_gid) /* special case $) = $( */
2333 (void)PerlProc_setgid(PL_egid);
748a9306 2334 else {
d8eceb89 2335 PL_egid = PerlProc_getegid();
cea2e8a9 2336 Perl_croak(aTHX_ "setegid() not implemented");
748a9306 2337 }
79072805
LW
2338#endif
2339#endif
85e6fe83 2340#endif
d8eceb89 2341 PL_egid = PerlProc_getegid();
3280af22 2342 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
79072805
LW
2343 break;
2344 case ':':
2d8e6c8d 2345 PL_chopset = SvPV_force(sv,len);
79072805 2346 break;
cd39f2b6 2347#ifndef MACOS_TRADITIONAL
79072805 2348 case '0':
e2975953 2349 LOCK_DOLLARZERO_MUTEX;
4bc88a62
PS
2350#ifdef HAS_SETPROCTITLE
2351 /* The BSDs don't show the argv[] in ps(1) output, they
2352 * show a string from the process struct and provide
2353 * the setproctitle() routine to manipulate that. */
2354 {
2355 s = SvPV(sv, len);
98b76f99 2356# if __FreeBSD_version > 410001
9aad2c0e 2357 /* The leading "-" removes the "perl: " prefix,
4bc88a62
PS
2358 * but not the "(perl) suffix from the ps(1)
2359 * output, because that's what ps(1) shows if the
2360 * argv[] is modified. */
6f2ad931 2361 setproctitle("-%s", s);
9aad2c0e 2362# else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
4bc88a62
PS
2363 /* This doesn't really work if you assume that
2364 * $0 = 'foobar'; will wipe out 'perl' from the $0
2365 * because in ps(1) output the result will be like
2366 * sprintf("perl: %s (perl)", s)
2367 * I guess this is a security feature:
2368 * one (a user process) cannot get rid of the original name.
2369 * --jhi */
2370 setproctitle("%s", s);
2371# endif
2372 }
2373#endif
17aa7f3d
JH
2374#if defined(__hpux) && defined(PSTAT_SETCMD)
2375 {
2376 union pstun un;
2377 s = SvPV(sv, len);
2378 un.pst_command = s;
2379 pstat(PSTAT_SETCMD, un, len, 0, 0);
2380 }
2381#endif
3cb9023d 2382 /* PL_origalen is set in perl_parse(). */
a0d0e21e 2383 s = SvPV_force(sv,len);
8bafa735 2384 if (len >= (STRLEN)PL_origalen) {
54bfe034
JH
2385 /* Longer than original, will be truncated. */
2386 Copy(s, PL_origargv[0], PL_origalen, char);
2387 PL_origargv[0][PL_origalen - 1] = 0;
79072805
LW
2388 }
2389 else {
54bfe034
JH
2390 /* Shorter than original, will be padded. */
2391 Copy(s, PL_origargv[0], len, char);
2392 PL_origargv[0][len] = 0;
2393 memset(PL_origargv[0] + len + 1,
2394 /* Is the space counterintuitive? Yes.
2395 * (You were expecting \0?)
3cb9023d 2396 * Does it work? Seems to. (In Linux 2.4.20 at least.)
54bfe034
JH
2397 * --jhi */
2398 (int)' ',
2399 PL_origalen - len - 1);
3280af22 2400 for (i = 1; i < PL_origargc; i++)
54bfe034 2401 PL_origargv[i] = 0;
79072805 2402 }
e2975953 2403 UNLOCK_DOLLARZERO_MUTEX;
79072805 2404 break;
cd39f2b6 2405#endif
79072805
LW
2406 }
2407 return 0;
2408}
2409
2410I32
864dbfa3 2411Perl_whichsig(pTHX_ char *sig)
79072805
LW
2412{
2413 register char **sigv;
2414
e02bfb16 2415 for (sigv = PL_sig_name; *sigv; sigv++)
79072805 2416 if (strEQ(sig,*sigv))
22c35a8c 2417 return PL_sig_num[sigv - PL_sig_name];
79072805
LW
2418#ifdef SIGCLD
2419 if (strEQ(sig,"CHLD"))
2420 return SIGCLD;
2421#endif
2422#ifdef SIGCHLD
2423 if (strEQ(sig,"CLD"))
2424 return SIGCHLD;
2425#endif
7f1236c0 2426 return -1;
79072805
LW
2427}
2428
df3728a2 2429#if !defined(PERL_IMPLICIT_CONTEXT)
84902520 2430static SV* sig_sv;
df3728a2 2431#endif
84902520 2432
ecfc5424 2433Signal_t
cea2e8a9 2434Perl_sighandler(int sig)
79072805 2435{
1018e26f
NIS
2436#ifdef PERL_GET_SIG_CONTEXT
2437 dTHXa(PERL_GET_SIG_CONTEXT);
71d280e3 2438#else
cea2e8a9 2439 dTHX;
71d280e3 2440#endif
79072805 2441 dSP;
00d579c5 2442 GV *gv = Nullgv;
a0d0e21e 2443 HV *st;
b7953727 2444 SV *sv = Nullsv, *tSv = PL_Sv;
00d579c5 2445 CV *cv = Nullcv;
533c011a 2446 OP *myop = PL_op;
84902520 2447 U32 flags = 0;
3280af22 2448 XPV *tXpv = PL_Xpv;
71d280e3 2449
3280af22 2450 if (PL_savestack_ix + 15 <= PL_savestack_max)
84902520 2451 flags |= 1;
3280af22 2452 if (PL_markstack_ptr < PL_markstack_max - 2)
84902520 2453 flags |= 4;
3280af22 2454 if (PL_retstack_ix < PL_retstack_max - 2)
84902520 2455 flags |= 8;
3280af22 2456 if (PL_scopestack_ix < PL_scopestack_max - 3)
84902520
TB
2457 flags |= 16;
2458
727405f8 2459 if (!PL_psig_ptr[sig]) {
99ef548b 2460 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
727405f8
NIS
2461 PL_sig_name[sig]);
2462 exit(sig);
2463 }
ff0cee69 2464
84902520
TB
2465 /* Max number of items pushed there is 3*n or 4. We cannot fix
2466 infinity, so we fix 4 (in fact 5): */
2467 if (flags & 1) {
3280af22 2468 PL_savestack_ix += 5; /* Protect save in progress. */
c76ac1ee 2469 SAVEDESTRUCTOR_X(unwind_handler_stack, (void*)&flags);
84902520 2470 }
ac27b0f5 2471 if (flags & 4)
3280af22 2472 PL_markstack_ptr++; /* Protect mark. */
84902520 2473 if (flags & 8) {
3280af22
NIS
2474 PL_retstack_ix++;
2475 PL_retstack[PL_retstack_ix] = NULL;
84902520
TB
2476 }
2477 if (flags & 16)
3280af22 2478 PL_scopestack_ix += 1;
84902520 2479 /* sv_2cv is too complicated, try a simpler variant first: */
ac27b0f5 2480 if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
84902520 2481 || SvTYPE(cv) != SVt_PVCV)
22c35a8c 2482 cv = sv_2cv(PL_psig_ptr[sig],&st,&gv,TRUE);
84902520 2483
a0d0e21e 2484 if (!cv || !CvROOT(cv)) {
599cee73 2485 if (ckWARN(WARN_SIGNAL))
9014280d 2486 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
22c35a8c 2487 PL_sig_name[sig], (gv ? GvENAME(gv)
00d579c5
GS
2488 : ((cv && CvGV(cv))
2489 ? GvENAME(CvGV(cv))
2490 : "__ANON__")));
2491 goto cleanup;
79072805
LW
2492 }
2493
22c35a8c
GS
2494 if(PL_psig_name[sig]) {
2495 sv = SvREFCNT_inc(PL_psig_name[sig]);
84902520 2496 flags |= 64;
df3728a2 2497#if !defined(PERL_IMPLICIT_CONTEXT)
84902520 2498 sig_sv = sv;
df3728a2 2499#endif
84902520 2500 } else {
ff0cee69 2501 sv = sv_newmortal();
22c35a8c 2502 sv_setpv(sv,PL_sig_name[sig]);
88e89b8a 2503 }
e336de0d 2504
e788e7d3 2505 PUSHSTACKi(PERLSI_SIGNAL);
924508f0 2506 PUSHMARK(SP);
79072805 2507 PUSHs(sv);
79072805 2508 PUTBACK;
a0d0e21e 2509
1b266415 2510 call_sv((SV*)cv, G_DISCARD|G_EVAL);
79072805 2511
d3acc0f7 2512 POPSTACK;
1b266415 2513 if (SvTRUE(ERRSV)) {
1d615522 2514#ifndef PERL_MICRO
983dbef6 2515#ifdef HAS_SIGPROCMASK
1b266415
NIS
2516 /* Handler "died", for example to get out of a restart-able read().
2517 * Before we re-do that on its behalf re-enable the signal which was
2518 * blocked by the system when we entered.
2519 */
2520 sigset_t set;
2521 sigemptyset(&set);
2522 sigaddset(&set,sig);
2523 sigprocmask(SIG_UNBLOCK, &set, NULL);
2524#else
2525 /* Not clear if this will work */
2526 (void)rsignal(sig, SIG_IGN);
5c1546dc 2527 (void)rsignal(sig, PL_csighandlerp);
1b266415 2528#endif
1d615522 2529#endif /* !PERL_MICRO */
b3fe4827 2530 Perl_die(aTHX_ Nullformat);
1b266415 2531 }
00d579c5 2532cleanup:
84902520 2533 if (flags & 1)
3280af22 2534 PL_savestack_ix -= 8; /* Unprotect save in progress. */
ac27b0f5 2535 if (flags & 4)
3280af22 2536 PL_markstack_ptr--;
ac27b0f5 2537 if (flags & 8)
3280af22 2538 PL_retstack_ix--;
84902520 2539 if (flags & 16)
3280af22 2540 PL_scopestack_ix -= 1;
84902520
TB
2541 if (flags & 64)
2542 SvREFCNT_dec(sv);
533c011a 2543 PL_op = myop; /* Apparently not needed... */
ac27b0f5 2544
3280af22
NIS
2545 PL_Sv = tSv; /* Restore global temporaries. */
2546 PL_Xpv = tXpv;
53bb94e2 2547 return;
79072805 2548}
4e35701f
NIS
2549
2550
51371543 2551static void
acfe0abc 2552restore_magic(pTHX_ void *p)
51371543 2553{
48944bdf 2554 MGS* mgs = SSPTR(PTR2IV(p), MGS*);
51371543
GS
2555 SV* sv = mgs->mgs_sv;
2556
2557 if (!sv)
2558 return;
2559
2560 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2561 {
2562 if (mgs->mgs_flags)
2563 SvFLAGS(sv) |= mgs->mgs_flags;
2564 else
2565 mg_magical(sv);
2566 if (SvGMAGICAL(sv))
2567 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
2568 }
2569
2570 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
2571
2572 /* If we're still on top of the stack, pop us off. (That condition
2573 * will be satisfied if restore_magic was called explicitly, but *not*
2574 * if it's being called via leave_scope.)
2575 * The reason for doing this is that otherwise, things like sv_2cv()
2576 * may leave alloc gunk on the savestack, and some code
2577 * (e.g. sighandler) doesn't expect that...
2578 */
2579 if (PL_savestack_ix == mgs->mgs_ss_ix)
2580 {
2581 I32 popval = SSPOPINT;
c76ac1ee 2582 assert(popval == SAVEt_DESTRUCTOR_X);
51371543
GS
2583 PL_savestack_ix -= 2;
2584 popval = SSPOPINT;
2585 assert(popval == SAVEt_ALLOC);
2586 popval = SSPOPINT;
2587 PL_savestack_ix -= popval;
2588 }
2589
2590}
2591
2592static void
acfe0abc 2593unwind_handler_stack(pTHX_ void *p)
51371543 2594{
51371543
GS
2595 U32 flags = *(U32*)p;
2596
2597 if (flags & 1)
2598 PL_savestack_ix -= 5; /* Unprotect save in progress. */
2599 /* cxstack_ix-- Not needed, die already unwound it. */
df3728a2 2600#if !defined(PERL_IMPLICIT_CONTEXT)
51371543
GS
2601 if (flags & 64)
2602 SvREFCNT_dec(sig_sv);
df3728a2 2603#endif
51371543 2604}
1018e26f
NIS
2605
2606