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