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