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