This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[perl #18209] bug in regex s/\s$word\s/ /gi; and $&
[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);
f5a63d97 275 len = utf8_length(s, s + len);
5636d518
DB
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)
f5a63d97 534 i = utf8_length((U8*)b, (U8*)(b+i));
0bd48802 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 732 sv_setnv(sv, (NV)errno);
666ea192 733 sv_setpv(sv, errno ? Strerror(errno) : "");
f6c8f21d
RGS
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) {
666ea192
JH
813 sv_setpvn(
814 sv,
815 (PL_dowarn & G_WARN_ON) ? WARN_ALLstring : WARN_NONEstring,
816 WARNsize
817 );
013b78e8 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 */
823a54a3 822 HV * const bits=get_hv("warnings::Bits", FALSE);
f5a63d97
AL
823 if (bits) {
824 SV ** const bits_all = hv_fetchs(bits, "all", FALSE);
825 if (bits_all)
826 sv_setsv(sv, *bits_all);
75b6c4ca
RGS
827 }
828 else {
829 sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
830 }
ac27b0f5 831 }
4438c4b7 832 else {
72dc9ed5
NC
833 sv_setpvn(sv, (char *) (PL_compiling.cop_warnings + 1),
834 *PL_compiling.cop_warnings);
ac27b0f5 835 }
d3a7d8c7 836 SvPOK_only(sv);
4438c4b7 837 }
79072805
LW
838 break;
839 case '1': case '2': case '3': case '4':
840 case '5': case '6': case '7': case '8': case '9': case '&':
aaa362c4 841 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
cf93c79d
IZ
842 I32 s1, t1;
843
a863c7d1
MB
844 /*
845 * Pre-threads, this was paren = atoi(GvENAME((GV*)mg->mg_obj));
846 * XXX Does the new way break anything?
847 */
ffc61ed2 848 paren = atoi(mg->mg_ptr); /* $& is in [0] */
79072805 849 getparen:
eb160463 850 if (paren <= (I32)rx->nparens &&
cf93c79d
IZ
851 (s1 = rx->startp[paren]) != -1 &&
852 (t1 = rx->endp[paren]) != -1)
bbce6d69 853 {
cf93c79d
IZ
854 i = t1 - s1;
855 s = rx->subbeg + s1;
c2b4a044 856 assert(rx->subbeg);
3d82f0cd 857 assert(rx->sublen >= s1);
c2e66d9e 858
13f57bf8 859 getrx:
748a9306 860 if (i >= 0) {
fabdb6c0 861 const int oldtainted = PL_tainted;
f6ba9920 862 TAINT_NOT;
cf93c79d 863 sv_setpvn(sv, s, i);
f6ba9920 864 PL_tainted = oldtainted;
52655000
YO
865 if ( (rx->reganch & ROPT_CANY_SEEN)
866 ? (RX_MATCH_UTF8(rx)
867 && (!i || is_utf8_string((U8*)s, i)))
868 : (RX_MATCH_UTF8(rx)) )
869 {
7e2040f0 870 SvUTF8_on(sv);
52655000 871 }
7e2040f0
GS
872 else
873 SvUTF8_off(sv);
e9814ee1
HS
874 if (PL_tainting) {
875 if (RX_MATCH_TAINTED(rx)) {
823a54a3 876 MAGIC* const mg = SvMAGIC(sv);
e9814ee1
HS
877 MAGIC* mgt;
878 PL_tainted = 1;
b162af07 879 SvMAGIC_set(sv, mg->mg_moremagic);
e9814ee1
HS
880 SvTAINT(sv);
881 if ((mgt = SvMAGIC(sv))) {
882 mg->mg_moremagic = mgt;
b162af07 883 SvMAGIC_set(sv, mg);
e9814ee1
HS
884 }
885 } else
886 SvTAINTED_off(sv);
887 }
748a9306
LW
888 break;
889 }
79072805 890 }
79072805 891 }
3280af22 892 sv_setsv(sv,&PL_sv_undef);
79072805
LW
893 break;
894 case '+':
aaa362c4 895 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
d9f97599 896 paren = rx->lastparen;
a0d0e21e
LW
897 if (paren)
898 goto getparen;
79072805 899 }
3280af22 900 sv_setsv(sv,&PL_sv_undef);
79072805 901 break;
a01268b5
JH
902 case '\016': /* ^N */
903 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
904 paren = rx->lastcloseparen;
905 if (paren)
906 goto getparen;
907 }
908 sv_setsv(sv,&PL_sv_undef);
909 break;
79072805 910 case '`':
aaa362c4 911 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
cf93c79d
IZ
912 if ((s = rx->subbeg) && rx->startp[0] != -1) {
913 i = rx->startp[0];
13f57bf8 914 goto getrx;
79072805 915 }
79072805 916 }
3280af22 917 sv_setsv(sv,&PL_sv_undef);
79072805
LW
918 break;
919 case '\'':
aaa362c4 920 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
cf93c79d
IZ
921 if (rx->subbeg && rx->endp[0] != -1) {
922 s = rx->subbeg + rx->endp[0];
923 i = rx->sublen - rx->endp[0];
13f57bf8 924 goto getrx;
79072805 925 }
79072805 926 }
3280af22 927 sv_setsv(sv,&PL_sv_undef);
79072805
LW
928 break;
929 case '.':
3280af22 930 if (GvIO(PL_last_in_gv)) {
357c8808 931 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
79072805 932 }
79072805
LW
933 break;
934 case '?':
809a5acc 935 {
809a5acc 936 sv_setiv(sv, (IV)STATUS_CURRENT);
ff0cee69 937#ifdef COMPLEX_STATUS
6b88bc9c
GS
938 LvTARGOFF(sv) = PL_statusvalue;
939 LvTARGLEN(sv) = PL_statusvalue_vms;
ff0cee69 940#endif
809a5acc 941 }
79072805
LW
942 break;
943 case '^':
0daa599b
RGS
944 if (GvIOp(PL_defoutgv))
945 s = IoTOP_NAME(GvIOp(PL_defoutgv));
79072805
LW
946 if (s)
947 sv_setpv(sv,s);
948 else {
3280af22 949 sv_setpv(sv,GvENAME(PL_defoutgv));
79072805
LW
950 sv_catpv(sv,"_TOP");
951 }
952 break;
953 case '~':
0daa599b
RGS
954 if (GvIOp(PL_defoutgv))
955 s = IoFMT_NAME(GvIOp(PL_defoutgv));
79072805 956 if (!s)
3280af22 957 s = GvENAME(PL_defoutgv);
79072805
LW
958 sv_setpv(sv,s);
959 break;
79072805 960 case '=':
0daa599b
RGS
961 if (GvIOp(PL_defoutgv))
962 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
79072805
LW
963 break;
964 case '-':
0daa599b
RGS
965 if (GvIOp(PL_defoutgv))
966 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
79072805
LW
967 break;
968 case '%':
0daa599b
RGS
969 if (GvIOp(PL_defoutgv))
970 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
79072805 971 break;
79072805
LW
972 case ':':
973 break;
974 case '/':
975 break;
976 case '[':
11206fdd 977 sv_setiv(sv, (IV)CopARYBASE_get(PL_curcop));
79072805
LW
978 break;
979 case '|':
0daa599b
RGS
980 if (GvIOp(PL_defoutgv))
981 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
79072805
LW
982 break;
983 case ',':
79072805
LW
984 break;
985 case '\\':
b2ce0fda 986 if (PL_ors_sv)
f28098ff 987 sv_copypv(sv, PL_ors_sv);
79072805 988 break;
79072805 989 case '!':
a5f75d66 990#ifdef VMS
65202027 991 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
88e89b8a 992 sv_setpv(sv, errno ? Strerror(errno) : "");
a5f75d66 993#else
88e89b8a 994 {
8772537c 995 const int saveerrno = errno;
65202027 996 sv_setnv(sv, (NV)errno);
88e89b8a 997#ifdef OS2
ed344e4f
IZ
998 if (errno == errno_isOS2 || errno == errno_isOS2_set)
999 sv_setpv(sv, os2error(Perl_rc));
88e89b8a 1000 else
a5f75d66 1001#endif
666ea192 1002 sv_setpv(sv, errno ? Strerror(errno) : "");
88e89b8a
PP
1003 errno = saveerrno;
1004 }
1005#endif
ad3296c6 1006 SvRTRIM(sv);
946ec16e 1007 SvNOK_on(sv); /* what a wonderful hack! */
79072805
LW
1008 break;
1009 case '<':
3280af22 1010 sv_setiv(sv, (IV)PL_uid);
79072805
LW
1011 break;
1012 case '>':
3280af22 1013 sv_setiv(sv, (IV)PL_euid);
79072805
LW
1014 break;
1015 case '(':
3280af22 1016 sv_setiv(sv, (IV)PL_gid);
79072805
LW
1017 goto add_groups;
1018 case ')':
3280af22 1019 sv_setiv(sv, (IV)PL_egid);
79072805 1020 add_groups:
79072805 1021#ifdef HAS_GETGROUPS
79072805 1022 {
57d7c65e 1023 Groups_t *gary = NULL;
fb45abb2 1024 I32 i, num_groups = getgroups(0, gary);
57d7c65e
JC
1025 Newx(gary, num_groups, Groups_t);
1026 num_groups = getgroups(num_groups, gary);
fb45abb2
GA
1027 for (i = 0; i < num_groups; i++)
1028 Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]);
57d7c65e 1029 Safefree(gary);
79072805 1030 }
155aba94 1031 (void)SvIOK_on(sv); /* what a wonderful hack! */
cd70abae 1032#endif
79072805 1033 break;
cd39f2b6 1034#ifndef MACOS_TRADITIONAL
79072805
LW
1035 case '0':
1036 break;
cd39f2b6 1037#endif
79072805 1038 }
a0d0e21e 1039 return 0;
79072805
LW
1040}
1041
1042int
864dbfa3 1043Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
79072805 1044{
8772537c 1045 struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
79072805
LW
1046
1047 if (uf && uf->uf_val)
24f81a43 1048 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
79072805
LW
1049 return 0;
1050}
1051
1052int
864dbfa3 1053Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
79072805 1054{
27da23d5 1055 dVAR;
9ae3433d 1056 STRLEN len = 0, klen;
666ea192 1057 const char *s = SvOK(sv) ? SvPV_const(sv,len) : "";
fabdb6c0 1058 const char * const ptr = MgPV_const(mg,klen);
88e89b8a 1059 my_setenv(ptr, s);
1e422769 1060
a0d0e21e
LW
1061#ifdef DYNAMIC_ENV_FETCH
1062 /* We just undefd an environment var. Is a replacement */
1063 /* waiting in the wings? */
1064 if (!len) {
fabdb6c0
AL
1065 SV ** const valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE);
1066 if (valp)
4ab59fcc 1067 s = SvOK(*valp) ? SvPV_const(*valp, len) : "";
a0d0e21e
LW
1068 }
1069#endif
1e422769 1070
39e571d4 1071#if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
79072805
LW
1072 /* And you'll never guess what the dog had */
1073 /* in its mouth... */
3280af22 1074 if (PL_tainting) {
1e422769
PP
1075 MgTAINTEDDIR_off(mg);
1076#ifdef VMS
5aabfad6 1077 if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
b8ffc8df 1078 char pathbuf[256], eltbuf[256], *cp, *elt;
c623ac67 1079 Stat_t sbuf;
1e422769
PP
1080 int i = 0, j = 0;
1081
6fca0082 1082 my_strlcpy(eltbuf, s, sizeof(eltbuf));
b8ffc8df 1083 elt = eltbuf;
1e422769
PP
1084 do { /* DCL$PATH may be a search list */
1085 while (1) { /* as may dev portion of any element */
1086 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1087 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1088 cando_by_name(S_IWUSR,0,elt) ) {
1089 MgTAINTEDDIR_on(mg);
1090 return 0;
1091 }
1092 }
bd61b366 1093 if ((cp = strchr(elt, ':')) != NULL)
1e422769
PP
1094 *cp = '\0';
1095 if (my_trnlnm(elt, eltbuf, j++))
1096 elt = eltbuf;
1097 else
1098 break;
1099 }
1100 j = 0;
1101 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1102 }
1103#endif /* VMS */
5aabfad6 1104 if (s && klen == 4 && strEQ(ptr,"PATH")) {
8772537c 1105 const char * const strend = s + len;
463ee0b2
LW
1106
1107 while (s < strend) {
96827780 1108 char tmpbuf[256];
c623ac67 1109 Stat_t st;
5f74f29c 1110 I32 i;
f5a63d97
AL
1111#ifdef VMS /* Hmm. How do we get $Config{path_sep} from C? */
1112 const char path_sep = '|';
1113#else
1114 const char path_sep = ':';
1115#endif
96827780 1116 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
427eaa01 1117 s, strend, path_sep, &i);
463ee0b2 1118 s++;
bb7a0f54 1119 if (i >= (I32)sizeof tmpbuf /* too long -- assume the worst */
326b5008
CB
1120#ifdef VMS
1121 || !strchr(tmpbuf, ':') /* no colon thus no device name -- assume relative path */
1122#else
1123 || *tmpbuf != '/' /* no starting slash -- assume relative path */
1124#endif
c6ed36e1 1125 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
8990e307 1126 MgTAINTEDDIR_on(mg);
1e422769
PP
1127 return 0;
1128 }
463ee0b2 1129 }
79072805
LW
1130 }
1131 }
39e571d4 1132#endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1e422769 1133
79072805
LW
1134 return 0;
1135}
1136
1137int
864dbfa3 1138Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
85e6fe83 1139{
8772537c 1140 PERL_UNUSED_ARG(sv);
bd61b366 1141 my_setenv(MgPV_nolen_const(mg),NULL);
85e6fe83
LW
1142 return 0;
1143}
1144
88e89b8a 1145int
864dbfa3 1146Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
fb73857a 1147{
97aff369 1148 dVAR;
65e66c80 1149 PERL_UNUSED_ARG(mg);
b0269e46 1150#if defined(VMS)
cea2e8a9 1151 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
fb73857a 1152#else
3280af22 1153 if (PL_localizing) {
fb73857a 1154 HE* entry;
b0269e46 1155 my_clearenv();
fb73857a 1156 hv_iterinit((HV*)sv);
155aba94 1157 while ((entry = hv_iternext((HV*)sv))) {
fb73857a
PP
1158 I32 keylen;
1159 my_setenv(hv_iterkey(entry, &keylen),
b83604b4 1160 SvPV_nolen_const(hv_iterval((HV*)sv, entry)));
fb73857a
PP
1161 }
1162 }
1163#endif
1164 return 0;
1165}
1166
1167int
864dbfa3 1168Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
66b1d557 1169{
27da23d5 1170 dVAR;
8772537c
AL
1171 PERL_UNUSED_ARG(sv);
1172 PERL_UNUSED_ARG(mg);
b0269e46
AB
1173#if defined(VMS)
1174 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1175#else
1176 my_clearenv();
1177#endif
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{
0bd48802 1186 const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
f5a63d97 1187 (void)sigprocmask(SIG_SETMASK, ossetp, NULL);
2d4fcd5e
AJ
1188}
1189#endif
66b1d557 1190int
864dbfa3 1191Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
88e89b8a 1192{
97aff369 1193 dVAR;
88e89b8a 1194 /* Are we fetching a signal entry? */
8772537c 1195 const I32 i = whichsig(MgPV_nolen_const(mg));
e02bfb16 1196 if (i > 0) {
22c35a8c
GS
1197 if(PL_psig_ptr[i])
1198 sv_setsv(sv,PL_psig_ptr[i]);
88e89b8a 1199 else {
46da273f 1200 Sighandler_t sigstate = rsignal_state(i);
23ada85b 1201#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
46da273f
AL
1202 if (PL_sig_handlers_initted && PL_sig_ignoring[i])
1203 sigstate = SIG_IGN;
2e34cc90
CL
1204#endif
1205#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
46da273f
AL
1206 if (PL_sig_handlers_initted && PL_sig_defaulting[i])
1207 sigstate = SIG_DFL;
85b332e2 1208#endif
88e89b8a 1209 /* cache state so we don't fetch it again */
8aad04aa 1210 if(sigstate == (Sighandler_t) SIG_IGN)
88e89b8a
PP
1211 sv_setpv(sv,"IGNORE");
1212 else
3280af22 1213 sv_setsv(sv,&PL_sv_undef);
46da273f 1214 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
88e89b8a
PP
1215 SvTEMP_off(sv);
1216 }
1217 }
1218 return 0;
1219}
1220int
864dbfa3 1221Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
88e89b8a 1222{
2d4fcd5e
AJ
1223 /* XXX Some of this code was copied from Perl_magic_setsig. A little
1224 * refactoring might be in order.
1225 */
27da23d5 1226 dVAR;
8772537c
AL
1227 register const char * const s = MgPV_nolen_const(mg);
1228 PERL_UNUSED_ARG(sv);
2d4fcd5e 1229 if (*s == '_') {
cbbf8932 1230 SV** svp = NULL;
2d4fcd5e
AJ
1231 if (strEQ(s,"__DIE__"))
1232 svp = &PL_diehook;
b274dc4e 1233 else if (strEQ(s,"__WARN__") && PL_warnhook != PERL_WARNHOOK_FATAL)
2d4fcd5e 1234 svp = &PL_warnhook;
27da23d5 1235 if (svp && *svp) {
b274dc4e 1236 SV *const to_dec = *svp;
cbbf8932 1237 *svp = NULL;
b274dc4e 1238 SvREFCNT_dec(to_dec);
2d4fcd5e
AJ
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]) {
6136c704 1272 SV * const 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 1286{
97aff369 1287 dVAR;
0a8e0eff
NIS
1288 /* Set a flag to say this signal is pending */
1289 PL_psig_pend[sig]++;
1290 /* And one to say _a_ signal is pending */
1291 PL_sig_pending = 1;
1292}
1293
1294Signal_t
8aad04aa
JH
1295#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1296Perl_csighandler(int sig, ...)
1297#else
0a8e0eff 1298Perl_csighandler(int sig)
8aad04aa 1299#endif
0a8e0eff 1300{
1018e26f
NIS
1301#ifdef PERL_GET_SIG_CONTEXT
1302 dTHXa(PERL_GET_SIG_CONTEXT);
1303#else
85b332e2
CL
1304 dTHX;
1305#endif
23ada85b 1306#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
5c1546dc 1307 (void) rsignal(sig, PL_csighandlerp);
27da23d5 1308 if (PL_sig_ignoring[sig]) return;
85b332e2 1309#endif
2e34cc90 1310#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
27da23d5 1311 if (PL_sig_defaulting[sig])
2e34cc90
CL
1312#ifdef KILL_BY_SIGPRC
1313 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1314#else
1315 exit(1);
1316#endif
1317#endif
853d2c32
RGS
1318 if (
1319#ifdef SIGILL
1320 sig == SIGILL ||
1321#endif
1322#ifdef SIGBUS
1323 sig == SIGBUS ||
1324#endif
1325#ifdef SIGSEGV
1326 sig == SIGSEGV ||
1327#endif
1328 (PL_signals & PERL_SIGNALS_UNSAFE_FLAG))
4ffa73a3
JH
1329 /* Call the perl level handler now--
1330 * with risk we may be in malloc() etc. */
1331 (*PL_sighandlerp)(sig);
1332 else
dd374669 1333 S_raise_signal(aTHX_ sig);
0a8e0eff
NIS
1334}
1335
2e34cc90
CL
1336#if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1337void
1338Perl_csighandler_init(void)
1339{
1340 int sig;
27da23d5 1341 if (PL_sig_handlers_initted) return;
2e34cc90
CL
1342
1343 for (sig = 1; sig < SIG_SIZE; sig++) {
1344#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
218fdd94 1345 dTHX;
27da23d5 1346 PL_sig_defaulting[sig] = 1;
5c1546dc 1347 (void) rsignal(sig, PL_csighandlerp);
2e34cc90
CL
1348#endif
1349#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
27da23d5 1350 PL_sig_ignoring[sig] = 0;
2e34cc90
CL
1351#endif
1352 }
27da23d5 1353 PL_sig_handlers_initted = 1;
2e34cc90
CL
1354}
1355#endif
1356
0a8e0eff
NIS
1357void
1358Perl_despatch_signals(pTHX)
1359{
97aff369 1360 dVAR;
0a8e0eff
NIS
1361 int sig;
1362 PL_sig_pending = 0;
1363 for (sig = 1; sig < SIG_SIZE; sig++) {
1364 if (PL_psig_pend[sig]) {
25da4428
JH
1365 PERL_BLOCKSIG_ADD(set, sig);
1366 PL_psig_pend[sig] = 0;
1367 PERL_BLOCKSIG_BLOCK(set);
f5203343 1368 (*PL_sighandlerp)(sig);
25da4428 1369 PERL_BLOCKSIG_UNBLOCK(set);
0a8e0eff
NIS
1370 }
1371 }
1372}
1373
85e6fe83 1374int
864dbfa3 1375Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
79072805 1376{
27da23d5 1377 dVAR;
79072805 1378 I32 i;
cbbf8932 1379 SV** svp = NULL;
2d4fcd5e
AJ
1380 /* Need to be careful with SvREFCNT_dec(), because that can have side
1381 * effects (due to closures). We must make sure that the new disposition
1382 * is in place before it is called.
1383 */
cbbf8932 1384 SV* to_dec = NULL;
e72dc28c 1385 STRLEN len;
2d4fcd5e
AJ
1386#ifdef HAS_SIGPROCMASK
1387 sigset_t set, save;
1388 SV* save_sv;
1389#endif
a0d0e21e 1390
d5263905 1391 register const char *s = MgPV_const(mg,len);
748a9306
LW
1392 if (*s == '_') {
1393 if (strEQ(s,"__DIE__"))
3280af22 1394 svp = &PL_diehook;
748a9306 1395 else if (strEQ(s,"__WARN__"))
3280af22 1396 svp = &PL_warnhook;
748a9306 1397 else
cea2e8a9 1398 Perl_croak(aTHX_ "No such hook: %s", s);
748a9306 1399 i = 0;
4633a7c4 1400 if (*svp) {
9289f461
RGS
1401 if (*svp != PERL_WARNHOOK_FATAL)
1402 to_dec = *svp;
cbbf8932 1403 *svp = NULL;
4633a7c4 1404 }
748a9306
LW
1405 }
1406 else {
1407 i = whichsig(s); /* ...no, a brick */
86d86cad 1408 if (i <= 0) {
e476b1b5 1409 if (ckWARN(WARN_SIGNAL))
9014280d 1410 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
748a9306
LW
1411 return 0;
1412 }
2d4fcd5e
AJ
1413#ifdef HAS_SIGPROCMASK
1414 /* Avoid having the signal arrive at a bad time, if possible. */
1415 sigemptyset(&set);
1416 sigaddset(&set,i);
1417 sigprocmask(SIG_BLOCK, &set, &save);
1418 ENTER;
1419 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1420 SAVEFREESV(save_sv);
1421 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1422#endif
1423 PERL_ASYNC_CHECK();
2e34cc90 1424#if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
27da23d5 1425 if (!PL_sig_handlers_initted) Perl_csighandler_init();
2e34cc90 1426#endif
23ada85b 1427#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
27da23d5 1428 PL_sig_ignoring[i] = 0;
85b332e2 1429#endif
2e34cc90 1430#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
27da23d5 1431 PL_sig_defaulting[i] = 0;
2e34cc90 1432#endif
22c35a8c 1433 SvREFCNT_dec(PL_psig_name[i]);
2d4fcd5e 1434 to_dec = PL_psig_ptr[i];
46da273f 1435 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
88e89b8a 1436 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
e72dc28c 1437 PL_psig_name[i] = newSVpvn(s, len);
22c35a8c 1438 SvREADONLY_on(PL_psig_name[i]);
748a9306 1439 }
a0d0e21e 1440 if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
2d4fcd5e 1441 if (i) {
5c1546dc 1442 (void)rsignal(i, PL_csighandlerp);
2d4fcd5e
AJ
1443#ifdef HAS_SIGPROCMASK
1444 LEAVE;
1445#endif
1446 }
748a9306 1447 else
b37c2d43 1448 *svp = SvREFCNT_inc_simple_NN(sv);
2d4fcd5e
AJ
1449 if(to_dec)
1450 SvREFCNT_dec(to_dec);
a0d0e21e
LW
1451 return 0;
1452 }
e72dc28c 1453 s = SvPV_force(sv,len);
748a9306 1454 if (strEQ(s,"IGNORE")) {
85b332e2 1455 if (i) {
23ada85b 1456#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
27da23d5 1457 PL_sig_ignoring[i] = 1;
5c1546dc 1458 (void)rsignal(i, PL_csighandlerp);
85b332e2 1459#else
8aad04aa 1460 (void)rsignal(i, (Sighandler_t) SIG_IGN);
85b332e2 1461#endif
2d4fcd5e 1462 }
748a9306
LW
1463 }
1464 else if (strEQ(s,"DEFAULT") || !*s) {
1465 if (i)
2e34cc90
CL
1466#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1467 {
27da23d5 1468 PL_sig_defaulting[i] = 1;
5c1546dc 1469 (void)rsignal(i, PL_csighandlerp);
2e34cc90
CL
1470 }
1471#else
8aad04aa 1472 (void)rsignal(i, (Sighandler_t) SIG_DFL);
2e34cc90 1473#endif
748a9306 1474 }
79072805 1475 else {
5aabfad6
PP
1476 /*
1477 * We should warn if HINT_STRICT_REFS, but without
1478 * access to a known hint bit in a known OP, we can't
1479 * tell whether HINT_STRICT_REFS is in force or not.
1480 */
46fc3d4c 1481 if (!strchr(s,':') && !strchr(s,'\''))
89529cee 1482 Perl_sv_insert(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"));
748a9306 1483 if (i)
5c1546dc 1484 (void)rsignal(i, PL_csighandlerp);
748a9306 1485 else
46da273f 1486 *svp = SvREFCNT_inc_simple_NN(sv);
79072805 1487 }
2d4fcd5e
AJ
1488#ifdef HAS_SIGPROCMASK
1489 if(i)
1490 LEAVE;
1491#endif
1492 if(to_dec)
1493 SvREFCNT_dec(to_dec);
79072805
LW
1494 return 0;
1495}
64ca3a65 1496#endif /* !PERL_MICRO */
79072805
LW
1497
1498int
864dbfa3 1499Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
79072805 1500{
97aff369 1501 dVAR;
8772537c
AL
1502 PERL_UNUSED_ARG(sv);
1503 PERL_UNUSED_ARG(mg);
3280af22 1504 PL_sub_generation++;
463ee0b2
LW
1505 return 0;
1506}
1507
1508int
864dbfa3 1509Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
463ee0b2 1510{
97aff369 1511 dVAR;
8772537c
AL
1512 PERL_UNUSED_ARG(sv);
1513 PERL_UNUSED_ARG(mg);
a0d0e21e 1514 /* HV_badAMAGIC_on(Sv_STASH(sv)); */
3280af22 1515 PL_amagic_generation++;
463ee0b2 1516
a0d0e21e
LW
1517 return 0;
1518}
463ee0b2 1519
946ec16e 1520int
864dbfa3 1521Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
6ff81951 1522{
dd374669 1523 HV * const hv = (HV*)LvTARG(sv);
6ff81951 1524 I32 i = 0;
8772537c 1525 PERL_UNUSED_ARG(mg);
7719e241 1526
6ff81951 1527 if (hv) {
497b47a8
JH
1528 (void) hv_iterinit(hv);
1529 if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
1530 i = HvKEYS(hv);
1531 else {
1532 while (hv_iternext(hv))
1533 i++;
1534 }
6ff81951
GS
1535 }
1536
1537 sv_setiv(sv, (IV)i);
1538 return 0;
1539}
1540
1541int
864dbfa3 1542Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
946ec16e 1543{
8772537c 1544 PERL_UNUSED_ARG(mg);
946ec16e
PP
1545 if (LvTARG(sv)) {
1546 hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
946ec16e
PP
1547 }
1548 return 0;
ac27b0f5 1549}
946ec16e 1550
e336de0d 1551/* caller is responsible for stack switching/cleanup */
565764a8 1552STATIC int
e1ec3a88 1553S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV *val)
a0d0e21e 1554{
97aff369 1555 dVAR;
a0d0e21e 1556 dSP;
463ee0b2 1557
924508f0
GS
1558 PUSHMARK(SP);
1559 EXTEND(SP, n);
33c27489 1560 PUSHs(SvTIED_obj(sv, mg));
ac27b0f5 1561 if (n > 1) {
93965878 1562 if (mg->mg_ptr) {
565764a8 1563 if (mg->mg_len >= 0)
79cb57f6 1564 PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len)));
565764a8 1565 else if (mg->mg_len == HEf_SVKEY)
93965878
NIS
1566 PUSHs((SV*)mg->mg_ptr);
1567 }
14befaf4 1568 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
565764a8 1569 PUSHs(sv_2mortal(newSViv(mg->mg_len)));
93965878
NIS
1570 }
1571 }
1572 if (n > 2) {
1573 PUSHs(val);
88e89b8a 1574 }
463ee0b2
LW
1575 PUTBACK;
1576
864dbfa3 1577 return call_method(meth, flags);
946ec16e
PP
1578}
1579
76e3520e 1580STATIC int
e1ec3a88 1581S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
a0d0e21e 1582{
27da23d5 1583 dVAR; dSP;
463ee0b2 1584
a0d0e21e
LW
1585 ENTER;
1586 SAVETMPS;
e788e7d3 1587 PUSHSTACKi(PERLSI_MAGIC);
463ee0b2 1588
33c27489 1589 if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
3280af22 1590 sv_setsv(sv, *PL_stack_sp--);
93965878 1591 }
463ee0b2 1592
d3acc0f7 1593 POPSTACK;
a0d0e21e
LW
1594 FREETMPS;
1595 LEAVE;
1596 return 0;
1597}
463ee0b2 1598
a0d0e21e 1599int
864dbfa3 1600Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e 1601{
a0d0e21e
LW
1602 if (mg->mg_ptr)
1603 mg->mg_flags |= MGf_GSKIP;
58f82c5c 1604 magic_methpack(sv,mg,"FETCH");
463ee0b2
LW
1605 return 0;
1606}
1607
1608int
864dbfa3 1609Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
e336de0d 1610{
27da23d5 1611 dVAR; dSP;
a60c0954 1612 ENTER;
e788e7d3 1613 PUSHSTACKi(PERLSI_MAGIC);
33c27489 1614 magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
d3acc0f7 1615 POPSTACK;
a60c0954 1616 LEAVE;
463ee0b2
LW
1617 return 0;
1618}
1619
1620int
864dbfa3 1621Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
463ee0b2 1622{
a0d0e21e
LW
1623 return magic_methpack(sv,mg,"DELETE");
1624}
463ee0b2 1625
93965878
NIS
1626
1627U32
864dbfa3 1628Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
ac27b0f5 1629{
27da23d5 1630 dVAR; dSP;
93965878
NIS
1631 U32 retval = 0;
1632
1633 ENTER;
1634 SAVETMPS;
e788e7d3 1635 PUSHSTACKi(PERLSI_MAGIC);
33c27489 1636 if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
3280af22 1637 sv = *PL_stack_sp--;
a60c0954 1638 retval = (U32) SvIV(sv)-1;
93965878 1639 }
d3acc0f7 1640 POPSTACK;
93965878
NIS
1641 FREETMPS;
1642 LEAVE;
1643 return retval;
1644}
1645
cea2e8a9
GS
1646int
1647Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e 1648{
27da23d5 1649 dVAR; dSP;
463ee0b2 1650
e336de0d 1651 ENTER;
e788e7d3 1652 PUSHSTACKi(PERLSI_MAGIC);
924508f0 1653 PUSHMARK(SP);
33c27489 1654 XPUSHs(SvTIED_obj(sv, mg));
463ee0b2 1655 PUTBACK;
864dbfa3 1656 call_method("CLEAR", G_SCALAR|G_DISCARD);
d3acc0f7 1657 POPSTACK;
a60c0954 1658 LEAVE;
a3bcc51e 1659
463ee0b2
LW
1660 return 0;
1661}
1662
1663int
864dbfa3 1664Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
463ee0b2 1665{
27da23d5 1666 dVAR; dSP;
666ea192 1667 const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
463ee0b2
LW
1668
1669 ENTER;
a0d0e21e 1670 SAVETMPS;
e788e7d3 1671 PUSHSTACKi(PERLSI_MAGIC);
924508f0
GS
1672 PUSHMARK(SP);
1673 EXTEND(SP, 2);
33c27489 1674 PUSHs(SvTIED_obj(sv, mg));
463ee0b2
LW
1675 if (SvOK(key))
1676 PUSHs(key);
1677 PUTBACK;
1678
864dbfa3 1679 if (call_method(meth, G_SCALAR))
3280af22 1680 sv_setsv(key, *PL_stack_sp--);
463ee0b2 1681
d3acc0f7 1682 POPSTACK;
a0d0e21e
LW
1683 FREETMPS;
1684 LEAVE;
79072805
LW
1685 return 0;
1686}
1687
1688int
1146e912 1689Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg)
a0d0e21e
LW
1690{
1691 return magic_methpack(sv,mg,"EXISTS");
ac27b0f5 1692}
a0d0e21e 1693
a3bcc51e
TP
1694SV *
1695Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1696{
27da23d5 1697 dVAR; dSP;
5fcbf73d 1698 SV *retval;
8772537c
AL
1699 SV * const tied = SvTIED_obj((SV*)hv, mg);
1700 HV * const pkg = SvSTASH((SV*)SvRV(tied));
a3bcc51e
TP
1701
1702 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1703 SV *key;
bfcb3514 1704 if (HvEITER_get(hv))
a3bcc51e
TP
1705 /* we are in an iteration so the hash cannot be empty */
1706 return &PL_sv_yes;
1707 /* no xhv_eiter so now use FIRSTKEY */
1708 key = sv_newmortal();
1709 magic_nextpack((SV*)hv, mg, key);
bfcb3514 1710 HvEITER_set(hv, NULL); /* need to reset iterator */
a3bcc51e
TP
1711 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1712 }
1713
1714 /* there is a SCALAR method that we can call */
1715 ENTER;
1716 PUSHSTACKi(PERLSI_MAGIC);
1717 PUSHMARK(SP);
1718 EXTEND(SP, 1);
1719 PUSHs(tied);
1720 PUTBACK;
1721
1722 if (call_method("SCALAR", G_SCALAR))
1723 retval = *PL_stack_sp--;
5fcbf73d
AL
1724 else
1725 retval = &PL_sv_undef;
a3bcc51e
TP
1726 POPSTACK;
1727 LEAVE;
1728 return retval;
1729}
1730
a0d0e21e 1731int
864dbfa3 1732Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
79072805 1733{
97aff369 1734 dVAR;
8772537c
AL
1735 GV * const gv = PL_DBline;
1736 const I32 i = SvTRUE(sv);
1737 SV ** const svp = av_fetch(GvAV(gv),
01b8bcb7 1738 atoi(MgPV_nolen_const(mg)), FALSE);
8772537c
AL
1739 if (svp && SvIOKp(*svp)) {
1740 OP * const o = INT2PTR(OP*,SvIVX(*svp));
1741 if (o) {
1742 /* set or clear breakpoint in the relevant control op */
1743 if (i)
1744 o->op_flags |= OPf_SPECIAL;
1745 else
1746 o->op_flags &= ~OPf_SPECIAL;
1747 }
5df8de69 1748 }
79072805
LW
1749 return 0;
1750}
1751
1752int
8772537c 1753Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
79072805 1754{
97aff369 1755 dVAR;
8772537c 1756 const AV * const obj = (AV*)mg->mg_obj;
83bf042f 1757 if (obj) {
fc15ae8f 1758 sv_setiv(sv, AvFILL(obj) + CopARYBASE_get(PL_curcop));
83bf042f
NC
1759 } else {
1760 SvOK_off(sv);
1761 }
79072805
LW
1762 return 0;
1763}
1764
1765int
864dbfa3 1766Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
79072805 1767{
97aff369 1768 dVAR;
8772537c 1769 AV * const obj = (AV*)mg->mg_obj;
83bf042f 1770 if (obj) {
fc15ae8f 1771 av_fill(obj, SvIV(sv) - CopARYBASE_get(PL_curcop));
83bf042f
NC
1772 } else {
1773 if (ckWARN(WARN_MISC))
1774 Perl_warner(aTHX_ packWARN(WARN_MISC),
1775 "Attempt to set length of freed array");
1776 }
1777 return 0;
1778}
1779
1780int
1781Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
1782{
97aff369 1783 dVAR;
53c1dcc0 1784 PERL_UNUSED_ARG(sv);
94f3782b
DM
1785 /* during global destruction, mg_obj may already have been freed */
1786 if (PL_in_clean_all)
1ea47f64 1787 return 0;
94f3782b 1788
83bf042f
NC
1789 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
1790
1791 if (mg) {
1792 /* arylen scalar holds a pointer back to the array, but doesn't own a
1793 reference. Hence the we (the array) are about to go away with it
1794 still pointing at us. Clear its pointer, else it would be pointing
1795 at free memory. See the comment in sv_magic about reference loops,
1796 and why it can't own a reference to us. */
1797 mg->mg_obj = 0;
1798 }
a0d0e21e
LW
1799 return 0;
1800}
1801
1802int
864dbfa3 1803Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e 1804{
97aff369 1805 dVAR;
8772537c 1806 SV* const lsv = LvTARG(sv);
3881461a 1807 PERL_UNUSED_ARG(mg);
ac27b0f5 1808
a0d0e21e 1809 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
3881461a
AL
1810 MAGIC * const found = mg_find(lsv, PERL_MAGIC_regex_global);
1811 if (found && found->mg_len >= 0) {
1812 I32 i = found->mg_len;
7e2040f0 1813 if (DO_UTF8(lsv))
a0ed51b3 1814 sv_pos_b2u(lsv, &i);
fc15ae8f 1815 sv_setiv(sv, i + CopARYBASE_get(PL_curcop));
a0d0e21e
LW
1816 return 0;
1817 }
1818 }
0c34ef67 1819 SvOK_off(sv);
a0d0e21e
LW
1820 return 0;
1821}
1822
1823int
864dbfa3 1824Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e 1825{
97aff369 1826 dVAR;
8772537c 1827 SV* const lsv = LvTARG(sv);
a0d0e21e
LW
1828 SSize_t pos;
1829 STRLEN len;
c00206c8 1830 STRLEN ulen = 0;
3881461a 1831 MAGIC *found;
a0d0e21e 1832
3881461a 1833 PERL_UNUSED_ARG(mg);
ac27b0f5 1834
a0d0e21e 1835 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
3881461a
AL
1836 found = mg_find(lsv, PERL_MAGIC_regex_global);
1837 else
1838 found = NULL;
1839 if (!found) {
a0d0e21e
LW
1840 if (!SvOK(sv))
1841 return 0;
d83f0a82
NC
1842#ifdef PERL_OLD_COPY_ON_WRITE
1843 if (SvIsCOW(lsv))
1844 sv_force_normal_flags(lsv, 0);
1845#endif
3881461a 1846 found = sv_magicext(lsv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
d83f0a82 1847 NULL, 0);
a0d0e21e
LW
1848 }
1849 else if (!SvOK(sv)) {
3881461a 1850 found->mg_len = -1;
a0d0e21e
LW
1851 return 0;
1852 }
1853 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1854
fc15ae8f 1855 pos = SvIV(sv) - CopARYBASE_get(PL_curcop);
a0ed51b3 1856
7e2040f0 1857 if (DO_UTF8(lsv)) {
a0ed51b3
LW
1858 ulen = sv_len_utf8(lsv);
1859 if (ulen)
1860 len = ulen;
a0ed51b3
LW
1861 }
1862
a0d0e21e
LW
1863 if (pos < 0) {
1864 pos += len;
1865 if (pos < 0)
1866 pos = 0;
1867 }
eb160463 1868 else if (pos > (SSize_t)len)
a0d0e21e 1869 pos = len;
a0ed51b3
LW
1870
1871 if (ulen) {
1872 I32 p = pos;
1873 sv_pos_u2b(lsv, &p, 0);
1874 pos = p;
1875 }
727405f8 1876
3881461a
AL
1877 found->mg_len = pos;
1878 found->mg_flags &= ~MGf_MINMATCH;
a0d0e21e 1879
79072805
LW
1880 return 0;
1881}
1882
1883int
864dbfa3 1884Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg)
79072805 1885{
79072805 1886 GV* gv;
8772537c
AL
1887 PERL_UNUSED_ARG(mg);
1888
79072805
LW
1889 if (!SvOK(sv))
1890 return 0;
180488f8
NC
1891 if (SvFLAGS(sv) & SVp_SCREAM
1892 && (SvTYPE(sv) == SVt_PVGV || SvTYPE(sv) == SVt_PVGV)) {
1893 /* We're actually already a typeglob, so don't need the stuff below.
1894 */
1895 return 0;
1896 }
f776e3cd 1897 gv = gv_fetchsv(sv, GV_ADD, SVt_PVGV);
79072805
LW
1898 if (sv == (SV*)gv)
1899 return 0;
1900 if (GvGP(sv))
88e89b8a 1901 gp_free((GV*)sv);
79072805 1902 GvGP(sv) = gp_ref(GvGP(gv));
79072805
LW
1903 return 0;
1904}
1905
1906int
864dbfa3 1907Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
6ff81951
GS
1908{
1909 STRLEN len;
35a4481c 1910 SV * const lsv = LvTARG(sv);
b83604b4 1911 const char * const tmps = SvPV_const(lsv,len);
6ff81951
GS
1912 I32 offs = LvTARGOFF(sv);
1913 I32 rem = LvTARGLEN(sv);
8772537c 1914 PERL_UNUSED_ARG(mg);
6ff81951 1915
9aa983d2
JH
1916 if (SvUTF8(lsv))
1917 sv_pos_u2b(lsv, &offs, &rem);
eb160463 1918 if (offs > (I32)len)
6ff81951 1919 offs = len;
eb160463 1920 if (rem + offs > (I32)len)
6ff81951
GS
1921 rem = len - offs;
1922 sv_setpvn(sv, tmps + offs, (STRLEN)rem);
9aa983d2 1923 if (SvUTF8(lsv))
2ef4b674 1924 SvUTF8_on(sv);
6ff81951
GS
1925 return 0;
1926}
1927
1928int
864dbfa3 1929Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
79072805 1930{
97aff369 1931 dVAR;
9aa983d2 1932 STRLEN len;
5fcbf73d 1933 const char * const tmps = SvPV_const(sv, len);
dd374669 1934 SV * const lsv = LvTARG(sv);
9aa983d2
JH
1935 I32 lvoff = LvTARGOFF(sv);
1936 I32 lvlen = LvTARGLEN(sv);
8772537c 1937 PERL_UNUSED_ARG(mg);
075a4a2b 1938
1aa99e6b 1939 if (DO_UTF8(sv)) {
9aa983d2
JH
1940 sv_utf8_upgrade(lsv);
1941 sv_pos_u2b(lsv, &lvoff, &lvlen);
1942 sv_insert(lsv, lvoff, lvlen, tmps, len);
b76f3ce2 1943 LvTARGLEN(sv) = sv_len_utf8(sv);
9aa983d2
JH
1944 SvUTF8_on(lsv);
1945 }
9bf12eaf 1946 else if (lsv && SvUTF8(lsv)) {
5fcbf73d 1947 const char *utf8;
9aa983d2 1948 sv_pos_u2b(lsv, &lvoff, &lvlen);
b76f3ce2 1949 LvTARGLEN(sv) = len;
5fcbf73d
AL
1950 utf8 = (char*)bytes_to_utf8((U8*)tmps, &len);
1951 sv_insert(lsv, lvoff, lvlen, utf8, len);
1952 Safefree(utf8);
1aa99e6b 1953 }
b76f3ce2
GB
1954 else {
1955 sv_insert(lsv, lvoff, lvlen, tmps, len);
1956 LvTARGLEN(sv) = len;
1957 }
1958
1aa99e6b 1959
79072805
LW
1960 return 0;
1961}
1962
1963int
864dbfa3 1964Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
463ee0b2 1965{
97aff369 1966 dVAR;
8772537c 1967 PERL_UNUSED_ARG(sv);
27cc343c 1968 TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
463ee0b2
LW
1969 return 0;
1970}
1971
1972int
864dbfa3 1973Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
463ee0b2 1974{
97aff369 1975 dVAR;
8772537c 1976 PERL_UNUSED_ARG(sv);
0a9c116b
DM
1977 /* update taint status unless we're restoring at scope exit */
1978 if (PL_localizing != 2) {
1979 if (PL_tainted)
1980 mg->mg_len |= 1;
1981 else
1982 mg->mg_len &= ~1;
1983 }
463ee0b2
LW
1984 return 0;
1985}
1986
1987int
864dbfa3 1988Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
6ff81951 1989{
35a4481c 1990 SV * const lsv = LvTARG(sv);
8772537c 1991 PERL_UNUSED_ARG(mg);
6ff81951 1992
6136c704
AL
1993 if (lsv)
1994 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
1995 else
0c34ef67 1996 SvOK_off(sv);
6ff81951 1997
6ff81951
GS
1998 return 0;
1999}
2000
2001int
864dbfa3 2002Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
79072805 2003{
8772537c 2004 PERL_UNUSED_ARG(mg);
79072805
LW
2005 do_vecset(sv); /* XXX slurp this routine */
2006 return 0;
2007}
2008
2009int
864dbfa3 2010Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
5f05dabc 2011{
97aff369 2012 dVAR;
a0714e2c 2013 SV *targ = NULL;
5f05dabc 2014 if (LvTARGLEN(sv)) {
68dc0745 2015 if (mg->mg_obj) {
8772537c
AL
2016 SV * const ahv = LvTARG(sv);
2017 HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
6d822dc4
MS
2018 if (he)
2019 targ = HeVAL(he);
68dc0745
PP
2020 }
2021 else {
8772537c 2022 AV* const av = (AV*)LvTARG(sv);
68dc0745
PP
2023 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
2024 targ = AvARRAY(av)[LvTARGOFF(sv)];
2025 }
46da273f 2026 if (targ && (targ != &PL_sv_undef)) {
68dc0745
PP
2027 /* somebody else defined it for us */
2028 SvREFCNT_dec(LvTARG(sv));
b37c2d43 2029 LvTARG(sv) = SvREFCNT_inc_simple_NN(targ);
68dc0745
PP
2030 LvTARGLEN(sv) = 0;
2031 SvREFCNT_dec(mg->mg_obj);
a0714e2c 2032 mg->mg_obj = NULL;
68dc0745
PP
2033 mg->mg_flags &= ~MGf_REFCOUNTED;
2034 }
5f05dabc 2035 }
71be2cbc
PP
2036 else
2037 targ = LvTARG(sv);
3280af22 2038 sv_setsv(sv, targ ? targ : &PL_sv_undef);
71be2cbc
PP
2039 return 0;
2040}
2041
2042int
864dbfa3 2043Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
71be2cbc 2044{
8772537c 2045 PERL_UNUSED_ARG(mg);
71be2cbc 2046 if (LvTARGLEN(sv))
68dc0745
PP
2047 vivify_defelem(sv);
2048 if (LvTARG(sv)) {
5f05dabc 2049 sv_setsv(LvTARG(sv), sv);
68dc0745
PP
2050 SvSETMAGIC(LvTARG(sv));
2051 }
5f05dabc
PP
2052 return 0;
2053}
2054
71be2cbc 2055void
864dbfa3 2056Perl_vivify_defelem(pTHX_ SV *sv)
71be2cbc 2057{
97aff369 2058 dVAR;
74e13ce4 2059 MAGIC *mg;
a0714e2c 2060 SV *value = NULL;
71be2cbc 2061
14befaf4 2062 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
71be2cbc 2063 return;
68dc0745 2064 if (mg->mg_obj) {
8772537c
AL
2065 SV * const ahv = LvTARG(sv);
2066 HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
6d822dc4
MS
2067 if (he)
2068 value = HeVAL(he);
3280af22 2069 if (!value || value == &PL_sv_undef)
ce5030a2 2070 Perl_croak(aTHX_ PL_no_helem_sv, mg->mg_obj);
71be2cbc 2071 }
68dc0745 2072 else {
8772537c 2073 AV* const av = (AV*)LvTARG(sv);
5aabfad6 2074 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
a0714e2c 2075 LvTARG(sv) = NULL; /* array can't be extended */
68dc0745 2076 else {
d4c19fe8 2077 SV* const * const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
3280af22 2078 if (!svp || (value = *svp) == &PL_sv_undef)
cea2e8a9 2079 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
68dc0745
PP
2080 }
2081 }
b37c2d43 2082 SvREFCNT_inc_simple_void(value);
68dc0745
PP
2083 SvREFCNT_dec(LvTARG(sv));
2084 LvTARG(sv) = value;
71be2cbc 2085 LvTARGLEN(sv) = 0;
68dc0745 2086 SvREFCNT_dec(mg->mg_obj);
a0714e2c 2087 mg->mg_obj = NULL;
68dc0745 2088 mg->mg_flags &= ~MGf_REFCOUNTED;
5f05dabc
PP
2089}
2090
2091int
864dbfa3 2092Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
810b8aa5 2093{
86f55936 2094 return Perl_sv_kill_backrefs(aTHX_ sv, (AV*)mg->mg_obj);
810b8aa5
GS
2095}
2096
2097int
864dbfa3 2098Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
93a17b20 2099{
96a5add6 2100 PERL_UNUSED_CONTEXT;
565764a8 2101 mg->mg_len = -1;
c6496cc7 2102 SvSCREAM_off(sv);
93a17b20
LW
2103 return 0;
2104}
2105
2106int
864dbfa3 2107Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
79072805 2108{
8772537c 2109 PERL_UNUSED_ARG(mg);
14befaf4 2110 sv_unmagic(sv, PERL_MAGIC_bm);
79072805
LW
2111 SvVALID_off(sv);
2112 return 0;
2113}
2114
2115int
864dbfa3 2116Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
55497cff 2117{
8772537c 2118 PERL_UNUSED_ARG(mg);
14befaf4 2119 sv_unmagic(sv, PERL_MAGIC_fm);
55497cff
PP
2120 SvCOMPILED_off(sv);
2121 return 0;
2122}
2123
2124int
864dbfa3 2125Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
79072805 2126{
35a4481c 2127 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
79072805
LW
2128
2129 if (uf && uf->uf_set)
24f81a43 2130 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
79072805
LW
2131 return 0;
2132}
2133
c277df42 2134int
faf82a0b
AE
2135Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2136{
8772537c 2137 PERL_UNUSED_ARG(mg);
faf82a0b
AE
2138 sv_unmagic(sv, PERL_MAGIC_qr);
2139 return 0;
2140}
2141
2142int
864dbfa3 2143Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
c277df42 2144{
97aff369 2145 dVAR;
8772537c
AL
2146 regexp * const re = (regexp *)mg->mg_obj;
2147 PERL_UNUSED_ARG(sv);
2148
c277df42
IZ
2149 ReREFCNT_dec(re);
2150 return 0;
2151}
2152
7a4c00b4 2153#ifdef USE_LOCALE_COLLATE
79072805 2154int
864dbfa3 2155Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
bbce6d69
PP
2156{
2157 /*
838b5b74 2158 * RenE<eacute> Descartes said "I think not."
bbce6d69
PP
2159 * and vanished with a faint plop.
2160 */
96a5add6 2161 PERL_UNUSED_CONTEXT;
8772537c 2162 PERL_UNUSED_ARG(sv);
7a4c00b4
PP
2163 if (mg->mg_ptr) {
2164 Safefree(mg->mg_ptr);
2165 mg->mg_ptr = NULL;
565764a8 2166 mg->mg_len = -1;
7a4c00b4 2167 }
bbce6d69
PP
2168 return 0;
2169}
7a4c00b4 2170#endif /* USE_LOCALE_COLLATE */
bbce6d69 2171
7e8c5dac
HS
2172/* Just clear the UTF-8 cache data. */
2173int
2174Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2175{
96a5add6 2176 PERL_UNUSED_CONTEXT;
8772537c 2177 PERL_UNUSED_ARG(sv);
7e8c5dac 2178 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
3881461a 2179 mg->mg_ptr = NULL;
7e8c5dac
HS
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{
97aff369 2187 dVAR;
e1ec3a88 2188 register const char *s;
79072805 2189 I32 i;
8990e307 2190 STRLEN len;
79072805 2191 switch (*mg->mg_ptr) {
748a9306 2192 case '\001': /* ^A */
3280af22 2193 sv_setsv(PL_bodytarget, sv);
748a9306 2194 break;
49460fe6 2195 case '\003': /* ^C */
38ab35f8 2196 PL_minus_c = (bool)SvIV(sv);
49460fe6
NIS
2197 break;
2198
79072805 2199 case '\004': /* ^D */
b4ab917c 2200#ifdef DEBUGGING
b83604b4 2201 s = SvPV_nolen_const(sv);
ddcf8bc1 2202 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
79072805 2203 DEBUG_x(dump_all());
b4ab917c 2204#else
38ab35f8 2205 PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG;
b4ab917c 2206#endif
79072805 2207 break;
28f23441 2208 case '\005': /* ^E */
d0063567 2209 if (*(mg->mg_ptr+1) == '\0') {
cd39f2b6 2210#ifdef MACOS_TRADITIONAL
38ab35f8 2211 gMacPerl_OSErr = SvIV(sv);
28f23441 2212#else
cd39f2b6 2213# ifdef VMS
38ab35f8 2214 set_vaxc_errno(SvIV(sv));
048c1ddf 2215# else
cd39f2b6 2216# ifdef WIN32
d0063567 2217 SetLastError( SvIV(sv) );
cd39f2b6 2218# else
9fed8b87 2219# ifdef OS2
38ab35f8 2220 os2_setsyserrno(SvIV(sv));
9fed8b87 2221# else
d0063567 2222 /* will anyone ever use this? */
38ab35f8 2223 SETERRNO(SvIV(sv), 4);
cd39f2b6 2224# endif
048c1ddf
IZ
2225# endif
2226# endif
22fae026 2227#endif
d0063567
DK
2228 }
2229 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2230 if (PL_encoding)
2231 SvREFCNT_dec(PL_encoding);
2232 if (SvOK(sv) || SvGMAGICAL(sv)) {
2233 PL_encoding = newSVsv(sv);
2234 }
2235 else {
a0714e2c 2236 PL_encoding = NULL;
d0063567
DK
2237 }
2238 }
2239 break;
79072805 2240 case '\006': /* ^F */
38ab35f8 2241 PL_maxsysfd = SvIV(sv);
79072805 2242 break;
a0d0e21e 2243 case '\010': /* ^H */
38ab35f8 2244 PL_hints = SvIV(sv);
a0d0e21e 2245 break;
9d116dd7 2246 case '\011': /* ^I */ /* NOT \t in EBCDIC */
43c5f42d 2247 Safefree(PL_inplace);
bd61b366 2248 PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
da78da6e 2249 break;
28f23441 2250 case '\017': /* ^O */
ac27b0f5 2251 if (*(mg->mg_ptr+1) == '\0') {
43c5f42d 2252 Safefree(PL_osname);
bd61b366 2253 PL_osname = NULL;
3511154c
DM
2254 if (SvOK(sv)) {
2255 TAINT_PROPER("assigning to $^O");
2e0de35c 2256 PL_osname = savesvpv(sv);
3511154c 2257 }
ac27b0f5
NIS
2258 }
2259 else if (strEQ(mg->mg_ptr, "\017PEN")) {
11bcd5da
NC
2260 PL_compiling.cop_hints |= HINT_LEXICAL_IO;
2261 PL_hints |= HINT_LOCALIZE_HH | HINT_LEXICAL_IO;
2262 PL_compiling.cop_hints_hash
2263 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
2264 sv_2mortal(newSVpvs("open")), sv);
ac27b0f5 2265 }
28f23441 2266 break;
79072805 2267 case '\020': /* ^P */
38ab35f8 2268 PL_perldb = SvIV(sv);
f2a7f298 2269 if (PL_perldb && !PL_DBsingle)
1ee4443e 2270 init_debugger();
79072805
LW
2271 break;
2272 case '\024': /* ^T */
88e89b8a 2273#ifdef BIG_TIME
6b88bc9c 2274 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
88e89b8a 2275#else
38ab35f8 2276 PL_basetime = (Time_t)SvIV(sv);
88e89b8a 2277#endif
79072805 2278 break;
e07ea26a
NC
2279 case '\025': /* ^UTF8CACHE */
2280 if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
2281 PL_utf8cache = (signed char) sv_2iv(sv);
2282 }
2283 break;
fde18df1 2284 case '\027': /* ^W & $^WARNING_BITS */
4438c4b7
JH
2285 if (*(mg->mg_ptr+1) == '\0') {
2286 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
38ab35f8 2287 i = SvIV(sv);
ac27b0f5 2288 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
0453d815 2289 | (i ? G_WARN_ON : G_WARN_OFF) ;
4438c4b7 2290 }
599cee73 2291 }
0a378802 2292 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
4438c4b7 2293 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
d775746e
GS
2294 if (!SvPOK(sv) && PL_localizing) {
2295 sv_setpvn(sv, WARN_NONEstring, WARNsize);
d3a7d8c7 2296 PL_compiling.cop_warnings = pWARN_NONE;
d775746e
GS
2297 break;
2298 }
f4fc7782 2299 {
b5477537 2300 STRLEN len, i;
d3a7d8c7 2301 int accumulate = 0 ;
f4fc7782 2302 int any_fatals = 0 ;
b83604b4 2303 const char * const ptr = SvPV_const(sv, len) ;
f4fc7782
JH
2304 for (i = 0 ; i < len ; ++i) {
2305 accumulate |= ptr[i] ;
2306 any_fatals |= (ptr[i] & 0xAA) ;
2307 }
4243c432
NC
2308 if (!accumulate) {
2309 if (!specialWARN(PL_compiling.cop_warnings))
2310 PerlMemShared_free(PL_compiling.cop_warnings);
2311 PL_compiling.cop_warnings = pWARN_NONE;
2312 }
72dc9ed5
NC
2313 /* Yuck. I can't see how to abstract this: */
2314 else if (isWARN_on(((STRLEN *)SvPV_nolen_const(sv)) - 1,
2315 WARN_ALL) && !any_fatals) {
4243c432
NC
2316 if (!specialWARN(PL_compiling.cop_warnings))
2317 PerlMemShared_free(PL_compiling.cop_warnings);
f4fc7782
JH
2318 PL_compiling.cop_warnings = pWARN_ALL;
2319 PL_dowarn |= G_WARN_ONCE ;
727405f8 2320 }
d3a7d8c7 2321 else {
72dc9ed5
NC
2322 STRLEN len;
2323 const char *const p = SvPV_const(sv, len);
2324
2325 PL_compiling.cop_warnings
8ee4cf24 2326 = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
72dc9ed5
NC
2327 p, len);
2328
d3a7d8c7
GS
2329 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2330 PL_dowarn |= G_WARN_ONCE ;
2331 }
f4fc7782 2332
d3a7d8c7 2333 }
4438c4b7 2334 }
971a9dd3 2335 }
79072805
LW
2336 break;
2337 case '.':
3280af22
NIS
2338 if (PL_localizing) {
2339 if (PL_localizing == 1)
7766f137 2340 SAVESPTR(PL_last_in_gv);
748a9306 2341 }
3280af22 2342 else if (SvOK(sv) && GvIO(PL_last_in_gv))
632db599 2343 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
79072805
LW
2344 break;
2345 case '^':
3280af22 2346 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
e1ec3a88 2347 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
f776e3cd 2348 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
79072805
LW
2349 break;
2350 case '~':
3280af22 2351 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
e1ec3a88 2352 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
f776e3cd 2353 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
79072805
LW
2354 break;
2355 case '=':
38ab35f8 2356 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
79072805
LW
2357 break;
2358 case '-':
38ab35f8 2359 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
3280af22
NIS
2360 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2361 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
79072805
LW
2362 break;
2363 case '%':
38ab35f8 2364 IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
79072805
LW
2365 break;
2366 case '|':
4b65379b 2367 {
8772537c 2368 IO * const io = GvIOp(PL_defoutgv);
720f287d
AB
2369 if(!io)
2370 break;
38ab35f8 2371 if ((SvIV(sv)) == 0)
4b65379b
CS
2372 IoFLAGS(io) &= ~IOf_FLUSH;
2373 else {
2374 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2375 PerlIO *ofp = IoOFP(io);
2376 if (ofp)
2377 (void)PerlIO_flush(ofp);
2378 IoFLAGS(io) |= IOf_FLUSH;
2379 }
2380 }
79072805
LW
2381 }
2382 break;
79072805 2383 case '/':
3280af22 2384 SvREFCNT_dec(PL_rs);
8bfdd7d9 2385 PL_rs = newSVsv(sv);
79072805
LW
2386 break;
2387 case '\\':
7889fe52
NIS
2388 if (PL_ors_sv)
2389 SvREFCNT_dec(PL_ors_sv);
009c130f 2390 if (SvOK(sv) || SvGMAGICAL(sv)) {
7889fe52 2391 PL_ors_sv = newSVsv(sv);
009c130f 2392 }
e3c19b7b 2393 else {
a0714e2c 2394 PL_ors_sv = NULL;
e3c19b7b 2395 }
79072805
LW
2396 break;
2397 case ',':
7889fe52
NIS
2398 if (PL_ofs_sv)
2399 SvREFCNT_dec(PL_ofs_sv);
2400 if (SvOK(sv) || SvGMAGICAL(sv)) {
2401 PL_ofs_sv = newSVsv(sv);
2402 }
2403 else {
a0714e2c 2404 PL_ofs_sv = NULL;
7889fe52 2405 }
79072805 2406 break;
79072805 2407 case '[':
38ab35f8 2408 CopARYBASE_set(&PL_compiling, SvIV(sv));
79072805
LW
2409 break;
2410 case '?':
ff0cee69 2411#ifdef COMPLEX_STATUS
6b88bc9c
GS
2412 if (PL_localizing == 2) {
2413 PL_statusvalue = LvTARGOFF(sv);
2414 PL_statusvalue_vms = LvTARGLEN(sv);
ff0cee69
PP
2415 }
2416 else
2417#endif
2418#ifdef VMSISH_STATUS
2419 if (VMSISH_STATUS)
fb38d079 2420 STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
ff0cee69
PP
2421 else
2422#endif
38ab35f8 2423 STATUS_UNIX_EXIT_SET(SvIV(sv));
79072805
LW
2424 break;
2425 case '!':
93189314
JH
2426 {
2427#ifdef VMS
2428# define PERL_VMS_BANG vaxc$errno
2429#else
2430# define PERL_VMS_BANG 0
2431#endif
91487cfc 2432 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
93189314
JH
2433 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2434 }
79072805
LW
2435 break;
2436 case '<':
38ab35f8 2437 PL_uid = SvIV(sv);
3280af22
NIS
2438 if (PL_delaymagic) {
2439 PL_delaymagic |= DM_RUID;
79072805
LW
2440 break; /* don't do magic till later */
2441 }
2442#ifdef HAS_SETRUID
b28d0864 2443 (void)setruid((Uid_t)PL_uid);
79072805
LW
2444#else
2445#ifdef HAS_SETREUID
3280af22 2446 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
748a9306 2447#else
85e6fe83 2448#ifdef HAS_SETRESUID
b28d0864 2449 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
79072805 2450#else
75870ed3 2451 if (PL_uid == PL_euid) { /* special case $< = $> */
2452#ifdef PERL_DARWIN
2453 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2454 if (PL_uid != 0 && PerlProc_getuid() == 0)
2455 (void)PerlProc_setuid(0);
2456#endif
b28d0864 2457 (void)PerlProc_setuid(PL_uid);
75870ed3 2458 } else {
d8eceb89 2459 PL_uid = PerlProc_getuid();
cea2e8a9 2460 Perl_croak(aTHX_ "setruid() not implemented");
a0d0e21e 2461 }
79072805
LW
2462#endif
2463#endif
85e6fe83 2464#endif
d8eceb89 2465 PL_uid = PerlProc_getuid();
3280af22 2466 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
79072805
LW
2467 break;
2468 case '>':
38ab35f8 2469 PL_euid = SvIV(sv);
3280af22
NIS
2470 if (PL_delaymagic) {
2471 PL_delaymagic |= DM_EUID;
79072805
LW
2472 break; /* don't do magic till later */
2473 }
2474#ifdef HAS_SETEUID
3280af22 2475 (void)seteuid((Uid_t)PL_euid);
79072805
LW
2476#else
2477#ifdef HAS_SETREUID
b28d0864 2478 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
85e6fe83
LW
2479#else
2480#ifdef HAS_SETRESUID
6b88bc9c 2481 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
79072805 2482#else
b28d0864
NIS
2483 if (PL_euid == PL_uid) /* special case $> = $< */
2484 PerlProc_setuid(PL_euid);
a0d0e21e 2485 else {
e8ee3774 2486 PL_euid = PerlProc_geteuid();
cea2e8a9 2487 Perl_croak(aTHX_ "seteuid() not implemented");
a0d0e21e 2488 }
79072805
LW
2489#endif
2490#endif
85e6fe83 2491#endif
d8eceb89 2492 PL_euid = PerlProc_geteuid();
3280af22 2493 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
79072805
LW
2494 break;
2495 case '(':
38ab35f8 2496 PL_gid = SvIV(sv);
3280af22
NIS
2497 if (PL_delaymagic) {
2498 PL_delaymagic |= DM_RGID;
79072805
LW
2499 break; /* don't do magic till later */
2500 }
2501#ifdef HAS_SETRGID
b28d0864 2502 (void)setrgid((Gid_t)PL_gid);
79072805
LW
2503#else
2504#ifdef HAS_SETREGID
3280af22 2505 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
85e6fe83
LW
2506#else
2507#ifdef HAS_SETRESGID
b28d0864 2508 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
79072805 2509#else
b28d0864
NIS
2510 if (PL_gid == PL_egid) /* special case $( = $) */
2511 (void)PerlProc_setgid(PL_gid);
748a9306 2512 else {
d8eceb89 2513 PL_gid = PerlProc_getgid();
cea2e8a9 2514 Perl_croak(aTHX_ "setrgid() not implemented");
748a9306 2515 }
79072805
LW
2516#endif
2517#endif
85e6fe83 2518#endif
d8eceb89 2519 PL_gid = PerlProc_getgid();
3280af22 2520 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
79072805
LW
2521 break;
2522 case ')':
5cd24f17
PP
2523#ifdef HAS_SETGROUPS
2524 {
b83604b4 2525 const char *p = SvPV_const(sv, len);
757f63d8
SP
2526 Groups_t *gary = NULL;
2527
2528 while (isSPACE(*p))
2529 ++p;
2530 PL_egid = Atol(p);
2531 for (i = 0; i < NGROUPS; ++i) {
2532 while (*p && !isSPACE(*p))
2533 ++p;
2534 while (isSPACE(*p))
2535 ++p;
2536 if (!*p)
2537 break;
2538 if(!gary)
2539 Newx(gary, i + 1, Groups_t);
2540 else
2541 Renew(gary, i + 1, Groups_t);
2542 gary[i] = Atol(p);
2543 }
2544 if (i)
2545 (void)setgroups(i, gary);
f5a63d97 2546 Safefree(gary);
5cd24f17
PP
2547 }
2548#else /* HAS_SETGROUPS */
38ab35f8 2549 PL_egid = SvIV(sv);
5cd24f17 2550#endif /* HAS_SETGROUPS */
3280af22
NIS
2551 if (PL_delaymagic) {
2552 PL_delaymagic |= DM_EGID;
79072805
LW
2553 break; /* don't do magic till later */
2554 }
2555#ifdef HAS_SETEGID
3280af22 2556 (void)setegid((Gid_t)PL_egid);
79072805
LW
2557#else
2558#ifdef HAS_SETREGID
b28d0864 2559 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
85e6fe83
LW
2560#else
2561#ifdef HAS_SETRESGID
b28d0864 2562 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
79072805 2563#else
b28d0864
NIS
2564 if (PL_egid == PL_gid) /* special case $) = $( */
2565 (void)PerlProc_setgid(PL_egid);
748a9306 2566 else {
d8eceb89 2567 PL_egid = PerlProc_getegid();
cea2e8a9 2568 Perl_croak(aTHX_ "setegid() not implemented");
748a9306 2569 }
79072805
LW
2570#endif
2571#endif
85e6fe83 2572#endif
d8eceb89 2573 PL_egid = PerlProc_getegid();
3280af22 2574 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
79072805
LW
2575 break;
2576 case ':':
2d8e6c8d 2577 PL_chopset = SvPV_force(sv,len);
79072805 2578 break;
cd39f2b6 2579#ifndef MACOS_TRADITIONAL
79072805 2580 case '0':
e2975953 2581 LOCK_DOLLARZERO_MUTEX;
4bc88a62
PS
2582#ifdef HAS_SETPROCTITLE
2583 /* The BSDs don't show the argv[] in ps(1) output, they
2584 * show a string from the process struct and provide
2585 * the setproctitle() routine to manipulate that. */
a2722ac9 2586 if (PL_origalen != 1) {
b83604b4 2587 s = SvPV_const(sv, len);
98b76f99 2588# if __FreeBSD_version > 410001
9aad2c0e 2589 /* The leading "-" removes the "perl: " prefix,
4bc88a62
PS
2590 * but not the "(perl) suffix from the ps(1)
2591 * output, because that's what ps(1) shows if the
2592 * argv[] is modified. */
6f2ad931 2593 setproctitle("-%s", s);
9aad2c0e 2594# else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
4bc88a62
PS
2595 /* This doesn't really work if you assume that
2596 * $0 = 'foobar'; will wipe out 'perl' from the $0
2597 * because in ps(1) output the result will be like
2598 * sprintf("perl: %s (perl)", s)
2599 * I guess this is a security feature:
2600 * one (a user process) cannot get rid of the original name.
2601 * --jhi */
2602 setproctitle("%s", s);
2603# endif
2604 }
2605#endif
17aa7f3d 2606#if defined(__hpux) && defined(PSTAT_SETCMD)
a2722ac9 2607 if (PL_origalen != 1) {
17aa7f3d 2608 union pstun un;
b83604b4 2609 s = SvPV_const(sv, len);
6867be6d 2610 un.pst_command = (char *)s;
17aa7f3d
JH
2611 pstat(PSTAT_SETCMD, un, len, 0, 0);
2612 }
2613#endif
2d2af554
GA
2614 if (PL_origalen > 1) {
2615 /* PL_origalen is set in perl_parse(). */
2616 s = SvPV_force(sv,len);
2617 if (len >= (STRLEN)PL_origalen-1) {
2618 /* Longer than original, will be truncated. We assume that
2619 * PL_origalen bytes are available. */
2620 Copy(s, PL_origargv[0], PL_origalen-1, char);
2621 }
2622 else {
2623 /* Shorter than original, will be padded. */
2624 Copy(s, PL_origargv[0], len, char);
2625 PL_origargv[0][len] = 0;
2626 memset(PL_origargv[0] + len + 1,
2627 /* Is the space counterintuitive? Yes.
2628 * (You were expecting \0?)
2629 * Does it work? Seems to. (In Linux 2.4.20 at least.)
2630 * --jhi */
2631 (int)' ',
2632 PL_origalen - len - 1);
2633 }
2634 PL_origargv[0][PL_origalen-1] = 0;
2635 for (i = 1; i < PL_origargc; i++)
2636 PL_origargv[i] = 0;
79072805 2637 }
e2975953 2638 UNLOCK_DOLLARZERO_MUTEX;
79072805 2639 break;
cd39f2b6 2640#endif
79072805
LW
2641 }
2642 return 0;
2643}
2644
2645I32
35a4481c 2646Perl_whichsig(pTHX_ const char *sig)
79072805 2647{
aadb217d 2648 register char* const* sigv;
96a5add6 2649 PERL_UNUSED_CONTEXT;
79072805 2650
aadb217d 2651 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
79072805 2652 if (strEQ(sig,*sigv))
aadb217d 2653 return PL_sig_num[sigv - (char* const*)PL_sig_name];
79072805
LW
2654#ifdef SIGCLD
2655 if (strEQ(sig,"CHLD"))
2656 return SIGCLD;
2657#endif
2658#ifdef SIGCHLD
2659 if (strEQ(sig,"CLD"))
2660 return SIGCHLD;
2661#endif
7f1236c0 2662 return -1;
79072805
LW
2663}
2664
ecfc5424 2665Signal_t
1e82f5a6 2666#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
8aad04aa 2667Perl_sighandler(int sig, ...)
1e82f5a6
SH
2668#else
2669Perl_sighandler(int sig)
2670#endif
79072805 2671{
1018e26f
NIS
2672#ifdef PERL_GET_SIG_CONTEXT
2673 dTHXa(PERL_GET_SIG_CONTEXT);
71d280e3 2674#else
cea2e8a9 2675 dTHX;
71d280e3 2676#endif
79072805 2677 dSP;
a0714e2c
SS
2678 GV *gv = NULL;
2679 SV *sv = NULL;
8772537c 2680 SV * const tSv = PL_Sv;
601f1833 2681 CV *cv = NULL;
533c011a 2682 OP *myop = PL_op;
84902520 2683 U32 flags = 0;
8772537c 2684 XPV * const tXpv = PL_Xpv;
71d280e3 2685
3280af22 2686 if (PL_savestack_ix + 15 <= PL_savestack_max)
84902520 2687 flags |= 1;
3280af22 2688 if (PL_markstack_ptr < PL_markstack_max - 2)
84902520 2689 flags |= 4;
3280af22 2690 if (PL_scopestack_ix < PL_scopestack_max - 3)
84902520
TB
2691 flags |= 16;
2692
727405f8 2693 if (!PL_psig_ptr[sig]) {
99ef548b 2694 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
727405f8
NIS
2695 PL_sig_name[sig]);
2696 exit(sig);
2697 }
ff0cee69 2698
84902520
TB
2699 /* Max number of items pushed there is 3*n or 4. We cannot fix
2700 infinity, so we fix 4 (in fact 5): */
2701 if (flags & 1) {
3280af22 2702 PL_savestack_ix += 5; /* Protect save in progress. */
8772537c 2703 SAVEDESTRUCTOR_X(S_unwind_handler_stack, (void*)&flags);
84902520 2704 }
ac27b0f5 2705 if (flags & 4)
3280af22 2706 PL_markstack_ptr++; /* Protect mark. */
84902520 2707 if (flags & 16)
3280af22 2708 PL_scopestack_ix += 1;
84902520 2709 /* sv_2cv is too complicated, try a simpler variant first: */
ac27b0f5 2710 if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
8772537c
AL
2711 || SvTYPE(cv) != SVt_PVCV) {
2712 HV *st;
f2c0649b 2713 cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
8772537c 2714 }
84902520 2715
a0d0e21e 2716 if (!cv || !CvROOT(cv)) {
599cee73 2717 if (ckWARN(WARN_SIGNAL))
9014280d 2718 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
22c35a8c 2719 PL_sig_name[sig], (gv ? GvENAME(gv)
00d579c5
GS
2720 : ((cv && CvGV(cv))
2721 ? GvENAME(CvGV(cv))
2722 : "__ANON__")));
2723 goto cleanup;
79072805
LW
2724 }
2725
22c35a8c 2726 if(PL_psig_name[sig]) {
b37c2d43 2727 sv = SvREFCNT_inc_NN(PL_psig_name[sig]);
84902520 2728 flags |= 64;
df3728a2 2729#if !defined(PERL_IMPLICIT_CONTEXT)
27da23d5 2730 PL_sig_sv = sv;
df3728a2 2731#endif
84902520 2732 } else {
ff0cee69 2733 sv = sv_newmortal();
22c35a8c 2734 sv_setpv(sv,PL_sig_name[sig]);
88e89b8a 2735 }
e336de0d 2736
e788e7d3 2737 PUSHSTACKi(PERLSI_SIGNAL);
924508f0 2738 PUSHMARK(SP);
79072805 2739 PUSHs(sv);
8aad04aa
JH
2740#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2741 {
2742 struct sigaction oact;
2743
2744 if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
2745 siginfo_t *sip;
2746 va_list args;
2747
2748 va_start(args, sig);
2749 sip = (siginfo_t*)va_arg(args, siginfo_t*);
2750 if (sip) {
2751 HV *sih = newHV();
2752 SV *rv = newRV_noinc((SV*)sih);
2753 /* The siginfo fields signo, code, errno, pid, uid,
2754 * addr, status, and band are defined by POSIX/SUSv3. */
2755 hv_store(sih, "signo", 5, newSViv(sip->si_signo), 0);
2756 hv_store(sih, "code", 4, newSViv(sip->si_code), 0);
79dec0f4 2757#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 2758 hv_store(sih, "errno", 5, newSViv(sip->si_errno), 0);
79dec0f4 2759 hv_store(sih, "status", 6, newSViv(sip->si_status), 0);
8aad04aa
JH
2760 hv_store(sih, "uid", 3, newSViv(sip->si_uid), 0);
2761 hv_store(sih, "pid", 3, newSViv(sip->si_pid), 0);
2762 hv_store(sih, "addr", 4, newSVuv(PTR2UV(sip->si_addr)), 0);
8aad04aa 2763 hv_store(sih, "band", 4, newSViv(sip->si_band), 0);
79dec0f4 2764#endif
8aad04aa
JH
2765 EXTEND(SP, 2);
2766 PUSHs((SV*)rv);
10edeb5d 2767 PUSHs(newSVpv((char *)sip, sizeof(*sip)));
8aad04aa 2768 }
b4552a27 2769
31427afe 2770 va_end(args);
8aad04aa
JH
2771 }
2772 }
2773#endif
79072805 2774 PUTBACK;
a0d0e21e 2775
1b266415 2776 call_sv((SV*)cv, G_DISCARD|G_EVAL);
79072805 2777
d3acc0f7 2778 POPSTACK;
1b266415 2779 if (SvTRUE(ERRSV)) {
1d615522 2780#ifndef PERL_MICRO
983dbef6 2781#ifdef HAS_SIGPROCMASK
1b266415
NIS
2782 /* Handler "died", for example to get out of a restart-able read().
2783 * Before we re-do that on its behalf re-enable the signal which was
2784 * blocked by the system when we entered.
2785 */
2786 sigset_t set;
2787 sigemptyset(&set);
2788 sigaddset(&set,sig);
2789 sigprocmask(SIG_UNBLOCK, &set, NULL);
2790#else
2791 /* Not clear if this will work */
2792 (void)rsignal(sig, SIG_IGN);
5c1546dc 2793 (void)rsignal(sig, PL_csighandlerp);
1b266415 2794#endif
1d615522 2795#endif /* !PERL_MICRO */
bd61b366 2796 Perl_die(aTHX_ NULL);
1b266415 2797 }
00d579c5 2798cleanup:
84902520 2799 if (flags & 1)
3280af22 2800 PL_savestack_ix -= 8; /* Unprotect save in progress. */
ac27b0f5 2801 if (flags & 4)
3280af22 2802 PL_markstack_ptr--;
84902520 2803 if (flags & 16)
3280af22 2804 PL_scopestack_ix -= 1;
84902520
TB
2805 if (flags & 64)
2806 SvREFCNT_dec(sv);
533c011a 2807 PL_op = myop; /* Apparently not needed... */
ac27b0f5 2808
3280af22
NIS
2809 PL_Sv = tSv; /* Restore global temporaries. */
2810 PL_Xpv = tXpv;
53bb94e2 2811 return;
79072805 2812}
4e35701f
NIS
2813
2814
51371543 2815static void
8772537c 2816S_restore_magic(pTHX_ const void *p)
51371543 2817{
97aff369 2818 dVAR;
8772537c
AL
2819 MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
2820 SV* const sv = mgs->mgs_sv;
51371543
GS
2821
2822 if (!sv)
2823 return;
2824
2825 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2826 {
f8c7b90f 2827#ifdef PERL_OLD_COPY_ON_WRITE
f9701176
NC
2828 /* While magic was saved (and off) sv_setsv may well have seen
2829 this SV as a prime candidate for COW. */
2830 if (SvIsCOW(sv))
e424a81e 2831 sv_force_normal_flags(sv, 0);
f9701176
NC
2832#endif
2833
51371543
GS
2834 if (mgs->mgs_flags)
2835 SvFLAGS(sv) |= mgs->mgs_flags;
2836 else
2837 mg_magical(sv);
2b77b520
YST
2838 if (SvGMAGICAL(sv)) {
2839 /* downgrade public flags to private,
2840 and discard any other private flags */
2841
10edeb5d
JH
2842 const U32 pubflags = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
2843 if (pubflags) {
2844 SvFLAGS(sv) &= ~( pubflags | (SVp_IOK|SVp_NOK|SVp_POK) );
2845 SvFLAGS(sv) |= ( pubflags << PRIVSHIFT );
2b77b520
YST
2846 }
2847 }
51371543
GS
2848 }
2849
2850 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
2851
2852 /* If we're still on top of the stack, pop us off. (That condition
2853 * will be satisfied if restore_magic was called explicitly, but *not*
2854 * if it's being called via leave_scope.)
2855 * The reason for doing this is that otherwise, things like sv_2cv()
2856 * may leave alloc gunk on the savestack, and some code
2857 * (e.g. sighandler) doesn't expect that...
2858 */
2859 if (PL_savestack_ix == mgs->mgs_ss_ix)
2860 {
2861 I32 popval = SSPOPINT;
c76ac1ee 2862 assert(popval == SAVEt_DESTRUCTOR_X);
51371543
GS
2863 PL_savestack_ix -= 2;
2864 popval = SSPOPINT;
2865 assert(popval == SAVEt_ALLOC);
2866 popval = SSPOPINT;
2867 PL_savestack_ix -= popval;
2868 }
2869
2870}
2871
2872static void
8772537c 2873S_unwind_handler_stack(pTHX_ const void *p)
51371543 2874{
27da23d5 2875 dVAR;
e1ec3a88 2876 const U32 flags = *(const U32*)p;
51371543
GS
2877
2878 if (flags & 1)
2879 PL_savestack_ix -= 5; /* Unprotect save in progress. */
df3728a2 2880#if !defined(PERL_IMPLICIT_CONTEXT)
51371543 2881 if (flags & 64)
27da23d5 2882 SvREFCNT_dec(PL_sig_sv);
df3728a2 2883#endif
51371543 2884}
1018e26f 2885
66610fdd 2886/*
b3ca2e83
NC
2887=for apidoc magic_sethint
2888
2889Triggered by a store to %^H, records the key/value pair to
c28fe1ec
NC
2890C<PL_compiling.cop_hints_hash>. It is assumed that hints aren't storing
2891anything that would need a deep copy. Maybe we should warn if we find a
2892reference.
b3ca2e83
NC
2893
2894=cut
2895*/
2896int
2897Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
2898{
2899 dVAR;
2900 assert(mg->mg_len == HEf_SVKEY);
2901
e6e3e454
NC
2902 /* mg->mg_obj isn't being used. If needed, it would be possible to store
2903 an alternative leaf in there, with PL_compiling.cop_hints being used if
2904 it's NULL. If needed for threads, the alternative could lock a mutex,
2905 or take other more complex action. */
2906
5b9c0671
NC
2907 /* Something changed in %^H, so it will need to be restored on scope exit.
2908 Doing this here saves a lot of doing it manually in perl code (and
2909 forgetting to do it, and consequent subtle errors. */
2910 PL_hints |= HINT_LOCALIZE_HH;
c28fe1ec
NC
2911 PL_compiling.cop_hints_hash
2912 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
ec2a1de7 2913 (SV *)mg->mg_ptr, sv);
b3ca2e83
NC
2914 return 0;
2915}
2916
2917/*
2918=for apidoc magic_sethint
2919
c28fe1ec
NC
2920Triggered by a delete from %^H, records the key to
2921C<PL_compiling.cop_hints_hash>.
b3ca2e83
NC
2922
2923=cut
2924*/
2925int
2926Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
2927{
2928 dVAR;
f5a63d97
AL
2929 PERL_UNUSED_ARG(sv);
2930
b3ca2e83
NC
2931 assert(mg->mg_len == HEf_SVKEY);
2932
b3f24c00
MHM
2933 PERL_UNUSED_ARG(sv);
2934
5b9c0671 2935 PL_hints |= HINT_LOCALIZE_HH;
c28fe1ec
NC
2936 PL_compiling.cop_hints_hash
2937 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
b3ca2e83
NC
2938 (SV *)mg->mg_ptr, &PL_sv_placeholder);
2939 return 0;
2940}
2941
2942/*
66610fdd
RGS
2943 * Local variables:
2944 * c-indentation-style: bsd
2945 * c-basic-offset: 4
2946 * indent-tabs-mode: t
2947 * End:
2948 *
37442d52
RGS
2949 * ex: set ts=8 sts=4 sw=4 noet:
2950 */