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