This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Added amd64 and x86_64 to recognized predefined cpp syms
[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")) {
b8ffc8df 1048 char pathbuf[256], eltbuf[256], *cp, *elt;
c623ac67 1049 Stat_t sbuf;
1e422769
PP
1050 int i = 0, j = 0;
1051
b8ffc8df
RGS
1052 strncpy(eltbuf, s, 255);
1053 eltbuf[255] = 0;
1054 elt = eltbuf;
1e422769
PP
1055 do { /* DCL$PATH may be a search list */
1056 while (1) { /* as may dev portion of any element */
1057 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1058 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1059 cando_by_name(S_IWUSR,0,elt) ) {
1060 MgTAINTEDDIR_on(mg);
1061 return 0;
1062 }
1063 }
1064 if ((cp = strchr(elt, ':')) != Nullch)
1065 *cp = '\0';
1066 if (my_trnlnm(elt, eltbuf, j++))
1067 elt = eltbuf;
1068 else
1069 break;
1070 }
1071 j = 0;
1072 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1073 }
1074#endif /* VMS */
5aabfad6 1075 if (s && klen == 4 && strEQ(ptr,"PATH")) {
8772537c 1076 const char * const strend = s + len;
463ee0b2
LW
1077
1078 while (s < strend) {
96827780 1079 char tmpbuf[256];
c623ac67 1080 Stat_t st;
5f74f29c 1081 I32 i;
96827780 1082 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
fc36a67e 1083 s, strend, ':', &i);
463ee0b2 1084 s++;
96827780
MB
1085 if (i >= sizeof tmpbuf /* too long -- assume the worst */
1086 || *tmpbuf != '/'
c6ed36e1 1087 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
8990e307 1088 MgTAINTEDDIR_on(mg);
1e422769
PP
1089 return 0;
1090 }
463ee0b2 1091 }
79072805
LW
1092 }
1093 }
39e571d4 1094#endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1e422769 1095
79072805
LW
1096 return 0;
1097}
1098
1099int
864dbfa3 1100Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
85e6fe83 1101{
8772537c 1102 PERL_UNUSED_ARG(sv);
01b8bcb7 1103 my_setenv(MgPV_nolen_const(mg),Nullch);
85e6fe83
LW
1104 return 0;
1105}
1106
88e89b8a 1107int
864dbfa3 1108Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
fb73857a 1109{
27da23d5 1110#if defined(VMS) || defined(EPOC) || defined(SYMBIAN)
cea2e8a9 1111 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
fb73857a 1112#else
3280af22 1113 if (PL_localizing) {
fb73857a
PP
1114 HE* entry;
1115 magic_clear_all_env(sv,mg);
1116 hv_iterinit((HV*)sv);
155aba94 1117 while ((entry = hv_iternext((HV*)sv))) {
fb73857a
PP
1118 I32 keylen;
1119 my_setenv(hv_iterkey(entry, &keylen),
b83604b4 1120 SvPV_nolen_const(hv_iterval((HV*)sv, entry)));
fb73857a
PP
1121 }
1122 }
1123#endif
1124 return 0;
1125}
1126
1127int
864dbfa3 1128Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
66b1d557 1129{
27da23d5 1130 dVAR;
2f42fcb0 1131#ifndef PERL_MICRO
27da23d5 1132#if defined(VMS) || defined(EPOC) || defined(SYMBIAN)
cea2e8a9 1133 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
3e3baf6d 1134#else
4efc5df6 1135# if defined(PERL_IMPLICIT_SYS) || defined(WIN32)
7766f137 1136 PerlEnv_clearenv();
4efc5df6
GS
1137# else
1138# ifdef USE_ENVIRON_ARRAY
1139# if defined(USE_ITHREADS)
1140 /* only the parent thread can clobber the process environment */
1141 if (PL_curinterp == aTHX)
1142# endif
1143 {
1144# ifndef PERL_USE_SAFE_PUTENV
50acdf95 1145 if (!PL_use_safe_putenv) {
66b1d557
HM
1146 I32 i;
1147
3280af22 1148 if (environ == PL_origenviron)
f2517201 1149 environ = (char**)safesysmalloc(sizeof(char*));
66b1d557
HM
1150 else
1151 for (i = 0; environ[i]; i++)
f2517201 1152 safesysfree(environ[i]);
50acdf95 1153 }
4efc5df6 1154# endif /* PERL_USE_SAFE_PUTENV */
f2517201 1155
66b1d557 1156 environ[0] = Nullch;
4efc5df6
GS
1157 }
1158# endif /* USE_ENVIRON_ARRAY */
052c2dc6 1159# endif /* PERL_IMPLICIT_SYS || WIN32 */
2f42fcb0
JH
1160#endif /* VMS || EPOC */
1161#endif /* !PERL_MICRO */
8772537c
AL
1162 PERL_UNUSED_ARG(sv);
1163 PERL_UNUSED_ARG(mg);
3e3baf6d 1164 return 0;
66b1d557
HM
1165}
1166
64ca3a65 1167#ifndef PERL_MICRO
2d4fcd5e
AJ
1168#ifdef HAS_SIGPROCMASK
1169static void
1170restore_sigmask(pTHX_ SV *save_sv)
1171{
b83604b4 1172 const sigset_t *ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
2d4fcd5e
AJ
1173 (void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0);
1174}
1175#endif
66b1d557 1176int
864dbfa3 1177Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
88e89b8a 1178{
88e89b8a 1179 /* Are we fetching a signal entry? */
8772537c 1180 const I32 i = whichsig(MgPV_nolen_const(mg));
e02bfb16 1181 if (i > 0) {
22c35a8c
GS
1182 if(PL_psig_ptr[i])
1183 sv_setsv(sv,PL_psig_ptr[i]);
88e89b8a 1184 else {
85b332e2 1185 Sighandler_t sigstate;
2e34cc90 1186 sigstate = rsignal_state(i);
23ada85b 1187#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
27da23d5 1188 if (PL_sig_handlers_initted && PL_sig_ignoring[i]) sigstate = SIG_IGN;
2e34cc90
CL
1189#endif
1190#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
27da23d5 1191 if (PL_sig_handlers_initted && PL_sig_defaulting[i]) sigstate = SIG_DFL;
85b332e2 1192#endif
88e89b8a 1193 /* cache state so we don't fetch it again */
8aad04aa 1194 if(sigstate == (Sighandler_t) SIG_IGN)
88e89b8a
PP
1195 sv_setpv(sv,"IGNORE");
1196 else
3280af22 1197 sv_setsv(sv,&PL_sv_undef);
22c35a8c 1198 PL_psig_ptr[i] = SvREFCNT_inc(sv);
88e89b8a
PP
1199 SvTEMP_off(sv);
1200 }
1201 }
1202 return 0;
1203}
1204int
864dbfa3 1205Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
88e89b8a 1206{
2d4fcd5e
AJ
1207 /* XXX Some of this code was copied from Perl_magic_setsig. A little
1208 * refactoring might be in order.
1209 */
27da23d5 1210 dVAR;
8772537c
AL
1211 register const char * const s = MgPV_nolen_const(mg);
1212 PERL_UNUSED_ARG(sv);
2d4fcd5e 1213 if (*s == '_') {
27da23d5 1214 SV** svp = 0;
2d4fcd5e
AJ
1215 if (strEQ(s,"__DIE__"))
1216 svp = &PL_diehook;
1217 else if (strEQ(s,"__WARN__"))
1218 svp = &PL_warnhook;
1219 else
1220 Perl_croak(aTHX_ "No such hook: %s", s);
27da23d5 1221 if (svp && *svp) {
8772537c 1222 SV * const to_dec = *svp;
2d4fcd5e
AJ
1223 *svp = 0;
1224 SvREFCNT_dec(to_dec);
1225 }
1226 }
1227 else {
2d4fcd5e 1228 /* Are we clearing a signal entry? */
8772537c 1229 const I32 i = whichsig(s);
e02bfb16 1230 if (i > 0) {
2d4fcd5e
AJ
1231#ifdef HAS_SIGPROCMASK
1232 sigset_t set, save;
1233 SV* save_sv;
1234 /* Avoid having the signal arrive at a bad time, if possible. */
1235 sigemptyset(&set);
1236 sigaddset(&set,i);
1237 sigprocmask(SIG_BLOCK, &set, &save);
1238 ENTER;
1239 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1240 SAVEFREESV(save_sv);
1241 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1242#endif
1243 PERL_ASYNC_CHECK();
1244#if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
27da23d5 1245 if (!PL_sig_handlers_initted) Perl_csighandler_init();
2d4fcd5e
AJ
1246#endif
1247#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
27da23d5 1248 PL_sig_defaulting[i] = 1;
5c1546dc 1249 (void)rsignal(i, PL_csighandlerp);
2d4fcd5e 1250#else
8aad04aa 1251 (void)rsignal(i, (Sighandler_t) SIG_DFL);
2d4fcd5e
AJ
1252#endif
1253 if(PL_psig_name[i]) {
1254 SvREFCNT_dec(PL_psig_name[i]);
1255 PL_psig_name[i]=0;
1256 }
1257 if(PL_psig_ptr[i]) {
dd374669 1258 SV *to_dec=PL_psig_ptr[i];
2d4fcd5e
AJ
1259 PL_psig_ptr[i]=0;
1260 LEAVE;
1261 SvREFCNT_dec(to_dec);
1262 }
1263 else
1264 LEAVE;
1265 }
88e89b8a
PP
1266 }
1267 return 0;
1268}
3d37d572 1269
dd374669
AL
1270static void
1271S_raise_signal(pTHX_ int sig)
0a8e0eff
NIS
1272{
1273 /* Set a flag to say this signal is pending */
1274 PL_psig_pend[sig]++;
1275 /* And one to say _a_ signal is pending */
1276 PL_sig_pending = 1;
1277}
1278
1279Signal_t
8aad04aa
JH
1280#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1281Perl_csighandler(int sig, ...)
1282#else
0a8e0eff 1283Perl_csighandler(int sig)
8aad04aa 1284#endif
0a8e0eff 1285{
1018e26f
NIS
1286#ifdef PERL_GET_SIG_CONTEXT
1287 dTHXa(PERL_GET_SIG_CONTEXT);
1288#else
85b332e2
CL
1289 dTHX;
1290#endif
23ada85b 1291#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
5c1546dc 1292 (void) rsignal(sig, PL_csighandlerp);
27da23d5 1293 if (PL_sig_ignoring[sig]) return;
85b332e2 1294#endif
2e34cc90 1295#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
27da23d5 1296 if (PL_sig_defaulting[sig])
2e34cc90
CL
1297#ifdef KILL_BY_SIGPRC
1298 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1299#else
1300 exit(1);
1301#endif
1302#endif
4ffa73a3
JH
1303 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
1304 /* Call the perl level handler now--
1305 * with risk we may be in malloc() etc. */
1306 (*PL_sighandlerp)(sig);
1307 else
dd374669 1308 S_raise_signal(aTHX_ sig);
0a8e0eff
NIS
1309}
1310
2e34cc90
CL
1311#if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1312void
1313Perl_csighandler_init(void)
1314{
1315 int sig;
27da23d5 1316 if (PL_sig_handlers_initted) return;
2e34cc90
CL
1317
1318 for (sig = 1; sig < SIG_SIZE; sig++) {
1319#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
218fdd94 1320 dTHX;
27da23d5 1321 PL_sig_defaulting[sig] = 1;
5c1546dc 1322 (void) rsignal(sig, PL_csighandlerp);
2e34cc90
CL
1323#endif
1324#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
27da23d5 1325 PL_sig_ignoring[sig] = 0;
2e34cc90
CL
1326#endif
1327 }
27da23d5 1328 PL_sig_handlers_initted = 1;
2e34cc90
CL
1329}
1330#endif
1331
0a8e0eff
NIS
1332void
1333Perl_despatch_signals(pTHX)
1334{
1335 int sig;
1336 PL_sig_pending = 0;
1337 for (sig = 1; sig < SIG_SIZE; sig++) {
1338 if (PL_psig_pend[sig]) {
25da4428
JH
1339 PERL_BLOCKSIG_ADD(set, sig);
1340 PL_psig_pend[sig] = 0;
1341 PERL_BLOCKSIG_BLOCK(set);
f5203343 1342 (*PL_sighandlerp)(sig);
25da4428 1343 PERL_BLOCKSIG_UNBLOCK(set);
0a8e0eff
NIS
1344 }
1345 }
1346}
1347
85e6fe83 1348int
864dbfa3 1349Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
79072805 1350{
27da23d5 1351 dVAR;
79072805 1352 I32 i;
b7953727 1353 SV** svp = 0;
2d4fcd5e
AJ
1354 /* Need to be careful with SvREFCNT_dec(), because that can have side
1355 * effects (due to closures). We must make sure that the new disposition
1356 * is in place before it is called.
1357 */
1358 SV* to_dec = 0;
e72dc28c 1359 STRLEN len;
2d4fcd5e
AJ
1360#ifdef HAS_SIGPROCMASK
1361 sigset_t set, save;
1362 SV* save_sv;
1363#endif
a0d0e21e 1364
d5263905 1365 register const char *s = MgPV_const(mg,len);
748a9306
LW
1366 if (*s == '_') {
1367 if (strEQ(s,"__DIE__"))
3280af22 1368 svp = &PL_diehook;
748a9306 1369 else if (strEQ(s,"__WARN__"))
3280af22 1370 svp = &PL_warnhook;
748a9306 1371 else
cea2e8a9 1372 Perl_croak(aTHX_ "No such hook: %s", s);
748a9306 1373 i = 0;
4633a7c4 1374 if (*svp) {
2d4fcd5e 1375 to_dec = *svp;
4633a7c4
LW
1376 *svp = 0;
1377 }
748a9306
LW
1378 }
1379 else {
1380 i = whichsig(s); /* ...no, a brick */
86d86cad 1381 if (i <= 0) {
e476b1b5 1382 if (ckWARN(WARN_SIGNAL))
9014280d 1383 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
748a9306
LW
1384 return 0;
1385 }
2d4fcd5e
AJ
1386#ifdef HAS_SIGPROCMASK
1387 /* Avoid having the signal arrive at a bad time, if possible. */
1388 sigemptyset(&set);
1389 sigaddset(&set,i);
1390 sigprocmask(SIG_BLOCK, &set, &save);
1391 ENTER;
1392 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1393 SAVEFREESV(save_sv);
1394 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1395#endif
1396 PERL_ASYNC_CHECK();
2e34cc90 1397#if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
27da23d5 1398 if (!PL_sig_handlers_initted) Perl_csighandler_init();
2e34cc90 1399#endif
23ada85b 1400#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
27da23d5 1401 PL_sig_ignoring[i] = 0;
85b332e2 1402#endif
2e34cc90 1403#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
27da23d5 1404 PL_sig_defaulting[i] = 0;
2e34cc90 1405#endif
22c35a8c 1406 SvREFCNT_dec(PL_psig_name[i]);
2d4fcd5e 1407 to_dec = PL_psig_ptr[i];
22c35a8c 1408 PL_psig_ptr[i] = SvREFCNT_inc(sv);
88e89b8a 1409 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
e72dc28c 1410 PL_psig_name[i] = newSVpvn(s, len);
22c35a8c 1411 SvREADONLY_on(PL_psig_name[i]);
748a9306 1412 }
a0d0e21e 1413 if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
2d4fcd5e 1414 if (i) {
5c1546dc 1415 (void)rsignal(i, PL_csighandlerp);
2d4fcd5e
AJ
1416#ifdef HAS_SIGPROCMASK
1417 LEAVE;
1418#endif
1419 }
748a9306
LW
1420 else
1421 *svp = SvREFCNT_inc(sv);
2d4fcd5e
AJ
1422 if(to_dec)
1423 SvREFCNT_dec(to_dec);
a0d0e21e
LW
1424 return 0;
1425 }
e72dc28c 1426 s = SvPV_force(sv,len);
748a9306 1427 if (strEQ(s,"IGNORE")) {
85b332e2 1428 if (i) {
23ada85b 1429#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
27da23d5 1430 PL_sig_ignoring[i] = 1;
5c1546dc 1431 (void)rsignal(i, PL_csighandlerp);
85b332e2 1432#else
8aad04aa 1433 (void)rsignal(i, (Sighandler_t) SIG_IGN);
85b332e2 1434#endif
2d4fcd5e 1435 }
748a9306
LW
1436 }
1437 else if (strEQ(s,"DEFAULT") || !*s) {
1438 if (i)
2e34cc90
CL
1439#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1440 {
27da23d5 1441 PL_sig_defaulting[i] = 1;
5c1546dc 1442 (void)rsignal(i, PL_csighandlerp);
2e34cc90
CL
1443 }
1444#else
8aad04aa 1445 (void)rsignal(i, (Sighandler_t) SIG_DFL);
2e34cc90 1446#endif
748a9306 1447 }
79072805 1448 else {
5aabfad6
PP
1449 /*
1450 * We should warn if HINT_STRICT_REFS, but without
1451 * access to a known hint bit in a known OP, we can't
1452 * tell whether HINT_STRICT_REFS is in force or not.
1453 */
46fc3d4c 1454 if (!strchr(s,':') && !strchr(s,'\''))
e72dc28c 1455 sv_insert(sv, 0, 0, "main::", 6);
748a9306 1456 if (i)
5c1546dc 1457 (void)rsignal(i, PL_csighandlerp);
748a9306
LW
1458 else
1459 *svp = SvREFCNT_inc(sv);
79072805 1460 }
2d4fcd5e
AJ
1461#ifdef HAS_SIGPROCMASK
1462 if(i)
1463 LEAVE;
1464#endif
1465 if(to_dec)
1466 SvREFCNT_dec(to_dec);
79072805
LW
1467 return 0;
1468}
64ca3a65 1469#endif /* !PERL_MICRO */
79072805
LW
1470
1471int
864dbfa3 1472Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
79072805 1473{
8772537c
AL
1474 PERL_UNUSED_ARG(sv);
1475 PERL_UNUSED_ARG(mg);
3280af22 1476 PL_sub_generation++;
463ee0b2
LW
1477 return 0;
1478}
1479
1480int
864dbfa3 1481Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
463ee0b2 1482{
8772537c
AL
1483 PERL_UNUSED_ARG(sv);
1484 PERL_UNUSED_ARG(mg);
a0d0e21e 1485 /* HV_badAMAGIC_on(Sv_STASH(sv)); */
3280af22 1486 PL_amagic_generation++;
463ee0b2 1487
a0d0e21e
LW
1488 return 0;
1489}
463ee0b2 1490
946ec16e 1491int
864dbfa3 1492Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
6ff81951 1493{
dd374669 1494 HV * const hv = (HV*)LvTARG(sv);
6ff81951 1495 I32 i = 0;
8772537c 1496 PERL_UNUSED_ARG(mg);
7719e241 1497
6ff81951 1498 if (hv) {
497b47a8
JH
1499 (void) hv_iterinit(hv);
1500 if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
1501 i = HvKEYS(hv);
1502 else {
1503 while (hv_iternext(hv))
1504 i++;
1505 }
6ff81951
GS
1506 }
1507
1508 sv_setiv(sv, (IV)i);
1509 return 0;
1510}
1511
1512int
864dbfa3 1513Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
946ec16e 1514{
8772537c 1515 PERL_UNUSED_ARG(mg);
946ec16e
PP
1516 if (LvTARG(sv)) {
1517 hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
946ec16e
PP
1518 }
1519 return 0;
ac27b0f5 1520}
946ec16e 1521
e336de0d 1522/* caller is responsible for stack switching/cleanup */
565764a8 1523STATIC int
e1ec3a88 1524S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV *val)
a0d0e21e
LW
1525{
1526 dSP;
463ee0b2 1527
924508f0
GS
1528 PUSHMARK(SP);
1529 EXTEND(SP, n);
33c27489 1530 PUSHs(SvTIED_obj(sv, mg));
ac27b0f5 1531 if (n > 1) {
93965878 1532 if (mg->mg_ptr) {
565764a8 1533 if (mg->mg_len >= 0)
79cb57f6 1534 PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len)));
565764a8 1535 else if (mg->mg_len == HEf_SVKEY)
93965878
NIS
1536 PUSHs((SV*)mg->mg_ptr);
1537 }
14befaf4 1538 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
565764a8 1539 PUSHs(sv_2mortal(newSViv(mg->mg_len)));
93965878
NIS
1540 }
1541 }
1542 if (n > 2) {
1543 PUSHs(val);
88e89b8a 1544 }
463ee0b2
LW
1545 PUTBACK;
1546
864dbfa3 1547 return call_method(meth, flags);
946ec16e
PP
1548}
1549
76e3520e 1550STATIC int
e1ec3a88 1551S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
a0d0e21e 1552{
27da23d5 1553 dVAR; dSP;
463ee0b2 1554
a0d0e21e
LW
1555 ENTER;
1556 SAVETMPS;
e788e7d3 1557 PUSHSTACKi(PERLSI_MAGIC);
463ee0b2 1558
33c27489 1559 if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
3280af22 1560 sv_setsv(sv, *PL_stack_sp--);
93965878 1561 }
463ee0b2 1562
d3acc0f7 1563 POPSTACK;
a0d0e21e
LW
1564 FREETMPS;
1565 LEAVE;
1566 return 0;
1567}
463ee0b2 1568
a0d0e21e 1569int
864dbfa3 1570Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e 1571{
a0d0e21e
LW
1572 if (mg->mg_ptr)
1573 mg->mg_flags |= MGf_GSKIP;
58f82c5c 1574 magic_methpack(sv,mg,"FETCH");
463ee0b2
LW
1575 return 0;
1576}
1577
1578int
864dbfa3 1579Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
e336de0d 1580{
27da23d5 1581 dVAR; dSP;
a60c0954 1582 ENTER;
e788e7d3 1583 PUSHSTACKi(PERLSI_MAGIC);
33c27489 1584 magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
d3acc0f7 1585 POPSTACK;
a60c0954 1586 LEAVE;
463ee0b2
LW
1587 return 0;
1588}
1589
1590int
864dbfa3 1591Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
463ee0b2 1592{
a0d0e21e
LW
1593 return magic_methpack(sv,mg,"DELETE");
1594}
463ee0b2 1595
93965878
NIS
1596
1597U32
864dbfa3 1598Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
ac27b0f5 1599{
27da23d5 1600 dVAR; dSP;
93965878
NIS
1601 U32 retval = 0;
1602
1603 ENTER;
1604 SAVETMPS;
e788e7d3 1605 PUSHSTACKi(PERLSI_MAGIC);
33c27489 1606 if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
3280af22 1607 sv = *PL_stack_sp--;
a60c0954 1608 retval = (U32) SvIV(sv)-1;
93965878 1609 }
d3acc0f7 1610 POPSTACK;
93965878
NIS
1611 FREETMPS;
1612 LEAVE;
1613 return retval;
1614}
1615
cea2e8a9
GS
1616int
1617Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e 1618{
27da23d5 1619 dVAR; dSP;
463ee0b2 1620
e336de0d 1621 ENTER;
e788e7d3 1622 PUSHSTACKi(PERLSI_MAGIC);
924508f0 1623 PUSHMARK(SP);
33c27489 1624 XPUSHs(SvTIED_obj(sv, mg));
463ee0b2 1625 PUTBACK;
864dbfa3 1626 call_method("CLEAR", G_SCALAR|G_DISCARD);
d3acc0f7 1627 POPSTACK;
a60c0954 1628 LEAVE;
a3bcc51e 1629
463ee0b2
LW
1630 return 0;
1631}
1632
1633int
864dbfa3 1634Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
463ee0b2 1635{
27da23d5 1636 dVAR; dSP;
35a4481c 1637 const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
463ee0b2
LW
1638
1639 ENTER;
a0d0e21e 1640 SAVETMPS;
e788e7d3 1641 PUSHSTACKi(PERLSI_MAGIC);
924508f0
GS
1642 PUSHMARK(SP);
1643 EXTEND(SP, 2);
33c27489 1644 PUSHs(SvTIED_obj(sv, mg));
463ee0b2
LW
1645 if (SvOK(key))
1646 PUSHs(key);
1647 PUTBACK;
1648
864dbfa3 1649 if (call_method(meth, G_SCALAR))
3280af22 1650 sv_setsv(key, *PL_stack_sp--);
463ee0b2 1651
d3acc0f7 1652 POPSTACK;
a0d0e21e
LW
1653 FREETMPS;
1654 LEAVE;
79072805
LW
1655 return 0;
1656}
1657
1658int
864dbfa3 1659Perl_magic_existspack(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e
LW
1660{
1661 return magic_methpack(sv,mg,"EXISTS");
ac27b0f5 1662}
a0d0e21e 1663
a3bcc51e
TP
1664SV *
1665Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1666{
27da23d5 1667 dVAR; dSP;
a3bcc51e 1668 SV *retval = &PL_sv_undef;
8772537c
AL
1669 SV * const tied = SvTIED_obj((SV*)hv, mg);
1670 HV * const pkg = SvSTASH((SV*)SvRV(tied));
a3bcc51e
TP
1671
1672 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1673 SV *key;
bfcb3514 1674 if (HvEITER_get(hv))
a3bcc51e
TP
1675 /* we are in an iteration so the hash cannot be empty */
1676 return &PL_sv_yes;
1677 /* no xhv_eiter so now use FIRSTKEY */
1678 key = sv_newmortal();
1679 magic_nextpack((SV*)hv, mg, key);
bfcb3514 1680 HvEITER_set(hv, NULL); /* need to reset iterator */
a3bcc51e
TP
1681 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1682 }
1683
1684 /* there is a SCALAR method that we can call */
1685 ENTER;
1686 PUSHSTACKi(PERLSI_MAGIC);
1687 PUSHMARK(SP);
1688 EXTEND(SP, 1);
1689 PUSHs(tied);
1690 PUTBACK;
1691
1692 if (call_method("SCALAR", G_SCALAR))
1693 retval = *PL_stack_sp--;
1694 POPSTACK;
1695 LEAVE;
1696 return retval;
1697}
1698
a0d0e21e 1699int
864dbfa3 1700Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
79072805 1701{
8772537c
AL
1702 GV * const gv = PL_DBline;
1703 const I32 i = SvTRUE(sv);
1704 SV ** const svp = av_fetch(GvAV(gv),
01b8bcb7 1705 atoi(MgPV_nolen_const(mg)), FALSE);
8772537c
AL
1706 if (svp && SvIOKp(*svp)) {
1707 OP * const o = INT2PTR(OP*,SvIVX(*svp));
1708 if (o) {
1709 /* set or clear breakpoint in the relevant control op */
1710 if (i)
1711 o->op_flags |= OPf_SPECIAL;
1712 else
1713 o->op_flags &= ~OPf_SPECIAL;
1714 }
5df8de69 1715 }
79072805
LW
1716 return 0;
1717}
1718
1719int
8772537c 1720Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
79072805 1721{
8772537c 1722 const AV * const obj = (AV*)mg->mg_obj;
83bf042f
NC
1723 if (obj) {
1724 sv_setiv(sv, AvFILL(obj) + PL_curcop->cop_arybase);
1725 } else {
1726 SvOK_off(sv);
1727 }
79072805
LW
1728 return 0;
1729}
1730
1731int
864dbfa3 1732Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
79072805 1733{
8772537c 1734 AV * const obj = (AV*)mg->mg_obj;
83bf042f
NC
1735 if (obj) {
1736 av_fill(obj, SvIV(sv) - PL_curcop->cop_arybase);
1737 } else {
1738 if (ckWARN(WARN_MISC))
1739 Perl_warner(aTHX_ packWARN(WARN_MISC),
1740 "Attempt to set length of freed array");
1741 }
1742 return 0;
1743}
1744
1745int
1746Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
1747{
53c1dcc0 1748 PERL_UNUSED_ARG(sv);
94f3782b
DM
1749 /* during global destruction, mg_obj may already have been freed */
1750 if (PL_in_clean_all)
1ea47f64 1751 return 0;
94f3782b 1752
83bf042f
NC
1753 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
1754
1755 if (mg) {
1756 /* arylen scalar holds a pointer back to the array, but doesn't own a
1757 reference. Hence the we (the array) are about to go away with it
1758 still pointing at us. Clear its pointer, else it would be pointing
1759 at free memory. See the comment in sv_magic about reference loops,
1760 and why it can't own a reference to us. */
1761 mg->mg_obj = 0;
1762 }
a0d0e21e
LW
1763 return 0;
1764}
1765
1766int
864dbfa3 1767Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e 1768{
8772537c 1769 SV* const lsv = LvTARG(sv);
ac27b0f5 1770
a0d0e21e 1771 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
14befaf4 1772 mg = mg_find(lsv, PERL_MAGIC_regex_global);
565764a8 1773 if (mg && mg->mg_len >= 0) {
a0ed51b3 1774 I32 i = mg->mg_len;
7e2040f0 1775 if (DO_UTF8(lsv))
a0ed51b3
LW
1776 sv_pos_b2u(lsv, &i);
1777 sv_setiv(sv, i + PL_curcop->cop_arybase);
a0d0e21e
LW
1778 return 0;
1779 }
1780 }
0c34ef67 1781 SvOK_off(sv);
a0d0e21e
LW
1782 return 0;
1783}
1784
1785int
864dbfa3 1786Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e 1787{
8772537c 1788 SV* const lsv = LvTARG(sv);
a0d0e21e
LW
1789 SSize_t pos;
1790 STRLEN len;
c00206c8 1791 STRLEN ulen = 0;
a0d0e21e
LW
1792
1793 mg = 0;
ac27b0f5 1794
a0d0e21e 1795 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
14befaf4 1796 mg = mg_find(lsv, PERL_MAGIC_regex_global);
a0d0e21e
LW
1797 if (!mg) {
1798 if (!SvOK(sv))
1799 return 0;
14befaf4
DM
1800 sv_magic(lsv, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1801 mg = mg_find(lsv, PERL_MAGIC_regex_global);
a0d0e21e
LW
1802 }
1803 else if (!SvOK(sv)) {
565764a8 1804 mg->mg_len = -1;
a0d0e21e
LW
1805 return 0;
1806 }
1807 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1808
c485e607 1809 pos = SvIV(sv) - PL_curcop->cop_arybase;
a0ed51b3 1810
7e2040f0 1811 if (DO_UTF8(lsv)) {
a0ed51b3
LW
1812 ulen = sv_len_utf8(lsv);
1813 if (ulen)
1814 len = ulen;
a0ed51b3
LW
1815 }
1816
a0d0e21e
LW
1817 if (pos < 0) {
1818 pos += len;
1819 if (pos < 0)
1820 pos = 0;
1821 }
eb160463 1822 else if (pos > (SSize_t)len)
a0d0e21e 1823 pos = len;
a0ed51b3
LW
1824
1825 if (ulen) {
1826 I32 p = pos;
1827 sv_pos_u2b(lsv, &p, 0);
1828 pos = p;
1829 }
727405f8 1830
565764a8 1831 mg->mg_len = pos;
71be2cbc 1832 mg->mg_flags &= ~MGf_MINMATCH;
a0d0e21e 1833
79072805
LW
1834 return 0;
1835}
1836
1837int
864dbfa3 1838Perl_magic_getglob(pTHX_ SV *sv, MAGIC *mg)
79072805 1839{
8772537c 1840 PERL_UNUSED_ARG(mg);
8646b087
PP
1841 if (SvFAKE(sv)) { /* FAKE globs can get coerced */
1842 SvFAKE_off(sv);
946ec16e 1843 gv_efullname3(sv,((GV*)sv), "*");
8646b087
PP
1844 SvFAKE_on(sv);
1845 }
1846 else
946ec16e 1847 gv_efullname3(sv,((GV*)sv), "*"); /* a gv value, be nice */
79072805
LW
1848 return 0;
1849}
1850
1851int
864dbfa3 1852Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg)
79072805 1853{
79072805 1854 GV* gv;
8772537c
AL
1855 PERL_UNUSED_ARG(mg);
1856
79072805
LW
1857 if (!SvOK(sv))
1858 return 0;
7a5fd60d 1859 gv = gv_fetchsv(sv,TRUE, SVt_PVGV);
79072805
LW
1860 if (sv == (SV*)gv)
1861 return 0;
1862 if (GvGP(sv))
88e89b8a 1863 gp_free((GV*)sv);
79072805 1864 GvGP(sv) = gp_ref(GvGP(gv));
79072805
LW
1865 return 0;
1866}
1867
1868int
864dbfa3 1869Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
6ff81951
GS
1870{
1871 STRLEN len;
35a4481c 1872 SV * const lsv = LvTARG(sv);
b83604b4 1873 const char * const tmps = SvPV_const(lsv,len);
6ff81951
GS
1874 I32 offs = LvTARGOFF(sv);
1875 I32 rem = LvTARGLEN(sv);
8772537c 1876 PERL_UNUSED_ARG(mg);
6ff81951 1877
9aa983d2
JH
1878 if (SvUTF8(lsv))
1879 sv_pos_u2b(lsv, &offs, &rem);
eb160463 1880 if (offs > (I32)len)
6ff81951 1881 offs = len;
eb160463 1882 if (rem + offs > (I32)len)
6ff81951
GS
1883 rem = len - offs;
1884 sv_setpvn(sv, tmps + offs, (STRLEN)rem);
9aa983d2 1885 if (SvUTF8(lsv))
2ef4b674 1886 SvUTF8_on(sv);
6ff81951
GS
1887 return 0;
1888}
1889
1890int
864dbfa3 1891Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
79072805 1892{
9aa983d2 1893 STRLEN len;
b83604b4 1894 const char *tmps = SvPV_const(sv, len);
dd374669 1895 SV * const lsv = LvTARG(sv);
9aa983d2
JH
1896 I32 lvoff = LvTARGOFF(sv);
1897 I32 lvlen = LvTARGLEN(sv);
8772537c 1898 PERL_UNUSED_ARG(mg);
075a4a2b 1899
1aa99e6b 1900 if (DO_UTF8(sv)) {
9aa983d2
JH
1901 sv_utf8_upgrade(lsv);
1902 sv_pos_u2b(lsv, &lvoff, &lvlen);
1903 sv_insert(lsv, lvoff, lvlen, tmps, len);
b76f3ce2 1904 LvTARGLEN(sv) = sv_len_utf8(sv);
9aa983d2
JH
1905 SvUTF8_on(lsv);
1906 }
9bf12eaf 1907 else if (lsv && SvUTF8(lsv)) {
9aa983d2 1908 sv_pos_u2b(lsv, &lvoff, &lvlen);
b76f3ce2 1909 LvTARGLEN(sv) = len;
e95af362 1910 tmps = (char*)bytes_to_utf8((U8*)tmps, &len);
9aa983d2
JH
1911 sv_insert(lsv, lvoff, lvlen, tmps, len);
1912 Safefree(tmps);
1aa99e6b 1913 }
b76f3ce2
GB
1914 else {
1915 sv_insert(lsv, lvoff, lvlen, tmps, len);
1916 LvTARGLEN(sv) = len;
1917 }
1918
1aa99e6b 1919
79072805
LW
1920 return 0;
1921}
1922
1923int
864dbfa3 1924Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
463ee0b2 1925{
8772537c 1926 PERL_UNUSED_ARG(sv);
27cc343c 1927 TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
463ee0b2
LW
1928 return 0;
1929}
1930
1931int
864dbfa3 1932Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
463ee0b2 1933{
8772537c 1934 PERL_UNUSED_ARG(sv);
0a9c116b
DM
1935 /* update taint status unless we're restoring at scope exit */
1936 if (PL_localizing != 2) {
1937 if (PL_tainted)
1938 mg->mg_len |= 1;
1939 else
1940 mg->mg_len &= ~1;
1941 }
463ee0b2
LW
1942 return 0;
1943}
1944
1945int
864dbfa3 1946Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
6ff81951 1947{
35a4481c 1948 SV * const lsv = LvTARG(sv);
8772537c 1949 PERL_UNUSED_ARG(mg);
6ff81951
GS
1950
1951 if (!lsv) {
0c34ef67 1952 SvOK_off(sv);
6ff81951
GS
1953 return 0;
1954 }
6ff81951 1955
81e118e0 1956 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
6ff81951
GS
1957 return 0;
1958}
1959
1960int
864dbfa3 1961Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
79072805 1962{
8772537c 1963 PERL_UNUSED_ARG(mg);
79072805
LW
1964 do_vecset(sv); /* XXX slurp this routine */
1965 return 0;
1966}
1967
1968int
864dbfa3 1969Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
5f05dabc 1970{
71be2cbc 1971 SV *targ = Nullsv;
5f05dabc 1972 if (LvTARGLEN(sv)) {
68dc0745 1973 if (mg->mg_obj) {
8772537c
AL
1974 SV * const ahv = LvTARG(sv);
1975 HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
6d822dc4
MS
1976 if (he)
1977 targ = HeVAL(he);
68dc0745
PP
1978 }
1979 else {
8772537c 1980 AV* const av = (AV*)LvTARG(sv);
68dc0745
PP
1981 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
1982 targ = AvARRAY(av)[LvTARGOFF(sv)];
1983 }
3280af22 1984 if (targ && targ != &PL_sv_undef) {
68dc0745
PP
1985 /* somebody else defined it for us */
1986 SvREFCNT_dec(LvTARG(sv));
1987 LvTARG(sv) = SvREFCNT_inc(targ);
1988 LvTARGLEN(sv) = 0;
1989 SvREFCNT_dec(mg->mg_obj);
1990 mg->mg_obj = Nullsv;
1991 mg->mg_flags &= ~MGf_REFCOUNTED;
1992 }
5f05dabc 1993 }
71be2cbc
PP
1994 else
1995 targ = LvTARG(sv);
3280af22 1996 sv_setsv(sv, targ ? targ : &PL_sv_undef);
71be2cbc
PP
1997 return 0;
1998}
1999
2000int
864dbfa3 2001Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
71be2cbc 2002{
8772537c 2003 PERL_UNUSED_ARG(mg);
71be2cbc 2004 if (LvTARGLEN(sv))
68dc0745
PP
2005 vivify_defelem(sv);
2006 if (LvTARG(sv)) {
5f05dabc 2007 sv_setsv(LvTARG(sv), sv);
68dc0745
PP
2008 SvSETMAGIC(LvTARG(sv));
2009 }
5f05dabc
PP
2010 return 0;
2011}
2012
71be2cbc 2013void
864dbfa3 2014Perl_vivify_defelem(pTHX_ SV *sv)
71be2cbc 2015{
74e13ce4
GS
2016 MAGIC *mg;
2017 SV *value = Nullsv;
71be2cbc 2018
14befaf4 2019 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
71be2cbc 2020 return;
68dc0745 2021 if (mg->mg_obj) {
8772537c
AL
2022 SV * const ahv = LvTARG(sv);
2023 HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
6d822dc4
MS
2024 if (he)
2025 value = HeVAL(he);
3280af22 2026 if (!value || value == &PL_sv_undef)
ce5030a2 2027 Perl_croak(aTHX_ PL_no_helem_sv, mg->mg_obj);
71be2cbc 2028 }
68dc0745 2029 else {
8772537c 2030 AV* const av = (AV*)LvTARG(sv);
5aabfad6 2031 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
68dc0745
PP
2032 LvTARG(sv) = Nullsv; /* array can't be extended */
2033 else {
aec46f14 2034 SV** const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
3280af22 2035 if (!svp || (value = *svp) == &PL_sv_undef)
cea2e8a9 2036 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
68dc0745
PP
2037 }
2038 }
3e3baf6d 2039 (void)SvREFCNT_inc(value);
68dc0745
PP
2040 SvREFCNT_dec(LvTARG(sv));
2041 LvTARG(sv) = value;
71be2cbc 2042 LvTARGLEN(sv) = 0;
68dc0745
PP
2043 SvREFCNT_dec(mg->mg_obj);
2044 mg->mg_obj = Nullsv;
2045 mg->mg_flags &= ~MGf_REFCOUNTED;
5f05dabc
PP
2046}
2047
2048int
864dbfa3 2049Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
810b8aa5 2050{
e15faf7d
NC
2051 AV *const av = (AV*)mg->mg_obj;
2052 SV **svp = AvARRAY(av);
8772537c 2053 PERL_UNUSED_ARG(sv);
dd374669 2054
e15faf7d
NC
2055 if (svp) {
2056 SV *const *const last = svp + AvFILLp(av);
2057
2058 while (svp <= last) {
2059 if (*svp) {
2060 SV *const referrer = *svp;
2061 if (SvWEAKREF(referrer)) {
2062 /* XXX Should we check that it hasn't changed? */
2063 SvRV_set(referrer, 0);
2064 SvOK_off(referrer);
2065 SvWEAKREF_off(referrer);
2066 } else if (SvTYPE(referrer) == SVt_PVGV ||
2067 SvTYPE(referrer) == SVt_PVLV) {
2068 /* You lookin' at me? */
2069 assert(GvSTASH(referrer));
2070 assert(GvSTASH(referrer) == (HV*)sv);
2071 GvSTASH(referrer) = 0;
2072 } else {
2073 Perl_croak(aTHX_
2074 "panic: magic_killbackrefs (flags=%"UVxf")",
e91e3b10 2075 (UV)SvFLAGS(referrer));
e15faf7d
NC
2076 }
2077
2078 *svp = Nullsv;
2079 }
2080 svp++;
810b8aa5 2081 }
810b8aa5 2082 }
d99b02a1 2083 SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */
810b8aa5
GS
2084 return 0;
2085}
2086
2087int
864dbfa3 2088Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
93a17b20 2089{
565764a8 2090 mg->mg_len = -1;
c6496cc7 2091 SvSCREAM_off(sv);
93a17b20
LW
2092 return 0;
2093}
2094
2095int
864dbfa3 2096Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
79072805 2097{
8772537c 2098 PERL_UNUSED_ARG(mg);
14befaf4 2099 sv_unmagic(sv, PERL_MAGIC_bm);
79072805
LW
2100 SvVALID_off(sv);
2101 return 0;
2102}
2103
2104int
864dbfa3 2105Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
55497cff 2106{
8772537c 2107 PERL_UNUSED_ARG(mg);
14befaf4 2108 sv_unmagic(sv, PERL_MAGIC_fm);
55497cff
PP
2109 SvCOMPILED_off(sv);
2110 return 0;
2111}
2112
2113int
864dbfa3 2114Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
79072805 2115{
35a4481c 2116 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
79072805
LW
2117
2118 if (uf && uf->uf_set)
24f81a43 2119 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
79072805
LW
2120 return 0;
2121}
2122
c277df42 2123int
faf82a0b
AE
2124Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2125{
8772537c 2126 PERL_UNUSED_ARG(mg);
faf82a0b
AE
2127 sv_unmagic(sv, PERL_MAGIC_qr);
2128 return 0;
2129}
2130
2131int
864dbfa3 2132Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
c277df42 2133{
8772537c
AL
2134 regexp * const re = (regexp *)mg->mg_obj;
2135 PERL_UNUSED_ARG(sv);
2136
c277df42
IZ
2137 ReREFCNT_dec(re);
2138 return 0;
2139}
2140
7a4c00b4 2141#ifdef USE_LOCALE_COLLATE
79072805 2142int
864dbfa3 2143Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
bbce6d69
PP
2144{
2145 /*
838b5b74 2146 * RenE<eacute> Descartes said "I think not."
bbce6d69
PP
2147 * and vanished with a faint plop.
2148 */
8772537c 2149 PERL_UNUSED_ARG(sv);
7a4c00b4
PP
2150 if (mg->mg_ptr) {
2151 Safefree(mg->mg_ptr);
2152 mg->mg_ptr = NULL;
565764a8 2153 mg->mg_len = -1;
7a4c00b4 2154 }
bbce6d69
PP
2155 return 0;
2156}
7a4c00b4 2157#endif /* USE_LOCALE_COLLATE */
bbce6d69 2158
7e8c5dac
HS
2159/* Just clear the UTF-8 cache data. */
2160int
2161Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2162{
8772537c 2163 PERL_UNUSED_ARG(sv);
7e8c5dac
HS
2164 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2165 mg->mg_ptr = 0;
2166 mg->mg_len = -1; /* The mg_len holds the len cache. */
2167 return 0;
2168}
2169
bbce6d69 2170int
864dbfa3 2171Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
79072805 2172{
e1ec3a88 2173 register const char *s;
79072805 2174 I32 i;
8990e307 2175 STRLEN len;
79072805 2176 switch (*mg->mg_ptr) {
748a9306 2177 case '\001': /* ^A */
3280af22 2178 sv_setsv(PL_bodytarget, sv);
748a9306 2179 break;
49460fe6 2180 case '\003': /* ^C */
eb160463 2181 PL_minus_c = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
49460fe6
NIS
2182 break;
2183
79072805 2184 case '\004': /* ^D */
b4ab917c 2185#ifdef DEBUGGING
b83604b4 2186 s = SvPV_nolen_const(sv);
ddcf8bc1 2187 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
79072805 2188 DEBUG_x(dump_all());
b4ab917c
DM
2189#else
2190 PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | DEBUG_TOP_FLAG;
2191#endif
79072805 2192 break;
28f23441 2193 case '\005': /* ^E */
d0063567 2194 if (*(mg->mg_ptr+1) == '\0') {
cd39f2b6 2195#ifdef MACOS_TRADITIONAL
d0063567 2196 gMacPerl_OSErr = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
28f23441 2197#else
cd39f2b6 2198# ifdef VMS
d0063567 2199 set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
048c1ddf 2200# else
cd39f2b6 2201# ifdef WIN32
d0063567 2202 SetLastError( SvIV(sv) );
cd39f2b6 2203# else
9fed8b87 2204# ifdef OS2
d0063567 2205 os2_setsyserrno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
9fed8b87 2206# else
d0063567
DK
2207 /* will anyone ever use this? */
2208 SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4);
cd39f2b6 2209# endif
048c1ddf
IZ
2210# endif
2211# endif
22fae026 2212#endif
d0063567
DK
2213 }
2214 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2215 if (PL_encoding)
2216 SvREFCNT_dec(PL_encoding);
2217 if (SvOK(sv) || SvGMAGICAL(sv)) {
2218 PL_encoding = newSVsv(sv);
2219 }
2220 else {
2221 PL_encoding = Nullsv;
2222 }
2223 }
2224 break;
79072805 2225 case '\006': /* ^F */
3280af22 2226 PL_maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
79072805 2227 break;
a0d0e21e 2228 case '\010': /* ^H */
3280af22 2229 PL_hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
a0d0e21e 2230 break;
9d116dd7 2231 case '\011': /* ^I */ /* NOT \t in EBCDIC */
43c5f42d
NC
2232 Safefree(PL_inplace);
2233 PL_inplace = SvOK(sv) ? savesvpv(sv) : Nullch;
da78da6e 2234 break;
28f23441 2235 case '\017': /* ^O */
ac27b0f5 2236 if (*(mg->mg_ptr+1) == '\0') {
43c5f42d
NC
2237 Safefree(PL_osname);
2238 PL_osname = Nullch;
3511154c
DM
2239 if (SvOK(sv)) {
2240 TAINT_PROPER("assigning to $^O");
2e0de35c 2241 PL_osname = savesvpv(sv);
3511154c 2242 }
ac27b0f5
NIS
2243 }
2244 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2245 if (!PL_compiling.cop_io)
2246 PL_compiling.cop_io = newSVsv(sv);
2247 else
2248 sv_setsv(PL_compiling.cop_io,sv);
2249 }
28f23441 2250 break;
79072805 2251 case '\020': /* ^P */
3280af22 2252 PL_perldb = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
f2a7f298 2253 if (PL_perldb && !PL_DBsingle)
1ee4443e 2254 init_debugger();
79072805
LW
2255 break;
2256 case '\024': /* ^T */
88e89b8a 2257#ifdef BIG_TIME
6b88bc9c 2258 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
88e89b8a 2259#else
3280af22 2260 PL_basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
88e89b8a 2261#endif
79072805 2262 break;
fde18df1 2263 case '\027': /* ^W & $^WARNING_BITS */
4438c4b7
JH
2264 if (*(mg->mg_ptr+1) == '\0') {
2265 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2266 i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
ac27b0f5 2267 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
0453d815 2268 | (i ? G_WARN_ON : G_WARN_OFF) ;
4438c4b7 2269 }
599cee73 2270 }
0a378802 2271 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
4438c4b7 2272 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
d775746e
GS
2273 if (!SvPOK(sv) && PL_localizing) {
2274 sv_setpvn(sv, WARN_NONEstring, WARNsize);
d3a7d8c7 2275 PL_compiling.cop_warnings = pWARN_NONE;
d775746e
GS
2276 break;
2277 }
f4fc7782 2278 {
b5477537 2279 STRLEN len, i;
d3a7d8c7 2280 int accumulate = 0 ;
f4fc7782 2281 int any_fatals = 0 ;
b83604b4 2282 const char * const ptr = SvPV_const(sv, len) ;
f4fc7782
JH
2283 for (i = 0 ; i < len ; ++i) {
2284 accumulate |= ptr[i] ;
2285 any_fatals |= (ptr[i] & 0xAA) ;
2286 }
d3a7d8c7
GS
2287 if (!accumulate)
2288 PL_compiling.cop_warnings = pWARN_NONE;
f4fc7782
JH
2289 else if (isWARN_on(sv, WARN_ALL) && !any_fatals) {
2290 PL_compiling.cop_warnings = pWARN_ALL;
2291 PL_dowarn |= G_WARN_ONCE ;
727405f8 2292 }
d3a7d8c7
GS
2293 else {
2294 if (specialWARN(PL_compiling.cop_warnings))
2295 PL_compiling.cop_warnings = newSVsv(sv) ;
2296 else
2297 sv_setsv(PL_compiling.cop_warnings, sv);
2298 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2299 PL_dowarn |= G_WARN_ONCE ;
2300 }
f4fc7782 2301
d3a7d8c7 2302 }
4438c4b7 2303 }
971a9dd3 2304 }
79072805
LW
2305 break;
2306 case '.':
3280af22
NIS
2307 if (PL_localizing) {
2308 if (PL_localizing == 1)
7766f137 2309 SAVESPTR(PL_last_in_gv);
748a9306 2310 }
3280af22 2311 else if (SvOK(sv) && GvIO(PL_last_in_gv))
632db599 2312 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
79072805
LW
2313 break;
2314 case '^':
3280af22 2315 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
e1ec3a88 2316 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
7a5fd60d 2317 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv,TRUE, SVt_PVIO);
79072805
LW
2318 break;
2319 case '~':
3280af22 2320 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
e1ec3a88 2321 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
7a5fd60d 2322 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv,TRUE, SVt_PVIO);
79072805
LW
2323 break;
2324 case '=':
632db599 2325 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
79072805
LW
2326 break;
2327 case '-':
632db599 2328 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
3280af22
NIS
2329 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2330 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
79072805
LW
2331 break;
2332 case '%':
632db599 2333 IoPAGE(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
79072805
LW
2334 break;
2335 case '|':
4b65379b 2336 {
8772537c 2337 IO * const io = GvIOp(PL_defoutgv);
720f287d
AB
2338 if(!io)
2339 break;
4b65379b
CS
2340 if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) == 0)
2341 IoFLAGS(io) &= ~IOf_FLUSH;
2342 else {
2343 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2344 PerlIO *ofp = IoOFP(io);
2345 if (ofp)
2346 (void)PerlIO_flush(ofp);
2347 IoFLAGS(io) |= IOf_FLUSH;
2348 }
2349 }
79072805
LW
2350 }
2351 break;
79072805 2352 case '/':
3280af22 2353 SvREFCNT_dec(PL_rs);
8bfdd7d9 2354 PL_rs = newSVsv(sv);
79072805
LW
2355 break;
2356 case '\\':
7889fe52
NIS
2357 if (PL_ors_sv)
2358 SvREFCNT_dec(PL_ors_sv);
009c130f 2359 if (SvOK(sv) || SvGMAGICAL(sv)) {
7889fe52 2360 PL_ors_sv = newSVsv(sv);
009c130f 2361 }
e3c19b7b 2362 else {
7889fe52 2363 PL_ors_sv = Nullsv;
e3c19b7b 2364 }
79072805
LW
2365 break;
2366 case ',':
7889fe52
NIS
2367 if (PL_ofs_sv)
2368 SvREFCNT_dec(PL_ofs_sv);
2369 if (SvOK(sv) || SvGMAGICAL(sv)) {
2370 PL_ofs_sv = newSVsv(sv);
2371 }
2372 else {
2373 PL_ofs_sv = Nullsv;
2374 }
79072805 2375 break;
79072805 2376 case '[':
3280af22 2377 PL_compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
79072805
LW
2378 break;
2379 case '?':
ff0cee69 2380#ifdef COMPLEX_STATUS
6b88bc9c
GS
2381 if (PL_localizing == 2) {
2382 PL_statusvalue = LvTARGOFF(sv);
2383 PL_statusvalue_vms = LvTARGLEN(sv);
ff0cee69
PP
2384 }
2385 else
2386#endif
2387#ifdef VMSISH_STATUS
2388 if (VMSISH_STATUS)
2389 STATUS_NATIVE_SET((U32)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)));
2390 else
2391#endif
e5218da5 2392 STATUS_UNIX_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
79072805
LW
2393 break;
2394 case '!':
93189314
JH
2395 {
2396#ifdef VMS
2397# define PERL_VMS_BANG vaxc$errno
2398#else
2399# define PERL_VMS_BANG 0
2400#endif
91487cfc 2401 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
93189314
JH
2402 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2403 }
79072805
LW
2404 break;
2405 case '<':
3280af22
NIS
2406 PL_uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2407 if (PL_delaymagic) {
2408 PL_delaymagic |= DM_RUID;
79072805
LW
2409 break; /* don't do magic till later */
2410 }
2411#ifdef HAS_SETRUID
b28d0864 2412 (void)setruid((Uid_t)PL_uid);
79072805
LW
2413#else
2414#ifdef HAS_SETREUID
3280af22 2415 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
748a9306 2416#else
85e6fe83 2417#ifdef HAS_SETRESUID
b28d0864 2418 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
79072805 2419#else
75870ed3 2420 if (PL_uid == PL_euid) { /* special case $< = $> */
2421#ifdef PERL_DARWIN
2422 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2423 if (PL_uid != 0 && PerlProc_getuid() == 0)
2424 (void)PerlProc_setuid(0);
2425#endif
b28d0864 2426 (void)PerlProc_setuid(PL_uid);
75870ed3 2427 } else {
d8eceb89 2428 PL_uid = PerlProc_getuid();
cea2e8a9 2429 Perl_croak(aTHX_ "setruid() not implemented");
a0d0e21e 2430 }
79072805
LW
2431#endif
2432#endif
85e6fe83 2433#endif
d8eceb89 2434 PL_uid = PerlProc_getuid();
3280af22 2435 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
79072805
LW
2436 break;
2437 case '>':
3280af22
NIS
2438 PL_euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2439 if (PL_delaymagic) {
2440 PL_delaymagic |= DM_EUID;
79072805
LW
2441 break; /* don't do magic till later */
2442 }
2443#ifdef HAS_SETEUID
3280af22 2444 (void)seteuid((Uid_t)PL_euid);
79072805
LW
2445#else
2446#ifdef HAS_SETREUID
b28d0864 2447 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
85e6fe83
LW
2448#else
2449#ifdef HAS_SETRESUID
6b88bc9c 2450 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
79072805 2451#else
b28d0864
NIS
2452 if (PL_euid == PL_uid) /* special case $> = $< */
2453 PerlProc_setuid(PL_euid);
a0d0e21e 2454 else {
e8ee3774 2455 PL_euid = PerlProc_geteuid();
cea2e8a9 2456 Perl_croak(aTHX_ "seteuid() not implemented");
a0d0e21e 2457 }
79072805
LW
2458#endif
2459#endif
85e6fe83 2460#endif
d8eceb89 2461 PL_euid = PerlProc_geteuid();
3280af22 2462 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
79072805
LW
2463 break;
2464 case '(':
3280af22
NIS
2465 PL_gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2466 if (PL_delaymagic) {
2467 PL_delaymagic |= DM_RGID;
79072805
LW
2468 break; /* don't do magic till later */
2469 }
2470#ifdef HAS_SETRGID
b28d0864 2471 (void)setrgid((Gid_t)PL_gid);
79072805
LW
2472#else
2473#ifdef HAS_SETREGID
3280af22 2474 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
85e6fe83
LW
2475#else
2476#ifdef HAS_SETRESGID
b28d0864 2477 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
79072805 2478#else
b28d0864
NIS
2479 if (PL_gid == PL_egid) /* special case $( = $) */
2480 (void)PerlProc_setgid(PL_gid);
748a9306 2481 else {
d8eceb89 2482 PL_gid = PerlProc_getgid();
cea2e8a9 2483 Perl_croak(aTHX_ "setrgid() not implemented");
748a9306 2484 }
79072805
LW
2485#endif
2486#endif
85e6fe83 2487#endif
d8eceb89 2488 PL_gid = PerlProc_getgid();
3280af22 2489 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
79072805
LW
2490 break;
2491 case ')':
5cd24f17
PP
2492#ifdef HAS_SETGROUPS
2493 {
b83604b4 2494 const char *p = SvPV_const(sv, len);
5cd24f17
PP
2495 Groups_t gary[NGROUPS];
2496
5cd24f17
PP
2497 while (isSPACE(*p))
2498 ++p;
2d4389e4 2499 PL_egid = Atol(p);
5cd24f17
PP
2500 for (i = 0; i < NGROUPS; ++i) {
2501 while (*p && !isSPACE(*p))
2502 ++p;
2503 while (isSPACE(*p))
2504 ++p;
2505 if (!*p)
2506 break;
2d4389e4 2507 gary[i] = Atol(p);
5cd24f17 2508 }
8cc95fdb
PP
2509 if (i)
2510 (void)setgroups(i, gary);
5cd24f17
PP
2511 }
2512#else /* HAS_SETGROUPS */
b28d0864 2513 PL_egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
5cd24f17 2514#endif /* HAS_SETGROUPS */
3280af22
NIS
2515 if (PL_delaymagic) {
2516 PL_delaymagic |= DM_EGID;
79072805
LW
2517 break; /* don't do magic till later */
2518 }
2519#ifdef HAS_SETEGID
3280af22 2520 (void)setegid((Gid_t)PL_egid);
79072805
LW
2521#else
2522#ifdef HAS_SETREGID
b28d0864 2523 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
85e6fe83
LW
2524#else
2525#ifdef HAS_SETRESGID
b28d0864 2526 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
79072805 2527#else
b28d0864
NIS
2528 if (PL_egid == PL_gid) /* special case $) = $( */
2529 (void)PerlProc_setgid(PL_egid);
748a9306 2530 else {
d8eceb89 2531 PL_egid = PerlProc_getegid();
cea2e8a9 2532 Perl_croak(aTHX_ "setegid() not implemented");
748a9306 2533 }
79072805
LW
2534#endif
2535#endif
85e6fe83 2536#endif
d8eceb89 2537 PL_egid = PerlProc_getegid();
3280af22 2538 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
79072805
LW
2539 break;
2540 case ':':
2d8e6c8d 2541 PL_chopset = SvPV_force(sv,len);
79072805 2542 break;
cd39f2b6 2543#ifndef MACOS_TRADITIONAL
79072805 2544 case '0':
e2975953 2545 LOCK_DOLLARZERO_MUTEX;
4bc88a62
PS
2546#ifdef HAS_SETPROCTITLE
2547 /* The BSDs don't show the argv[] in ps(1) output, they
2548 * show a string from the process struct and provide
2549 * the setproctitle() routine to manipulate that. */
2550 {
b83604b4 2551 s = SvPV_const(sv, len);
98b76f99 2552# if __FreeBSD_version > 410001
9aad2c0e 2553 /* The leading "-" removes the "perl: " prefix,
4bc88a62
PS
2554 * but not the "(perl) suffix from the ps(1)
2555 * output, because that's what ps(1) shows if the
2556 * argv[] is modified. */
6f2ad931 2557 setproctitle("-%s", s);
9aad2c0e 2558# else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
4bc88a62
PS
2559 /* This doesn't really work if you assume that
2560 * $0 = 'foobar'; will wipe out 'perl' from the $0
2561 * because in ps(1) output the result will be like
2562 * sprintf("perl: %s (perl)", s)
2563 * I guess this is a security feature:
2564 * one (a user process) cannot get rid of the original name.
2565 * --jhi */
2566 setproctitle("%s", s);
2567# endif
2568 }
2569#endif
17aa7f3d
JH
2570#if defined(__hpux) && defined(PSTAT_SETCMD)
2571 {
2572 union pstun un;
b83604b4 2573 s = SvPV_const(sv, len);
6867be6d 2574 un.pst_command = (char *)s;
17aa7f3d
JH
2575 pstat(PSTAT_SETCMD, un, len, 0, 0);
2576 }
2577#endif
3cb9023d 2578 /* PL_origalen is set in perl_parse(). */
a0d0e21e 2579 s = SvPV_force(sv,len);
6f698202
AMS
2580 if (len >= (STRLEN)PL_origalen-1) {
2581 /* Longer than original, will be truncated. We assume that
2582 * PL_origalen bytes are available. */
2583 Copy(s, PL_origargv[0], PL_origalen-1, char);
79072805
LW
2584 }
2585 else {
54bfe034
JH
2586 /* Shorter than original, will be padded. */
2587 Copy(s, PL_origargv[0], len, char);
2588 PL_origargv[0][len] = 0;
2589 memset(PL_origargv[0] + len + 1,
2590 /* Is the space counterintuitive? Yes.
2591 * (You were expecting \0?)
3cb9023d 2592 * Does it work? Seems to. (In Linux 2.4.20 at least.)
54bfe034
JH
2593 * --jhi */
2594 (int)' ',
2595 PL_origalen - len - 1);
79072805 2596 }
ad7eccf4
JD
2597 PL_origargv[0][PL_origalen-1] = 0;
2598 for (i = 1; i < PL_origargc; i++)
2599 PL_origargv[i] = 0;
e2975953 2600 UNLOCK_DOLLARZERO_MUTEX;
79072805 2601 break;
cd39f2b6 2602#endif
79072805
LW
2603 }
2604 return 0;
2605}
2606
2607I32
35a4481c 2608Perl_whichsig(pTHX_ const char *sig)
79072805 2609{
aadb217d 2610 register char* const* sigv;
79072805 2611
aadb217d 2612 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
79072805 2613 if (strEQ(sig,*sigv))
aadb217d 2614 return PL_sig_num[sigv - (char* const*)PL_sig_name];
79072805
LW
2615#ifdef SIGCLD
2616 if (strEQ(sig,"CHLD"))
2617 return SIGCLD;
2618#endif
2619#ifdef SIGCHLD
2620 if (strEQ(sig,"CLD"))
2621 return SIGCHLD;
2622#endif
7f1236c0 2623 return -1;
79072805
LW
2624}
2625
ecfc5424 2626Signal_t
1e82f5a6 2627#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
8aad04aa 2628Perl_sighandler(int sig, ...)
1e82f5a6
SH
2629#else
2630Perl_sighandler(int sig)
2631#endif
79072805 2632{
1018e26f
NIS
2633#ifdef PERL_GET_SIG_CONTEXT
2634 dTHXa(PERL_GET_SIG_CONTEXT);
71d280e3 2635#else
cea2e8a9 2636 dTHX;
71d280e3 2637#endif
79072805 2638 dSP;
00d579c5 2639 GV *gv = Nullgv;
8772537c
AL
2640 SV *sv = Nullsv;
2641 SV * const tSv = PL_Sv;
00d579c5 2642 CV *cv = Nullcv;
533c011a 2643 OP *myop = PL_op;
84902520 2644 U32 flags = 0;
8772537c 2645 XPV * const tXpv = PL_Xpv;
71d280e3 2646
3280af22 2647 if (PL_savestack_ix + 15 <= PL_savestack_max)
84902520 2648 flags |= 1;
3280af22 2649 if (PL_markstack_ptr < PL_markstack_max - 2)
84902520 2650 flags |= 4;
3280af22 2651 if (PL_scopestack_ix < PL_scopestack_max - 3)
84902520
TB
2652 flags |= 16;
2653
727405f8 2654 if (!PL_psig_ptr[sig]) {
99ef548b 2655 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
727405f8
NIS
2656 PL_sig_name[sig]);
2657 exit(sig);
2658 }
ff0cee69 2659
84902520
TB
2660 /* Max number of items pushed there is 3*n or 4. We cannot fix
2661 infinity, so we fix 4 (in fact 5): */
2662 if (flags & 1) {
3280af22 2663 PL_savestack_ix += 5; /* Protect save in progress. */
8772537c 2664 SAVEDESTRUCTOR_X(S_unwind_handler_stack, (void*)&flags);
84902520 2665 }
ac27b0f5 2666 if (flags & 4)
3280af22 2667 PL_markstack_ptr++; /* Protect mark. */
84902520 2668 if (flags & 16)
3280af22 2669 PL_scopestack_ix += 1;
84902520 2670 /* sv_2cv is too complicated, try a simpler variant first: */
ac27b0f5 2671 if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
8772537c
AL
2672 || SvTYPE(cv) != SVt_PVCV) {
2673 HV *st;
22c35a8c 2674 cv = sv_2cv(PL_psig_ptr[sig],&st,&gv,TRUE);
8772537c 2675 }
84902520 2676
a0d0e21e 2677 if (!cv || !CvROOT(cv)) {
599cee73 2678 if (ckWARN(WARN_SIGNAL))
9014280d 2679 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
22c35a8c 2680 PL_sig_name[sig], (gv ? GvENAME(gv)
00d579c5
GS
2681 : ((cv && CvGV(cv))
2682 ? GvENAME(CvGV(cv))
2683 : "__ANON__")));
2684 goto cleanup;
79072805
LW
2685 }
2686
22c35a8c
GS
2687 if(PL_psig_name[sig]) {
2688 sv = SvREFCNT_inc(PL_psig_name[sig]);
84902520 2689 flags |= 64;
df3728a2 2690#if !defined(PERL_IMPLICIT_CONTEXT)
27da23d5 2691 PL_sig_sv = sv;
df3728a2 2692#endif
84902520 2693 } else {
ff0cee69 2694 sv = sv_newmortal();
22c35a8c 2695 sv_setpv(sv,PL_sig_name[sig]);
88e89b8a 2696 }
e336de0d 2697
e788e7d3 2698 PUSHSTACKi(PERLSI_SIGNAL);
924508f0 2699 PUSHMARK(SP);
79072805 2700 PUSHs(sv);
8aad04aa
JH
2701#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2702 {
2703 struct sigaction oact;
2704
2705 if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
2706 siginfo_t *sip;
2707 va_list args;
2708
2709 va_start(args, sig);
2710 sip = (siginfo_t*)va_arg(args, siginfo_t*);
2711 if (sip) {
2712 HV *sih = newHV();
2713 SV *rv = newRV_noinc((SV*)sih);
2714 /* The siginfo fields signo, code, errno, pid, uid,
2715 * addr, status, and band are defined by POSIX/SUSv3. */
2716 hv_store(sih, "signo", 5, newSViv(sip->si_signo), 0);
2717 hv_store(sih, "code", 4, newSViv(sip->si_code), 0);
79dec0f4 2718#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 2719 hv_store(sih, "errno", 5, newSViv(sip->si_errno), 0);
79dec0f4 2720 hv_store(sih, "status", 6, newSViv(sip->si_status), 0);
8aad04aa
JH
2721 hv_store(sih, "uid", 3, newSViv(sip->si_uid), 0);
2722 hv_store(sih, "pid", 3, newSViv(sip->si_pid), 0);
2723 hv_store(sih, "addr", 4, newSVuv(PTR2UV(sip->si_addr)), 0);
8aad04aa 2724 hv_store(sih, "band", 4, newSViv(sip->si_band), 0);
79dec0f4 2725#endif
8aad04aa
JH
2726 EXTEND(SP, 2);
2727 PUSHs((SV*)rv);
2728 PUSHs(newSVpv((void*)sip, sizeof(*sip)));
2729 }
2730 }
2731 }
2732#endif
79072805 2733 PUTBACK;
a0d0e21e 2734
1b266415 2735 call_sv((SV*)cv, G_DISCARD|G_EVAL);
79072805 2736
d3acc0f7 2737 POPSTACK;
1b266415 2738 if (SvTRUE(ERRSV)) {
1d615522 2739#ifndef PERL_MICRO
983dbef6 2740#ifdef HAS_SIGPROCMASK
1b266415
NIS
2741 /* Handler "died", for example to get out of a restart-able read().
2742 * Before we re-do that on its behalf re-enable the signal which was
2743 * blocked by the system when we entered.
2744 */
2745 sigset_t set;
2746 sigemptyset(&set);
2747 sigaddset(&set,sig);
2748 sigprocmask(SIG_UNBLOCK, &set, NULL);
2749#else
2750 /* Not clear if this will work */
2751 (void)rsignal(sig, SIG_IGN);
5c1546dc 2752 (void)rsignal(sig, PL_csighandlerp);
1b266415 2753#endif
1d615522 2754#endif /* !PERL_MICRO */
c3bdd826 2755 Perl_die(aTHX_ Nullch);
1b266415 2756 }
00d579c5 2757cleanup:
84902520 2758 if (flags & 1)
3280af22 2759 PL_savestack_ix -= 8; /* Unprotect save in progress. */
ac27b0f5 2760 if (flags & 4)
3280af22 2761 PL_markstack_ptr--;
84902520 2762 if (flags & 16)
3280af22 2763 PL_scopestack_ix -= 1;
84902520
TB
2764 if (flags & 64)
2765 SvREFCNT_dec(sv);
533c011a 2766 PL_op = myop; /* Apparently not needed... */
ac27b0f5 2767
3280af22
NIS
2768 PL_Sv = tSv; /* Restore global temporaries. */
2769 PL_Xpv = tXpv;
53bb94e2 2770 return;
79072805 2771}
4e35701f
NIS
2772
2773
51371543 2774static void
8772537c 2775S_restore_magic(pTHX_ const void *p)
51371543 2776{
8772537c
AL
2777 MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
2778 SV* const sv = mgs->mgs_sv;
51371543
GS
2779
2780 if (!sv)
2781 return;
2782
2783 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2784 {
f8c7b90f 2785#ifdef PERL_OLD_COPY_ON_WRITE
f9701176
NC
2786 /* While magic was saved (and off) sv_setsv may well have seen
2787 this SV as a prime candidate for COW. */
2788 if (SvIsCOW(sv))
2789 sv_force_normal(sv);
2790#endif
2791
51371543
GS
2792 if (mgs->mgs_flags)
2793 SvFLAGS(sv) |= mgs->mgs_flags;
2794 else
2795 mg_magical(sv);
2796 if (SvGMAGICAL(sv))
2797 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
2798 }
2799
2800 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
2801
2802 /* If we're still on top of the stack, pop us off. (That condition
2803 * will be satisfied if restore_magic was called explicitly, but *not*
2804 * if it's being called via leave_scope.)
2805 * The reason for doing this is that otherwise, things like sv_2cv()
2806 * may leave alloc gunk on the savestack, and some code
2807 * (e.g. sighandler) doesn't expect that...
2808 */
2809 if (PL_savestack_ix == mgs->mgs_ss_ix)
2810 {
2811 I32 popval = SSPOPINT;
c76ac1ee 2812 assert(popval == SAVEt_DESTRUCTOR_X);
51371543
GS
2813 PL_savestack_ix -= 2;
2814 popval = SSPOPINT;
2815 assert(popval == SAVEt_ALLOC);
2816 popval = SSPOPINT;
2817 PL_savestack_ix -= popval;
2818 }
2819
2820}
2821
2822static void
8772537c 2823S_unwind_handler_stack(pTHX_ const void *p)
51371543 2824{
27da23d5 2825 dVAR;
e1ec3a88 2826 const U32 flags = *(const U32*)p;
51371543
GS
2827
2828 if (flags & 1)
2829 PL_savestack_ix -= 5; /* Unprotect save in progress. */
2830 /* cxstack_ix-- Not needed, die already unwound it. */
df3728a2 2831#if !defined(PERL_IMPLICIT_CONTEXT)
51371543 2832 if (flags & 64)
27da23d5 2833 SvREFCNT_dec(PL_sig_sv);
df3728a2 2834#endif
51371543 2835}
1018e26f 2836
66610fdd
RGS
2837/*
2838 * Local variables:
2839 * c-indentation-style: bsd
2840 * c-basic-offset: 4
2841 * indent-tabs-mode: t
2842 * End:
2843 *
37442d52
RGS
2844 * ex: set ts=8 sts=4 sw=4 noet:
2845 */