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