This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
OPf_SPECIAL on OP_DBSTATE now indicates a breakpoint.
[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
53c4c00c 421 if (i > 0 && PL_reg_match_utf8) {
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:
53c4c00c 462 if (i > 0 && PL_reg_match_utf8) {
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 */
d58bf5aa 643 {
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;
fde18df1
JH
665 case '\025': /* $^UTF8_LOCALE */
666 if (strEQ(mg->mg_ptr, "\025TF8_LOCALE"))
667 sv_setiv(sv, (IV) (PL_wantutf8 && PL_utf8locale));
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);
a8c7c11a 710 if (PL_reg_match_utf8 && 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
1125
0a8e0eff
NIS
1126#ifdef PERL_OLD_SIGNALS
1127 /* Call the perl level handler now with risk we may be in malloc() etc. */
1128 (*PL_sighandlerp)(sig);
1129#else
0a8e0eff
NIS
1130 Perl_raise_signal(aTHX_ sig);
1131#endif
1132}
1133
2e34cc90
CL
1134#if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1135void
1136Perl_csighandler_init(void)
1137{
1138 int sig;
1139 if (sig_handlers_initted) return;
1140
1141 for (sig = 1; sig < SIG_SIZE; sig++) {
1142#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
218fdd94 1143 dTHX;
2e34cc90
CL
1144 sig_defaulting[sig] = 1;
1145 (void) rsignal(sig, &Perl_csighandler);
1146#endif
1147#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1148 sig_ignoring[sig] = 0;
1149#endif
1150 }
1151 sig_handlers_initted = 1;
1152}
1153#endif
1154
0a8e0eff
NIS
1155void
1156Perl_despatch_signals(pTHX)
1157{
1158 int sig;
1159 PL_sig_pending = 0;
1160 for (sig = 1; sig < SIG_SIZE; sig++) {
1161 if (PL_psig_pend[sig]) {
1162 PL_psig_pend[sig] = 0;
1163 (*PL_sighandlerp)(sig);
1164 }
1165 }
1166}
1167
85e6fe83 1168int
864dbfa3 1169Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
79072805
LW
1170{
1171 register char *s;
1172 I32 i;
b7953727 1173 SV** svp = 0;
e72dc28c 1174 STRLEN len;
a0d0e21e 1175
e72dc28c 1176 s = MgPV(mg,len);
748a9306
LW
1177 if (*s == '_') {
1178 if (strEQ(s,"__DIE__"))
3280af22 1179 svp = &PL_diehook;
748a9306 1180 else if (strEQ(s,"__WARN__"))
3280af22 1181 svp = &PL_warnhook;
748a9306 1182 else
cea2e8a9 1183 Perl_croak(aTHX_ "No such hook: %s", s);
748a9306 1184 i = 0;
4633a7c4
LW
1185 if (*svp) {
1186 SvREFCNT_dec(*svp);
1187 *svp = 0;
1188 }
748a9306
LW
1189 }
1190 else {
1191 i = whichsig(s); /* ...no, a brick */
1192 if (!i) {
e476b1b5 1193 if (ckWARN(WARN_SIGNAL))
9014280d 1194 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
748a9306
LW
1195 return 0;
1196 }
2e34cc90
CL
1197#if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1198 if (!sig_handlers_initted) Perl_csighandler_init();
1199#endif
23ada85b 1200#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
85b332e2
CL
1201 sig_ignoring[i] = 0;
1202#endif
2e34cc90
CL
1203#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1204 sig_defaulting[i] = 0;
1205#endif
22c35a8c
GS
1206 SvREFCNT_dec(PL_psig_name[i]);
1207 SvREFCNT_dec(PL_psig_ptr[i]);
1208 PL_psig_ptr[i] = SvREFCNT_inc(sv);
88e89b8a 1209 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
e72dc28c 1210 PL_psig_name[i] = newSVpvn(s, len);
22c35a8c 1211 SvREADONLY_on(PL_psig_name[i]);
748a9306 1212 }
a0d0e21e 1213 if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
748a9306 1214 if (i)
0a8e0eff 1215 (void)rsignal(i, &Perl_csighandler);
748a9306
LW
1216 else
1217 *svp = SvREFCNT_inc(sv);
a0d0e21e
LW
1218 return 0;
1219 }
e72dc28c 1220 s = SvPV_force(sv,len);
748a9306 1221 if (strEQ(s,"IGNORE")) {
85b332e2 1222 if (i) {
23ada85b 1223#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
85b332e2
CL
1224 sig_ignoring[i] = 1;
1225 (void)rsignal(i, &Perl_csighandler);
1226#else
ff68c719 1227 (void)rsignal(i, SIG_IGN);
85b332e2
CL
1228#endif
1229 } else
748a9306
LW
1230 *svp = 0;
1231 }
1232 else if (strEQ(s,"DEFAULT") || !*s) {
1233 if (i)
2e34cc90
CL
1234#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1235 {
1236 sig_defaulting[i] = 1;
1237 (void)rsignal(i, &Perl_csighandler);
1238 }
1239#else
ff68c719 1240 (void)rsignal(i, SIG_DFL);
2e34cc90 1241#endif
748a9306
LW
1242 else
1243 *svp = 0;
1244 }
79072805 1245 else {
5aabfad6
PP
1246 /*
1247 * We should warn if HINT_STRICT_REFS, but without
1248 * access to a known hint bit in a known OP, we can't
1249 * tell whether HINT_STRICT_REFS is in force or not.
1250 */
46fc3d4c 1251 if (!strchr(s,':') && !strchr(s,'\''))
e72dc28c 1252 sv_insert(sv, 0, 0, "main::", 6);
748a9306 1253 if (i)
0a8e0eff 1254 (void)rsignal(i, &Perl_csighandler);
748a9306
LW
1255 else
1256 *svp = SvREFCNT_inc(sv);
79072805
LW
1257 }
1258 return 0;
1259}
64ca3a65 1260#endif /* !PERL_MICRO */
79072805
LW
1261
1262int
864dbfa3 1263Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
79072805 1264{
3280af22 1265 PL_sub_generation++;
463ee0b2
LW
1266 return 0;
1267}
1268
1269int
864dbfa3 1270Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
463ee0b2 1271{
a0d0e21e 1272 /* HV_badAMAGIC_on(Sv_STASH(sv)); */
3280af22 1273 PL_amagic_generation++;
463ee0b2 1274
a0d0e21e
LW
1275 return 0;
1276}
463ee0b2 1277
946ec16e 1278int
864dbfa3 1279Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
6ff81951
GS
1280{
1281 HV *hv = (HV*)LvTARG(sv);
6ff81951 1282 I32 i = 0;
7719e241 1283
6ff81951 1284 if (hv) {
497b47a8
JH
1285 (void) hv_iterinit(hv);
1286 if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
1287 i = HvKEYS(hv);
1288 else {
1289 while (hv_iternext(hv))
1290 i++;
1291 }
6ff81951
GS
1292 }
1293
1294 sv_setiv(sv, (IV)i);
1295 return 0;
1296}
1297
1298int
864dbfa3 1299Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
946ec16e
PP
1300{
1301 if (LvTARG(sv)) {
1302 hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
946ec16e
PP
1303 }
1304 return 0;
ac27b0f5 1305}
946ec16e 1306
e336de0d 1307/* caller is responsible for stack switching/cleanup */
565764a8 1308STATIC int
cea2e8a9 1309S_magic_methcall(pTHX_ SV *sv, MAGIC *mg, char *meth, I32 flags, int n, SV *val)
a0d0e21e
LW
1310{
1311 dSP;
463ee0b2 1312
924508f0
GS
1313 PUSHMARK(SP);
1314 EXTEND(SP, n);
33c27489 1315 PUSHs(SvTIED_obj(sv, mg));
ac27b0f5 1316 if (n > 1) {
93965878 1317 if (mg->mg_ptr) {
565764a8 1318 if (mg->mg_len >= 0)
79cb57f6 1319 PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len)));
565764a8 1320 else if (mg->mg_len == HEf_SVKEY)
93965878
NIS
1321 PUSHs((SV*)mg->mg_ptr);
1322 }
14befaf4 1323 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
565764a8 1324 PUSHs(sv_2mortal(newSViv(mg->mg_len)));
93965878
NIS
1325 }
1326 }
1327 if (n > 2) {
1328 PUSHs(val);
88e89b8a 1329 }
463ee0b2
LW
1330 PUTBACK;
1331
864dbfa3 1332 return call_method(meth, flags);
946ec16e
PP
1333}
1334
76e3520e 1335STATIC int
cea2e8a9 1336S_magic_methpack(pTHX_ SV *sv, MAGIC *mg, char *meth)
a0d0e21e
LW
1337{
1338 dSP;
463ee0b2 1339
a0d0e21e
LW
1340 ENTER;
1341 SAVETMPS;
e788e7d3 1342 PUSHSTACKi(PERLSI_MAGIC);
463ee0b2 1343
33c27489 1344 if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
3280af22 1345 sv_setsv(sv, *PL_stack_sp--);
93965878 1346 }
463ee0b2 1347
d3acc0f7 1348 POPSTACK;
a0d0e21e
LW
1349 FREETMPS;
1350 LEAVE;
1351 return 0;
1352}
463ee0b2 1353
a0d0e21e 1354int
864dbfa3 1355Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e
LW
1356{
1357 magic_methpack(sv,mg,"FETCH");
1358 if (mg->mg_ptr)
1359 mg->mg_flags |= MGf_GSKIP;
463ee0b2
LW
1360 return 0;
1361}
1362
1363int
864dbfa3 1364Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
e336de0d
GS
1365{
1366 dSP;
a60c0954 1367 ENTER;
e788e7d3 1368 PUSHSTACKi(PERLSI_MAGIC);
33c27489 1369 magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
d3acc0f7 1370 POPSTACK;
a60c0954 1371 LEAVE;
463ee0b2
LW
1372 return 0;
1373}
1374
1375int
864dbfa3 1376Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
463ee0b2 1377{
a0d0e21e
LW
1378 return magic_methpack(sv,mg,"DELETE");
1379}
463ee0b2 1380
93965878
NIS
1381
1382U32
864dbfa3 1383Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
ac27b0f5 1384{
e336de0d 1385 dSP;
93965878
NIS
1386 U32 retval = 0;
1387
1388 ENTER;
1389 SAVETMPS;
e788e7d3 1390 PUSHSTACKi(PERLSI_MAGIC);
33c27489 1391 if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
3280af22 1392 sv = *PL_stack_sp--;
a60c0954 1393 retval = (U32) SvIV(sv)-1;
93965878 1394 }
d3acc0f7 1395 POPSTACK;
93965878
NIS
1396 FREETMPS;
1397 LEAVE;
1398 return retval;
1399}
1400
cea2e8a9
GS
1401int
1402Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e
LW
1403{
1404 dSP;
463ee0b2 1405
e336de0d 1406 ENTER;
e788e7d3 1407 PUSHSTACKi(PERLSI_MAGIC);
924508f0 1408 PUSHMARK(SP);
33c27489 1409 XPUSHs(SvTIED_obj(sv, mg));
463ee0b2 1410 PUTBACK;
864dbfa3 1411 call_method("CLEAR", G_SCALAR|G_DISCARD);
d3acc0f7 1412 POPSTACK;
a60c0954 1413 LEAVE;
463ee0b2
LW
1414 return 0;
1415}
1416
1417int
864dbfa3 1418Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
463ee0b2 1419{
463ee0b2 1420 dSP;
dff6d3cd 1421 const char *meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
463ee0b2
LW
1422
1423 ENTER;
a0d0e21e 1424 SAVETMPS;
e788e7d3 1425 PUSHSTACKi(PERLSI_MAGIC);
924508f0
GS
1426 PUSHMARK(SP);
1427 EXTEND(SP, 2);
33c27489 1428 PUSHs(SvTIED_obj(sv, mg));
463ee0b2
LW
1429 if (SvOK(key))
1430 PUSHs(key);
1431 PUTBACK;
1432
864dbfa3 1433 if (call_method(meth, G_SCALAR))
3280af22 1434 sv_setsv(key, *PL_stack_sp--);
463ee0b2 1435
d3acc0f7 1436 POPSTACK;
a0d0e21e
LW
1437 FREETMPS;
1438 LEAVE;
79072805
LW
1439 return 0;
1440}
1441
1442int
864dbfa3 1443Perl_magic_existspack(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e
LW
1444{
1445 return magic_methpack(sv,mg,"EXISTS");
ac27b0f5 1446}
a0d0e21e
LW
1447
1448int
864dbfa3 1449Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
79072805
LW
1450{
1451 OP *o;
1452 I32 i;
1453 GV* gv;
1454 SV** svp;
2d8e6c8d 1455 STRLEN n_a;
79072805 1456
3280af22 1457 gv = PL_DBline;
79072805 1458 i = SvTRUE(sv);
188ea221 1459 svp = av_fetch(GvAV(gv),
2d8e6c8d 1460 atoi(MgPV(mg,n_a)), FALSE);
5df8de69
DM
1461 if (svp && SvIOKp(*svp) && (o = INT2PTR(OP*,SvIVX(*svp)))) {
1462 /* set or clear breakpoint in the relevant control op */
1463 if (i)
1464 o->op_flags |= OPf_SPECIAL;
1465 else
1466 o->op_flags &= ~OPf_SPECIAL;
1467 }
79072805
LW
1468 return 0;
1469}
1470
1471int
864dbfa3 1472Perl_magic_getarylen(pTHX_ SV *sv, MAGIC *mg)
79072805 1473{
3280af22 1474 sv_setiv(sv, AvFILL((AV*)mg->mg_obj) + PL_curcop->cop_arybase);
79072805
LW
1475 return 0;
1476}
1477
1478int
864dbfa3 1479Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
79072805 1480{
3280af22 1481 av_fill((AV*)mg->mg_obj, SvIV(sv) - PL_curcop->cop_arybase);
a0d0e21e
LW
1482 return 0;
1483}
1484
1485int
864dbfa3 1486Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e
LW
1487{
1488 SV* lsv = LvTARG(sv);
ac27b0f5 1489
a0d0e21e 1490 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
14befaf4 1491 mg = mg_find(lsv, PERL_MAGIC_regex_global);
565764a8 1492 if (mg && mg->mg_len >= 0) {
a0ed51b3 1493 I32 i = mg->mg_len;
7e2040f0 1494 if (DO_UTF8(lsv))
a0ed51b3
LW
1495 sv_pos_b2u(lsv, &i);
1496 sv_setiv(sv, i + PL_curcop->cop_arybase);
a0d0e21e
LW
1497 return 0;
1498 }
1499 }
1500 (void)SvOK_off(sv);
1501 return 0;
1502}
1503
1504int
864dbfa3 1505Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e
LW
1506{
1507 SV* lsv = LvTARG(sv);
1508 SSize_t pos;
1509 STRLEN len;
c00206c8 1510 STRLEN ulen = 0;
a0d0e21e
LW
1511
1512 mg = 0;
ac27b0f5 1513
a0d0e21e 1514 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
14befaf4 1515 mg = mg_find(lsv, PERL_MAGIC_regex_global);
a0d0e21e
LW
1516 if (!mg) {
1517 if (!SvOK(sv))
1518 return 0;
14befaf4
DM
1519 sv_magic(lsv, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1520 mg = mg_find(lsv, PERL_MAGIC_regex_global);
a0d0e21e
LW
1521 }
1522 else if (!SvOK(sv)) {
565764a8 1523 mg->mg_len = -1;
a0d0e21e
LW
1524 return 0;
1525 }
1526 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1527
c485e607 1528 pos = SvIV(sv) - PL_curcop->cop_arybase;
a0ed51b3 1529
7e2040f0 1530 if (DO_UTF8(lsv)) {
a0ed51b3
LW
1531 ulen = sv_len_utf8(lsv);
1532 if (ulen)
1533 len = ulen;
a0ed51b3
LW
1534 }
1535
a0d0e21e
LW
1536 if (pos < 0) {
1537 pos += len;
1538 if (pos < 0)
1539 pos = 0;
1540 }
eb160463 1541 else if (pos > (SSize_t)len)
a0d0e21e 1542 pos = len;
a0ed51b3
LW
1543
1544 if (ulen) {
1545 I32 p = pos;
1546 sv_pos_u2b(lsv, &p, 0);
1547 pos = p;
1548 }
727405f8 1549
565764a8 1550 mg->mg_len = pos;
71be2cbc 1551 mg->mg_flags &= ~MGf_MINMATCH;
a0d0e21e 1552
79072805
LW
1553 return 0;
1554}
1555
1556int
864dbfa3 1557Perl_magic_getglob(pTHX_ SV *sv, MAGIC *mg)
79072805 1558{
8646b087
PP
1559 if (SvFAKE(sv)) { /* FAKE globs can get coerced */
1560 SvFAKE_off(sv);
946ec16e 1561 gv_efullname3(sv,((GV*)sv), "*");
8646b087
PP
1562 SvFAKE_on(sv);
1563 }
1564 else
946ec16e 1565 gv_efullname3(sv,((GV*)sv), "*"); /* a gv value, be nice */
79072805
LW
1566 return 0;
1567}
1568
1569int
864dbfa3 1570Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg)
79072805
LW
1571{
1572 register char *s;
1573 GV* gv;
2d8e6c8d 1574 STRLEN n_a;
79072805
LW
1575
1576 if (!SvOK(sv))
1577 return 0;
2d8e6c8d 1578 s = SvPV(sv, n_a);
79072805
LW
1579 if (*s == '*' && s[1])
1580 s++;
85e6fe83 1581 gv = gv_fetchpv(s,TRUE, SVt_PVGV);
79072805
LW
1582 if (sv == (SV*)gv)
1583 return 0;
1584 if (GvGP(sv))
88e89b8a 1585 gp_free((GV*)sv);
79072805 1586 GvGP(sv) = gp_ref(GvGP(gv));
79072805
LW
1587 return 0;
1588}
1589
1590int
864dbfa3 1591Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
6ff81951
GS
1592{
1593 STRLEN len;
1594 SV *lsv = LvTARG(sv);
1595 char *tmps = SvPV(lsv,len);
1596 I32 offs = LvTARGOFF(sv);
1597 I32 rem = LvTARGLEN(sv);
1598
9aa983d2
JH
1599 if (SvUTF8(lsv))
1600 sv_pos_u2b(lsv, &offs, &rem);
eb160463 1601 if (offs > (I32)len)
6ff81951 1602 offs = len;
eb160463 1603 if (rem + offs > (I32)len)
6ff81951
GS
1604 rem = len - offs;
1605 sv_setpvn(sv, tmps + offs, (STRLEN)rem);
9aa983d2 1606 if (SvUTF8(lsv))
2ef4b674 1607 SvUTF8_on(sv);
6ff81951
GS
1608 return 0;
1609}
1610
1611int
864dbfa3 1612Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
79072805 1613{
9aa983d2
JH
1614 STRLEN len;
1615 char *tmps = SvPV(sv, len);
1616 SV *lsv = LvTARG(sv);
1617 I32 lvoff = LvTARGOFF(sv);
1618 I32 lvlen = LvTARGLEN(sv);
075a4a2b 1619
1aa99e6b 1620 if (DO_UTF8(sv)) {
9aa983d2
JH
1621 sv_utf8_upgrade(lsv);
1622 sv_pos_u2b(lsv, &lvoff, &lvlen);
1623 sv_insert(lsv, lvoff, lvlen, tmps, len);
1624 SvUTF8_on(lsv);
1625 }
9bf12eaf 1626 else if (lsv && SvUTF8(lsv)) {
9aa983d2 1627 sv_pos_u2b(lsv, &lvoff, &lvlen);
e95af362 1628 tmps = (char*)bytes_to_utf8((U8*)tmps, &len);
9aa983d2
JH
1629 sv_insert(lsv, lvoff, lvlen, tmps, len);
1630 Safefree(tmps);
1aa99e6b
IH
1631 }
1632 else
9aa983d2 1633 sv_insert(lsv, lvoff, lvlen, tmps, len);
1aa99e6b 1634
79072805
LW
1635 return 0;
1636}
1637
1638int
864dbfa3 1639Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
463ee0b2 1640{
565764a8 1641 TAINT_IF((mg->mg_len & 1) ||
155aba94 1642 ((mg->mg_len & 2) && mg->mg_obj == sv)); /* kludge */
463ee0b2
LW
1643 return 0;
1644}
1645
1646int
864dbfa3 1647Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
463ee0b2 1648{
3280af22
NIS
1649 if (PL_localizing) {
1650 if (PL_localizing == 1)
565764a8 1651 mg->mg_len <<= 1;
748a9306 1652 else
565764a8 1653 mg->mg_len >>= 1;
a0d0e21e 1654 }
3280af22 1655 else if (PL_tainted)
565764a8 1656 mg->mg_len |= 1;
748a9306 1657 else
565764a8 1658 mg->mg_len &= ~1;
463ee0b2
LW
1659 return 0;
1660}
1661
1662int
864dbfa3 1663Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
6ff81951
GS
1664{
1665 SV *lsv = LvTARG(sv);
6ff81951
GS
1666
1667 if (!lsv) {
155aba94 1668 (void)SvOK_off(sv);
6ff81951
GS
1669 return 0;
1670 }
6ff81951 1671
81e118e0 1672 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
6ff81951
GS
1673 return 0;
1674}
1675
1676int
864dbfa3 1677Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
79072805
LW
1678{
1679 do_vecset(sv); /* XXX slurp this routine */
1680 return 0;
1681}
1682
1683int
864dbfa3 1684Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
5f05dabc 1685{
71be2cbc 1686 SV *targ = Nullsv;
5f05dabc 1687 if (LvTARGLEN(sv)) {
68dc0745 1688 if (mg->mg_obj) {
74e13ce4 1689 SV *ahv = LvTARG(sv);
6d822dc4
MS
1690 HE *he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
1691 if (he)
1692 targ = HeVAL(he);
68dc0745
PP
1693 }
1694 else {
3c78fafa 1695 AV* av = (AV*)LvTARG(sv);
68dc0745
PP
1696 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
1697 targ = AvARRAY(av)[LvTARGOFF(sv)];
1698 }
3280af22 1699 if (targ && targ != &PL_sv_undef) {
68dc0745
PP
1700 /* somebody else defined it for us */
1701 SvREFCNT_dec(LvTARG(sv));
1702 LvTARG(sv) = SvREFCNT_inc(targ);
1703 LvTARGLEN(sv) = 0;
1704 SvREFCNT_dec(mg->mg_obj);
1705 mg->mg_obj = Nullsv;
1706 mg->mg_flags &= ~MGf_REFCOUNTED;
1707 }
5f05dabc 1708 }
71be2cbc
PP
1709 else
1710 targ = LvTARG(sv);
3280af22 1711 sv_setsv(sv, targ ? targ : &PL_sv_undef);
71be2cbc
PP
1712 return 0;
1713}
1714
1715int
864dbfa3 1716Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
71be2cbc
PP
1717{
1718 if (LvTARGLEN(sv))
68dc0745
PP
1719 vivify_defelem(sv);
1720 if (LvTARG(sv)) {
5f05dabc 1721 sv_setsv(LvTARG(sv), sv);
68dc0745
PP
1722 SvSETMAGIC(LvTARG(sv));
1723 }
5f05dabc
PP
1724 return 0;
1725}
1726
71be2cbc 1727void
864dbfa3 1728Perl_vivify_defelem(pTHX_ SV *sv)
71be2cbc 1729{
74e13ce4
GS
1730 MAGIC *mg;
1731 SV *value = Nullsv;
71be2cbc 1732
14befaf4 1733 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
71be2cbc 1734 return;
68dc0745 1735 if (mg->mg_obj) {
74e13ce4 1736 SV *ahv = LvTARG(sv);
2d8e6c8d 1737 STRLEN n_a;
6d822dc4
MS
1738 HE *he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
1739 if (he)
1740 value = HeVAL(he);
3280af22 1741 if (!value || value == &PL_sv_undef)
cea2e8a9 1742 Perl_croak(aTHX_ PL_no_helem, SvPV(mg->mg_obj, n_a));
71be2cbc 1743 }
68dc0745
PP
1744 else {
1745 AV* av = (AV*)LvTARG(sv);
5aabfad6 1746 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
68dc0745
PP
1747 LvTARG(sv) = Nullsv; /* array can't be extended */
1748 else {
1749 SV** svp = av_fetch(av, LvTARGOFF(sv), TRUE);
3280af22 1750 if (!svp || (value = *svp) == &PL_sv_undef)
cea2e8a9 1751 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
68dc0745
PP
1752 }
1753 }
3e3baf6d 1754 (void)SvREFCNT_inc(value);
68dc0745
PP
1755 SvREFCNT_dec(LvTARG(sv));
1756 LvTARG(sv) = value;
71be2cbc 1757 LvTARGLEN(sv) = 0;
68dc0745
PP
1758 SvREFCNT_dec(mg->mg_obj);
1759 mg->mg_obj = Nullsv;
1760 mg->mg_flags &= ~MGf_REFCOUNTED;
5f05dabc
PP
1761}
1762
1763int
864dbfa3 1764Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
810b8aa5
GS
1765{
1766 AV *av = (AV*)mg->mg_obj;
1767 SV **svp = AvARRAY(av);
1768 I32 i = AvFILLp(av);
1769 while (i >= 0) {
1770 if (svp[i] && svp[i] != &PL_sv_undef) {
1771 if (!SvWEAKREF(svp[i]))
cea2e8a9 1772 Perl_croak(aTHX_ "panic: magic_killbackrefs");
810b8aa5
GS
1773 /* XXX Should we check that it hasn't changed? */
1774 SvRV(svp[i]) = 0;
155aba94 1775 (void)SvOK_off(svp[i]);
810b8aa5
GS
1776 SvWEAKREF_off(svp[i]);
1777 svp[i] = &PL_sv_undef;
1778 }
1779 i--;
1780 }
1781 return 0;
1782}
1783
1784int
864dbfa3 1785Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
93a17b20 1786{
565764a8 1787 mg->mg_len = -1;
c6496cc7 1788 SvSCREAM_off(sv);
93a17b20
LW
1789 return 0;
1790}
1791
1792int
864dbfa3 1793Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
79072805 1794{
14befaf4 1795 sv_unmagic(sv, PERL_MAGIC_bm);
79072805
LW
1796 SvVALID_off(sv);
1797 return 0;
1798}
1799
1800int
864dbfa3 1801Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
55497cff 1802{
14befaf4 1803 sv_unmagic(sv, PERL_MAGIC_fm);
55497cff
PP
1804 SvCOMPILED_off(sv);
1805 return 0;
1806}
1807
1808int
864dbfa3 1809Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
79072805
LW
1810{
1811 struct ufuncs *uf = (struct ufuncs *)mg->mg_ptr;
1812
1813 if (uf && uf->uf_set)
24f81a43 1814 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
79072805
LW
1815 return 0;
1816}
1817
c277df42 1818int
864dbfa3 1819Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
c277df42
IZ
1820{
1821 regexp *re = (regexp *)mg->mg_obj;
1822 ReREFCNT_dec(re);
1823 return 0;
1824}
1825
7a4c00b4 1826#ifdef USE_LOCALE_COLLATE
79072805 1827int
864dbfa3 1828Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
bbce6d69
PP
1829{
1830 /*
838b5b74 1831 * RenE<eacute> Descartes said "I think not."
bbce6d69
PP
1832 * and vanished with a faint plop.
1833 */
7a4c00b4
PP
1834 if (mg->mg_ptr) {
1835 Safefree(mg->mg_ptr);
1836 mg->mg_ptr = NULL;
565764a8 1837 mg->mg_len = -1;
7a4c00b4 1838 }
bbce6d69
PP
1839 return 0;
1840}
7a4c00b4 1841#endif /* USE_LOCALE_COLLATE */
bbce6d69 1842
7e8c5dac
HS
1843/* Just clear the UTF-8 cache data. */
1844int
1845Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
1846{
1847 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
1848 mg->mg_ptr = 0;
1849 mg->mg_len = -1; /* The mg_len holds the len cache. */
1850 return 0;
1851}
1852
bbce6d69 1853int
864dbfa3 1854Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
79072805
LW
1855{
1856 register char *s;
1857 I32 i;
8990e307 1858 STRLEN len;
79072805 1859 switch (*mg->mg_ptr) {
748a9306 1860 case '\001': /* ^A */
3280af22 1861 sv_setsv(PL_bodytarget, sv);
748a9306 1862 break;
49460fe6 1863 case '\003': /* ^C */
eb160463 1864 PL_minus_c = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
49460fe6
NIS
1865 break;
1866
79072805 1867 case '\004': /* ^D */
aea4f609 1868 PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | DEBUG_TOP_FLAG;
79072805
LW
1869 DEBUG_x(dump_all());
1870 break;
28f23441 1871 case '\005': /* ^E */
d0063567 1872 if (*(mg->mg_ptr+1) == '\0') {
cd39f2b6 1873#ifdef MACOS_TRADITIONAL
d0063567 1874 gMacPerl_OSErr = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
28f23441 1875#else
cd39f2b6 1876# ifdef VMS
d0063567 1877 set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
048c1ddf 1878# else
cd39f2b6 1879# ifdef WIN32
d0063567 1880 SetLastError( SvIV(sv) );
cd39f2b6 1881# else
9fed8b87 1882# ifdef OS2
d0063567 1883 os2_setsyserrno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
9fed8b87 1884# else
d0063567
DK
1885 /* will anyone ever use this? */
1886 SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4);
cd39f2b6 1887# endif
048c1ddf
IZ
1888# endif
1889# endif
22fae026 1890#endif
d0063567
DK
1891 }
1892 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
1893 if (PL_encoding)
1894 SvREFCNT_dec(PL_encoding);
1895 if (SvOK(sv) || SvGMAGICAL(sv)) {
1896 PL_encoding = newSVsv(sv);
1897 }
1898 else {
1899 PL_encoding = Nullsv;
1900 }
1901 }
1902 break;
79072805 1903 case '\006': /* ^F */
3280af22 1904 PL_maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
79072805 1905 break;
a0d0e21e 1906 case '\010': /* ^H */
3280af22 1907 PL_hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
a0d0e21e 1908 break;
9d116dd7 1909 case '\011': /* ^I */ /* NOT \t in EBCDIC */
3280af22
NIS
1910 if (PL_inplace)
1911 Safefree(PL_inplace);
79072805 1912 if (SvOK(sv))
2d8e6c8d 1913 PL_inplace = savepv(SvPV(sv,len));
79072805 1914 else
3280af22 1915 PL_inplace = Nullch;
79072805 1916 break;
28f23441 1917 case '\017': /* ^O */
ac27b0f5
NIS
1918 if (*(mg->mg_ptr+1) == '\0') {
1919 if (PL_osname)
1920 Safefree(PL_osname);
1921 if (SvOK(sv))
1922 PL_osname = savepv(SvPV(sv,len));
1923 else
1924 PL_osname = Nullch;
1925 }
1926 else if (strEQ(mg->mg_ptr, "\017PEN")) {
1927 if (!PL_compiling.cop_io)
1928 PL_compiling.cop_io = newSVsv(sv);
1929 else
1930 sv_setsv(PL_compiling.cop_io,sv);
1931 }
28f23441 1932 break;
79072805 1933 case '\020': /* ^P */
3280af22 1934 PL_perldb = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1ee4443e
IZ
1935 if (PL_perldb && !PL_DBsingle)
1936 init_debugger();
79072805
LW
1937 break;
1938 case '\024': /* ^T */
88e89b8a 1939#ifdef BIG_TIME
6b88bc9c 1940 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
88e89b8a 1941#else
3280af22 1942 PL_basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
88e89b8a 1943#endif
79072805 1944 break;
fde18df1
JH
1945 case '\025': /* $^UTF8_LOCALE */
1946 if (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv))
1947 PL_wantutf8 = PL_utf8locale;
1948 else
1949 PL_wantutf8 = FALSE;
1950 break;
1951 case '\027': /* ^W & $^WARNING_BITS */
4438c4b7
JH
1952 if (*(mg->mg_ptr+1) == '\0') {
1953 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
1954 i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
ac27b0f5 1955 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
0453d815 1956 | (i ? G_WARN_ON : G_WARN_OFF) ;
4438c4b7 1957 }
599cee73 1958 }
0a378802 1959 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
4438c4b7 1960 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
d775746e
GS
1961 if (!SvPOK(sv) && PL_localizing) {
1962 sv_setpvn(sv, WARN_NONEstring, WARNsize);
d3a7d8c7 1963 PL_compiling.cop_warnings = pWARN_NONE;
d775746e
GS
1964 break;
1965 }
f4fc7782 1966 {
b5477537 1967 STRLEN len, i;
d3a7d8c7 1968 int accumulate = 0 ;
f4fc7782 1969 int any_fatals = 0 ;
d3a7d8c7 1970 char * ptr = (char*)SvPV(sv, len) ;
f4fc7782
JH
1971 for (i = 0 ; i < len ; ++i) {
1972 accumulate |= ptr[i] ;
1973 any_fatals |= (ptr[i] & 0xAA) ;
1974 }
d3a7d8c7
GS
1975 if (!accumulate)
1976 PL_compiling.cop_warnings = pWARN_NONE;
f4fc7782
JH
1977 else if (isWARN_on(sv, WARN_ALL) && !any_fatals) {
1978 PL_compiling.cop_warnings = pWARN_ALL;
1979 PL_dowarn |= G_WARN_ONCE ;
727405f8 1980 }
d3a7d8c7
GS
1981 else {
1982 if (specialWARN(PL_compiling.cop_warnings))
1983 PL_compiling.cop_warnings = newSVsv(sv) ;
1984 else
1985 sv_setsv(PL_compiling.cop_warnings, sv);
1986 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
1987 PL_dowarn |= G_WARN_ONCE ;
1988 }
f4fc7782 1989
d3a7d8c7 1990 }
4438c4b7 1991 }
971a9dd3 1992 }
79072805
LW
1993 break;
1994 case '.':
3280af22
NIS
1995 if (PL_localizing) {
1996 if (PL_localizing == 1)
7766f137 1997 SAVESPTR(PL_last_in_gv);
748a9306 1998 }
3280af22 1999 else if (SvOK(sv) && GvIO(PL_last_in_gv))
632db599 2000 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
79072805
LW
2001 break;
2002 case '^':
3280af22 2003 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2d8e6c8d 2004 IoTOP_NAME(GvIOp(PL_defoutgv)) = s = savepv(SvPV(sv,len));
3280af22 2005 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchpv(s,TRUE, SVt_PVIO);
79072805
LW
2006 break;
2007 case '~':
3280af22 2008 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2d8e6c8d 2009 IoFMT_NAME(GvIOp(PL_defoutgv)) = s = savepv(SvPV(sv,len));
3280af22 2010 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchpv(s,TRUE, SVt_PVIO);
79072805
LW
2011 break;
2012 case '=':
632db599 2013 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
79072805
LW
2014 break;
2015 case '-':
632db599 2016 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
3280af22
NIS
2017 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2018 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
79072805
LW
2019 break;
2020 case '%':
632db599 2021 IoPAGE(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
79072805
LW
2022 break;
2023 case '|':
4b65379b 2024 {
3280af22 2025 IO *io = GvIOp(PL_defoutgv);
720f287d
AB
2026 if(!io)
2027 break;
4b65379b
CS
2028 if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) == 0)
2029 IoFLAGS(io) &= ~IOf_FLUSH;
2030 else {
2031 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2032 PerlIO *ofp = IoOFP(io);
2033 if (ofp)
2034 (void)PerlIO_flush(ofp);
2035 IoFLAGS(io) |= IOf_FLUSH;
2036 }
2037 }
79072805
LW
2038 }
2039 break;
2040 case '*':
463ee0b2 2041 i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
3280af22 2042 PL_multiline = (i != 0);
79072805
LW
2043 break;
2044 case '/':
3280af22 2045 SvREFCNT_dec(PL_rs);
8bfdd7d9 2046 PL_rs = newSVsv(sv);
79072805
LW
2047 break;
2048 case '\\':
7889fe52
NIS
2049 if (PL_ors_sv)
2050 SvREFCNT_dec(PL_ors_sv);
009c130f 2051 if (SvOK(sv) || SvGMAGICAL(sv)) {
7889fe52 2052 PL_ors_sv = newSVsv(sv);
009c130f 2053 }
e3c19b7b 2054 else {
7889fe52 2055 PL_ors_sv = Nullsv;
e3c19b7b 2056 }
79072805
LW
2057 break;
2058 case ',':
7889fe52
NIS
2059 if (PL_ofs_sv)
2060 SvREFCNT_dec(PL_ofs_sv);
2061 if (SvOK(sv) || SvGMAGICAL(sv)) {
2062 PL_ofs_sv = newSVsv(sv);
2063 }
2064 else {
2065 PL_ofs_sv = Nullsv;
2066 }
79072805
LW
2067 break;
2068 case '#':
3280af22
NIS
2069 if (PL_ofmt)
2070 Safefree(PL_ofmt);
2d8e6c8d 2071 PL_ofmt = savepv(SvPV(sv,len));
79072805
LW
2072 break;
2073 case '[':
3280af22 2074 PL_compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
79072805
LW
2075 break;
2076 case '?':
ff0cee69 2077#ifdef COMPLEX_STATUS
6b88bc9c
GS
2078 if (PL_localizing == 2) {
2079 PL_statusvalue = LvTARGOFF(sv);
2080 PL_statusvalue_vms = LvTARGLEN(sv);
ff0cee69
PP
2081 }
2082 else
2083#endif
2084#ifdef VMSISH_STATUS
2085 if (VMSISH_STATUS)
2086 STATUS_NATIVE_SET((U32)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)));
2087 else
2088#endif
2089 STATUS_POSIX_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
79072805
LW
2090 break;
2091 case '!':
93189314
JH
2092 {
2093#ifdef VMS
2094# define PERL_VMS_BANG vaxc$errno
2095#else
2096# define PERL_VMS_BANG 0
2097#endif
91487cfc 2098 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
93189314
JH
2099 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2100 }
79072805
LW
2101 break;
2102 case '<':
3280af22
NIS
2103 PL_uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2104 if (PL_delaymagic) {
2105 PL_delaymagic |= DM_RUID;
79072805
LW
2106 break; /* don't do magic till later */
2107 }
2108#ifdef HAS_SETRUID
b28d0864 2109 (void)setruid((Uid_t)PL_uid);
79072805
LW
2110#else
2111#ifdef HAS_SETREUID
3280af22 2112 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
748a9306 2113#else
85e6fe83 2114#ifdef HAS_SETRESUID
b28d0864 2115 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
79072805 2116#else
b28d0864
NIS
2117 if (PL_uid == PL_euid) /* special case $< = $> */
2118 (void)PerlProc_setuid(PL_uid);
a0d0e21e 2119 else {
d8eceb89 2120 PL_uid = PerlProc_getuid();
cea2e8a9 2121 Perl_croak(aTHX_ "setruid() not implemented");
a0d0e21e 2122 }
79072805
LW
2123#endif
2124#endif
85e6fe83 2125#endif
d8eceb89 2126 PL_uid = PerlProc_getuid();
3280af22 2127 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
79072805
LW
2128 break;
2129 case '>':
3280af22
NIS
2130 PL_euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2131 if (PL_delaymagic) {
2132 PL_delaymagic |= DM_EUID;
79072805
LW
2133 break; /* don't do magic till later */
2134 }
2135#ifdef HAS_SETEUID
3280af22 2136 (void)seteuid((Uid_t)PL_euid);
79072805
LW
2137#else
2138#ifdef HAS_SETREUID
b28d0864 2139 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
85e6fe83
LW
2140#else
2141#ifdef HAS_SETRESUID
6b88bc9c 2142 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
79072805 2143#else
b28d0864
NIS
2144 if (PL_euid == PL_uid) /* special case $> = $< */
2145 PerlProc_setuid(PL_euid);
a0d0e21e 2146 else {
e8ee3774 2147 PL_euid = PerlProc_geteuid();
cea2e8a9 2148 Perl_croak(aTHX_ "seteuid() not implemented");
a0d0e21e 2149 }
79072805
LW
2150#endif
2151#endif
85e6fe83 2152#endif
d8eceb89 2153 PL_euid = PerlProc_geteuid();
3280af22 2154 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
79072805
LW
2155 break;
2156 case '(':
3280af22
NIS
2157 PL_gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2158 if (PL_delaymagic) {
2159 PL_delaymagic |= DM_RGID;
79072805
LW
2160 break; /* don't do magic till later */
2161 }
2162#ifdef HAS_SETRGID
b28d0864 2163 (void)setrgid((Gid_t)PL_gid);
79072805
LW
2164#else
2165#ifdef HAS_SETREGID
3280af22 2166 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
85e6fe83
LW
2167#else
2168#ifdef HAS_SETRESGID
b28d0864 2169 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
79072805 2170#else
b28d0864
NIS
2171 if (PL_gid == PL_egid) /* special case $( = $) */
2172 (void)PerlProc_setgid(PL_gid);
748a9306 2173 else {
d8eceb89 2174 PL_gid = PerlProc_getgid();
cea2e8a9 2175 Perl_croak(aTHX_ "setrgid() not implemented");
748a9306 2176 }
79072805
LW
2177#endif
2178#endif
85e6fe83 2179#endif
d8eceb89 2180 PL_gid = PerlProc_getgid();
3280af22 2181 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
79072805
LW
2182 break;
2183 case ')':
5cd24f17
PP
2184#ifdef HAS_SETGROUPS
2185 {
2d8e6c8d 2186 char *p = SvPV(sv, len);
5cd24f17
PP
2187 Groups_t gary[NGROUPS];
2188
5cd24f17
PP
2189 while (isSPACE(*p))
2190 ++p;
2d4389e4 2191 PL_egid = Atol(p);
5cd24f17
PP
2192 for (i = 0; i < NGROUPS; ++i) {
2193 while (*p && !isSPACE(*p))
2194 ++p;
2195 while (isSPACE(*p))
2196 ++p;
2197 if (!*p)
2198 break;
2d4389e4 2199 gary[i] = Atol(p);
5cd24f17 2200 }
8cc95fdb
PP
2201 if (i)
2202 (void)setgroups(i, gary);
5cd24f17
PP
2203 }
2204#else /* HAS_SETGROUPS */
b28d0864 2205 PL_egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
5cd24f17 2206#endif /* HAS_SETGROUPS */
3280af22
NIS
2207 if (PL_delaymagic) {
2208 PL_delaymagic |= DM_EGID;
79072805
LW
2209 break; /* don't do magic till later */
2210 }
2211#ifdef HAS_SETEGID
3280af22 2212 (void)setegid((Gid_t)PL_egid);
79072805
LW
2213#else
2214#ifdef HAS_SETREGID
b28d0864 2215 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
85e6fe83
LW
2216#else
2217#ifdef HAS_SETRESGID
b28d0864 2218 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
79072805 2219#else
b28d0864
NIS
2220 if (PL_egid == PL_gid) /* special case $) = $( */
2221 (void)PerlProc_setgid(PL_egid);
748a9306 2222 else {
d8eceb89 2223 PL_egid = PerlProc_getegid();
cea2e8a9 2224 Perl_croak(aTHX_ "setegid() not implemented");
748a9306 2225 }
79072805
LW
2226#endif
2227#endif
85e6fe83 2228#endif
d8eceb89 2229 PL_egid = PerlProc_getegid();
3280af22 2230 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
79072805
LW
2231 break;
2232 case ':':
2d8e6c8d 2233 PL_chopset = SvPV_force(sv,len);
79072805 2234 break;
cd39f2b6 2235#ifndef MACOS_TRADITIONAL
79072805 2236 case '0':
e2975953 2237 LOCK_DOLLARZERO_MUTEX;
4bc88a62
PS
2238#ifdef HAS_SETPROCTITLE
2239 /* The BSDs don't show the argv[] in ps(1) output, they
2240 * show a string from the process struct and provide
2241 * the setproctitle() routine to manipulate that. */
2242 {
2243 s = SvPV(sv, len);
98b76f99 2244# if __FreeBSD_version > 410001
9aad2c0e 2245 /* The leading "-" removes the "perl: " prefix,
4bc88a62
PS
2246 * but not the "(perl) suffix from the ps(1)
2247 * output, because that's what ps(1) shows if the
2248 * argv[] is modified. */
6f2ad931 2249 setproctitle("-%s", s);
9aad2c0e 2250# else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
4bc88a62
PS
2251 /* This doesn't really work if you assume that
2252 * $0 = 'foobar'; will wipe out 'perl' from the $0
2253 * because in ps(1) output the result will be like
2254 * sprintf("perl: %s (perl)", s)
2255 * I guess this is a security feature:
2256 * one (a user process) cannot get rid of the original name.
2257 * --jhi */
2258 setproctitle("%s", s);
2259# endif
2260 }
2261#endif
17aa7f3d
JH
2262#if defined(__hpux) && defined(PSTAT_SETCMD)
2263 {
2264 union pstun un;
2265 s = SvPV(sv, len);
2266 un.pst_command = s;
2267 pstat(PSTAT_SETCMD, un, len, 0, 0);
2268 }
2269#endif
3280af22
NIS
2270 if (!PL_origalen) {
2271 s = PL_origargv[0];
79072805
LW
2272 s += strlen(s);
2273 /* See if all the arguments are contiguous in memory */
3280af22
NIS
2274 for (i = 1; i < PL_origargc; i++) {
2275 if (PL_origargv[i] == s + 1
fb73857a 2276#ifdef OS2
6b88bc9c 2277 || PL_origargv[i] == s + 2
ac27b0f5 2278#endif
fb73857a 2279 )
379c4362
GS
2280 {
2281 ++s;
2282 s += strlen(s); /* this one is ok too */
2283 }
fb73857a
PP
2284 else
2285 break;
79072805 2286 }
bbce6d69 2287 /* can grab env area too? */
4efc5df6
GS
2288 if (PL_origenviron
2289#ifdef USE_ITHREADS
2290 && PL_curinterp == aTHX
2291#endif
2292 && (PL_origenviron[0] == s + 1))
2293 {
66b1d557 2294 my_setenv("NoNe SuCh", Nullch);
79072805 2295 /* force copy of environment */
3280af22 2296 for (i = 0; PL_origenviron[i]; i++)
379c4362
GS
2297 if (PL_origenviron[i] == s + 1) {
2298 ++s;
2299 s += strlen(s);
2300 }
fb73857a
PP
2301 else
2302 break;
79072805 2303 }
3280af22 2304 PL_origalen = s - PL_origargv[0];
79072805 2305 }
a0d0e21e 2306 s = SvPV_force(sv,len);
8990e307 2307 i = len;
eb160463 2308 if (i >= (I32)PL_origalen) {
3280af22 2309 i = PL_origalen;
fb73857a
PP
2310 /* don't allow system to limit $0 seen by script */
2311 /* SvCUR_set(sv, i); *SvEND(sv) = '\0'; */
3280af22
NIS
2312 Copy(s, PL_origargv[0], i, char);
2313 s = PL_origargv[0]+i;
fb73857a 2314 *s = '\0';
79072805
LW
2315 }
2316 else {
3280af22
NIS
2317 Copy(s, PL_origargv[0], i, char);
2318 s = PL_origargv[0]+i;
79072805 2319 *s++ = '\0';
eb160463 2320 while (++i < (I32)PL_origalen)
f1c3b2ef 2321 *s++ = '\0';
3280af22
NIS
2322 for (i = 1; i < PL_origargc; i++)
2323 PL_origargv[i] = Nullch;
79072805 2324 }
e2975953 2325 UNLOCK_DOLLARZERO_MUTEX;
79072805 2326 break;
cd39f2b6 2327#endif
79072805
LW
2328 }
2329 return 0;
2330}
2331
2332I32
864dbfa3 2333Perl_whichsig(pTHX_ char *sig)
79072805
LW
2334{
2335 register char **sigv;
2336
22c35a8c 2337 for (sigv = PL_sig_name+1; *sigv; sigv++)
79072805 2338 if (strEQ(sig,*sigv))
22c35a8c 2339 return PL_sig_num[sigv - PL_sig_name];
79072805
LW
2340#ifdef SIGCLD
2341 if (strEQ(sig,"CHLD"))
2342 return SIGCLD;
2343#endif
2344#ifdef SIGCHLD
2345 if (strEQ(sig,"CLD"))
2346 return SIGCHLD;
2347#endif
2348 return 0;
2349}
2350
df3728a2 2351#if !defined(PERL_IMPLICIT_CONTEXT)
84902520 2352static SV* sig_sv;
df3728a2 2353#endif
84902520 2354
ecfc5424 2355Signal_t
cea2e8a9 2356Perl_sighandler(int sig)
79072805 2357{
1018e26f
NIS
2358#ifdef PERL_GET_SIG_CONTEXT
2359 dTHXa(PERL_GET_SIG_CONTEXT);
71d280e3 2360#else
cea2e8a9 2361 dTHX;
71d280e3 2362#endif
79072805 2363 dSP;
00d579c5 2364 GV *gv = Nullgv;
a0d0e21e 2365 HV *st;
b7953727 2366 SV *sv = Nullsv, *tSv = PL_Sv;
00d579c5 2367 CV *cv = Nullcv;
533c011a 2368 OP *myop = PL_op;
84902520 2369 U32 flags = 0;
3280af22 2370 XPV *tXpv = PL_Xpv;
71d280e3 2371
3280af22 2372 if (PL_savestack_ix + 15 <= PL_savestack_max)
84902520 2373 flags |= 1;
3280af22 2374 if (PL_markstack_ptr < PL_markstack_max - 2)
84902520 2375 flags |= 4;
3280af22 2376 if (PL_retstack_ix < PL_retstack_max - 2)
84902520 2377 flags |= 8;
3280af22 2378 if (PL_scopestack_ix < PL_scopestack_max - 3)
84902520
TB
2379 flags |= 16;
2380
727405f8 2381 if (!PL_psig_ptr[sig]) {
99ef548b 2382 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
727405f8
NIS
2383 PL_sig_name[sig]);
2384 exit(sig);
2385 }
ff0cee69 2386
84902520
TB
2387 /* Max number of items pushed there is 3*n or 4. We cannot fix
2388 infinity, so we fix 4 (in fact 5): */
2389 if (flags & 1) {
3280af22 2390 PL_savestack_ix += 5; /* Protect save in progress. */
c76ac1ee 2391 SAVEDESTRUCTOR_X(unwind_handler_stack, (void*)&flags);
84902520 2392 }
ac27b0f5 2393 if (flags & 4)
3280af22 2394 PL_markstack_ptr++; /* Protect mark. */
84902520 2395 if (flags & 8) {
3280af22
NIS
2396 PL_retstack_ix++;
2397 PL_retstack[PL_retstack_ix] = NULL;
84902520
TB
2398 }
2399 if (flags & 16)
3280af22 2400 PL_scopestack_ix += 1;
84902520 2401 /* sv_2cv is too complicated, try a simpler variant first: */
ac27b0f5 2402 if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
84902520 2403 || SvTYPE(cv) != SVt_PVCV)
22c35a8c 2404 cv = sv_2cv(PL_psig_ptr[sig],&st,&gv,TRUE);
84902520 2405
a0d0e21e 2406 if (!cv || !CvROOT(cv)) {
599cee73 2407 if (ckWARN(WARN_SIGNAL))
9014280d 2408 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
22c35a8c 2409 PL_sig_name[sig], (gv ? GvENAME(gv)
00d579c5
GS
2410 : ((cv && CvGV(cv))
2411 ? GvENAME(CvGV(cv))
2412 : "__ANON__")));
2413 goto cleanup;
79072805
LW
2414 }
2415
22c35a8c
GS
2416 if(PL_psig_name[sig]) {
2417 sv = SvREFCNT_inc(PL_psig_name[sig]);
84902520 2418 flags |= 64;
df3728a2 2419#if !defined(PERL_IMPLICIT_CONTEXT)
84902520 2420 sig_sv = sv;
df3728a2 2421#endif
84902520 2422 } else {
ff0cee69 2423 sv = sv_newmortal();
22c35a8c 2424 sv_setpv(sv,PL_sig_name[sig]);
88e89b8a 2425 }
e336de0d 2426
e788e7d3 2427 PUSHSTACKi(PERLSI_SIGNAL);
924508f0 2428 PUSHMARK(SP);
79072805 2429 PUSHs(sv);
79072805 2430 PUTBACK;
a0d0e21e 2431
1b266415 2432 call_sv((SV*)cv, G_DISCARD|G_EVAL);
79072805 2433
d3acc0f7 2434 POPSTACK;
1b266415 2435 if (SvTRUE(ERRSV)) {
1d615522 2436#ifndef PERL_MICRO
983dbef6 2437#ifdef HAS_SIGPROCMASK
1b266415
NIS
2438 /* Handler "died", for example to get out of a restart-able read().
2439 * Before we re-do that on its behalf re-enable the signal which was
2440 * blocked by the system when we entered.
2441 */
2442 sigset_t set;
2443 sigemptyset(&set);
2444 sigaddset(&set,sig);
2445 sigprocmask(SIG_UNBLOCK, &set, NULL);
2446#else
2447 /* Not clear if this will work */
2448 (void)rsignal(sig, SIG_IGN);
0a8e0eff 2449 (void)rsignal(sig, &Perl_csighandler);
1b266415 2450#endif
1d615522 2451#endif /* !PERL_MICRO */
b3fe4827 2452 Perl_die(aTHX_ Nullformat);
1b266415 2453 }
00d579c5 2454cleanup:
84902520 2455 if (flags & 1)
3280af22 2456 PL_savestack_ix -= 8; /* Unprotect save in progress. */
ac27b0f5 2457 if (flags & 4)
3280af22 2458 PL_markstack_ptr--;
ac27b0f5 2459 if (flags & 8)
3280af22 2460 PL_retstack_ix--;
84902520 2461 if (flags & 16)
3280af22 2462 PL_scopestack_ix -= 1;
84902520
TB
2463 if (flags & 64)
2464 SvREFCNT_dec(sv);
533c011a 2465 PL_op = myop; /* Apparently not needed... */
ac27b0f5 2466
3280af22
NIS
2467 PL_Sv = tSv; /* Restore global temporaries. */
2468 PL_Xpv = tXpv;
79072805
LW
2469 return;
2470}
4e35701f
NIS
2471
2472
51371543 2473static void
acfe0abc 2474restore_magic(pTHX_ void *p)
51371543 2475{
48944bdf 2476 MGS* mgs = SSPTR(PTR2IV(p), MGS*);
51371543
GS
2477 SV* sv = mgs->mgs_sv;
2478
2479 if (!sv)
2480 return;
2481
2482 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2483 {
2484 if (mgs->mgs_flags)
2485 SvFLAGS(sv) |= mgs->mgs_flags;
2486 else
2487 mg_magical(sv);
2488 if (SvGMAGICAL(sv))
2489 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
2490 }
2491
2492 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
2493
2494 /* If we're still on top of the stack, pop us off. (That condition
2495 * will be satisfied if restore_magic was called explicitly, but *not*
2496 * if it's being called via leave_scope.)
2497 * The reason for doing this is that otherwise, things like sv_2cv()
2498 * may leave alloc gunk on the savestack, and some code
2499 * (e.g. sighandler) doesn't expect that...
2500 */
2501 if (PL_savestack_ix == mgs->mgs_ss_ix)
2502 {
2503 I32 popval = SSPOPINT;
c76ac1ee 2504 assert(popval == SAVEt_DESTRUCTOR_X);
51371543
GS
2505 PL_savestack_ix -= 2;
2506 popval = SSPOPINT;
2507 assert(popval == SAVEt_ALLOC);
2508 popval = SSPOPINT;
2509 PL_savestack_ix -= popval;
2510 }
2511
2512}
2513
2514static void
acfe0abc 2515unwind_handler_stack(pTHX_ void *p)
51371543 2516{
51371543
GS
2517 U32 flags = *(U32*)p;
2518
2519 if (flags & 1)
2520 PL_savestack_ix -= 5; /* Unprotect save in progress. */
2521 /* cxstack_ix-- Not needed, die already unwound it. */
df3728a2 2522#if !defined(PERL_IMPLICIT_CONTEXT)
51371543
GS
2523 if (flags & 64)
2524 SvREFCNT_dec(sig_sv);
df3728a2 2525#endif
51371543 2526}
1018e26f
NIS
2527
2528