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