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