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