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