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