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