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