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