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