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