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