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