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