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