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