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