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