This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
new thread should set current interp in TLS
[perl5.git] / mg.c
CommitLineData
a0d0e21e 1/* mg.c
79072805 2 *
4eb8286e 3 * Copyright (c) 1991-1999, Larry Wall
79072805
LW
4 *
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
7 *
a0d0e21e
LW
8 */
9
10/*
11 * "Sam sat on the ground and put his head in his hands. 'I wish I had never
12 * come here, and I don't want to see no more magic,' he said, and fell silent."
79072805
LW
13 */
14
15#include "EXTERN.h"
864dbfa3 16#define PERL_IN_MG_C
79072805
LW
17#include "perl.h"
18
e6d9441c 19/* XXX If this causes problems, set i_unistd=undef in the hint file. */
a0d0e21e
LW
20#ifdef I_UNISTD
21# include <unistd.h>
22#endif
a0d0e21e 23
5cd24f17 24#if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS)
188ea221
CS
25# ifndef NGROUPS
26# define NGROUPS 32
27# endif
28#endif
29
455ece5e
AD
30#ifdef PERL_OBJECT
31# define VTBL this->*vtbl
32#else
33# define VTBL *vtbl
455ece5e
AD
34#endif
35
51371543
GS
36static void restore_magic(pTHXo_ void *p);
37static void unwind_handler_stack(pTHXo_ void *p);
38
c07a80fd
PP
39/*
40 * Use the "DESTRUCTOR" scope cleanup to reinstate magic.
41 */
42
43struct magic_state {
44 SV* mgs_sv;
45 U32 mgs_flags;
455ece5e 46 I32 mgs_ss_ix;
c07a80fd 47};
455ece5e 48/* MGS is typedef'ed to struct magic_state in perl.h */
76e3520e
GS
49
50STATIC void
cea2e8a9 51S_save_magic(pTHX_ I32 mgs_ix, SV *sv)
c07a80fd 52{
46124e9e 53 dTHR;
455ece5e 54 MGS* mgs;
c07a80fd
PP
55 assert(SvMAGICAL(sv));
56
51371543 57 SAVEDESTRUCTOR(restore_magic, (void*)mgs_ix);
455ece5e
AD
58
59 mgs = SSPTR(mgs_ix, MGS*);
c07a80fd
PP
60 mgs->mgs_sv = sv;
61 mgs->mgs_flags = SvMAGICAL(sv) | SvREADONLY(sv);
455ece5e 62 mgs->mgs_ss_ix = PL_savestack_ix; /* points after the saved destructor */
c07a80fd
PP
63
64 SvMAGICAL_off(sv);
65 SvREADONLY_off(sv);
66 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
c07a80fd
PP
67}
68
8990e307 69void
864dbfa3 70Perl_mg_magical(pTHX_ SV *sv)
8990e307
LW
71{
72 MAGIC* mg;
73 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
74 MGVTBL* vtbl = mg->mg_virtual;
75 if (vtbl) {
76e3520e 76 if ((vtbl->svt_get != NULL) && !(mg->mg_flags & MGf_GSKIP))
8990e307
LW
77 SvGMAGICAL_on(sv);
78 if (vtbl->svt_set)
79 SvSMAGICAL_on(sv);
76e3520e 80 if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)) || (vtbl->svt_clear != NULL))
8990e307
LW
81 SvRMAGICAL_on(sv);
82 }
83 }
84}
85
79072805 86int
864dbfa3 87Perl_mg_get(pTHX_ SV *sv)
79072805 88{
46124e9e 89 dTHR;
455ece5e 90 I32 mgs_ix;
79072805 91 MAGIC* mg;
c6496cc7 92 MAGIC** mgp;
760ac839 93 int mgp_valid = 0;
463ee0b2 94
455ece5e
AD
95 mgs_ix = SSNEW(sizeof(MGS));
96 save_magic(mgs_ix, sv);
463ee0b2 97
c6496cc7
PP
98 mgp = &SvMAGIC(sv);
99 while ((mg = *mgp) != 0) {
79072805 100 MGVTBL* vtbl = mg->mg_virtual;
76e3520e 101 if (!(mg->mg_flags & MGf_GSKIP) && vtbl && (vtbl->svt_get != NULL)) {
cea2e8a9 102 (VTBL->svt_get)(aTHX_ sv, mg);
c6496cc7 103 /* Ignore this magic if it's been deleted */
48e43a1c
CS
104 if ((mg == (mgp_valid ? *mgp : SvMAGIC(sv))) &&
105 (mg->mg_flags & MGf_GSKIP))
455ece5e 106 (SSPTR(mgs_ix, MGS*))->mgs_flags = 0;
a0d0e21e 107 }
c6496cc7 108 /* Advance to next magic (complicated by possible deletion) */
760ac839 109 if (mg == (mgp_valid ? *mgp : SvMAGIC(sv))) {
c6496cc7 110 mgp = &mg->mg_moremagic;
760ac839
LW
111 mgp_valid = 1;
112 }
113 else
114 mgp = &SvMAGIC(sv); /* Re-establish pointer after sv_upgrade */
79072805 115 }
463ee0b2 116
51371543 117 restore_magic(aTHXo_ (void*)mgs_ix);
79072805
LW
118 return 0;
119}
120
121int
864dbfa3 122Perl_mg_set(pTHX_ SV *sv)
79072805 123{
46124e9e 124 dTHR;
455ece5e 125 I32 mgs_ix;
79072805 126 MAGIC* mg;
463ee0b2
LW
127 MAGIC* nextmg;
128
455ece5e
AD
129 mgs_ix = SSNEW(sizeof(MGS));
130 save_magic(mgs_ix, sv);
463ee0b2
LW
131
132 for (mg = SvMAGIC(sv); mg; mg = nextmg) {
79072805 133 MGVTBL* vtbl = mg->mg_virtual;
463ee0b2 134 nextmg = mg->mg_moremagic; /* it may delete itself */
a0d0e21e
LW
135 if (mg->mg_flags & MGf_GSKIP) {
136 mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */
455ece5e 137 (SSPTR(mgs_ix, MGS*))->mgs_flags = 0;
a0d0e21e 138 }
76e3520e 139 if (vtbl && (vtbl->svt_set != NULL))
cea2e8a9 140 (VTBL->svt_set)(aTHX_ sv, mg);
79072805 141 }
463ee0b2 142
51371543 143 restore_magic(aTHXo_ (void*)mgs_ix);
79072805
LW
144 return 0;
145}
146
147U32
864dbfa3 148Perl_mg_length(pTHX_ SV *sv)
79072805
LW
149{
150 MAGIC* mg;
748a9306 151 char *junk;
463ee0b2 152 STRLEN len;
463ee0b2 153
79072805
LW
154 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
155 MGVTBL* vtbl = mg->mg_virtual;
76e3520e 156 if (vtbl && (vtbl->svt_len != NULL)) {
455ece5e 157 I32 mgs_ix;
48e43a1c 158
455ece5e
AD
159 mgs_ix = SSNEW(sizeof(MGS));
160 save_magic(mgs_ix, sv);
a0d0e21e 161 /* omit MGf_GSKIP -- not changed here */
cea2e8a9 162 len = (VTBL->svt_len)(aTHX_ sv, mg);
51371543 163 restore_magic(aTHXo_ (void*)mgs_ix);
85e6fe83
LW
164 return len;
165 }
166 }
167
748a9306 168 junk = SvPV(sv, len);
463ee0b2 169 return len;
79072805
LW
170}
171
93965878 172I32
864dbfa3 173Perl_mg_size(pTHX_ SV *sv)
93965878
NIS
174{
175 MAGIC* mg;
176 I32 len;
177
178 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
179 MGVTBL* vtbl = mg->mg_virtual;
565764a8 180 if (vtbl && (vtbl->svt_len != NULL)) {
455ece5e
AD
181 I32 mgs_ix;
182
183 mgs_ix = SSNEW(sizeof(MGS));
184 save_magic(mgs_ix, sv);
93965878 185 /* omit MGf_GSKIP -- not changed here */
cea2e8a9 186 len = (VTBL->svt_len)(aTHX_ sv, mg);
51371543 187 restore_magic(aTHXo_ (void*)mgs_ix);
93965878
NIS
188 return len;
189 }
190 }
191
192 switch(SvTYPE(sv)) {
193 case SVt_PVAV:
194 len = AvFILLp((AV *) sv); /* Fallback to non-tied array */
195 return len;
196 case SVt_PVHV:
197 /* FIXME */
198 default:
cea2e8a9 199 Perl_croak(aTHX_ "Size magic not implemented");
93965878
NIS
200 break;
201 }
202 return 0;
203}
204
79072805 205int
864dbfa3 206Perl_mg_clear(pTHX_ SV *sv)
79072805 207{
455ece5e 208 I32 mgs_ix;
79072805 209 MAGIC* mg;
463ee0b2 210
455ece5e
AD
211 mgs_ix = SSNEW(sizeof(MGS));
212 save_magic(mgs_ix, sv);
463ee0b2 213
79072805
LW
214 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
215 MGVTBL* vtbl = mg->mg_virtual;
a0d0e21e
LW
216 /* omit GSKIP -- never set here */
217
76e3520e 218 if (vtbl && (vtbl->svt_clear != NULL))
cea2e8a9 219 (VTBL->svt_clear)(aTHX_ sv, mg);
79072805 220 }
463ee0b2 221
51371543 222 restore_magic(aTHXo_ (void*)mgs_ix);
79072805
LW
223 return 0;
224}
225
93a17b20 226MAGIC*
864dbfa3 227Perl_mg_find(pTHX_ SV *sv, int type)
93a17b20
LW
228{
229 MAGIC* mg;
93a17b20
LW
230 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
231 if (mg->mg_type == type)
232 return mg;
233 }
234 return 0;
235}
236
79072805 237int
864dbfa3 238Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
79072805 239{
463ee0b2 240 int count = 0;
79072805 241 MAGIC* mg;
463ee0b2
LW
242 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
243 if (isUPPER(mg->mg_type)) {
33c27489
GS
244 sv_magic(nsv,
245 mg->mg_type == 'P' ? SvTIED_obj(sv, mg) : mg->mg_obj,
246 toLOWER(mg->mg_type), key, klen);
463ee0b2 247 count++;
79072805 248 }
79072805 249 }
463ee0b2 250 return count;
79072805
LW
251}
252
253int
864dbfa3 254Perl_mg_free(pTHX_ SV *sv)
79072805
LW
255{
256 MAGIC* mg;
257 MAGIC* moremagic;
258 for (mg = SvMAGIC(sv); mg; mg = moremagic) {
259 MGVTBL* vtbl = mg->mg_virtual;
260 moremagic = mg->mg_moremagic;
76e3520e 261 if (vtbl && (vtbl->svt_free != NULL))
cea2e8a9 262 (VTBL->svt_free)(aTHX_ sv, mg);
93a17b20 263 if (mg->mg_ptr && mg->mg_type != 'g')
565764a8 264 if (mg->mg_len >= 0)
88e89b8a 265 Safefree(mg->mg_ptr);
565764a8 266 else if (mg->mg_len == HEf_SVKEY)
88e89b8a 267 SvREFCNT_dec((SV*)mg->mg_ptr);
85e6fe83 268 if (mg->mg_flags & MGf_REFCOUNTED)
8990e307 269 SvREFCNT_dec(mg->mg_obj);
79072805
LW
270 Safefree(mg);
271 }
272 SvMAGIC(sv) = 0;
273 return 0;
274}
275
276#if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
277#include <signal.h>
278#endif
279
942e002e 280U32
864dbfa3 281Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
6cef1e77
IZ
282{
283 dTHR;
284 register char *s;
285 register I32 i;
286 register REGEXP *rx;
287 char *t;
288
8f580fb8
IZ
289 if (PL_curpm && (rx = PL_curpm->op_pmregexp)) {
290 if (mg->mg_obj) /* @+ */
291 return rx->nparens;
292 else /* @- */
293 return rx->lastparen;
294 }
295
942e002e 296 return (U32)-1;
6cef1e77
IZ
297}
298
299int
864dbfa3 300Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
6cef1e77
IZ
301{
302 dTHR;
303 register I32 paren;
cf93c79d 304 register I32 s;
6cef1e77
IZ
305 register I32 i;
306 register REGEXP *rx;
cf93c79d 307 I32 t;
6cef1e77
IZ
308
309 if (PL_curpm && (rx = PL_curpm->op_pmregexp)) {
310 paren = mg->mg_len;
311 if (paren < 0)
312 return 0;
313 if (paren <= rx->nparens &&
cf93c79d
IZ
314 (s = rx->startp[paren]) != -1 &&
315 (t = rx->endp[paren]) != -1)
6cef1e77
IZ
316 {
317 if (mg->mg_obj) /* @+ */
cf93c79d 318 i = t;
6cef1e77 319 else /* @- */
cf93c79d 320 i = s;
6cef1e77
IZ
321 sv_setiv(sv,i);
322 }
323 }
324 return 0;
325}
326
93a17b20 327U32
864dbfa3 328Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
93a17b20 329{
a863c7d1 330 dTHR;
93a17b20
LW
331 register I32 paren;
332 register char *s;
333 register I32 i;
d9f97599 334 register REGEXP *rx;
748a9306 335 char *t;
93a17b20
LW
336
337 switch (*mg->mg_ptr) {
338 case '1': case '2': case '3': case '4':
339 case '5': case '6': case '7': case '8': case '9': case '&':
3280af22 340 if (PL_curpm && (rx = PL_curpm->op_pmregexp)) {
cf93c79d
IZ
341 I32 s1, t1;
342
93a17b20
LW
343 paren = atoi(mg->mg_ptr);
344 getparen:
d9f97599 345 if (paren <= rx->nparens &&
cf93c79d
IZ
346 (s1 = rx->startp[paren]) != -1 &&
347 (t1 = rx->endp[paren]) != -1)
bbce6d69 348 {
cf93c79d 349 i = t1 - s1;
71be2cbc 350 if (i >= 0)
93a17b20 351 return i;
93a17b20 352 }
93a17b20 353 }
748a9306 354 return 0;
93a17b20 355 case '+':
3280af22 356 if (PL_curpm && (rx = PL_curpm->op_pmregexp)) {
d9f97599 357 paren = rx->lastparen;
13f57bf8
CS
358 if (paren)
359 goto getparen;
93a17b20 360 }
748a9306 361 return 0;
93a17b20 362 case '`':
3280af22 363 if (PL_curpm && (rx = PL_curpm->op_pmregexp)) {
cf93c79d
IZ
364 if (rx->startp[0] != -1) {
365 i = rx->startp[0];
71be2cbc 366 if (i >= 0)
93a17b20 367 return i;
93a17b20 368 }
93a17b20 369 }
748a9306 370 return 0;
93a17b20 371 case '\'':
3280af22 372 if (PL_curpm && (rx = PL_curpm->op_pmregexp)) {
cf93c79d
IZ
373 if (rx->endp[0] != -1) {
374 i = rx->sublen - rx->endp[0];
13f57bf8 375 if (i >= 0)
5cd24f17 376 return i;
93a17b20 377 }
93a17b20 378 }
748a9306 379 return 0;
93a17b20 380 case ',':
3280af22 381 return (STRLEN)PL_ofslen;
93a17b20 382 case '\\':
3280af22 383 return (STRLEN)PL_orslen;
93a17b20
LW
384 }
385 magic_get(sv,mg);
2d8e6c8d
GS
386 if (!SvPOK(sv) && SvNIOK(sv)) {
387 STRLEN n_a;
388 sv_2pv(sv, &n_a);
389 }
93a17b20
LW
390 if (SvPOK(sv))
391 return SvCUR(sv);
392 return 0;
393}
394
79072805 395int
864dbfa3 396Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
79072805 397{
a863c7d1 398 dTHR;
79072805
LW
399 register I32 paren;
400 register char *s;
401 register I32 i;
d9f97599 402 register REGEXP *rx;
748a9306 403 char *t;
79072805
LW
404
405 switch (*mg->mg_ptr) {
748a9306 406 case '\001': /* ^A */
3280af22 407 sv_setsv(sv, PL_bodytarget);
748a9306 408 break;
599cee73 409 case '\002': /* ^B */
0453d815
PM
410 if (PL_curcop->cop_warnings == WARN_NONE ||
411 PL_curcop->cop_warnings == WARN_STD)
412 {
599cee73 413 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
0453d815
PM
414 }
415 else if (PL_curcop->cop_warnings == WARN_ALL) {
599cee73 416 sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
0453d815
PM
417 }
418 else {
e24b16f9 419 sv_setsv(sv, PL_curcop->cop_warnings);
0453d815 420 }
599cee73 421 break;
49460fe6
NIS
422 case '\003': /* ^C */
423 sv_setiv(sv, (IV)PL_minus_c);
424 break;
425
79072805 426 case '\004': /* ^D */
3280af22 427 sv_setiv(sv, (IV)(PL_debug & 32767));
79072805 428 break;
28f23441
PP
429 case '\005': /* ^E */
430#ifdef VMS
431 {
432# include <descrip.h>
433# include <starlet.h>
434 char msg[255];
435 $DESCRIPTOR(msgdsc,msg);
65202027 436 sv_setnv(sv,(NV) vaxc$errno);
28f23441
PP
437 if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
438 sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
439 else
440 sv_setpv(sv,"");
441 }
442#else
88e89b8a 443#ifdef OS2
fb73857a 444 if (!(_emx_env & 0x200)) { /* Under DOS */
65202027 445 sv_setnv(sv, (NV)errno);
fb73857a
PP
446 sv_setpv(sv, errno ? Strerror(errno) : "");
447 } else {
017f25f1
IZ
448 if (errno != errno_isOS2) {
449 int tmp = _syserrno();
450 if (tmp) /* 2nd call to _syserrno() makes it 0 */
451 Perl_rc = tmp;
452 }
65202027 453 sv_setnv(sv, (NV)Perl_rc);
fb73857a
PP
454 sv_setpv(sv, os2error(Perl_rc));
455 }
88e89b8a 456#else
22fae026
TM
457#ifdef WIN32
458 {
459 DWORD dwErr = GetLastError();
65202027 460 sv_setnv(sv, (NV)dwErr);
22fae026 461 if (dwErr)
76e3520e 462 {
0cb96387 463 PerlProc_GetOSError(sv, dwErr);
76e3520e 464 }
22fae026
TM
465 else
466 sv_setpv(sv, "");
467 SetLastError(dwErr);
468 }
469#else
65202027 470 sv_setnv(sv, (NV)errno);
28f23441
PP
471 sv_setpv(sv, errno ? Strerror(errno) : "");
472#endif
88e89b8a 473#endif
22fae026 474#endif
946ec16e 475 SvNOK_on(sv); /* what a wonderful hack! */
28f23441 476 break;
79072805 477 case '\006': /* ^F */
3280af22 478 sv_setiv(sv, (IV)PL_maxsysfd);
79072805 479 break;
a0d0e21e 480 case '\010': /* ^H */
3280af22 481 sv_setiv(sv, (IV)PL_hints);
a0d0e21e 482 break;
9d116dd7 483 case '\011': /* ^I */ /* NOT \t in EBCDIC */
3280af22
NIS
484 if (PL_inplace)
485 sv_setpv(sv, PL_inplace);
79072805 486 else
3280af22 487 sv_setsv(sv, &PL_sv_undef);
79072805 488 break;
28f23441 489 case '\017': /* ^O */
3280af22 490 sv_setpv(sv, PL_osname);
28f23441 491 break;
79072805 492 case '\020': /* ^P */
3280af22 493 sv_setiv(sv, (IV)PL_perldb);
79072805 494 break;
fb73857a 495 case '\023': /* ^S */
d58bf5aa
MB
496 {
497 dTHR;
3280af22 498 if (PL_lex_state != LEX_NOTPARSING)
d58bf5aa 499 SvOK_off(sv);
3280af22 500 else if (PL_in_eval)
d58bf5aa
MB
501 sv_setiv(sv, 1);
502 else
503 sv_setiv(sv, 0);
504 }
fb73857a 505 break;
79072805 506 case '\024': /* ^T */
88e89b8a 507#ifdef BIG_TIME
6b88bc9c 508 sv_setnv(sv, PL_basetime);
88e89b8a 509#else
3280af22 510 sv_setiv(sv, (IV)PL_basetime);
88e89b8a 511#endif
79072805
LW
512 break;
513 case '\027': /* ^W */
0453d815 514 sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
79072805
LW
515 break;
516 case '1': case '2': case '3': case '4':
517 case '5': case '6': case '7': case '8': case '9': case '&':
3280af22 518 if (PL_curpm && (rx = PL_curpm->op_pmregexp)) {
cf93c79d
IZ
519 I32 s1, t1;
520
a863c7d1
MB
521 /*
522 * Pre-threads, this was paren = atoi(GvENAME((GV*)mg->mg_obj));
523 * XXX Does the new way break anything?
524 */
525 paren = atoi(mg->mg_ptr);
79072805 526 getparen:
d9f97599 527 if (paren <= rx->nparens &&
cf93c79d
IZ
528 (s1 = rx->startp[paren]) != -1 &&
529 (t1 = rx->endp[paren]) != -1)
bbce6d69 530 {
cf93c79d
IZ
531 i = t1 - s1;
532 s = rx->subbeg + s1;
13f57bf8 533 getrx:
748a9306 534 if (i >= 0) {
13f57bf8 535 bool was_tainted;
3280af22
NIS
536 if (PL_tainting) {
537 was_tainted = PL_tainted;
538 PL_tainted = FALSE;
13f57bf8 539 }
cf93c79d 540 sv_setpvn(sv, s, i);
3280af22
NIS
541 if (PL_tainting)
542 PL_tainted = (was_tainted || RX_MATCH_TAINTED(rx));
748a9306
LW
543 break;
544 }
79072805 545 }
79072805 546 }
3280af22 547 sv_setsv(sv,&PL_sv_undef);
79072805
LW
548 break;
549 case '+':
3280af22 550 if (PL_curpm && (rx = PL_curpm->op_pmregexp)) {
d9f97599 551 paren = rx->lastparen;
a0d0e21e
LW
552 if (paren)
553 goto getparen;
79072805 554 }
3280af22 555 sv_setsv(sv,&PL_sv_undef);
79072805
LW
556 break;
557 case '`':
3280af22 558 if (PL_curpm && (rx = PL_curpm->op_pmregexp)) {
cf93c79d
IZ
559 if ((s = rx->subbeg) && rx->startp[0] != -1) {
560 i = rx->startp[0];
13f57bf8 561 goto getrx;
79072805 562 }
79072805 563 }
3280af22 564 sv_setsv(sv,&PL_sv_undef);
79072805
LW
565 break;
566 case '\'':
3280af22 567 if (PL_curpm && (rx = PL_curpm->op_pmregexp)) {
cf93c79d
IZ
568 if (rx->subbeg && rx->endp[0] != -1) {
569 s = rx->subbeg + rx->endp[0];
570 i = rx->sublen - rx->endp[0];
13f57bf8 571 goto getrx;
79072805 572 }
79072805 573 }
3280af22 574 sv_setsv(sv,&PL_sv_undef);
79072805
LW
575 break;
576 case '.':
577#ifndef lint
3280af22
NIS
578 if (GvIO(PL_last_in_gv)) {
579 sv_setiv(sv, (IV)IoLINES(GvIO(PL_last_in_gv)));
79072805
LW
580 }
581#endif
582 break;
583 case '?':
809a5acc 584 {
809a5acc 585 sv_setiv(sv, (IV)STATUS_CURRENT);
ff0cee69 586#ifdef COMPLEX_STATUS
6b88bc9c
GS
587 LvTARGOFF(sv) = PL_statusvalue;
588 LvTARGLEN(sv) = PL_statusvalue_vms;
ff0cee69 589#endif
809a5acc 590 }
79072805
LW
591 break;
592 case '^':
3280af22 593 s = IoTOP_NAME(GvIOp(PL_defoutgv));
79072805
LW
594 if (s)
595 sv_setpv(sv,s);
596 else {
3280af22 597 sv_setpv(sv,GvENAME(PL_defoutgv));
79072805
LW
598 sv_catpv(sv,"_TOP");
599 }
600 break;
601 case '~':
3280af22 602 s = IoFMT_NAME(GvIOp(PL_defoutgv));
79072805 603 if (!s)
3280af22 604 s = GvENAME(PL_defoutgv);
79072805
LW
605 sv_setpv(sv,s);
606 break;
607#ifndef lint
608 case '=':
3280af22 609 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
79072805
LW
610 break;
611 case '-':
3280af22 612 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
79072805
LW
613 break;
614 case '%':
3280af22 615 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
79072805
LW
616 break;
617#endif
618 case ':':
619 break;
620 case '/':
621 break;
622 case '[':
3280af22 623 WITH_THR(sv_setiv(sv, (IV)PL_curcop->cop_arybase));
79072805
LW
624 break;
625 case '|':
3280af22 626 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
79072805
LW
627 break;
628 case ',':
3280af22 629 sv_setpvn(sv,PL_ofs,PL_ofslen);
79072805
LW
630 break;
631 case '\\':
3280af22 632 sv_setpvn(sv,PL_ors,PL_orslen);
79072805
LW
633 break;
634 case '#':
3280af22 635 sv_setpv(sv,PL_ofmt);
79072805
LW
636 break;
637 case '!':
a5f75d66 638#ifdef VMS
65202027 639 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
88e89b8a 640 sv_setpv(sv, errno ? Strerror(errno) : "");
a5f75d66 641#else
88e89b8a
PP
642 {
643 int saveerrno = errno;
65202027 644 sv_setnv(sv, (NV)errno);
88e89b8a
PP
645#ifdef OS2
646 if (errno == errno_isOS2) sv_setpv(sv, os2error(Perl_rc));
647 else
a5f75d66 648#endif
2304df62 649 sv_setpv(sv, errno ? Strerror(errno) : "");
88e89b8a
PP
650 errno = saveerrno;
651 }
652#endif
946ec16e 653 SvNOK_on(sv); /* what a wonderful hack! */
79072805
LW
654 break;
655 case '<':
3280af22 656 sv_setiv(sv, (IV)PL_uid);
79072805
LW
657 break;
658 case '>':
3280af22 659 sv_setiv(sv, (IV)PL_euid);
79072805
LW
660 break;
661 case '(':
3280af22 662 sv_setiv(sv, (IV)PL_gid);
cea2e8a9 663 Perl_sv_setpvf(aTHX_ sv, "%Vd", (IV)PL_gid);
79072805
LW
664 goto add_groups;
665 case ')':
3280af22 666 sv_setiv(sv, (IV)PL_egid);
cea2e8a9 667 Perl_sv_setpvf(aTHX_ sv, "%Vd", (IV)PL_egid);
79072805 668 add_groups:
79072805 669#ifdef HAS_GETGROUPS
79072805 670 {
a0d0e21e 671 Groups_t gary[NGROUPS];
79072805 672 i = getgroups(NGROUPS,gary);
46fc3d4c 673 while (--i >= 0)
cea2e8a9 674 Perl_sv_catpvf(aTHX_ sv, " %Vd", (IV)gary[i]);
79072805
LW
675 }
676#endif
29355cf7 677 SvIOK_on(sv); /* what a wonderful hack! */
79072805
LW
678 break;
679 case '*':
680 break;
681 case '0':
682 break;
a863c7d1
MB
683#ifdef USE_THREADS
684 case '@':
38a03e6e 685 sv_setsv(sv, thr->errsv);
a863c7d1
MB
686 break;
687#endif /* USE_THREADS */
79072805 688 }
a0d0e21e 689 return 0;
79072805
LW
690}
691
692int
864dbfa3 693Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
79072805
LW
694{
695 struct ufuncs *uf = (struct ufuncs *)mg->mg_ptr;
696
697 if (uf && uf->uf_val)
698 (*uf->uf_val)(uf->uf_index, sv);
699 return 0;
700}
701
702int
864dbfa3 703Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
79072805
LW
704{
705 register char *s;
88e89b8a 706 char *ptr;
5aabfad6 707 STRLEN len, klen;
a0d0e21e 708 I32 i;
1e422769 709
a0d0e21e 710 s = SvPV(sv,len);
5aabfad6 711 ptr = MgPV(mg,klen);
88e89b8a 712 my_setenv(ptr, s);
1e422769 713
a0d0e21e
LW
714#ifdef DYNAMIC_ENV_FETCH
715 /* We just undefd an environment var. Is a replacement */
716 /* waiting in the wings? */
717 if (!len) {
5aabfad6 718 SV **valp;
6b88bc9c 719 if ((valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE)))
5aabfad6 720 s = SvPV(*valp, len);
a0d0e21e
LW
721 }
722#endif
1e422769 723
39e571d4 724#if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
79072805
LW
725 /* And you'll never guess what the dog had */
726 /* in its mouth... */
3280af22 727 if (PL_tainting) {
1e422769
PP
728 MgTAINTEDDIR_off(mg);
729#ifdef VMS
5aabfad6 730 if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
1e422769
PP
731 char pathbuf[256], eltbuf[256], *cp, *elt = s;
732 struct stat sbuf;
733 int i = 0, j = 0;
734
735 do { /* DCL$PATH may be a search list */
736 while (1) { /* as may dev portion of any element */
737 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
738 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
739 cando_by_name(S_IWUSR,0,elt) ) {
740 MgTAINTEDDIR_on(mg);
741 return 0;
742 }
743 }
744 if ((cp = strchr(elt, ':')) != Nullch)
745 *cp = '\0';
746 if (my_trnlnm(elt, eltbuf, j++))
747 elt = eltbuf;
748 else
749 break;
750 }
751 j = 0;
752 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
753 }
754#endif /* VMS */
5aabfad6 755 if (s && klen == 4 && strEQ(ptr,"PATH")) {
a0d0e21e 756 char *strend = s + len;
463ee0b2
LW
757
758 while (s < strend) {
96827780 759 char tmpbuf[256];
1e422769 760 struct stat st;
96827780 761 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
fc36a67e 762 s, strend, ':', &i);
463ee0b2 763 s++;
96827780
MB
764 if (i >= sizeof tmpbuf /* too long -- assume the worst */
765 || *tmpbuf != '/'
c6ed36e1 766 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
8990e307 767 MgTAINTEDDIR_on(mg);
1e422769
PP
768 return 0;
769 }
463ee0b2 770 }
79072805
LW
771 }
772 }
39e571d4 773#endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1e422769 774
79072805
LW
775 return 0;
776}
777
778int
864dbfa3 779Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
85e6fe83 780{
2d8e6c8d
GS
781 STRLEN n_a;
782 my_setenv(MgPV(mg,n_a),Nullch);
85e6fe83
LW
783 return 0;
784}
785
88e89b8a 786int
864dbfa3 787Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
fb73857a
PP
788{
789#if defined(VMS)
cea2e8a9 790 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
fb73857a 791#else
d58bf5aa 792 dTHR;
3280af22 793 if (PL_localizing) {
fb73857a 794 HE* entry;
2d8e6c8d 795 STRLEN n_a;
fb73857a
PP
796 magic_clear_all_env(sv,mg);
797 hv_iterinit((HV*)sv);
798 while (entry = hv_iternext((HV*)sv)) {
799 I32 keylen;
800 my_setenv(hv_iterkey(entry, &keylen),
2d8e6c8d 801 SvPV(hv_iterval((HV*)sv, entry), n_a));
fb73857a
PP
802 }
803 }
804#endif
805 return 0;
806}
807
808int
864dbfa3 809Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
66b1d557 810{
3e3baf6d 811#if defined(VMS)
cea2e8a9 812 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
3e3baf6d 813#else
f2517201 814# ifdef WIN32
3e3baf6d
TB
815 char *envv = GetEnvironmentStrings();
816 char *cur = envv;
817 STRLEN len;
818 while (*cur) {
819 char *end = strchr(cur,'=');
820 if (end && end != cur) {
821 *end = '\0';
822 my_setenv(cur,Nullch);
823 *end = '=';
ac5c734f 824 cur = end + strlen(end+1)+2;
3e3baf6d
TB
825 }
826 else if ((len = strlen(cur)))
827 cur += len+1;
828 }
829 FreeEnvironmentStrings(envv);
f2517201 830# else
2c2d71f5
JH
831# ifdef CYGWIN
832 I32 i;
833 for (i = 0; environ[i]; i++)
834 Safefree(environ[i]);
835# else
836# ifndef PERL_USE_SAFE_PUTENV
66b1d557
HM
837 I32 i;
838
3280af22 839 if (environ == PL_origenviron)
f2517201 840 environ = (char**)safesysmalloc(sizeof(char*));
66b1d557
HM
841 else
842 for (i = 0; environ[i]; i++)
f2517201 843 safesysfree(environ[i]);
2c2d71f5
JH
844# endif /* PERL_USE_SAFE_PUTENV */
845# endif /* CYGWIN */
f2517201 846
66b1d557
HM
847 environ[0] = Nullch;
848
f2517201
GS
849# endif /* WIN32 */
850#endif /* VMS */
3e3baf6d 851 return 0;
66b1d557
HM
852}
853
854int
864dbfa3 855Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
88e89b8a
PP
856{
857 I32 i;
2d8e6c8d 858 STRLEN n_a;
88e89b8a 859 /* Are we fetching a signal entry? */
2d8e6c8d 860 i = whichsig(MgPV(mg,n_a));
88e89b8a 861 if (i) {
22c35a8c
GS
862 if(PL_psig_ptr[i])
863 sv_setsv(sv,PL_psig_ptr[i]);
88e89b8a 864 else {
ff68c719
PP
865 Sighandler_t sigstate = rsignal_state(i);
866
88e89b8a 867 /* cache state so we don't fetch it again */
ff68c719 868 if(sigstate == SIG_IGN)
88e89b8a
PP
869 sv_setpv(sv,"IGNORE");
870 else
3280af22 871 sv_setsv(sv,&PL_sv_undef);
22c35a8c 872 PL_psig_ptr[i] = SvREFCNT_inc(sv);
88e89b8a
PP
873 SvTEMP_off(sv);
874 }
875 }
876 return 0;
877}
878int
864dbfa3 879Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
88e89b8a
PP
880{
881 I32 i;
2d8e6c8d 882 STRLEN n_a;
88e89b8a 883 /* Are we clearing a signal entry? */
2d8e6c8d 884 i = whichsig(MgPV(mg,n_a));
88e89b8a 885 if (i) {
22c35a8c
GS
886 if(PL_psig_ptr[i]) {
887 SvREFCNT_dec(PL_psig_ptr[i]);
888 PL_psig_ptr[i]=0;
88e89b8a 889 }
22c35a8c
GS
890 if(PL_psig_name[i]) {
891 SvREFCNT_dec(PL_psig_name[i]);
892 PL_psig_name[i]=0;
88e89b8a
PP
893 }
894 }
895 return 0;
896}
3d37d572 897
85e6fe83 898int
864dbfa3 899Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
79072805 900{
11343788 901 dTHR;
79072805
LW
902 register char *s;
903 I32 i;
748a9306 904 SV** svp;
e72dc28c 905 STRLEN len;
a0d0e21e 906
e72dc28c 907 s = MgPV(mg,len);
748a9306
LW
908 if (*s == '_') {
909 if (strEQ(s,"__DIE__"))
3280af22 910 svp = &PL_diehook;
748a9306 911 else if (strEQ(s,"__WARN__"))
3280af22 912 svp = &PL_warnhook;
748a9306 913 else if (strEQ(s,"__PARSE__"))
3280af22 914 svp = &PL_parsehook;
748a9306 915 else
cea2e8a9 916 Perl_croak(aTHX_ "No such hook: %s", s);
748a9306 917 i = 0;
4633a7c4
LW
918 if (*svp) {
919 SvREFCNT_dec(*svp);
920 *svp = 0;
921 }
748a9306
LW
922 }
923 else {
924 i = whichsig(s); /* ...no, a brick */
925 if (!i) {
599cee73 926 if (ckWARN(WARN_SIGNAL) || strEQ(s,"ALARM"))
cea2e8a9 927 Perl_warner(aTHX_ WARN_SIGNAL, "No such signal: SIG%s", s);
748a9306
LW
928 return 0;
929 }
22c35a8c
GS
930 SvREFCNT_dec(PL_psig_name[i]);
931 SvREFCNT_dec(PL_psig_ptr[i]);
932 PL_psig_ptr[i] = SvREFCNT_inc(sv);
88e89b8a 933 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
e72dc28c 934 PL_psig_name[i] = newSVpvn(s, len);
22c35a8c 935 SvREADONLY_on(PL_psig_name[i]);
748a9306 936 }
a0d0e21e 937 if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
748a9306 938 if (i)
3280af22 939 (void)rsignal(i, PL_sighandlerp);
748a9306
LW
940 else
941 *svp = SvREFCNT_inc(sv);
a0d0e21e
LW
942 return 0;
943 }
e72dc28c 944 s = SvPV_force(sv,len);
748a9306
LW
945 if (strEQ(s,"IGNORE")) {
946 if (i)
ff68c719 947 (void)rsignal(i, SIG_IGN);
748a9306
LW
948 else
949 *svp = 0;
950 }
951 else if (strEQ(s,"DEFAULT") || !*s) {
952 if (i)
ff68c719 953 (void)rsignal(i, SIG_DFL);
748a9306
LW
954 else
955 *svp = 0;
956 }
79072805 957 else {
5aabfad6
PP
958 /*
959 * We should warn if HINT_STRICT_REFS, but without
960 * access to a known hint bit in a known OP, we can't
961 * tell whether HINT_STRICT_REFS is in force or not.
962 */
46fc3d4c 963 if (!strchr(s,':') && !strchr(s,'\''))
e72dc28c 964 sv_insert(sv, 0, 0, "main::", 6);
748a9306 965 if (i)
3280af22 966 (void)rsignal(i, PL_sighandlerp);
748a9306
LW
967 else
968 *svp = SvREFCNT_inc(sv);
79072805
LW
969 }
970 return 0;
971}
972
973int
864dbfa3 974Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
79072805 975{
3280af22 976 PL_sub_generation++;
463ee0b2
LW
977 return 0;
978}
979
980int
864dbfa3 981Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
463ee0b2 982{
a0d0e21e 983 /* HV_badAMAGIC_on(Sv_STASH(sv)); */
3280af22 984 PL_amagic_generation++;
463ee0b2 985
a0d0e21e
LW
986 return 0;
987}
463ee0b2 988
946ec16e 989int
864dbfa3 990Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
6ff81951
GS
991{
992 HV *hv = (HV*)LvTARG(sv);
993 HE *entry;
994 I32 i = 0;
995
996 if (hv) {
997 (void) hv_iterinit(hv);
33c27489 998 if (! SvTIED_mg((SV*)hv, 'P'))
6ff81951
GS
999 i = HvKEYS(hv);
1000 else {
1001 /*SUPPRESS 560*/
1002 while (entry = hv_iternext(hv)) {
1003 i++;
1004 }
1005 }
1006 }
1007
1008 sv_setiv(sv, (IV)i);
1009 return 0;
1010}
1011
1012int
864dbfa3 1013Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
946ec16e
PP
1014{
1015 if (LvTARG(sv)) {
1016 hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
946ec16e
PP
1017 }
1018 return 0;
93965878 1019}
946ec16e 1020
e336de0d 1021/* caller is responsible for stack switching/cleanup */
565764a8 1022STATIC int
cea2e8a9 1023S_magic_methcall(pTHX_ SV *sv, MAGIC *mg, char *meth, I32 flags, int n, SV *val)
a0d0e21e
LW
1024{
1025 dSP;
463ee0b2 1026
924508f0
GS
1027 PUSHMARK(SP);
1028 EXTEND(SP, n);
33c27489 1029 PUSHs(SvTIED_obj(sv, mg));
93965878
NIS
1030 if (n > 1) {
1031 if (mg->mg_ptr) {
565764a8 1032 if (mg->mg_len >= 0)
79cb57f6 1033 PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len)));
565764a8 1034 else if (mg->mg_len == HEf_SVKEY)
93965878
NIS
1035 PUSHs((SV*)mg->mg_ptr);
1036 }
1037 else if (mg->mg_type == 'p') {
565764a8 1038 PUSHs(sv_2mortal(newSViv(mg->mg_len)));
93965878
NIS
1039 }
1040 }
1041 if (n > 2) {
1042 PUSHs(val);
88e89b8a 1043 }
463ee0b2
LW
1044 PUTBACK;
1045
864dbfa3 1046 return call_method(meth, flags);
946ec16e
PP
1047}
1048
76e3520e 1049STATIC int
cea2e8a9 1050S_magic_methpack(pTHX_ SV *sv, MAGIC *mg, char *meth)
a0d0e21e
LW
1051{
1052 dSP;
463ee0b2 1053
a0d0e21e
LW
1054 ENTER;
1055 SAVETMPS;
e788e7d3 1056 PUSHSTACKi(PERLSI_MAGIC);
463ee0b2 1057
33c27489 1058 if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
3280af22 1059 sv_setsv(sv, *PL_stack_sp--);
93965878 1060 }
463ee0b2 1061
d3acc0f7 1062 POPSTACK;
a0d0e21e
LW
1063 FREETMPS;
1064 LEAVE;
1065 return 0;
1066}
463ee0b2 1067
a0d0e21e 1068int
864dbfa3 1069Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e
LW
1070{
1071 magic_methpack(sv,mg,"FETCH");
1072 if (mg->mg_ptr)
1073 mg->mg_flags |= MGf_GSKIP;
463ee0b2
LW
1074 return 0;
1075}
1076
1077int
864dbfa3 1078Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
e336de0d
GS
1079{
1080 dSP;
a60c0954 1081 ENTER;
e788e7d3 1082 PUSHSTACKi(PERLSI_MAGIC);
33c27489 1083 magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
d3acc0f7 1084 POPSTACK;
a60c0954 1085 LEAVE;
463ee0b2
LW
1086 return 0;
1087}
1088
1089int
864dbfa3 1090Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
463ee0b2 1091{
a0d0e21e
LW
1092 return magic_methpack(sv,mg,"DELETE");
1093}
463ee0b2 1094
93965878
NIS
1095
1096U32
864dbfa3 1097Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
93965878 1098{
e336de0d 1099 dSP;
93965878
NIS
1100 U32 retval = 0;
1101
1102 ENTER;
1103 SAVETMPS;
e788e7d3 1104 PUSHSTACKi(PERLSI_MAGIC);
33c27489 1105 if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
3280af22 1106 sv = *PL_stack_sp--;
a60c0954 1107 retval = (U32) SvIV(sv)-1;
93965878 1108 }
d3acc0f7 1109 POPSTACK;
93965878
NIS
1110 FREETMPS;
1111 LEAVE;
1112 return retval;
1113}
1114
cea2e8a9
GS
1115int
1116Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e
LW
1117{
1118 dSP;
463ee0b2 1119
e336de0d 1120 ENTER;
e788e7d3 1121 PUSHSTACKi(PERLSI_MAGIC);
924508f0 1122 PUSHMARK(SP);
33c27489 1123 XPUSHs(SvTIED_obj(sv, mg));
463ee0b2 1124 PUTBACK;
864dbfa3 1125 call_method("CLEAR", G_SCALAR|G_DISCARD);
d3acc0f7 1126 POPSTACK;
a60c0954 1127 LEAVE;
463ee0b2
LW
1128 return 0;
1129}
1130
1131int
864dbfa3 1132Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
463ee0b2 1133{
463ee0b2 1134 dSP;
a0d0e21e 1135 char *meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
463ee0b2
LW
1136
1137 ENTER;
a0d0e21e 1138 SAVETMPS;
e788e7d3 1139 PUSHSTACKi(PERLSI_MAGIC);
924508f0
GS
1140 PUSHMARK(SP);
1141 EXTEND(SP, 2);
33c27489 1142 PUSHs(SvTIED_obj(sv, mg));
463ee0b2
LW
1143 if (SvOK(key))
1144 PUSHs(key);
1145 PUTBACK;
1146
864dbfa3 1147 if (call_method(meth, G_SCALAR))
3280af22 1148 sv_setsv(key, *PL_stack_sp--);
463ee0b2 1149
d3acc0f7 1150 POPSTACK;
a0d0e21e
LW
1151 FREETMPS;
1152 LEAVE;
79072805
LW
1153 return 0;
1154}
1155
1156int
864dbfa3 1157Perl_magic_existspack(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e
LW
1158{
1159 return magic_methpack(sv,mg,"EXISTS");
1160}
1161
1162int
864dbfa3 1163Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
79072805 1164{
11343788 1165 dTHR;
79072805
LW
1166 OP *o;
1167 I32 i;
1168 GV* gv;
1169 SV** svp;
2d8e6c8d 1170 STRLEN n_a;
79072805 1171
3280af22 1172 gv = PL_DBline;
79072805 1173 i = SvTRUE(sv);
188ea221 1174 svp = av_fetch(GvAV(gv),
2d8e6c8d 1175 atoi(MgPV(mg,n_a)), FALSE);
8990e307 1176 if (svp && SvIOKp(*svp) && (o = (OP*)SvSTASH(*svp)))
93a17b20 1177 o->op_private = i;
0453d815
PM
1178 else if (ckWARN_d(WARN_INTERNAL))
1179 Perl_warner(aTHX_ WARN_INTERNAL, "Can't break at that line\n");
79072805
LW
1180 return 0;
1181}
1182
1183int
864dbfa3 1184Perl_magic_getarylen(pTHX_ SV *sv, MAGIC *mg)
79072805 1185{
0f15f207 1186 dTHR;
3280af22 1187 sv_setiv(sv, AvFILL((AV*)mg->mg_obj) + PL_curcop->cop_arybase);
79072805
LW
1188 return 0;
1189}
1190
1191int
864dbfa3 1192Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
79072805 1193{
0f15f207 1194 dTHR;
3280af22 1195 av_fill((AV*)mg->mg_obj, SvIV(sv) - PL_curcop->cop_arybase);
a0d0e21e
LW
1196 return 0;
1197}
1198
1199int
864dbfa3 1200Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e
LW
1201{
1202 SV* lsv = LvTARG(sv);
1203
1204 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1205 mg = mg_find(lsv, 'g');
565764a8 1206 if (mg && mg->mg_len >= 0) {
0f15f207 1207 dTHR;
a0ed51b3
LW
1208 I32 i = mg->mg_len;
1209 if (IN_UTF8)
1210 sv_pos_b2u(lsv, &i);
1211 sv_setiv(sv, i + PL_curcop->cop_arybase);
a0d0e21e
LW
1212 return 0;
1213 }
1214 }
1215 (void)SvOK_off(sv);
1216 return 0;
1217}
1218
1219int
864dbfa3 1220Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e
LW
1221{
1222 SV* lsv = LvTARG(sv);
1223 SSize_t pos;
1224 STRLEN len;
a0ed51b3 1225 STRLEN ulen;
c485e607 1226 dTHR;
a0d0e21e
LW
1227
1228 mg = 0;
1229
1230 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
1231 mg = mg_find(lsv, 'g');
1232 if (!mg) {
1233 if (!SvOK(sv))
1234 return 0;
1235 sv_magic(lsv, (SV*)0, 'g', Nullch, 0);
1236 mg = mg_find(lsv, 'g');
1237 }
1238 else if (!SvOK(sv)) {
565764a8 1239 mg->mg_len = -1;
a0d0e21e
LW
1240 return 0;
1241 }
1242 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1243
c485e607 1244 pos = SvIV(sv) - PL_curcop->cop_arybase;
a0ed51b3
LW
1245
1246 if (IN_UTF8) {
1247 ulen = sv_len_utf8(lsv);
1248 if (ulen)
1249 len = ulen;
1250 else
1251 ulen = 0;
1252 }
1253
a0d0e21e
LW
1254 if (pos < 0) {
1255 pos += len;
1256 if (pos < 0)
1257 pos = 0;
1258 }
1259 else if (pos > len)
1260 pos = len;
a0ed51b3
LW
1261
1262 if (ulen) {
1263 I32 p = pos;
1264 sv_pos_u2b(lsv, &p, 0);
1265 pos = p;
1266 }
1267
565764a8 1268 mg->mg_len = pos;
71be2cbc 1269 mg->mg_flags &= ~MGf_MINMATCH;
a0d0e21e 1270
79072805
LW
1271 return 0;
1272}
1273
1274int
864dbfa3 1275Perl_magic_getglob(pTHX_ SV *sv, MAGIC *mg)
79072805 1276{
8646b087
PP
1277 if (SvFAKE(sv)) { /* FAKE globs can get coerced */
1278 SvFAKE_off(sv);
946ec16e 1279 gv_efullname3(sv,((GV*)sv), "*");
8646b087
PP
1280 SvFAKE_on(sv);
1281 }
1282 else
946ec16e 1283 gv_efullname3(sv,((GV*)sv), "*"); /* a gv value, be nice */
79072805
LW
1284 return 0;
1285}
1286
1287int
864dbfa3 1288Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg)
79072805
LW
1289{
1290 register char *s;
1291 GV* gv;
2d8e6c8d 1292 STRLEN n_a;
79072805
LW
1293
1294 if (!SvOK(sv))
1295 return 0;
2d8e6c8d 1296 s = SvPV(sv, n_a);
79072805
LW
1297 if (*s == '*' && s[1])
1298 s++;
85e6fe83 1299 gv = gv_fetchpv(s,TRUE, SVt_PVGV);
79072805
LW
1300 if (sv == (SV*)gv)
1301 return 0;
1302 if (GvGP(sv))
88e89b8a 1303 gp_free((GV*)sv);
79072805 1304 GvGP(sv) = gp_ref(GvGP(gv));
79072805
LW
1305 return 0;
1306}
1307
1308int
864dbfa3 1309Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
6ff81951
GS
1310{
1311 STRLEN len;
1312 SV *lsv = LvTARG(sv);
1313 char *tmps = SvPV(lsv,len);
1314 I32 offs = LvTARGOFF(sv);
1315 I32 rem = LvTARGLEN(sv);
1316
1317 if (offs > len)
1318 offs = len;
1319 if (rem + offs > len)
1320 rem = len - offs;
1321 sv_setpvn(sv, tmps + offs, (STRLEN)rem);
1322 return 0;
1323}
1324
1325int
864dbfa3 1326Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
79072805 1327{
8990e307
LW
1328 STRLEN len;
1329 char *tmps = SvPV(sv,len);
1330 sv_insert(LvTARG(sv),LvTARGOFF(sv),LvTARGLEN(sv), tmps, len);
79072805
LW
1331 return 0;
1332}
1333
1334int
864dbfa3 1335Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
463ee0b2 1336{
a863c7d1 1337 dTHR;
565764a8
DL
1338 TAINT_IF((mg->mg_len & 1) ||
1339 (mg->mg_len & 2) && mg->mg_obj == sv); /* kludge */
463ee0b2
LW
1340 return 0;
1341}
1342
1343int
864dbfa3 1344Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
463ee0b2 1345{
11343788 1346 dTHR;
3280af22
NIS
1347 if (PL_localizing) {
1348 if (PL_localizing == 1)
565764a8 1349 mg->mg_len <<= 1;
748a9306 1350 else
565764a8 1351 mg->mg_len >>= 1;
a0d0e21e 1352 }
3280af22 1353 else if (PL_tainted)
565764a8 1354 mg->mg_len |= 1;
748a9306 1355 else
565764a8 1356 mg->mg_len &= ~1;
463ee0b2
LW
1357 return 0;
1358}
1359
1360int
864dbfa3 1361Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
6ff81951
GS
1362{
1363 SV *lsv = LvTARG(sv);
6ff81951
GS
1364
1365 if (!lsv) {
1366 SvOK_off(sv);
1367 return 0;
1368 }
6ff81951 1369
81e118e0 1370 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
6ff81951
GS
1371 return 0;
1372}
1373
1374int
864dbfa3 1375Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
79072805
LW
1376{
1377 do_vecset(sv); /* XXX slurp this routine */
1378 return 0;
1379}
1380
1381int
864dbfa3 1382Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
5f05dabc 1383{
71be2cbc 1384 SV *targ = Nullsv;
5f05dabc 1385 if (LvTARGLEN(sv)) {
68dc0745 1386 if (mg->mg_obj) {
74e13ce4
GS
1387 SV *ahv = LvTARG(sv);
1388 if (SvTYPE(ahv) == SVt_PVHV) {
1389 HE *he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
1390 if (he)
1391 targ = HeVAL(he);
1392 }
1393 else {
1394 SV **svp = avhv_fetch_ent((AV*)ahv, mg->mg_obj, FALSE, 0);
1395 if (svp)
1396 targ = *svp;
1397 }
68dc0745
PP
1398 }
1399 else {
3c78fafa 1400 AV* av = (AV*)LvTARG(sv);
68dc0745
PP
1401 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
1402 targ = AvARRAY(av)[LvTARGOFF(sv)];
1403 }
3280af22 1404 if (targ && targ != &PL_sv_undef) {
e858de61 1405 dTHR; /* just for SvREFCNT_dec */
68dc0745
PP
1406 /* somebody else defined it for us */
1407 SvREFCNT_dec(LvTARG(sv));
1408 LvTARG(sv) = SvREFCNT_inc(targ);
1409 LvTARGLEN(sv) = 0;
1410 SvREFCNT_dec(mg->mg_obj);
1411 mg->mg_obj = Nullsv;
1412 mg->mg_flags &= ~MGf_REFCOUNTED;
1413 }
5f05dabc 1414 }
71be2cbc
PP
1415 else
1416 targ = LvTARG(sv);
3280af22 1417 sv_setsv(sv, targ ? targ : &PL_sv_undef);
71be2cbc
PP
1418 return 0;
1419}
1420
1421int
864dbfa3 1422Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
71be2cbc
PP
1423{
1424 if (LvTARGLEN(sv))
68dc0745
PP
1425 vivify_defelem(sv);
1426 if (LvTARG(sv)) {
5f05dabc 1427 sv_setsv(LvTARG(sv), sv);
68dc0745
PP
1428 SvSETMAGIC(LvTARG(sv));
1429 }
5f05dabc
PP
1430 return 0;
1431}
1432
71be2cbc 1433void
864dbfa3 1434Perl_vivify_defelem(pTHX_ SV *sv)
71be2cbc 1435{
e858de61 1436 dTHR; /* just for SvREFCNT_inc and SvREFCNT_dec*/
74e13ce4
GS
1437 MAGIC *mg;
1438 SV *value = Nullsv;
71be2cbc 1439
68dc0745 1440 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, 'y')))
71be2cbc 1441 return;
68dc0745 1442 if (mg->mg_obj) {
74e13ce4 1443 SV *ahv = LvTARG(sv);
2d8e6c8d 1444 STRLEN n_a;
74e13ce4 1445 if (SvTYPE(ahv) == SVt_PVHV) {
af7f9c15 1446 HE *he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
74e13ce4
GS
1447 if (he)
1448 value = HeVAL(he);
1449 }
1450 else {
af7f9c15 1451 SV **svp = avhv_fetch_ent((AV*)ahv, mg->mg_obj, TRUE, 0);
74e13ce4
GS
1452 if (svp)
1453 value = *svp;
1454 }
3280af22 1455 if (!value || value == &PL_sv_undef)
cea2e8a9 1456 Perl_croak(aTHX_ PL_no_helem, SvPV(mg->mg_obj, n_a));
71be2cbc 1457 }
68dc0745
PP
1458 else {
1459 AV* av = (AV*)LvTARG(sv);
5aabfad6 1460 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
68dc0745
PP
1461 LvTARG(sv) = Nullsv; /* array can't be extended */
1462 else {
1463 SV** svp = av_fetch(av, LvTARGOFF(sv), TRUE);
3280af22 1464 if (!svp || (value = *svp) == &PL_sv_undef)
cea2e8a9 1465 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
68dc0745
PP
1466 }
1467 }
3e3baf6d 1468 (void)SvREFCNT_inc(value);
68dc0745
PP
1469 SvREFCNT_dec(LvTARG(sv));
1470 LvTARG(sv) = value;
71be2cbc 1471 LvTARGLEN(sv) = 0;
68dc0745
PP
1472 SvREFCNT_dec(mg->mg_obj);
1473 mg->mg_obj = Nullsv;
1474 mg->mg_flags &= ~MGf_REFCOUNTED;
5f05dabc
PP
1475}
1476
1477int
864dbfa3 1478Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
810b8aa5
GS
1479{
1480 AV *av = (AV*)mg->mg_obj;
1481 SV **svp = AvARRAY(av);
1482 I32 i = AvFILLp(av);
1483 while (i >= 0) {
1484 if (svp[i] && svp[i] != &PL_sv_undef) {
1485 if (!SvWEAKREF(svp[i]))
cea2e8a9 1486 Perl_croak(aTHX_ "panic: magic_killbackrefs");
810b8aa5
GS
1487 /* XXX Should we check that it hasn't changed? */
1488 SvRV(svp[i]) = 0;
1489 SvOK_off(svp[i]);
1490 SvWEAKREF_off(svp[i]);
1491 svp[i] = &PL_sv_undef;
1492 }
1493 i--;
1494 }
1495 return 0;
1496}
1497
1498int
864dbfa3 1499Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
93a17b20 1500{
565764a8 1501 mg->mg_len = -1;
c6496cc7 1502 SvSCREAM_off(sv);
93a17b20
LW
1503 return 0;
1504}
1505
1506int
864dbfa3 1507Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
79072805 1508{
463ee0b2 1509 sv_unmagic(sv, 'B');
79072805
LW
1510 SvVALID_off(sv);
1511 return 0;
1512}
1513
1514int
864dbfa3 1515Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
55497cff
PP
1516{
1517 sv_unmagic(sv, 'f');
1518 SvCOMPILED_off(sv);
1519 return 0;
1520}
1521
1522int
864dbfa3 1523Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
79072805
LW
1524{
1525 struct ufuncs *uf = (struct ufuncs *)mg->mg_ptr;
1526
1527 if (uf && uf->uf_set)
1528 (*uf->uf_set)(uf->uf_index, sv);
1529 return 0;
1530}
1531
c277df42 1532int
864dbfa3 1533Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
c277df42
IZ
1534{
1535 regexp *re = (regexp *)mg->mg_obj;
1536 ReREFCNT_dec(re);
1537 return 0;
1538}
1539
7a4c00b4 1540#ifdef USE_LOCALE_COLLATE
79072805 1541int
864dbfa3 1542Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
bbce6d69
PP
1543{
1544 /*
838b5b74 1545 * RenE<eacute> Descartes said "I think not."
bbce6d69
PP
1546 * and vanished with a faint plop.
1547 */
7a4c00b4
PP
1548 if (mg->mg_ptr) {
1549 Safefree(mg->mg_ptr);
1550 mg->mg_ptr = NULL;
565764a8 1551 mg->mg_len = -1;
7a4c00b4 1552 }
bbce6d69
PP
1553 return 0;
1554}
7a4c00b4 1555#endif /* USE_LOCALE_COLLATE */
bbce6d69
PP
1556
1557int
864dbfa3 1558Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
79072805 1559{
11343788 1560 dTHR;
79072805
LW
1561 register char *s;
1562 I32 i;
8990e307 1563 STRLEN len;
79072805 1564 switch (*mg->mg_ptr) {
748a9306 1565 case '\001': /* ^A */
3280af22 1566 sv_setsv(PL_bodytarget, sv);
748a9306 1567 break;
599cee73
PM
1568 case '\002': /* ^B */
1569 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
0453d815 1570 if (memEQ(SvPVX(sv), WARN_ALLstring, WARNsize)) {
e24b16f9 1571 PL_compiling.cop_warnings = WARN_ALL;
0453d815
PM
1572 PL_dowarn |= G_WARN_ONCE ;
1573 }
599cee73 1574 else if (memEQ(SvPVX(sv), WARN_NONEstring, WARNsize))
e24b16f9 1575 PL_compiling.cop_warnings = WARN_NONE;
599cee73 1576 else {
0453d815 1577 if (specialWARN(PL_compiling.cop_warnings))
e24b16f9 1578 PL_compiling.cop_warnings = newSVsv(sv) ;
0453d815
PM
1579 else
1580 sv_setsv(PL_compiling.cop_warnings, sv);
1581 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
1582 PL_dowarn |= G_WARN_ONCE ;
599cee73
PM
1583 }
1584 }
1585 break;
49460fe6
NIS
1586
1587 case '\003': /* ^C */
1588 PL_minus_c = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1589 break;
1590
79072805 1591 case '\004': /* ^D */
3280af22 1592 PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | 0x80000000;
79072805
LW
1593 DEBUG_x(dump_all());
1594 break;
28f23441
PP
1595 case '\005': /* ^E */
1596#ifdef VMS
1597 set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
1598#else
048c1ddf 1599# ifdef WIN32
22fae026 1600 SetLastError( SvIV(sv) );
048c1ddf
IZ
1601# else
1602# ifndef OS2
f86702cc
PP
1603 /* will anyone ever use this? */
1604 SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4);
048c1ddf
IZ
1605# endif
1606# endif
22fae026 1607#endif
28f23441 1608 break;
79072805 1609 case '\006': /* ^F */
3280af22 1610 PL_maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
79072805 1611 break;
a0d0e21e 1612 case '\010': /* ^H */
3280af22 1613 PL_hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
a0d0e21e 1614 break;
9d116dd7 1615 case '\011': /* ^I */ /* NOT \t in EBCDIC */
3280af22
NIS
1616 if (PL_inplace)
1617 Safefree(PL_inplace);
79072805 1618 if (SvOK(sv))
2d8e6c8d 1619 PL_inplace = savepv(SvPV(sv,len));
79072805 1620 else
3280af22 1621 PL_inplace = Nullch;
79072805 1622 break;
28f23441 1623 case '\017': /* ^O */
3280af22
NIS
1624 if (PL_osname)
1625 Safefree(PL_osname);
28f23441 1626 if (SvOK(sv))
2d8e6c8d 1627 PL_osname = savepv(SvPV(sv,len));
28f23441 1628 else
3280af22 1629 PL_osname = Nullch;
28f23441 1630 break;
79072805 1631 case '\020': /* ^P */
3280af22 1632 PL_perldb = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1ee4443e
IZ
1633 if (PL_perldb && !PL_DBsingle)
1634 init_debugger();
79072805
LW
1635 break;
1636 case '\024': /* ^T */
88e89b8a 1637#ifdef BIG_TIME
6b88bc9c 1638 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
88e89b8a 1639#else
3280af22 1640 PL_basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
88e89b8a 1641#endif
79072805
LW
1642 break;
1643 case '\027': /* ^W */
599cee73
PM
1644 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
1645 i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
0453d815
PM
1646 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
1647 | (i ? G_WARN_ON : G_WARN_OFF) ;
599cee73 1648 }
79072805
LW
1649 break;
1650 case '.':
3280af22
NIS
1651 if (PL_localizing) {
1652 if (PL_localizing == 1)
1653 save_sptr((SV**)&PL_last_in_gv);
748a9306 1654 }
3280af22
NIS
1655 else if (SvOK(sv) && GvIO(PL_last_in_gv))
1656 IoLINES(GvIOp(PL_last_in_gv)) = (long)SvIV(sv);
79072805
LW
1657 break;
1658 case '^':
3280af22 1659 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2d8e6c8d 1660 IoTOP_NAME(GvIOp(PL_defoutgv)) = s = savepv(SvPV(sv,len));
3280af22 1661 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchpv(s,TRUE, SVt_PVIO);
79072805
LW
1662 break;
1663 case '~':
3280af22 1664 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2d8e6c8d 1665 IoFMT_NAME(GvIOp(PL_defoutgv)) = s = savepv(SvPV(sv,len));
3280af22 1666 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchpv(s,TRUE, SVt_PVIO);
79072805
LW
1667 break;
1668 case '=':
3280af22 1669 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
79072805
LW
1670 break;
1671 case '-':
3280af22
NIS
1672 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
1673 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
1674 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
79072805
LW
1675 break;
1676 case '%':
3280af22 1677 IoPAGE(GvIOp(PL_defoutgv)) = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
79072805
LW
1678 break;
1679 case '|':
4b65379b 1680 {
3280af22 1681 IO *io = GvIOp(PL_defoutgv);
4b65379b
CS
1682 if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) == 0)
1683 IoFLAGS(io) &= ~IOf_FLUSH;
1684 else {
1685 if (!(IoFLAGS(io) & IOf_FLUSH)) {
1686 PerlIO *ofp = IoOFP(io);
1687 if (ofp)
1688 (void)PerlIO_flush(ofp);
1689 IoFLAGS(io) |= IOf_FLUSH;
1690 }
1691 }
79072805
LW
1692 }
1693 break;
1694 case '*':
463ee0b2 1695 i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
3280af22 1696 PL_multiline = (i != 0);
79072805
LW
1697 break;
1698 case '/':
3280af22
NIS
1699 SvREFCNT_dec(PL_nrs);
1700 PL_nrs = newSVsv(sv);
1701 SvREFCNT_dec(PL_rs);
1702 PL_rs = SvREFCNT_inc(PL_nrs);
79072805
LW
1703 break;
1704 case '\\':
3280af22
NIS
1705 if (PL_ors)
1706 Safefree(PL_ors);
e3c19b7b 1707 if (SvOK(sv) || SvGMAGICAL(sv))
3280af22 1708 PL_ors = savepv(SvPV(sv,PL_orslen));
e3c19b7b 1709 else {
3280af22
NIS
1710 PL_ors = Nullch;
1711 PL_orslen = 0;
e3c19b7b 1712 }
79072805
LW
1713 break;
1714 case ',':
3280af22
NIS
1715 if (PL_ofs)
1716 Safefree(PL_ofs);
1717 PL_ofs = savepv(SvPV(sv, PL_ofslen));
79072805
LW
1718 break;
1719 case '#':
3280af22
NIS
1720 if (PL_ofmt)
1721 Safefree(PL_ofmt);
2d8e6c8d 1722 PL_ofmt = savepv(SvPV(sv,len));
79072805
LW
1723 break;
1724 case '[':
3280af22 1725 PL_compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
79072805
LW
1726 break;
1727 case '?':
ff0cee69 1728#ifdef COMPLEX_STATUS
6b88bc9c
GS
1729 if (PL_localizing == 2) {
1730 PL_statusvalue = LvTARGOFF(sv);
1731 PL_statusvalue_vms = LvTARGLEN(sv);
ff0cee69
PP
1732 }
1733 else
1734#endif
1735#ifdef VMSISH_STATUS
1736 if (VMSISH_STATUS)
1737 STATUS_NATIVE_SET((U32)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)));
1738 else
1739#endif
1740 STATUS_POSIX_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
79072805
LW
1741 break;
1742 case '!':
78987ded 1743 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
f86702cc 1744 (SvIV(sv) == EVMSERR) ? 4 : vaxc$errno);
79072805
LW
1745 break;
1746 case '<':
3280af22
NIS
1747 PL_uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1748 if (PL_delaymagic) {
1749 PL_delaymagic |= DM_RUID;
79072805
LW
1750 break; /* don't do magic till later */
1751 }
1752#ifdef HAS_SETRUID
b28d0864 1753 (void)setruid((Uid_t)PL_uid);
79072805
LW
1754#else
1755#ifdef HAS_SETREUID
3280af22 1756 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
748a9306 1757#else
85e6fe83 1758#ifdef HAS_SETRESUID
b28d0864 1759 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
79072805 1760#else
b28d0864
NIS
1761 if (PL_uid == PL_euid) /* special case $< = $> */
1762 (void)PerlProc_setuid(PL_uid);
a0d0e21e 1763 else {
d8eceb89 1764 PL_uid = PerlProc_getuid();
cea2e8a9 1765 Perl_croak(aTHX_ "setruid() not implemented");
a0d0e21e 1766 }
79072805
LW
1767#endif
1768#endif
85e6fe83 1769#endif
d8eceb89 1770 PL_uid = PerlProc_getuid();
3280af22 1771 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
79072805
LW
1772 break;
1773 case '>':
3280af22
NIS
1774 PL_euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1775 if (PL_delaymagic) {
1776 PL_delaymagic |= DM_EUID;
79072805
LW
1777 break; /* don't do magic till later */
1778 }
1779#ifdef HAS_SETEUID
3280af22 1780 (void)seteuid((Uid_t)PL_euid);
79072805
LW
1781#else
1782#ifdef HAS_SETREUID
b28d0864 1783 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
85e6fe83
LW
1784#else
1785#ifdef HAS_SETRESUID
6b88bc9c 1786 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
79072805 1787#else
b28d0864
NIS
1788 if (PL_euid == PL_uid) /* special case $> = $< */
1789 PerlProc_setuid(PL_euid);
a0d0e21e 1790 else {
e8ee3774 1791 PL_euid = PerlProc_geteuid();
cea2e8a9 1792 Perl_croak(aTHX_ "seteuid() not implemented");
a0d0e21e 1793 }
79072805
LW
1794#endif
1795#endif
85e6fe83 1796#endif
d8eceb89 1797 PL_euid = PerlProc_geteuid();
3280af22 1798 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
79072805
LW
1799 break;
1800 case '(':
3280af22
NIS
1801 PL_gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1802 if (PL_delaymagic) {
1803 PL_delaymagic |= DM_RGID;
79072805
LW
1804 break; /* don't do magic till later */
1805 }
1806#ifdef HAS_SETRGID
b28d0864 1807 (void)setrgid((Gid_t)PL_gid);
79072805
LW
1808#else
1809#ifdef HAS_SETREGID
3280af22 1810 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
85e6fe83
LW
1811#else
1812#ifdef HAS_SETRESGID
b28d0864 1813 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
79072805 1814#else
b28d0864
NIS
1815 if (PL_gid == PL_egid) /* special case $( = $) */
1816 (void)PerlProc_setgid(PL_gid);
748a9306 1817 else {
d8eceb89 1818 PL_gid = PerlProc_getgid();
cea2e8a9 1819 Perl_croak(aTHX_ "setrgid() not implemented");
748a9306 1820 }
79072805
LW
1821#endif
1822#endif
85e6fe83 1823#endif
d8eceb89 1824 PL_gid = PerlProc_getgid();
3280af22 1825 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
79072805
LW
1826 break;
1827 case ')':
5cd24f17
PP
1828#ifdef HAS_SETGROUPS
1829 {
2d8e6c8d 1830 char *p = SvPV(sv, len);
5cd24f17
PP
1831 Groups_t gary[NGROUPS];
1832
5cd24f17
PP
1833 while (isSPACE(*p))
1834 ++p;
2d4389e4 1835 PL_egid = Atol(p);
5cd24f17
PP
1836 for (i = 0; i < NGROUPS; ++i) {
1837 while (*p && !isSPACE(*p))
1838 ++p;
1839 while (isSPACE(*p))
1840 ++p;
1841 if (!*p)
1842 break;
2d4389e4 1843 gary[i] = Atol(p);
5cd24f17 1844 }
8cc95fdb
PP
1845 if (i)
1846 (void)setgroups(i, gary);
5cd24f17
PP
1847 }
1848#else /* HAS_SETGROUPS */
b28d0864 1849 PL_egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
5cd24f17 1850#endif /* HAS_SETGROUPS */
3280af22
NIS
1851 if (PL_delaymagic) {
1852 PL_delaymagic |= DM_EGID;
79072805
LW
1853 break; /* don't do magic till later */
1854 }
1855#ifdef HAS_SETEGID
3280af22 1856 (void)setegid((Gid_t)PL_egid);
79072805
LW
1857#else
1858#ifdef HAS_SETREGID
b28d0864 1859 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
85e6fe83
LW
1860#else
1861#ifdef HAS_SETRESGID
b28d0864 1862 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
79072805 1863#else
b28d0864
NIS
1864 if (PL_egid == PL_gid) /* special case $) = $( */
1865 (void)PerlProc_setgid(PL_egid);
748a9306 1866 else {
d8eceb89 1867 PL_egid = PerlProc_getegid();
cea2e8a9 1868 Perl_croak(aTHX_ "setegid() not implemented");
748a9306 1869 }
79072805
LW
1870#endif
1871#endif
85e6fe83 1872#endif
d8eceb89 1873 PL_egid = PerlProc_getegid();
3280af22 1874 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
79072805
LW
1875 break;
1876 case ':':
2d8e6c8d 1877 PL_chopset = SvPV_force(sv,len);
79072805
LW
1878 break;
1879 case '0':
3280af22
NIS
1880 if (!PL_origalen) {
1881 s = PL_origargv[0];
79072805
LW
1882 s += strlen(s);
1883 /* See if all the arguments are contiguous in memory */
3280af22
NIS
1884 for (i = 1; i < PL_origargc; i++) {
1885 if (PL_origargv[i] == s + 1
fb73857a 1886#ifdef OS2
6b88bc9c 1887 || PL_origargv[i] == s + 2
fb73857a
PP
1888#endif
1889 )
379c4362
GS
1890 {
1891 ++s;
1892 s += strlen(s); /* this one is ok too */
1893 }
fb73857a
PP
1894 else
1895 break;
79072805 1896 }
bbce6d69 1897 /* can grab env area too? */
3280af22 1898 if (PL_origenviron && (PL_origenviron[0] == s + 1
fb73857a 1899#ifdef OS2
6b88bc9c 1900 || (PL_origenviron[0] == s + 9 && (s += 8))
fb73857a
PP
1901#endif
1902 )) {
66b1d557 1903 my_setenv("NoNe SuCh", Nullch);
79072805 1904 /* force copy of environment */
3280af22 1905 for (i = 0; PL_origenviron[i]; i++)
379c4362
GS
1906 if (PL_origenviron[i] == s + 1) {
1907 ++s;
1908 s += strlen(s);
1909 }
fb73857a
PP
1910 else
1911 break;
79072805 1912 }
3280af22 1913 PL_origalen = s - PL_origargv[0];
79072805 1914 }
a0d0e21e 1915 s = SvPV_force(sv,len);
8990e307 1916 i = len;
3280af22
NIS
1917 if (i >= PL_origalen) {
1918 i = PL_origalen;
fb73857a
PP
1919 /* don't allow system to limit $0 seen by script */
1920 /* SvCUR_set(sv, i); *SvEND(sv) = '\0'; */
3280af22
NIS
1921 Copy(s, PL_origargv[0], i, char);
1922 s = PL_origargv[0]+i;
fb73857a 1923 *s = '\0';
79072805
LW
1924 }
1925 else {
3280af22
NIS
1926 Copy(s, PL_origargv[0], i, char);
1927 s = PL_origargv[0]+i;
79072805 1928 *s++ = '\0';
3280af22 1929 while (++i < PL_origalen)
8990e307 1930 *s++ = ' ';
3280af22
NIS
1931 s = PL_origargv[0]+i;
1932 for (i = 1; i < PL_origargc; i++)
1933 PL_origargv[i] = Nullch;
79072805
LW
1934 }
1935 break;
a863c7d1
MB
1936#ifdef USE_THREADS
1937 case '@':
38a03e6e 1938 sv_setsv(thr->errsv, sv);
a863c7d1
MB
1939 break;
1940#endif /* USE_THREADS */
79072805
LW
1941 }
1942 return 0;
1943}
1944
f93b4edd
MB
1945#ifdef USE_THREADS
1946int
864dbfa3 1947Perl_magic_mutexfree(pTHX_ SV *sv, MAGIC *mg)
f93b4edd
MB
1948{
1949 dTHR;
8b73bbec 1950 DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: magic_mutexfree 0x%lx\n",
bc1f4c86 1951 (unsigned long)thr, (unsigned long)sv);)
f93b4edd 1952 if (MgOWNER(mg))
cea2e8a9 1953 Perl_croak(aTHX_ "panic: magic_mutexfree");
f93b4edd
MB
1954 MUTEX_DESTROY(MgMUTEXP(mg));
1955 COND_DESTROY(MgCONDP(mg));
1956 return 0;
1957}
1958#endif /* USE_THREADS */
1959
79072805 1960I32
864dbfa3 1961Perl_whichsig(pTHX_ char *sig)
79072805
LW
1962{
1963 register char **sigv;
1964
22c35a8c 1965 for (sigv = PL_sig_name+1; *sigv; sigv++)
79072805 1966 if (strEQ(sig,*sigv))
22c35a8c 1967 return PL_sig_num[sigv - PL_sig_name];
79072805
LW
1968#ifdef SIGCLD
1969 if (strEQ(sig,"CHLD"))
1970 return SIGCLD;
1971#endif
1972#ifdef SIGCHLD
1973 if (strEQ(sig,"CLD"))
1974 return SIGCHLD;
1975#endif
1976 return 0;
1977}
1978
84902520
TB
1979static SV* sig_sv;
1980
ecfc5424 1981Signal_t
cea2e8a9 1982Perl_sighandler(int sig)
79072805 1983{
cea2e8a9 1984 dTHX;
79072805 1985 dSP;
00d579c5 1986 GV *gv = Nullgv;
a0d0e21e 1987 HV *st;
3280af22 1988 SV *sv, *tSv = PL_Sv;
00d579c5 1989 CV *cv = Nullcv;
533c011a 1990 OP *myop = PL_op;
84902520 1991 U32 flags = 0;
3280af22
NIS
1992 I32 o_save_i = PL_savestack_ix, type;
1993 XPV *tXpv = PL_Xpv;
84902520 1994
3280af22 1995 if (PL_savestack_ix + 15 <= PL_savestack_max)
84902520 1996 flags |= 1;
3280af22 1997 if (PL_markstack_ptr < PL_markstack_max - 2)
84902520 1998 flags |= 4;
3280af22 1999 if (PL_retstack_ix < PL_retstack_max - 2)
84902520 2000 flags |= 8;
3280af22 2001 if (PL_scopestack_ix < PL_scopestack_max - 3)
84902520
TB
2002 flags |= 16;
2003
22c35a8c 2004 if (!PL_psig_ptr[sig])
cea2e8a9 2005 Perl_die(aTHX_ "Signal SIG%s received, but no signal handler set.\n",
22c35a8c 2006 PL_sig_name[sig]);
ff0cee69 2007
84902520
TB
2008 /* Max number of items pushed there is 3*n or 4. We cannot fix
2009 infinity, so we fix 4 (in fact 5): */
2010 if (flags & 1) {
3280af22
NIS
2011 PL_savestack_ix += 5; /* Protect save in progress. */
2012 o_save_i = PL_savestack_ix;
51371543 2013 SAVEDESTRUCTOR(unwind_handler_stack, (void*)&flags);
84902520
TB
2014 }
2015 if (flags & 4)
3280af22 2016 PL_markstack_ptr++; /* Protect mark. */
84902520 2017 if (flags & 8) {
3280af22
NIS
2018 PL_retstack_ix++;
2019 PL_retstack[PL_retstack_ix] = NULL;
84902520
TB
2020 }
2021 if (flags & 16)
3280af22 2022 PL_scopestack_ix += 1;
84902520 2023 /* sv_2cv is too complicated, try a simpler variant first: */
22c35a8c 2024 if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
84902520 2025 || SvTYPE(cv) != SVt_PVCV)
22c35a8c 2026 cv = sv_2cv(PL_psig_ptr[sig],&st,&gv,TRUE);
84902520 2027
a0d0e21e 2028 if (!cv || !CvROOT(cv)) {
599cee73 2029 if (ckWARN(WARN_SIGNAL))
cea2e8a9 2030 Perl_warner(aTHX_ WARN_SIGNAL, "SIG%s handler \"%s\" not defined.\n",
22c35a8c 2031 PL_sig_name[sig], (gv ? GvENAME(gv)
00d579c5
GS
2032 : ((cv && CvGV(cv))
2033 ? GvENAME(CvGV(cv))
2034 : "__ANON__")));
2035 goto cleanup;
79072805
LW
2036 }
2037
22c35a8c
GS
2038 if(PL_psig_name[sig]) {
2039 sv = SvREFCNT_inc(PL_psig_name[sig]);
84902520
TB
2040 flags |= 64;
2041 sig_sv = sv;
2042 } else {
ff0cee69 2043 sv = sv_newmortal();
22c35a8c 2044 sv_setpv(sv,PL_sig_name[sig]);
88e89b8a 2045 }
e336de0d 2046
e788e7d3 2047 PUSHSTACKi(PERLSI_SIGNAL);
924508f0 2048 PUSHMARK(SP);
79072805 2049 PUSHs(sv);
79072805 2050 PUTBACK;
a0d0e21e 2051
864dbfa3 2052 call_sv((SV*)cv, G_DISCARD);
79072805 2053
d3acc0f7 2054 POPSTACK;
00d579c5 2055cleanup:
84902520 2056 if (flags & 1)
3280af22 2057 PL_savestack_ix -= 8; /* Unprotect save in progress. */
84902520 2058 if (flags & 4)
3280af22 2059 PL_markstack_ptr--;
84902520 2060 if (flags & 8)
3280af22 2061 PL_retstack_ix--;
84902520 2062 if (flags & 16)
3280af22 2063 PL_scopestack_ix -= 1;
84902520
TB
2064 if (flags & 64)
2065 SvREFCNT_dec(sv);
533c011a 2066 PL_op = myop; /* Apparently not needed... */
84902520 2067
3280af22
NIS
2068 PL_Sv = tSv; /* Restore global temporaries. */
2069 PL_Xpv = tXpv;
79072805
LW
2070 return;
2071}
4e35701f
NIS
2072
2073
51371543
GS
2074#ifdef PERL_OBJECT
2075#define NO_XSLOCKS
2076#include "XSUB.h"
2077#endif
2078
2079static void
2080restore_magic(pTHXo_ void *p)
2081{
2082 dTHR;
2083 MGS* mgs = SSPTR((I32)p, MGS*);
2084 SV* sv = mgs->mgs_sv;
2085
2086 if (!sv)
2087 return;
2088
2089 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2090 {
2091 if (mgs->mgs_flags)
2092 SvFLAGS(sv) |= mgs->mgs_flags;
2093 else
2094 mg_magical(sv);
2095 if (SvGMAGICAL(sv))
2096 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
2097 }
2098
2099 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
2100
2101 /* If we're still on top of the stack, pop us off. (That condition
2102 * will be satisfied if restore_magic was called explicitly, but *not*
2103 * if it's being called via leave_scope.)
2104 * The reason for doing this is that otherwise, things like sv_2cv()
2105 * may leave alloc gunk on the savestack, and some code
2106 * (e.g. sighandler) doesn't expect that...
2107 */
2108 if (PL_savestack_ix == mgs->mgs_ss_ix)
2109 {
2110 I32 popval = SSPOPINT;
2111 assert(popval == SAVEt_DESTRUCTOR);
2112 PL_savestack_ix -= 2;
2113 popval = SSPOPINT;
2114 assert(popval == SAVEt_ALLOC);
2115 popval = SSPOPINT;
2116 PL_savestack_ix -= popval;
2117 }
2118
2119}
2120
2121static void
2122unwind_handler_stack(pTHXo_ void *p)
2123{
2124 dTHR;
2125 U32 flags = *(U32*)p;
2126
2127 if (flags & 1)
2128 PL_savestack_ix -= 5; /* Unprotect save in progress. */
2129 /* cxstack_ix-- Not needed, die already unwound it. */
2130 if (flags & 64)
2131 SvREFCNT_dec(sig_sv);
2132}