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