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