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