This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Re: futimes [PATCH]
[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{
a0fd4948 1124#if defined(VMS) || defined(EPOC)
cea2e8a9 1125 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
fb73857a 1126#else
3280af22 1127 if (PL_localizing) {
fb73857a
PP
1128 HE* entry;
1129 magic_clear_all_env(sv,mg);
1130 hv_iterinit((HV*)sv);
155aba94 1131 while ((entry = hv_iternext((HV*)sv))) {
fb73857a
PP
1132 I32 keylen;
1133 my_setenv(hv_iterkey(entry, &keylen),
b83604b4 1134 SvPV_nolen_const(hv_iterval((HV*)sv, entry)));
fb73857a
PP
1135 }
1136 }
1137#endif
1138 return 0;
1139}
1140
1141int
864dbfa3 1142Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
66b1d557 1143{
27da23d5 1144 dVAR;
2f42fcb0 1145#ifndef PERL_MICRO
a0fd4948 1146#if defined(VMS) || defined(EPOC)
cea2e8a9 1147 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
3e3baf6d 1148#else
4efc5df6 1149# if defined(PERL_IMPLICIT_SYS) || defined(WIN32)
7766f137 1150 PerlEnv_clearenv();
4efc5df6
GS
1151# else
1152# ifdef USE_ENVIRON_ARRAY
1153# if defined(USE_ITHREADS)
1154 /* only the parent thread can clobber the process environment */
1155 if (PL_curinterp == aTHX)
1156# endif
1157 {
1158# ifndef PERL_USE_SAFE_PUTENV
50acdf95 1159 if (!PL_use_safe_putenv) {
66b1d557
HM
1160 I32 i;
1161
3280af22 1162 if (environ == PL_origenviron)
f2517201 1163 environ = (char**)safesysmalloc(sizeof(char*));
66b1d557
HM
1164 else
1165 for (i = 0; environ[i]; i++)
f2517201 1166 safesysfree(environ[i]);
50acdf95 1167 }
4efc5df6 1168# endif /* PERL_USE_SAFE_PUTENV */
f2517201 1169
66b1d557 1170 environ[0] = Nullch;
4efc5df6
GS
1171 }
1172# endif /* USE_ENVIRON_ARRAY */
052c2dc6 1173# endif /* PERL_IMPLICIT_SYS || WIN32 */
2f42fcb0
JH
1174#endif /* VMS || EPOC */
1175#endif /* !PERL_MICRO */
8772537c
AL
1176 PERL_UNUSED_ARG(sv);
1177 PERL_UNUSED_ARG(mg);
3e3baf6d 1178 return 0;
66b1d557
HM
1179}
1180
64ca3a65 1181#ifndef PERL_MICRO
2d4fcd5e
AJ
1182#ifdef HAS_SIGPROCMASK
1183static void
1184restore_sigmask(pTHX_ SV *save_sv)
1185{
b83604b4 1186 const sigset_t *ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
2d4fcd5e
AJ
1187 (void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0);
1188}
1189#endif
66b1d557 1190int
864dbfa3 1191Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
88e89b8a 1192{
88e89b8a 1193 /* Are we fetching a signal entry? */
8772537c 1194 const I32 i = whichsig(MgPV_nolen_const(mg));
e02bfb16 1195 if (i > 0) {
22c35a8c
GS
1196 if(PL_psig_ptr[i])
1197 sv_setsv(sv,PL_psig_ptr[i]);
88e89b8a 1198 else {
85b332e2 1199 Sighandler_t sigstate;
2e34cc90 1200 sigstate = rsignal_state(i);
23ada85b 1201#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
27da23d5 1202 if (PL_sig_handlers_initted && PL_sig_ignoring[i]) sigstate = SIG_IGN;
2e34cc90
CL
1203#endif
1204#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
27da23d5 1205 if (PL_sig_handlers_initted && PL_sig_defaulting[i]) sigstate = SIG_DFL;
85b332e2 1206#endif
88e89b8a 1207 /* cache state so we don't fetch it again */
8aad04aa 1208 if(sigstate == (Sighandler_t) SIG_IGN)
88e89b8a
PP
1209 sv_setpv(sv,"IGNORE");
1210 else
3280af22 1211 sv_setsv(sv,&PL_sv_undef);
22c35a8c 1212 PL_psig_ptr[i] = SvREFCNT_inc(sv);
88e89b8a
PP
1213 SvTEMP_off(sv);
1214 }
1215 }
1216 return 0;
1217}
1218int
864dbfa3 1219Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
88e89b8a 1220{
2d4fcd5e
AJ
1221 /* XXX Some of this code was copied from Perl_magic_setsig. A little
1222 * refactoring might be in order.
1223 */
27da23d5 1224 dVAR;
8772537c
AL
1225 register const char * const s = MgPV_nolen_const(mg);
1226 PERL_UNUSED_ARG(sv);
2d4fcd5e 1227 if (*s == '_') {
27da23d5 1228 SV** svp = 0;
2d4fcd5e
AJ
1229 if (strEQ(s,"__DIE__"))
1230 svp = &PL_diehook;
1231 else if (strEQ(s,"__WARN__"))
1232 svp = &PL_warnhook;
1233 else
1234 Perl_croak(aTHX_ "No such hook: %s", s);
27da23d5 1235 if (svp && *svp) {
8772537c 1236 SV * const to_dec = *svp;
2d4fcd5e
AJ
1237 *svp = 0;
1238 SvREFCNT_dec(to_dec);
1239 }
1240 }
1241 else {
2d4fcd5e 1242 /* Are we clearing a signal entry? */
8772537c 1243 const I32 i = whichsig(s);
e02bfb16 1244 if (i > 0) {
2d4fcd5e
AJ
1245#ifdef HAS_SIGPROCMASK
1246 sigset_t set, save;
1247 SV* save_sv;
1248 /* Avoid having the signal arrive at a bad time, if possible. */
1249 sigemptyset(&set);
1250 sigaddset(&set,i);
1251 sigprocmask(SIG_BLOCK, &set, &save);
1252 ENTER;
1253 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1254 SAVEFREESV(save_sv);
1255 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1256#endif
1257 PERL_ASYNC_CHECK();
1258#if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
27da23d5 1259 if (!PL_sig_handlers_initted) Perl_csighandler_init();
2d4fcd5e
AJ
1260#endif
1261#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
27da23d5 1262 PL_sig_defaulting[i] = 1;
5c1546dc 1263 (void)rsignal(i, PL_csighandlerp);
2d4fcd5e 1264#else
8aad04aa 1265 (void)rsignal(i, (Sighandler_t) SIG_DFL);
2d4fcd5e
AJ
1266#endif
1267 if(PL_psig_name[i]) {
1268 SvREFCNT_dec(PL_psig_name[i]);
1269 PL_psig_name[i]=0;
1270 }
1271 if(PL_psig_ptr[i]) {
dd374669 1272 SV *to_dec=PL_psig_ptr[i];
2d4fcd5e
AJ
1273 PL_psig_ptr[i]=0;
1274 LEAVE;
1275 SvREFCNT_dec(to_dec);
1276 }
1277 else
1278 LEAVE;
1279 }
88e89b8a
PP
1280 }
1281 return 0;
1282}
3d37d572 1283
dd374669
AL
1284static void
1285S_raise_signal(pTHX_ int sig)
0a8e0eff
NIS
1286{
1287 /* Set a flag to say this signal is pending */
1288 PL_psig_pend[sig]++;
1289 /* And one to say _a_ signal is pending */
1290 PL_sig_pending = 1;
1291}
1292
1293Signal_t
8aad04aa
JH
1294#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1295Perl_csighandler(int sig, ...)
1296#else
0a8e0eff 1297Perl_csighandler(int sig)
8aad04aa 1298#endif
0a8e0eff 1299{
1018e26f
NIS
1300#ifdef PERL_GET_SIG_CONTEXT
1301 dTHXa(PERL_GET_SIG_CONTEXT);
1302#else
85b332e2
CL
1303 dTHX;
1304#endif
23ada85b 1305#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
5c1546dc 1306 (void) rsignal(sig, PL_csighandlerp);
27da23d5 1307 if (PL_sig_ignoring[sig]) return;
85b332e2 1308#endif
2e34cc90 1309#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
27da23d5 1310 if (PL_sig_defaulting[sig])
2e34cc90
CL
1311#ifdef KILL_BY_SIGPRC
1312 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1313#else
1314 exit(1);
1315#endif
1316#endif
4ffa73a3
JH
1317 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
1318 /* Call the perl level handler now--
1319 * with risk we may be in malloc() etc. */
1320 (*PL_sighandlerp)(sig);
1321 else
dd374669 1322 S_raise_signal(aTHX_ sig);
0a8e0eff
NIS
1323}
1324
2e34cc90
CL
1325#if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1326void
1327Perl_csighandler_init(void)
1328{
1329 int sig;
27da23d5 1330 if (PL_sig_handlers_initted) return;
2e34cc90
CL
1331
1332 for (sig = 1; sig < SIG_SIZE; sig++) {
1333#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
218fdd94 1334 dTHX;
27da23d5 1335 PL_sig_defaulting[sig] = 1;
5c1546dc 1336 (void) rsignal(sig, PL_csighandlerp);
2e34cc90
CL
1337#endif
1338#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
27da23d5 1339 PL_sig_ignoring[sig] = 0;
2e34cc90
CL
1340#endif
1341 }
27da23d5 1342 PL_sig_handlers_initted = 1;
2e34cc90
CL
1343}
1344#endif
1345
0a8e0eff
NIS
1346void
1347Perl_despatch_signals(pTHX)
1348{
1349 int sig;
1350 PL_sig_pending = 0;
1351 for (sig = 1; sig < SIG_SIZE; sig++) {
1352 if (PL_psig_pend[sig]) {
25da4428
JH
1353 PERL_BLOCKSIG_ADD(set, sig);
1354 PL_psig_pend[sig] = 0;
1355 PERL_BLOCKSIG_BLOCK(set);
f5203343 1356 (*PL_sighandlerp)(sig);
25da4428 1357 PERL_BLOCKSIG_UNBLOCK(set);
0a8e0eff
NIS
1358 }
1359 }
1360}
1361
85e6fe83 1362int
864dbfa3 1363Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
79072805 1364{
27da23d5 1365 dVAR;
79072805 1366 I32 i;
b7953727 1367 SV** svp = 0;
2d4fcd5e
AJ
1368 /* Need to be careful with SvREFCNT_dec(), because that can have side
1369 * effects (due to closures). We must make sure that the new disposition
1370 * is in place before it is called.
1371 */
1372 SV* to_dec = 0;
e72dc28c 1373 STRLEN len;
2d4fcd5e
AJ
1374#ifdef HAS_SIGPROCMASK
1375 sigset_t set, save;
1376 SV* save_sv;
1377#endif
a0d0e21e 1378
d5263905 1379 register const char *s = MgPV_const(mg,len);
748a9306
LW
1380 if (*s == '_') {
1381 if (strEQ(s,"__DIE__"))
3280af22 1382 svp = &PL_diehook;
748a9306 1383 else if (strEQ(s,"__WARN__"))
3280af22 1384 svp = &PL_warnhook;
748a9306 1385 else
cea2e8a9 1386 Perl_croak(aTHX_ "No such hook: %s", s);
748a9306 1387 i = 0;
4633a7c4 1388 if (*svp) {
2d4fcd5e 1389 to_dec = *svp;
4633a7c4
LW
1390 *svp = 0;
1391 }
748a9306
LW
1392 }
1393 else {
1394 i = whichsig(s); /* ...no, a brick */
86d86cad 1395 if (i <= 0) {
e476b1b5 1396 if (ckWARN(WARN_SIGNAL))
9014280d 1397 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
748a9306
LW
1398 return 0;
1399 }
2d4fcd5e
AJ
1400#ifdef HAS_SIGPROCMASK
1401 /* Avoid having the signal arrive at a bad time, if possible. */
1402 sigemptyset(&set);
1403 sigaddset(&set,i);
1404 sigprocmask(SIG_BLOCK, &set, &save);
1405 ENTER;
1406 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1407 SAVEFREESV(save_sv);
1408 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1409#endif
1410 PERL_ASYNC_CHECK();
2e34cc90 1411#if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
27da23d5 1412 if (!PL_sig_handlers_initted) Perl_csighandler_init();
2e34cc90 1413#endif
23ada85b 1414#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
27da23d5 1415 PL_sig_ignoring[i] = 0;
85b332e2 1416#endif
2e34cc90 1417#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
27da23d5 1418 PL_sig_defaulting[i] = 0;
2e34cc90 1419#endif
22c35a8c 1420 SvREFCNT_dec(PL_psig_name[i]);
2d4fcd5e 1421 to_dec = PL_psig_ptr[i];
22c35a8c 1422 PL_psig_ptr[i] = SvREFCNT_inc(sv);
88e89b8a 1423 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
e72dc28c 1424 PL_psig_name[i] = newSVpvn(s, len);
22c35a8c 1425 SvREADONLY_on(PL_psig_name[i]);
748a9306 1426 }
a0d0e21e 1427 if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
2d4fcd5e 1428 if (i) {
5c1546dc 1429 (void)rsignal(i, PL_csighandlerp);
2d4fcd5e
AJ
1430#ifdef HAS_SIGPROCMASK
1431 LEAVE;
1432#endif
1433 }
748a9306
LW
1434 else
1435 *svp = SvREFCNT_inc(sv);
2d4fcd5e
AJ
1436 if(to_dec)
1437 SvREFCNT_dec(to_dec);
a0d0e21e
LW
1438 return 0;
1439 }
e72dc28c 1440 s = SvPV_force(sv,len);
748a9306 1441 if (strEQ(s,"IGNORE")) {
85b332e2 1442 if (i) {
23ada85b 1443#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
27da23d5 1444 PL_sig_ignoring[i] = 1;
5c1546dc 1445 (void)rsignal(i, PL_csighandlerp);
85b332e2 1446#else
8aad04aa 1447 (void)rsignal(i, (Sighandler_t) SIG_IGN);
85b332e2 1448#endif
2d4fcd5e 1449 }
748a9306
LW
1450 }
1451 else if (strEQ(s,"DEFAULT") || !*s) {
1452 if (i)
2e34cc90
CL
1453#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1454 {
27da23d5 1455 PL_sig_defaulting[i] = 1;
5c1546dc 1456 (void)rsignal(i, PL_csighandlerp);
2e34cc90
CL
1457 }
1458#else
8aad04aa 1459 (void)rsignal(i, (Sighandler_t) SIG_DFL);
2e34cc90 1460#endif
748a9306 1461 }
79072805 1462 else {
5aabfad6
PP
1463 /*
1464 * We should warn if HINT_STRICT_REFS, but without
1465 * access to a known hint bit in a known OP, we can't
1466 * tell whether HINT_STRICT_REFS is in force or not.
1467 */
46fc3d4c 1468 if (!strchr(s,':') && !strchr(s,'\''))
e72dc28c 1469 sv_insert(sv, 0, 0, "main::", 6);
748a9306 1470 if (i)
5c1546dc 1471 (void)rsignal(i, PL_csighandlerp);
748a9306
LW
1472 else
1473 *svp = SvREFCNT_inc(sv);
79072805 1474 }
2d4fcd5e
AJ
1475#ifdef HAS_SIGPROCMASK
1476 if(i)
1477 LEAVE;
1478#endif
1479 if(to_dec)
1480 SvREFCNT_dec(to_dec);
79072805
LW
1481 return 0;
1482}
64ca3a65 1483#endif /* !PERL_MICRO */
79072805
LW
1484
1485int
864dbfa3 1486Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
79072805 1487{
8772537c
AL
1488 PERL_UNUSED_ARG(sv);
1489 PERL_UNUSED_ARG(mg);
3280af22 1490 PL_sub_generation++;
463ee0b2
LW
1491 return 0;
1492}
1493
1494int
864dbfa3 1495Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
463ee0b2 1496{
8772537c
AL
1497 PERL_UNUSED_ARG(sv);
1498 PERL_UNUSED_ARG(mg);
a0d0e21e 1499 /* HV_badAMAGIC_on(Sv_STASH(sv)); */
3280af22 1500 PL_amagic_generation++;
463ee0b2 1501
a0d0e21e
LW
1502 return 0;
1503}
463ee0b2 1504
946ec16e 1505int
864dbfa3 1506Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
6ff81951 1507{
dd374669 1508 HV * const hv = (HV*)LvTARG(sv);
6ff81951 1509 I32 i = 0;
8772537c 1510 PERL_UNUSED_ARG(mg);
7719e241 1511
6ff81951 1512 if (hv) {
497b47a8
JH
1513 (void) hv_iterinit(hv);
1514 if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
1515 i = HvKEYS(hv);
1516 else {
1517 while (hv_iternext(hv))
1518 i++;
1519 }
6ff81951
GS
1520 }
1521
1522 sv_setiv(sv, (IV)i);
1523 return 0;
1524}
1525
1526int
864dbfa3 1527Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
946ec16e 1528{
8772537c 1529 PERL_UNUSED_ARG(mg);
946ec16e
PP
1530 if (LvTARG(sv)) {
1531 hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
946ec16e
PP
1532 }
1533 return 0;
ac27b0f5 1534}
946ec16e 1535
e336de0d 1536/* caller is responsible for stack switching/cleanup */
565764a8 1537STATIC int
e1ec3a88 1538S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV *val)
a0d0e21e
LW
1539{
1540 dSP;
463ee0b2 1541
924508f0
GS
1542 PUSHMARK(SP);
1543 EXTEND(SP, n);
33c27489 1544 PUSHs(SvTIED_obj(sv, mg));
ac27b0f5 1545 if (n > 1) {
93965878 1546 if (mg->mg_ptr) {
565764a8 1547 if (mg->mg_len >= 0)
79cb57f6 1548 PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len)));
565764a8 1549 else if (mg->mg_len == HEf_SVKEY)
93965878
NIS
1550 PUSHs((SV*)mg->mg_ptr);
1551 }
14befaf4 1552 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
565764a8 1553 PUSHs(sv_2mortal(newSViv(mg->mg_len)));
93965878
NIS
1554 }
1555 }
1556 if (n > 2) {
1557 PUSHs(val);
88e89b8a 1558 }
463ee0b2
LW
1559 PUTBACK;
1560
864dbfa3 1561 return call_method(meth, flags);
946ec16e
PP
1562}
1563
76e3520e 1564STATIC int
e1ec3a88 1565S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
a0d0e21e 1566{
27da23d5 1567 dVAR; dSP;
463ee0b2 1568
a0d0e21e
LW
1569 ENTER;
1570 SAVETMPS;
e788e7d3 1571 PUSHSTACKi(PERLSI_MAGIC);
463ee0b2 1572
33c27489 1573 if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
3280af22 1574 sv_setsv(sv, *PL_stack_sp--);
93965878 1575 }
463ee0b2 1576
d3acc0f7 1577 POPSTACK;
a0d0e21e
LW
1578 FREETMPS;
1579 LEAVE;
1580 return 0;
1581}
463ee0b2 1582
a0d0e21e 1583int
864dbfa3 1584Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e 1585{
a0d0e21e
LW
1586 if (mg->mg_ptr)
1587 mg->mg_flags |= MGf_GSKIP;
58f82c5c 1588 magic_methpack(sv,mg,"FETCH");
463ee0b2
LW
1589 return 0;
1590}
1591
1592int
864dbfa3 1593Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
e336de0d 1594{
27da23d5 1595 dVAR; dSP;
a60c0954 1596 ENTER;
e788e7d3 1597 PUSHSTACKi(PERLSI_MAGIC);
33c27489 1598 magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
d3acc0f7 1599 POPSTACK;
a60c0954 1600 LEAVE;
463ee0b2
LW
1601 return 0;
1602}
1603
1604int
864dbfa3 1605Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
463ee0b2 1606{
a0d0e21e
LW
1607 return magic_methpack(sv,mg,"DELETE");
1608}
463ee0b2 1609
93965878
NIS
1610
1611U32
864dbfa3 1612Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
ac27b0f5 1613{
27da23d5 1614 dVAR; dSP;
93965878
NIS
1615 U32 retval = 0;
1616
1617 ENTER;
1618 SAVETMPS;
e788e7d3 1619 PUSHSTACKi(PERLSI_MAGIC);
33c27489 1620 if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
3280af22 1621 sv = *PL_stack_sp--;
a60c0954 1622 retval = (U32) SvIV(sv)-1;
93965878 1623 }
d3acc0f7 1624 POPSTACK;
93965878
NIS
1625 FREETMPS;
1626 LEAVE;
1627 return retval;
1628}
1629
cea2e8a9
GS
1630int
1631Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e 1632{
27da23d5 1633 dVAR; dSP;
463ee0b2 1634
e336de0d 1635 ENTER;
e788e7d3 1636 PUSHSTACKi(PERLSI_MAGIC);
924508f0 1637 PUSHMARK(SP);
33c27489 1638 XPUSHs(SvTIED_obj(sv, mg));
463ee0b2 1639 PUTBACK;
864dbfa3 1640 call_method("CLEAR", G_SCALAR|G_DISCARD);
d3acc0f7 1641 POPSTACK;
a60c0954 1642 LEAVE;
a3bcc51e 1643
463ee0b2
LW
1644 return 0;
1645}
1646
1647int
864dbfa3 1648Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
463ee0b2 1649{
27da23d5 1650 dVAR; dSP;
35a4481c 1651 const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
463ee0b2
LW
1652
1653 ENTER;
a0d0e21e 1654 SAVETMPS;
e788e7d3 1655 PUSHSTACKi(PERLSI_MAGIC);
924508f0
GS
1656 PUSHMARK(SP);
1657 EXTEND(SP, 2);
33c27489 1658 PUSHs(SvTIED_obj(sv, mg));
463ee0b2
LW
1659 if (SvOK(key))
1660 PUSHs(key);
1661 PUTBACK;
1662
864dbfa3 1663 if (call_method(meth, G_SCALAR))
3280af22 1664 sv_setsv(key, *PL_stack_sp--);
463ee0b2 1665
d3acc0f7 1666 POPSTACK;
a0d0e21e
LW
1667 FREETMPS;
1668 LEAVE;
79072805
LW
1669 return 0;
1670}
1671
1672int
864dbfa3 1673Perl_magic_existspack(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e
LW
1674{
1675 return magic_methpack(sv,mg,"EXISTS");
ac27b0f5 1676}
a0d0e21e 1677
a3bcc51e
TP
1678SV *
1679Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1680{
27da23d5 1681 dVAR; dSP;
a3bcc51e 1682 SV *retval = &PL_sv_undef;
8772537c
AL
1683 SV * const tied = SvTIED_obj((SV*)hv, mg);
1684 HV * const pkg = SvSTASH((SV*)SvRV(tied));
a3bcc51e
TP
1685
1686 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1687 SV *key;
bfcb3514 1688 if (HvEITER_get(hv))
a3bcc51e
TP
1689 /* we are in an iteration so the hash cannot be empty */
1690 return &PL_sv_yes;
1691 /* no xhv_eiter so now use FIRSTKEY */
1692 key = sv_newmortal();
1693 magic_nextpack((SV*)hv, mg, key);
bfcb3514 1694 HvEITER_set(hv, NULL); /* need to reset iterator */
a3bcc51e
TP
1695 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1696 }
1697
1698 /* there is a SCALAR method that we can call */
1699 ENTER;
1700 PUSHSTACKi(PERLSI_MAGIC);
1701 PUSHMARK(SP);
1702 EXTEND(SP, 1);
1703 PUSHs(tied);
1704 PUTBACK;
1705
1706 if (call_method("SCALAR", G_SCALAR))
1707 retval = *PL_stack_sp--;
1708 POPSTACK;
1709 LEAVE;
1710 return retval;
1711}
1712
a0d0e21e 1713int
864dbfa3 1714Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
79072805 1715{
8772537c
AL
1716 GV * const gv = PL_DBline;
1717 const I32 i = SvTRUE(sv);
1718 SV ** const svp = av_fetch(GvAV(gv),
01b8bcb7 1719 atoi(MgPV_nolen_const(mg)), FALSE);
8772537c
AL
1720 if (svp && SvIOKp(*svp)) {
1721 OP * const o = INT2PTR(OP*,SvIVX(*svp));
1722 if (o) {
1723 /* set or clear breakpoint in the relevant control op */
1724 if (i)
1725 o->op_flags |= OPf_SPECIAL;
1726 else
1727 o->op_flags &= ~OPf_SPECIAL;
1728 }
5df8de69 1729 }
79072805
LW
1730 return 0;
1731}
1732
1733int
8772537c 1734Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
79072805 1735{
8772537c 1736 const AV * const obj = (AV*)mg->mg_obj;
83bf042f
NC
1737 if (obj) {
1738 sv_setiv(sv, AvFILL(obj) + PL_curcop->cop_arybase);
1739 } else {
1740 SvOK_off(sv);
1741 }
79072805
LW
1742 return 0;
1743}
1744
1745int
864dbfa3 1746Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
79072805 1747{
8772537c 1748 AV * const obj = (AV*)mg->mg_obj;
83bf042f
NC
1749 if (obj) {
1750 av_fill(obj, SvIV(sv) - PL_curcop->cop_arybase);
1751 } else {
1752 if (ckWARN(WARN_MISC))
1753 Perl_warner(aTHX_ packWARN(WARN_MISC),
1754 "Attempt to set length of freed array");
1755 }
1756 return 0;
1757}
1758
1759int
1760Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
1761{
53c1dcc0 1762 PERL_UNUSED_ARG(sv);
94f3782b
DM
1763 /* during global destruction, mg_obj may already have been freed */
1764 if (PL_in_clean_all)
1ea47f64 1765 return 0;
94f3782b 1766
83bf042f
NC
1767 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
1768
1769 if (mg) {
1770 /* arylen scalar holds a pointer back to the array, but doesn't own a
1771 reference. Hence the we (the array) are about to go away with it
1772 still pointing at us. Clear its pointer, else it would be pointing
1773 at free memory. See the comment in sv_magic about reference loops,
1774 and why it can't own a reference to us. */
1775 mg->mg_obj = 0;
1776 }
a0d0e21e
LW
1777 return 0;
1778}
1779
1780int
864dbfa3 1781Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e 1782{
8772537c 1783 SV* const lsv = LvTARG(sv);
ac27b0f5 1784
a0d0e21e 1785 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
14befaf4 1786 mg = mg_find(lsv, PERL_MAGIC_regex_global);
565764a8 1787 if (mg && mg->mg_len >= 0) {
a0ed51b3 1788 I32 i = mg->mg_len;
7e2040f0 1789 if (DO_UTF8(lsv))
a0ed51b3
LW
1790 sv_pos_b2u(lsv, &i);
1791 sv_setiv(sv, i + PL_curcop->cop_arybase);
a0d0e21e
LW
1792 return 0;
1793 }
1794 }
0c34ef67 1795 SvOK_off(sv);
a0d0e21e
LW
1796 return 0;
1797}
1798
1799int
864dbfa3 1800Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e 1801{
8772537c 1802 SV* const lsv = LvTARG(sv);
a0d0e21e
LW
1803 SSize_t pos;
1804 STRLEN len;
c00206c8 1805 STRLEN ulen = 0;
a0d0e21e
LW
1806
1807 mg = 0;
ac27b0f5 1808
a0d0e21e 1809 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
14befaf4 1810 mg = mg_find(lsv, PERL_MAGIC_regex_global);
a0d0e21e
LW
1811 if (!mg) {
1812 if (!SvOK(sv))
1813 return 0;
14befaf4
DM
1814 sv_magic(lsv, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1815 mg = mg_find(lsv, PERL_MAGIC_regex_global);
a0d0e21e
LW
1816 }
1817 else if (!SvOK(sv)) {
565764a8 1818 mg->mg_len = -1;
a0d0e21e
LW
1819 return 0;
1820 }
1821 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1822
c485e607 1823 pos = SvIV(sv) - PL_curcop->cop_arybase;
a0ed51b3 1824
7e2040f0 1825 if (DO_UTF8(lsv)) {
a0ed51b3
LW
1826 ulen = sv_len_utf8(lsv);
1827 if (ulen)
1828 len = ulen;
a0ed51b3
LW
1829 }
1830
a0d0e21e
LW
1831 if (pos < 0) {
1832 pos += len;
1833 if (pos < 0)
1834 pos = 0;
1835 }
eb160463 1836 else if (pos > (SSize_t)len)
a0d0e21e 1837 pos = len;
a0ed51b3
LW
1838
1839 if (ulen) {
1840 I32 p = pos;
1841 sv_pos_u2b(lsv, &p, 0);
1842 pos = p;
1843 }
727405f8 1844
565764a8 1845 mg->mg_len = pos;
71be2cbc 1846 mg->mg_flags &= ~MGf_MINMATCH;
a0d0e21e 1847
79072805
LW
1848 return 0;
1849}
1850
1851int
864dbfa3 1852Perl_magic_getglob(pTHX_ SV *sv, MAGIC *mg)
79072805 1853{
8772537c 1854 PERL_UNUSED_ARG(mg);
8646b087
PP
1855 if (SvFAKE(sv)) { /* FAKE globs can get coerced */
1856 SvFAKE_off(sv);
946ec16e 1857 gv_efullname3(sv,((GV*)sv), "*");
8646b087
PP
1858 SvFAKE_on(sv);
1859 }
1860 else
946ec16e 1861 gv_efullname3(sv,((GV*)sv), "*"); /* a gv value, be nice */
79072805
LW
1862 return 0;
1863}
1864
1865int
864dbfa3 1866Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg)
79072805 1867{
79072805 1868 GV* gv;
8772537c
AL
1869 PERL_UNUSED_ARG(mg);
1870
79072805
LW
1871 if (!SvOK(sv))
1872 return 0;
7a5fd60d 1873 gv = gv_fetchsv(sv,TRUE, SVt_PVGV);
79072805
LW
1874 if (sv == (SV*)gv)
1875 return 0;
1876 if (GvGP(sv))
88e89b8a 1877 gp_free((GV*)sv);
79072805 1878 GvGP(sv) = gp_ref(GvGP(gv));
79072805
LW
1879 return 0;
1880}
1881
1882int
864dbfa3 1883Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
6ff81951
GS
1884{
1885 STRLEN len;
35a4481c 1886 SV * const lsv = LvTARG(sv);
b83604b4 1887 const char * const tmps = SvPV_const(lsv,len);
6ff81951
GS
1888 I32 offs = LvTARGOFF(sv);
1889 I32 rem = LvTARGLEN(sv);
8772537c 1890 PERL_UNUSED_ARG(mg);
6ff81951 1891
9aa983d2
JH
1892 if (SvUTF8(lsv))
1893 sv_pos_u2b(lsv, &offs, &rem);
eb160463 1894 if (offs > (I32)len)
6ff81951 1895 offs = len;
eb160463 1896 if (rem + offs > (I32)len)
6ff81951
GS
1897 rem = len - offs;
1898 sv_setpvn(sv, tmps + offs, (STRLEN)rem);
9aa983d2 1899 if (SvUTF8(lsv))
2ef4b674 1900 SvUTF8_on(sv);
6ff81951
GS
1901 return 0;
1902}
1903
1904int
864dbfa3 1905Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
79072805 1906{
9aa983d2 1907 STRLEN len;
b83604b4 1908 const char *tmps = SvPV_const(sv, len);
dd374669 1909 SV * const lsv = LvTARG(sv);
9aa983d2
JH
1910 I32 lvoff = LvTARGOFF(sv);
1911 I32 lvlen = LvTARGLEN(sv);
8772537c 1912 PERL_UNUSED_ARG(mg);
075a4a2b 1913
1aa99e6b 1914 if (DO_UTF8(sv)) {
9aa983d2
JH
1915 sv_utf8_upgrade(lsv);
1916 sv_pos_u2b(lsv, &lvoff, &lvlen);
1917 sv_insert(lsv, lvoff, lvlen, tmps, len);
b76f3ce2 1918 LvTARGLEN(sv) = sv_len_utf8(sv);
9aa983d2
JH
1919 SvUTF8_on(lsv);
1920 }
9bf12eaf 1921 else if (lsv && SvUTF8(lsv)) {
9aa983d2 1922 sv_pos_u2b(lsv, &lvoff, &lvlen);
b76f3ce2 1923 LvTARGLEN(sv) = len;
e95af362 1924 tmps = (char*)bytes_to_utf8((U8*)tmps, &len);
9aa983d2
JH
1925 sv_insert(lsv, lvoff, lvlen, tmps, len);
1926 Safefree(tmps);
1aa99e6b 1927 }
b76f3ce2
GB
1928 else {
1929 sv_insert(lsv, lvoff, lvlen, tmps, len);
1930 LvTARGLEN(sv) = len;
1931 }
1932
1aa99e6b 1933
79072805
LW
1934 return 0;
1935}
1936
1937int
864dbfa3 1938Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
463ee0b2 1939{
8772537c 1940 PERL_UNUSED_ARG(sv);
27cc343c 1941 TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
463ee0b2
LW
1942 return 0;
1943}
1944
1945int
864dbfa3 1946Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
463ee0b2 1947{
8772537c 1948 PERL_UNUSED_ARG(sv);
0a9c116b
DM
1949 /* update taint status unless we're restoring at scope exit */
1950 if (PL_localizing != 2) {
1951 if (PL_tainted)
1952 mg->mg_len |= 1;
1953 else
1954 mg->mg_len &= ~1;
1955 }
463ee0b2
LW
1956 return 0;
1957}
1958
1959int
864dbfa3 1960Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
6ff81951 1961{
35a4481c 1962 SV * const lsv = LvTARG(sv);
8772537c 1963 PERL_UNUSED_ARG(mg);
6ff81951
GS
1964
1965 if (!lsv) {
0c34ef67 1966 SvOK_off(sv);
6ff81951
GS
1967 return 0;
1968 }
6ff81951 1969
81e118e0 1970 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
6ff81951
GS
1971 return 0;
1972}
1973
1974int
864dbfa3 1975Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
79072805 1976{
8772537c 1977 PERL_UNUSED_ARG(mg);
79072805
LW
1978 do_vecset(sv); /* XXX slurp this routine */
1979 return 0;
1980}
1981
1982int
864dbfa3 1983Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
5f05dabc 1984{
71be2cbc 1985 SV *targ = Nullsv;
5f05dabc 1986 if (LvTARGLEN(sv)) {
68dc0745 1987 if (mg->mg_obj) {
8772537c
AL
1988 SV * const ahv = LvTARG(sv);
1989 HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
6d822dc4
MS
1990 if (he)
1991 targ = HeVAL(he);
68dc0745
PP
1992 }
1993 else {
8772537c 1994 AV* const av = (AV*)LvTARG(sv);
68dc0745
PP
1995 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
1996 targ = AvARRAY(av)[LvTARGOFF(sv)];
1997 }
3280af22 1998 if (targ && targ != &PL_sv_undef) {
68dc0745
PP
1999 /* somebody else defined it for us */
2000 SvREFCNT_dec(LvTARG(sv));
2001 LvTARG(sv) = SvREFCNT_inc(targ);
2002 LvTARGLEN(sv) = 0;
2003 SvREFCNT_dec(mg->mg_obj);
2004 mg->mg_obj = Nullsv;
2005 mg->mg_flags &= ~MGf_REFCOUNTED;
2006 }
5f05dabc 2007 }
71be2cbc
PP
2008 else
2009 targ = LvTARG(sv);
3280af22 2010 sv_setsv(sv, targ ? targ : &PL_sv_undef);
71be2cbc
PP
2011 return 0;
2012}
2013
2014int
864dbfa3 2015Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
71be2cbc 2016{
8772537c 2017 PERL_UNUSED_ARG(mg);
71be2cbc 2018 if (LvTARGLEN(sv))
68dc0745
PP
2019 vivify_defelem(sv);
2020 if (LvTARG(sv)) {
5f05dabc 2021 sv_setsv(LvTARG(sv), sv);
68dc0745
PP
2022 SvSETMAGIC(LvTARG(sv));
2023 }
5f05dabc
PP
2024 return 0;
2025}
2026
71be2cbc 2027void
864dbfa3 2028Perl_vivify_defelem(pTHX_ SV *sv)
71be2cbc 2029{
74e13ce4
GS
2030 MAGIC *mg;
2031 SV *value = Nullsv;
71be2cbc 2032
14befaf4 2033 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
71be2cbc 2034 return;
68dc0745 2035 if (mg->mg_obj) {
8772537c
AL
2036 SV * const ahv = LvTARG(sv);
2037 HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
6d822dc4
MS
2038 if (he)
2039 value = HeVAL(he);
3280af22 2040 if (!value || value == &PL_sv_undef)
ce5030a2 2041 Perl_croak(aTHX_ PL_no_helem_sv, mg->mg_obj);
71be2cbc 2042 }
68dc0745 2043 else {
8772537c 2044 AV* const av = (AV*)LvTARG(sv);
5aabfad6 2045 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
68dc0745
PP
2046 LvTARG(sv) = Nullsv; /* array can't be extended */
2047 else {
aec46f14 2048 SV** const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
3280af22 2049 if (!svp || (value = *svp) == &PL_sv_undef)
cea2e8a9 2050 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
68dc0745
PP
2051 }
2052 }
3e3baf6d 2053 (void)SvREFCNT_inc(value);
68dc0745
PP
2054 SvREFCNT_dec(LvTARG(sv));
2055 LvTARG(sv) = value;
71be2cbc 2056 LvTARGLEN(sv) = 0;
68dc0745
PP
2057 SvREFCNT_dec(mg->mg_obj);
2058 mg->mg_obj = Nullsv;
2059 mg->mg_flags &= ~MGf_REFCOUNTED;
5f05dabc
PP
2060}
2061
2062int
864dbfa3 2063Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
810b8aa5 2064{
e15faf7d
NC
2065 AV *const av = (AV*)mg->mg_obj;
2066 SV **svp = AvARRAY(av);
8772537c 2067 PERL_UNUSED_ARG(sv);
dd374669 2068
e15faf7d
NC
2069 if (svp) {
2070 SV *const *const last = svp + AvFILLp(av);
2071
2072 while (svp <= last) {
2073 if (*svp) {
2074 SV *const referrer = *svp;
2075 if (SvWEAKREF(referrer)) {
2076 /* XXX Should we check that it hasn't changed? */
2077 SvRV_set(referrer, 0);
2078 SvOK_off(referrer);
2079 SvWEAKREF_off(referrer);
2080 } else if (SvTYPE(referrer) == SVt_PVGV ||
2081 SvTYPE(referrer) == SVt_PVLV) {
2082 /* You lookin' at me? */
2083 assert(GvSTASH(referrer));
2084 assert(GvSTASH(referrer) == (HV*)sv);
2085 GvSTASH(referrer) = 0;
2086 } else {
2087 Perl_croak(aTHX_
2088 "panic: magic_killbackrefs (flags=%"UVxf")",
e91e3b10 2089 (UV)SvFLAGS(referrer));
e15faf7d
NC
2090 }
2091
2092 *svp = Nullsv;
2093 }
2094 svp++;
810b8aa5 2095 }
810b8aa5 2096 }
d99b02a1 2097 SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */
810b8aa5
GS
2098 return 0;
2099}
2100
2101int
864dbfa3 2102Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
93a17b20 2103{
565764a8 2104 mg->mg_len = -1;
c6496cc7 2105 SvSCREAM_off(sv);
93a17b20
LW
2106 return 0;
2107}
2108
2109int
864dbfa3 2110Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
79072805 2111{
8772537c 2112 PERL_UNUSED_ARG(mg);
14befaf4 2113 sv_unmagic(sv, PERL_MAGIC_bm);
79072805
LW
2114 SvVALID_off(sv);
2115 return 0;
2116}
2117
2118int
864dbfa3 2119Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
55497cff 2120{
8772537c 2121 PERL_UNUSED_ARG(mg);
14befaf4 2122 sv_unmagic(sv, PERL_MAGIC_fm);
55497cff
PP
2123 SvCOMPILED_off(sv);
2124 return 0;
2125}
2126
2127int
864dbfa3 2128Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
79072805 2129{
35a4481c 2130 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
79072805
LW
2131
2132 if (uf && uf->uf_set)
24f81a43 2133 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
79072805
LW
2134 return 0;
2135}
2136
c277df42 2137int
faf82a0b
AE
2138Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2139{
8772537c 2140 PERL_UNUSED_ARG(mg);
faf82a0b
AE
2141 sv_unmagic(sv, PERL_MAGIC_qr);
2142 return 0;
2143}
2144
2145int
864dbfa3 2146Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
c277df42 2147{
8772537c
AL
2148 regexp * const re = (regexp *)mg->mg_obj;
2149 PERL_UNUSED_ARG(sv);
2150
c277df42
IZ
2151 ReREFCNT_dec(re);
2152 return 0;
2153}
2154
7a4c00b4 2155#ifdef USE_LOCALE_COLLATE
79072805 2156int
864dbfa3 2157Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
bbce6d69
PP
2158{
2159 /*
838b5b74 2160 * RenE<eacute> Descartes said "I think not."
bbce6d69
PP
2161 * and vanished with a faint plop.
2162 */
8772537c 2163 PERL_UNUSED_ARG(sv);
7a4c00b4
PP
2164 if (mg->mg_ptr) {
2165 Safefree(mg->mg_ptr);
2166 mg->mg_ptr = NULL;
565764a8 2167 mg->mg_len = -1;
7a4c00b4 2168 }
bbce6d69
PP
2169 return 0;
2170}
7a4c00b4 2171#endif /* USE_LOCALE_COLLATE */
bbce6d69 2172
7e8c5dac
HS
2173/* Just clear the UTF-8 cache data. */
2174int
2175Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2176{
8772537c 2177 PERL_UNUSED_ARG(sv);
7e8c5dac
HS
2178 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2179 mg->mg_ptr = 0;
2180 mg->mg_len = -1; /* The mg_len holds the len cache. */
2181 return 0;
2182}
2183
bbce6d69 2184int
864dbfa3 2185Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
79072805 2186{
e1ec3a88 2187 register const char *s;
79072805 2188 I32 i;
8990e307 2189 STRLEN len;
79072805 2190 switch (*mg->mg_ptr) {
748a9306 2191 case '\001': /* ^A */
3280af22 2192 sv_setsv(PL_bodytarget, sv);
748a9306 2193 break;
49460fe6 2194 case '\003': /* ^C */
eb160463 2195 PL_minus_c = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
49460fe6
NIS
2196 break;
2197
79072805 2198 case '\004': /* ^D */
b4ab917c 2199#ifdef DEBUGGING
b83604b4 2200 s = SvPV_nolen_const(sv);
ddcf8bc1 2201 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
79072805 2202 DEBUG_x(dump_all());
b4ab917c
DM
2203#else
2204 PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | DEBUG_TOP_FLAG;
2205#endif
79072805 2206 break;
28f23441 2207 case '\005': /* ^E */
d0063567 2208 if (*(mg->mg_ptr+1) == '\0') {
cd39f2b6 2209#ifdef MACOS_TRADITIONAL
d0063567 2210 gMacPerl_OSErr = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
28f23441 2211#else
cd39f2b6 2212# ifdef VMS
d0063567 2213 set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
048c1ddf 2214# else
cd39f2b6 2215# ifdef WIN32
d0063567 2216 SetLastError( SvIV(sv) );
cd39f2b6 2217# else
9fed8b87 2218# ifdef OS2
d0063567 2219 os2_setsyserrno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
9fed8b87 2220# else
d0063567
DK
2221 /* will anyone ever use this? */
2222 SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4);
cd39f2b6 2223# endif
048c1ddf
IZ
2224# endif
2225# endif
22fae026 2226#endif
d0063567
DK
2227 }
2228 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2229 if (PL_encoding)
2230 SvREFCNT_dec(PL_encoding);
2231 if (SvOK(sv) || SvGMAGICAL(sv)) {
2232 PL_encoding = newSVsv(sv);
2233 }
2234 else {
2235 PL_encoding = Nullsv;
2236 }
2237 }
2238 break;
79072805 2239 case '\006': /* ^F */
3280af22 2240 PL_maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
79072805 2241 break;
a0d0e21e 2242 case '\010': /* ^H */
3280af22 2243 PL_hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
a0d0e21e 2244 break;
9d116dd7 2245 case '\011': /* ^I */ /* NOT \t in EBCDIC */
43c5f42d
NC
2246 Safefree(PL_inplace);
2247 PL_inplace = SvOK(sv) ? savesvpv(sv) : Nullch;
da78da6e 2248 break;
28f23441 2249 case '\017': /* ^O */
ac27b0f5 2250 if (*(mg->mg_ptr+1) == '\0') {
43c5f42d
NC
2251 Safefree(PL_osname);
2252 PL_osname = Nullch;
3511154c
DM
2253 if (SvOK(sv)) {
2254 TAINT_PROPER("assigning to $^O");
2e0de35c 2255 PL_osname = savesvpv(sv);
3511154c 2256 }
ac27b0f5
NIS
2257 }
2258 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2259 if (!PL_compiling.cop_io)
2260 PL_compiling.cop_io = newSVsv(sv);
2261 else
2262 sv_setsv(PL_compiling.cop_io,sv);
2263 }
28f23441 2264 break;
79072805 2265 case '\020': /* ^P */
3280af22 2266 PL_perldb = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
f2a7f298 2267 if (PL_perldb && !PL_DBsingle)
1ee4443e 2268 init_debugger();
79072805
LW
2269 break;
2270 case '\024': /* ^T */
88e89b8a 2271#ifdef BIG_TIME
6b88bc9c 2272 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
88e89b8a 2273#else
3280af22 2274 PL_basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
88e89b8a 2275#endif
79072805 2276 break;
fde18df1 2277 case '\027': /* ^W & $^WARNING_BITS */
4438c4b7
JH
2278 if (*(mg->mg_ptr+1) == '\0') {
2279 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2280 i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
ac27b0f5 2281 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
0453d815 2282 | (i ? G_WARN_ON : G_WARN_OFF) ;
4438c4b7 2283 }
599cee73 2284 }
0a378802 2285 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
4438c4b7 2286 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
d775746e
GS
2287 if (!SvPOK(sv) && PL_localizing) {
2288 sv_setpvn(sv, WARN_NONEstring, WARNsize);
d3a7d8c7 2289 PL_compiling.cop_warnings = pWARN_NONE;
d775746e
GS
2290 break;
2291 }
f4fc7782 2292 {
b5477537 2293 STRLEN len, i;
d3a7d8c7 2294 int accumulate = 0 ;
f4fc7782 2295 int any_fatals = 0 ;
b83604b4 2296 const char * const ptr = SvPV_const(sv, len) ;
f4fc7782
JH
2297 for (i = 0 ; i < len ; ++i) {
2298 accumulate |= ptr[i] ;
2299 any_fatals |= (ptr[i] & 0xAA) ;
2300 }
d3a7d8c7
GS
2301 if (!accumulate)
2302 PL_compiling.cop_warnings = pWARN_NONE;
f4fc7782
JH
2303 else if (isWARN_on(sv, WARN_ALL) && !any_fatals) {
2304 PL_compiling.cop_warnings = pWARN_ALL;
2305 PL_dowarn |= G_WARN_ONCE ;
727405f8 2306 }
d3a7d8c7
GS
2307 else {
2308 if (specialWARN(PL_compiling.cop_warnings))
2309 PL_compiling.cop_warnings = newSVsv(sv) ;
2310 else
2311 sv_setsv(PL_compiling.cop_warnings, sv);
2312 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2313 PL_dowarn |= G_WARN_ONCE ;
2314 }
f4fc7782 2315
d3a7d8c7 2316 }
4438c4b7 2317 }
971a9dd3 2318 }
79072805
LW
2319 break;
2320 case '.':
3280af22
NIS
2321 if (PL_localizing) {
2322 if (PL_localizing == 1)
7766f137 2323 SAVESPTR(PL_last_in_gv);
748a9306 2324 }
3280af22 2325 else if (SvOK(sv) && GvIO(PL_last_in_gv))
632db599 2326 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
79072805
LW
2327 break;
2328 case '^':
3280af22 2329 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
e1ec3a88 2330 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
7a5fd60d 2331 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv,TRUE, SVt_PVIO);
79072805
LW
2332 break;
2333 case '~':
3280af22 2334 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
e1ec3a88 2335 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
7a5fd60d 2336 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv,TRUE, SVt_PVIO);
79072805
LW
2337 break;
2338 case '=':
632db599 2339 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
79072805
LW
2340 break;
2341 case '-':
632db599 2342 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
3280af22
NIS
2343 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2344 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
79072805
LW
2345 break;
2346 case '%':
632db599 2347 IoPAGE(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
79072805
LW
2348 break;
2349 case '|':
4b65379b 2350 {
8772537c 2351 IO * const io = GvIOp(PL_defoutgv);
720f287d
AB
2352 if(!io)
2353 break;
4b65379b
CS
2354 if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) == 0)
2355 IoFLAGS(io) &= ~IOf_FLUSH;
2356 else {
2357 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2358 PerlIO *ofp = IoOFP(io);
2359 if (ofp)
2360 (void)PerlIO_flush(ofp);
2361 IoFLAGS(io) |= IOf_FLUSH;
2362 }
2363 }
79072805
LW
2364 }
2365 break;
79072805 2366 case '/':
3280af22 2367 SvREFCNT_dec(PL_rs);
8bfdd7d9 2368 PL_rs = newSVsv(sv);
79072805
LW
2369 break;
2370 case '\\':
7889fe52
NIS
2371 if (PL_ors_sv)
2372 SvREFCNT_dec(PL_ors_sv);
009c130f 2373 if (SvOK(sv) || SvGMAGICAL(sv)) {
7889fe52 2374 PL_ors_sv = newSVsv(sv);
009c130f 2375 }
e3c19b7b 2376 else {
7889fe52 2377 PL_ors_sv = Nullsv;
e3c19b7b 2378 }
79072805
LW
2379 break;
2380 case ',':
7889fe52
NIS
2381 if (PL_ofs_sv)
2382 SvREFCNT_dec(PL_ofs_sv);
2383 if (SvOK(sv) || SvGMAGICAL(sv)) {
2384 PL_ofs_sv = newSVsv(sv);
2385 }
2386 else {
2387 PL_ofs_sv = Nullsv;
2388 }
79072805 2389 break;
79072805 2390 case '[':
3280af22 2391 PL_compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
79072805
LW
2392 break;
2393 case '?':
ff0cee69 2394#ifdef COMPLEX_STATUS
6b88bc9c
GS
2395 if (PL_localizing == 2) {
2396 PL_statusvalue = LvTARGOFF(sv);
2397 PL_statusvalue_vms = LvTARGLEN(sv);
ff0cee69
PP
2398 }
2399 else
2400#endif
2401#ifdef VMSISH_STATUS
2402 if (VMSISH_STATUS)
fb38d079 2403 STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
ff0cee69
PP
2404 else
2405#endif
fb38d079 2406 STATUS_UNIX_EXIT_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
79072805
LW
2407 break;
2408 case '!':
93189314
JH
2409 {
2410#ifdef VMS
2411# define PERL_VMS_BANG vaxc$errno
2412#else
2413# define PERL_VMS_BANG 0
2414#endif
91487cfc 2415 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
93189314
JH
2416 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2417 }
79072805
LW
2418 break;
2419 case '<':
3280af22
NIS
2420 PL_uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2421 if (PL_delaymagic) {
2422 PL_delaymagic |= DM_RUID;
79072805
LW
2423 break; /* don't do magic till later */
2424 }
2425#ifdef HAS_SETRUID
b28d0864 2426 (void)setruid((Uid_t)PL_uid);
79072805
LW
2427#else
2428#ifdef HAS_SETREUID
3280af22 2429 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
748a9306 2430#else
85e6fe83 2431#ifdef HAS_SETRESUID
b28d0864 2432 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
79072805 2433#else
75870ed3 2434 if (PL_uid == PL_euid) { /* special case $< = $> */
2435#ifdef PERL_DARWIN
2436 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2437 if (PL_uid != 0 && PerlProc_getuid() == 0)
2438 (void)PerlProc_setuid(0);
2439#endif
b28d0864 2440 (void)PerlProc_setuid(PL_uid);
75870ed3 2441 } else {
d8eceb89 2442 PL_uid = PerlProc_getuid();
cea2e8a9 2443 Perl_croak(aTHX_ "setruid() not implemented");
a0d0e21e 2444 }
79072805
LW
2445#endif
2446#endif
85e6fe83 2447#endif
d8eceb89 2448 PL_uid = PerlProc_getuid();
3280af22 2449 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
79072805
LW
2450 break;
2451 case '>':
3280af22
NIS
2452 PL_euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2453 if (PL_delaymagic) {
2454 PL_delaymagic |= DM_EUID;
79072805
LW
2455 break; /* don't do magic till later */
2456 }
2457#ifdef HAS_SETEUID
3280af22 2458 (void)seteuid((Uid_t)PL_euid);
79072805
LW
2459#else
2460#ifdef HAS_SETREUID
b28d0864 2461 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
85e6fe83
LW
2462#else
2463#ifdef HAS_SETRESUID
6b88bc9c 2464 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
79072805 2465#else
b28d0864
NIS
2466 if (PL_euid == PL_uid) /* special case $> = $< */
2467 PerlProc_setuid(PL_euid);
a0d0e21e 2468 else {
e8ee3774 2469 PL_euid = PerlProc_geteuid();
cea2e8a9 2470 Perl_croak(aTHX_ "seteuid() not implemented");
a0d0e21e 2471 }
79072805
LW
2472#endif
2473#endif
85e6fe83 2474#endif
d8eceb89 2475 PL_euid = PerlProc_geteuid();
3280af22 2476 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
79072805
LW
2477 break;
2478 case '(':
3280af22
NIS
2479 PL_gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2480 if (PL_delaymagic) {
2481 PL_delaymagic |= DM_RGID;
79072805
LW
2482 break; /* don't do magic till later */
2483 }
2484#ifdef HAS_SETRGID
b28d0864 2485 (void)setrgid((Gid_t)PL_gid);
79072805
LW
2486#else
2487#ifdef HAS_SETREGID
3280af22 2488 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
85e6fe83
LW
2489#else
2490#ifdef HAS_SETRESGID
b28d0864 2491 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
79072805 2492#else
b28d0864
NIS
2493 if (PL_gid == PL_egid) /* special case $( = $) */
2494 (void)PerlProc_setgid(PL_gid);
748a9306 2495 else {
d8eceb89 2496 PL_gid = PerlProc_getgid();
cea2e8a9 2497 Perl_croak(aTHX_ "setrgid() not implemented");
748a9306 2498 }
79072805
LW
2499#endif
2500#endif
85e6fe83 2501#endif
d8eceb89 2502 PL_gid = PerlProc_getgid();
3280af22 2503 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
79072805
LW
2504 break;
2505 case ')':
5cd24f17
PP
2506#ifdef HAS_SETGROUPS
2507 {
b83604b4 2508 const char *p = SvPV_const(sv, len);
5cd24f17
PP
2509 Groups_t gary[NGROUPS];
2510
5cd24f17
PP
2511 while (isSPACE(*p))
2512 ++p;
2d4389e4 2513 PL_egid = Atol(p);
5cd24f17
PP
2514 for (i = 0; i < NGROUPS; ++i) {
2515 while (*p && !isSPACE(*p))
2516 ++p;
2517 while (isSPACE(*p))
2518 ++p;
2519 if (!*p)
2520 break;
2d4389e4 2521 gary[i] = Atol(p);
5cd24f17 2522 }
8cc95fdb
PP
2523 if (i)
2524 (void)setgroups(i, gary);
5cd24f17
PP
2525 }
2526#else /* HAS_SETGROUPS */
b28d0864 2527 PL_egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
5cd24f17 2528#endif /* HAS_SETGROUPS */
3280af22
NIS
2529 if (PL_delaymagic) {
2530 PL_delaymagic |= DM_EGID;
79072805
LW
2531 break; /* don't do magic till later */
2532 }
2533#ifdef HAS_SETEGID
3280af22 2534 (void)setegid((Gid_t)PL_egid);
79072805
LW
2535#else
2536#ifdef HAS_SETREGID
b28d0864 2537 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
85e6fe83
LW
2538#else
2539#ifdef HAS_SETRESGID
b28d0864 2540 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
79072805 2541#else
b28d0864
NIS
2542 if (PL_egid == PL_gid) /* special case $) = $( */
2543 (void)PerlProc_setgid(PL_egid);
748a9306 2544 else {
d8eceb89 2545 PL_egid = PerlProc_getegid();
cea2e8a9 2546 Perl_croak(aTHX_ "setegid() not implemented");
748a9306 2547 }
79072805
LW
2548#endif
2549#endif
85e6fe83 2550#endif
d8eceb89 2551 PL_egid = PerlProc_getegid();
3280af22 2552 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
79072805
LW
2553 break;
2554 case ':':
2d8e6c8d 2555 PL_chopset = SvPV_force(sv,len);
79072805 2556 break;
cd39f2b6 2557#ifndef MACOS_TRADITIONAL
79072805 2558 case '0':
e2975953 2559 LOCK_DOLLARZERO_MUTEX;
4bc88a62
PS
2560#ifdef HAS_SETPROCTITLE
2561 /* The BSDs don't show the argv[] in ps(1) output, they
2562 * show a string from the process struct and provide
2563 * the setproctitle() routine to manipulate that. */
2564 {
b83604b4 2565 s = SvPV_const(sv, len);
98b76f99 2566# if __FreeBSD_version > 410001
9aad2c0e 2567 /* The leading "-" removes the "perl: " prefix,
4bc88a62
PS
2568 * but not the "(perl) suffix from the ps(1)
2569 * output, because that's what ps(1) shows if the
2570 * argv[] is modified. */
6f2ad931 2571 setproctitle("-%s", s);
9aad2c0e 2572# else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
4bc88a62
PS
2573 /* This doesn't really work if you assume that
2574 * $0 = 'foobar'; will wipe out 'perl' from the $0
2575 * because in ps(1) output the result will be like
2576 * sprintf("perl: %s (perl)", s)
2577 * I guess this is a security feature:
2578 * one (a user process) cannot get rid of the original name.
2579 * --jhi */
2580 setproctitle("%s", s);
2581# endif
2582 }
2583#endif
17aa7f3d
JH
2584#if defined(__hpux) && defined(PSTAT_SETCMD)
2585 {
2586 union pstun un;
b83604b4 2587 s = SvPV_const(sv, len);
6867be6d 2588 un.pst_command = (char *)s;
17aa7f3d
JH
2589 pstat(PSTAT_SETCMD, un, len, 0, 0);
2590 }
2591#endif
3cb9023d 2592 /* PL_origalen is set in perl_parse(). */
a0d0e21e 2593 s = SvPV_force(sv,len);
6f698202
AMS
2594 if (len >= (STRLEN)PL_origalen-1) {
2595 /* Longer than original, will be truncated. We assume that
2596 * PL_origalen bytes are available. */
2597 Copy(s, PL_origargv[0], PL_origalen-1, char);
79072805
LW
2598 }
2599 else {
54bfe034
JH
2600 /* Shorter than original, will be padded. */
2601 Copy(s, PL_origargv[0], len, char);
2602 PL_origargv[0][len] = 0;
2603 memset(PL_origargv[0] + len + 1,
2604 /* Is the space counterintuitive? Yes.
2605 * (You were expecting \0?)
3cb9023d 2606 * Does it work? Seems to. (In Linux 2.4.20 at least.)
54bfe034
JH
2607 * --jhi */
2608 (int)' ',
2609 PL_origalen - len - 1);
79072805 2610 }
ad7eccf4
JD
2611 PL_origargv[0][PL_origalen-1] = 0;
2612 for (i = 1; i < PL_origargc; i++)
2613 PL_origargv[i] = 0;
e2975953 2614 UNLOCK_DOLLARZERO_MUTEX;
79072805 2615 break;
cd39f2b6 2616#endif
79072805
LW
2617 }
2618 return 0;
2619}
2620
2621I32
35a4481c 2622Perl_whichsig(pTHX_ const char *sig)
79072805 2623{
aadb217d 2624 register char* const* sigv;
79072805 2625
aadb217d 2626 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
79072805 2627 if (strEQ(sig,*sigv))
aadb217d 2628 return PL_sig_num[sigv - (char* const*)PL_sig_name];
79072805
LW
2629#ifdef SIGCLD
2630 if (strEQ(sig,"CHLD"))
2631 return SIGCLD;
2632#endif
2633#ifdef SIGCHLD
2634 if (strEQ(sig,"CLD"))
2635 return SIGCHLD;
2636#endif
7f1236c0 2637 return -1;
79072805
LW
2638}
2639
ecfc5424 2640Signal_t
1e82f5a6 2641#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
8aad04aa 2642Perl_sighandler(int sig, ...)
1e82f5a6
SH
2643#else
2644Perl_sighandler(int sig)
2645#endif
79072805 2646{
1018e26f
NIS
2647#ifdef PERL_GET_SIG_CONTEXT
2648 dTHXa(PERL_GET_SIG_CONTEXT);
71d280e3 2649#else
cea2e8a9 2650 dTHX;
71d280e3 2651#endif
79072805 2652 dSP;
00d579c5 2653 GV *gv = Nullgv;
8772537c
AL
2654 SV *sv = Nullsv;
2655 SV * const tSv = PL_Sv;
00d579c5 2656 CV *cv = Nullcv;
533c011a 2657 OP *myop = PL_op;
84902520 2658 U32 flags = 0;
8772537c 2659 XPV * const tXpv = PL_Xpv;
71d280e3 2660
3280af22 2661 if (PL_savestack_ix + 15 <= PL_savestack_max)
84902520 2662 flags |= 1;
3280af22 2663 if (PL_markstack_ptr < PL_markstack_max - 2)
84902520 2664 flags |= 4;
3280af22 2665 if (PL_scopestack_ix < PL_scopestack_max - 3)
84902520
TB
2666 flags |= 16;
2667
727405f8 2668 if (!PL_psig_ptr[sig]) {
99ef548b 2669 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
727405f8
NIS
2670 PL_sig_name[sig]);
2671 exit(sig);
2672 }
ff0cee69 2673
84902520
TB
2674 /* Max number of items pushed there is 3*n or 4. We cannot fix
2675 infinity, so we fix 4 (in fact 5): */
2676 if (flags & 1) {
3280af22 2677 PL_savestack_ix += 5; /* Protect save in progress. */
8772537c 2678 SAVEDESTRUCTOR_X(S_unwind_handler_stack, (void*)&flags);
84902520 2679 }
ac27b0f5 2680 if (flags & 4)
3280af22 2681 PL_markstack_ptr++; /* Protect mark. */
84902520 2682 if (flags & 16)
3280af22 2683 PL_scopestack_ix += 1;
84902520 2684 /* sv_2cv is too complicated, try a simpler variant first: */
ac27b0f5 2685 if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
8772537c
AL
2686 || SvTYPE(cv) != SVt_PVCV) {
2687 HV *st;
22c35a8c 2688 cv = sv_2cv(PL_psig_ptr[sig],&st,&gv,TRUE);
8772537c 2689 }
84902520 2690
a0d0e21e 2691 if (!cv || !CvROOT(cv)) {
599cee73 2692 if (ckWARN(WARN_SIGNAL))
9014280d 2693 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
22c35a8c 2694 PL_sig_name[sig], (gv ? GvENAME(gv)
00d579c5
GS
2695 : ((cv && CvGV(cv))
2696 ? GvENAME(CvGV(cv))
2697 : "__ANON__")));
2698 goto cleanup;
79072805
LW
2699 }
2700
22c35a8c
GS
2701 if(PL_psig_name[sig]) {
2702 sv = SvREFCNT_inc(PL_psig_name[sig]);
84902520 2703 flags |= 64;
df3728a2 2704#if !defined(PERL_IMPLICIT_CONTEXT)
27da23d5 2705 PL_sig_sv = sv;
df3728a2 2706#endif
84902520 2707 } else {
ff0cee69 2708 sv = sv_newmortal();
22c35a8c 2709 sv_setpv(sv,PL_sig_name[sig]);
88e89b8a 2710 }
e336de0d 2711
e788e7d3 2712 PUSHSTACKi(PERLSI_SIGNAL);
924508f0 2713 PUSHMARK(SP);
79072805 2714 PUSHs(sv);
8aad04aa
JH
2715#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2716 {
2717 struct sigaction oact;
2718
2719 if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
2720 siginfo_t *sip;
2721 va_list args;
2722
2723 va_start(args, sig);
2724 sip = (siginfo_t*)va_arg(args, siginfo_t*);
2725 if (sip) {
2726 HV *sih = newHV();
2727 SV *rv = newRV_noinc((SV*)sih);
2728 /* The siginfo fields signo, code, errno, pid, uid,
2729 * addr, status, and band are defined by POSIX/SUSv3. */
2730 hv_store(sih, "signo", 5, newSViv(sip->si_signo), 0);
2731 hv_store(sih, "code", 4, newSViv(sip->si_code), 0);
79dec0f4 2732#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 2733 hv_store(sih, "errno", 5, newSViv(sip->si_errno), 0);
79dec0f4 2734 hv_store(sih, "status", 6, newSViv(sip->si_status), 0);
8aad04aa
JH
2735 hv_store(sih, "uid", 3, newSViv(sip->si_uid), 0);
2736 hv_store(sih, "pid", 3, newSViv(sip->si_pid), 0);
2737 hv_store(sih, "addr", 4, newSVuv(PTR2UV(sip->si_addr)), 0);
8aad04aa 2738 hv_store(sih, "band", 4, newSViv(sip->si_band), 0);
79dec0f4 2739#endif
8aad04aa
JH
2740 EXTEND(SP, 2);
2741 PUSHs((SV*)rv);
2742 PUSHs(newSVpv((void*)sip, sizeof(*sip)));
2743 }
b4552a27 2744
31427afe 2745 va_end(args);
8aad04aa
JH
2746 }
2747 }
2748#endif
79072805 2749 PUTBACK;
a0d0e21e 2750
1b266415 2751 call_sv((SV*)cv, G_DISCARD|G_EVAL);
79072805 2752
d3acc0f7 2753 POPSTACK;
1b266415 2754 if (SvTRUE(ERRSV)) {
1d615522 2755#ifndef PERL_MICRO
983dbef6 2756#ifdef HAS_SIGPROCMASK
1b266415
NIS
2757 /* Handler "died", for example to get out of a restart-able read().
2758 * Before we re-do that on its behalf re-enable the signal which was
2759 * blocked by the system when we entered.
2760 */
2761 sigset_t set;
2762 sigemptyset(&set);
2763 sigaddset(&set,sig);
2764 sigprocmask(SIG_UNBLOCK, &set, NULL);
2765#else
2766 /* Not clear if this will work */
2767 (void)rsignal(sig, SIG_IGN);
5c1546dc 2768 (void)rsignal(sig, PL_csighandlerp);
1b266415 2769#endif
1d615522 2770#endif /* !PERL_MICRO */
c3bdd826 2771 Perl_die(aTHX_ Nullch);
1b266415 2772 }
00d579c5 2773cleanup:
84902520 2774 if (flags & 1)
3280af22 2775 PL_savestack_ix -= 8; /* Unprotect save in progress. */
ac27b0f5 2776 if (flags & 4)
3280af22 2777 PL_markstack_ptr--;
84902520 2778 if (flags & 16)
3280af22 2779 PL_scopestack_ix -= 1;
84902520
TB
2780 if (flags & 64)
2781 SvREFCNT_dec(sv);
533c011a 2782 PL_op = myop; /* Apparently not needed... */
ac27b0f5 2783
3280af22
NIS
2784 PL_Sv = tSv; /* Restore global temporaries. */
2785 PL_Xpv = tXpv;
53bb94e2 2786 return;
79072805 2787}
4e35701f
NIS
2788
2789
51371543 2790static void
8772537c 2791S_restore_magic(pTHX_ const void *p)
51371543 2792{
8772537c
AL
2793 MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
2794 SV* const sv = mgs->mgs_sv;
51371543
GS
2795
2796 if (!sv)
2797 return;
2798
2799 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2800 {
f8c7b90f 2801#ifdef PERL_OLD_COPY_ON_WRITE
f9701176
NC
2802 /* While magic was saved (and off) sv_setsv may well have seen
2803 this SV as a prime candidate for COW. */
2804 if (SvIsCOW(sv))
e424a81e 2805 sv_force_normal_flags(sv, 0);
f9701176
NC
2806#endif
2807
51371543
GS
2808 if (mgs->mgs_flags)
2809 SvFLAGS(sv) |= mgs->mgs_flags;
2810 else
2811 mg_magical(sv);
2b77b520
YST
2812 if (SvGMAGICAL(sv)) {
2813 /* downgrade public flags to private,
2814 and discard any other private flags */
2815
2816 U32 public = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
2817 if (public) {
2818 SvFLAGS(sv) &= ~( public | SVp_IOK|SVp_NOK|SVp_POK );
2819 SvFLAGS(sv) |= ( public << PRIVSHIFT );
2820 }
2821 }
51371543
GS
2822 }
2823
2824 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
2825
2826 /* If we're still on top of the stack, pop us off. (That condition
2827 * will be satisfied if restore_magic was called explicitly, but *not*
2828 * if it's being called via leave_scope.)
2829 * The reason for doing this is that otherwise, things like sv_2cv()
2830 * may leave alloc gunk on the savestack, and some code
2831 * (e.g. sighandler) doesn't expect that...
2832 */
2833 if (PL_savestack_ix == mgs->mgs_ss_ix)
2834 {
2835 I32 popval = SSPOPINT;
c76ac1ee 2836 assert(popval == SAVEt_DESTRUCTOR_X);
51371543
GS
2837 PL_savestack_ix -= 2;
2838 popval = SSPOPINT;
2839 assert(popval == SAVEt_ALLOC);
2840 popval = SSPOPINT;
2841 PL_savestack_ix -= popval;
2842 }
2843
2844}
2845
2846static void
8772537c 2847S_unwind_handler_stack(pTHX_ const void *p)
51371543 2848{
27da23d5 2849 dVAR;
e1ec3a88 2850 const U32 flags = *(const U32*)p;
51371543
GS
2851
2852 if (flags & 1)
2853 PL_savestack_ix -= 5; /* Unprotect save in progress. */
2854 /* cxstack_ix-- Not needed, die already unwound it. */
df3728a2 2855#if !defined(PERL_IMPLICIT_CONTEXT)
51371543 2856 if (flags & 64)
27da23d5 2857 SvREFCNT_dec(PL_sig_sv);
df3728a2 2858#endif
51371543 2859}
1018e26f 2860
66610fdd
RGS
2861/*
2862 * Local variables:
2863 * c-indentation-style: bsd
2864 * c-basic-offset: 4
2865 * indent-tabs-mode: t
2866 * End:
2867 *
37442d52
RGS
2868 * ex: set ts=8 sts=4 sw=4 noet:
2869 */