This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Remove I32 casts from pp_stat, these make stat()
[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);
1364 unsigned char *s;
1365 unsigned long retnum;
1366 STRLEN lsvlen;
1367 I32 len;
1368 I32 offset;
1369 I32 size;
1370
1371 if (!lsv) {
1372 SvOK_off(sv);
1373 return 0;
1374 }
1375 s = (unsigned char *) SvPV(lsv, lsvlen);
1376 offset = LvTARGOFF(sv);
1377 size = LvTARGLEN(sv);
1378 len = (offset + size + 7) / 8;
1379
1380 /* Copied from pp_vec() */
1381
1382 if (len > lsvlen) {
1383 if (size <= 8)
1384 retnum = 0;
1385 else {
1386 offset >>= 3;
1387 if (size == 16) {
1388 if (offset >= lsvlen)
1389 retnum = 0;
1390 else
1391 retnum = (unsigned long) s[offset] << 8;
1392 }
1393 else if (size == 32) {
1394 if (offset >= lsvlen)
1395 retnum = 0;
1396 else if (offset + 1 >= lsvlen)
1397 retnum = (unsigned long) s[offset] << 24;
1398 else if (offset + 2 >= lsvlen)
1399 retnum = ((unsigned long) s[offset] << 24) +
1400 ((unsigned long) s[offset + 1] << 16);
1401 else
1402 retnum = ((unsigned long) s[offset] << 24) +
1403 ((unsigned long) s[offset + 1] << 16) +
1404 (s[offset + 2] << 8);
1405 }
1406 }
1407 }
1408 else if (size < 8)
1409 retnum = (s[offset >> 3] >> (offset & 7)) & ((1 << size) - 1);
1410 else {
1411 offset >>= 3;
1412 if (size == 8)
1413 retnum = s[offset];
1414 else if (size == 16)
1415 retnum = ((unsigned long) s[offset] << 8) + s[offset+1];
1416 else if (size == 32)
1417 retnum = ((unsigned long) s[offset] << 24) +
1418 ((unsigned long) s[offset + 1] << 16) +
1419 (s[offset + 2] << 8) + s[offset+3];
1420 }
1421
1422 sv_setuv(sv, (UV)retnum);
1423 return 0;
1424}
1425
1426int
864dbfa3 1427Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
79072805
LW
1428{
1429 do_vecset(sv); /* XXX slurp this routine */
1430 return 0;
1431}
1432
1433int
864dbfa3 1434Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
5f05dabc 1435{
71be2cbc 1436 SV *targ = Nullsv;
5f05dabc 1437 if (LvTARGLEN(sv)) {
68dc0745 1438 if (mg->mg_obj) {
74e13ce4
GS
1439 SV *ahv = LvTARG(sv);
1440 if (SvTYPE(ahv) == SVt_PVHV) {
1441 HE *he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
1442 if (he)
1443 targ = HeVAL(he);
1444 }
1445 else {
1446 SV **svp = avhv_fetch_ent((AV*)ahv, mg->mg_obj, FALSE, 0);
1447 if (svp)
1448 targ = *svp;
1449 }
68dc0745
PP
1450 }
1451 else {
3c78fafa 1452 AV* av = (AV*)LvTARG(sv);
68dc0745
PP
1453 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
1454 targ = AvARRAY(av)[LvTARGOFF(sv)];
1455 }
3280af22 1456 if (targ && targ != &PL_sv_undef) {
e858de61 1457 dTHR; /* just for SvREFCNT_dec */
68dc0745
PP
1458 /* somebody else defined it for us */
1459 SvREFCNT_dec(LvTARG(sv));
1460 LvTARG(sv) = SvREFCNT_inc(targ);
1461 LvTARGLEN(sv) = 0;
1462 SvREFCNT_dec(mg->mg_obj);
1463 mg->mg_obj = Nullsv;
1464 mg->mg_flags &= ~MGf_REFCOUNTED;
1465 }
5f05dabc 1466 }
71be2cbc
PP
1467 else
1468 targ = LvTARG(sv);
3280af22 1469 sv_setsv(sv, targ ? targ : &PL_sv_undef);
71be2cbc
PP
1470 return 0;
1471}
1472
1473int
864dbfa3 1474Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
71be2cbc
PP
1475{
1476 if (LvTARGLEN(sv))
68dc0745
PP
1477 vivify_defelem(sv);
1478 if (LvTARG(sv)) {
5f05dabc 1479 sv_setsv(LvTARG(sv), sv);
68dc0745
PP
1480 SvSETMAGIC(LvTARG(sv));
1481 }
5f05dabc
PP
1482 return 0;
1483}
1484
71be2cbc 1485void
864dbfa3 1486Perl_vivify_defelem(pTHX_ SV *sv)
71be2cbc 1487{
e858de61 1488 dTHR; /* just for SvREFCNT_inc and SvREFCNT_dec*/
74e13ce4
GS
1489 MAGIC *mg;
1490 SV *value = Nullsv;
71be2cbc 1491
68dc0745 1492 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, 'y')))
71be2cbc 1493 return;
68dc0745 1494 if (mg->mg_obj) {
74e13ce4 1495 SV *ahv = LvTARG(sv);
2d8e6c8d 1496 STRLEN n_a;
74e13ce4 1497 if (SvTYPE(ahv) == SVt_PVHV) {
af7f9c15 1498 HE *he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
74e13ce4
GS
1499 if (he)
1500 value = HeVAL(he);
1501 }
1502 else {
af7f9c15 1503 SV **svp = avhv_fetch_ent((AV*)ahv, mg->mg_obj, TRUE, 0);
74e13ce4
GS
1504 if (svp)
1505 value = *svp;
1506 }
3280af22 1507 if (!value || value == &PL_sv_undef)
cea2e8a9 1508 Perl_croak(aTHX_ PL_no_helem, SvPV(mg->mg_obj, n_a));
71be2cbc 1509 }
68dc0745
PP
1510 else {
1511 AV* av = (AV*)LvTARG(sv);
5aabfad6 1512 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
68dc0745
PP
1513 LvTARG(sv) = Nullsv; /* array can't be extended */
1514 else {
1515 SV** svp = av_fetch(av, LvTARGOFF(sv), TRUE);
3280af22 1516 if (!svp || (value = *svp) == &PL_sv_undef)
cea2e8a9 1517 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
68dc0745
PP
1518 }
1519 }
3e3baf6d 1520 (void)SvREFCNT_inc(value);
68dc0745
PP
1521 SvREFCNT_dec(LvTARG(sv));
1522 LvTARG(sv) = value;
71be2cbc 1523 LvTARGLEN(sv) = 0;
68dc0745
PP
1524 SvREFCNT_dec(mg->mg_obj);
1525 mg->mg_obj = Nullsv;
1526 mg->mg_flags &= ~MGf_REFCOUNTED;
5f05dabc
PP
1527}
1528
1529int
864dbfa3 1530Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
810b8aa5
GS
1531{
1532 AV *av = (AV*)mg->mg_obj;
1533 SV **svp = AvARRAY(av);
1534 I32 i = AvFILLp(av);
1535 while (i >= 0) {
1536 if (svp[i] && svp[i] != &PL_sv_undef) {
1537 if (!SvWEAKREF(svp[i]))
cea2e8a9 1538 Perl_croak(aTHX_ "panic: magic_killbackrefs");
810b8aa5
GS
1539 /* XXX Should we check that it hasn't changed? */
1540 SvRV(svp[i]) = 0;
1541 SvOK_off(svp[i]);
1542 SvWEAKREF_off(svp[i]);
1543 svp[i] = &PL_sv_undef;
1544 }
1545 i--;
1546 }
1547 return 0;
1548}
1549
1550int
864dbfa3 1551Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
93a17b20 1552{
565764a8 1553 mg->mg_len = -1;
c6496cc7 1554 SvSCREAM_off(sv);
93a17b20
LW
1555 return 0;
1556}
1557
1558int
864dbfa3 1559Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
79072805 1560{
463ee0b2 1561 sv_unmagic(sv, 'B');
79072805
LW
1562 SvVALID_off(sv);
1563 return 0;
1564}
1565
1566int
864dbfa3 1567Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
55497cff
PP
1568{
1569 sv_unmagic(sv, 'f');
1570 SvCOMPILED_off(sv);
1571 return 0;
1572}
1573
1574int
864dbfa3 1575Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
79072805
LW
1576{
1577 struct ufuncs *uf = (struct ufuncs *)mg->mg_ptr;
1578
1579 if (uf && uf->uf_set)
1580 (*uf->uf_set)(uf->uf_index, sv);
1581 return 0;
1582}
1583
c277df42 1584int
864dbfa3 1585Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
c277df42
IZ
1586{
1587 regexp *re = (regexp *)mg->mg_obj;
1588 ReREFCNT_dec(re);
1589 return 0;
1590}
1591
7a4c00b4 1592#ifdef USE_LOCALE_COLLATE
79072805 1593int
864dbfa3 1594Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
bbce6d69
PP
1595{
1596 /*
838b5b74 1597 * RenE<eacute> Descartes said "I think not."
bbce6d69
PP
1598 * and vanished with a faint plop.
1599 */
7a4c00b4
PP
1600 if (mg->mg_ptr) {
1601 Safefree(mg->mg_ptr);
1602 mg->mg_ptr = NULL;
565764a8 1603 mg->mg_len = -1;
7a4c00b4 1604 }
bbce6d69
PP
1605 return 0;
1606}
7a4c00b4 1607#endif /* USE_LOCALE_COLLATE */
bbce6d69
PP
1608
1609int
864dbfa3 1610Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
79072805 1611{
11343788 1612 dTHR;
79072805
LW
1613 register char *s;
1614 I32 i;
8990e307 1615 STRLEN len;
79072805 1616 switch (*mg->mg_ptr) {
748a9306 1617 case '\001': /* ^A */
3280af22 1618 sv_setsv(PL_bodytarget, sv);
748a9306 1619 break;
599cee73
PM
1620 case '\002': /* ^B */
1621 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
0453d815 1622 if (memEQ(SvPVX(sv), WARN_ALLstring, WARNsize)) {
e24b16f9 1623 PL_compiling.cop_warnings = WARN_ALL;
0453d815
PM
1624 PL_dowarn |= G_WARN_ONCE ;
1625 }
599cee73 1626 else if (memEQ(SvPVX(sv), WARN_NONEstring, WARNsize))
e24b16f9 1627 PL_compiling.cop_warnings = WARN_NONE;
599cee73 1628 else {
0453d815 1629 if (specialWARN(PL_compiling.cop_warnings))
e24b16f9 1630 PL_compiling.cop_warnings = newSVsv(sv) ;
0453d815
PM
1631 else
1632 sv_setsv(PL_compiling.cop_warnings, sv);
1633 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
1634 PL_dowarn |= G_WARN_ONCE ;
599cee73
PM
1635 }
1636 }
1637 break;
49460fe6
NIS
1638
1639 case '\003': /* ^C */
1640 PL_minus_c = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1641 break;
1642
79072805 1643 case '\004': /* ^D */
3280af22 1644 PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | 0x80000000;
79072805
LW
1645 DEBUG_x(dump_all());
1646 break;
28f23441
PP
1647 case '\005': /* ^E */
1648#ifdef VMS
1649 set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
1650#else
048c1ddf 1651# ifdef WIN32
22fae026 1652 SetLastError( SvIV(sv) );
048c1ddf
IZ
1653# else
1654# ifndef OS2
f86702cc
PP
1655 /* will anyone ever use this? */
1656 SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4);
048c1ddf
IZ
1657# endif
1658# endif
22fae026 1659#endif
28f23441 1660 break;
79072805 1661 case '\006': /* ^F */
3280af22 1662 PL_maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
79072805 1663 break;
a0d0e21e 1664 case '\010': /* ^H */
3280af22 1665 PL_hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
a0d0e21e 1666 break;
9d116dd7 1667 case '\011': /* ^I */ /* NOT \t in EBCDIC */
3280af22
NIS
1668 if (PL_inplace)
1669 Safefree(PL_inplace);
79072805 1670 if (SvOK(sv))
2d8e6c8d 1671 PL_inplace = savepv(SvPV(sv,len));
79072805 1672 else
3280af22 1673 PL_inplace = Nullch;
79072805 1674 break;
28f23441 1675 case '\017': /* ^O */
3280af22
NIS
1676 if (PL_osname)
1677 Safefree(PL_osname);
28f23441 1678 if (SvOK(sv))
2d8e6c8d 1679 PL_osname = savepv(SvPV(sv,len));
28f23441 1680 else
3280af22 1681 PL_osname = Nullch;
28f23441 1682 break;
79072805 1683 case '\020': /* ^P */
3280af22 1684 PL_perldb = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1ee4443e
IZ
1685 if (PL_perldb && !PL_DBsingle)
1686 init_debugger();
79072805
LW
1687 break;
1688 case '\024': /* ^T */
88e89b8a 1689#ifdef BIG_TIME
6b88bc9c 1690 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
88e89b8a 1691#else
3280af22 1692 PL_basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
88e89b8a 1693#endif
79072805
LW
1694 break;
1695 case '\027': /* ^W */
599cee73
PM
1696 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
1697 i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
0453d815
PM
1698 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
1699 | (i ? G_WARN_ON : G_WARN_OFF) ;
599cee73 1700 }
79072805
LW
1701 break;
1702 case '.':
3280af22
NIS
1703 if (PL_localizing) {
1704 if (PL_localizing == 1)
1705 save_sptr((SV**)&PL_last_in_gv);
748a9306 1706 }
3280af22
NIS
1707 else if (SvOK(sv) && GvIO(PL_last_in_gv))
1708 IoLINES(GvIOp(PL_last_in_gv)) = (long)SvIV(sv);
79072805
LW
1709 break;
1710 case '^':
3280af22 1711 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2d8e6c8d 1712 IoTOP_NAME(GvIOp(PL_defoutgv)) = s = savepv(SvPV(sv,len));
3280af22 1713 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchpv(s,TRUE, SVt_PVIO);
79072805
LW
1714 break;
1715 case '~':
3280af22 1716 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2d8e6c8d 1717 IoFMT_NAME(GvIOp(PL_defoutgv)) = s = savepv(SvPV(sv,len));
3280af22 1718 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchpv(s,TRUE, SVt_PVIO);
79072805
LW
1719 break;
1720 case '=':
3280af22 1721 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
79072805
LW
1722 break;
1723 case '-':
3280af22
NIS
1724 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
1725 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
1726 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
79072805
LW
1727 break;
1728 case '%':
3280af22 1729 IoPAGE(GvIOp(PL_defoutgv)) = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
79072805
LW
1730 break;
1731 case '|':
4b65379b 1732 {
3280af22 1733 IO *io = GvIOp(PL_defoutgv);
4b65379b
CS
1734 if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) == 0)
1735 IoFLAGS(io) &= ~IOf_FLUSH;
1736 else {
1737 if (!(IoFLAGS(io) & IOf_FLUSH)) {
1738 PerlIO *ofp = IoOFP(io);
1739 if (ofp)
1740 (void)PerlIO_flush(ofp);
1741 IoFLAGS(io) |= IOf_FLUSH;
1742 }
1743 }
79072805
LW
1744 }
1745 break;
1746 case '*':
463ee0b2 1747 i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
3280af22 1748 PL_multiline = (i != 0);
79072805
LW
1749 break;
1750 case '/':
3280af22
NIS
1751 SvREFCNT_dec(PL_nrs);
1752 PL_nrs = newSVsv(sv);
1753 SvREFCNT_dec(PL_rs);
1754 PL_rs = SvREFCNT_inc(PL_nrs);
79072805
LW
1755 break;
1756 case '\\':
3280af22
NIS
1757 if (PL_ors)
1758 Safefree(PL_ors);
e3c19b7b 1759 if (SvOK(sv) || SvGMAGICAL(sv))
3280af22 1760 PL_ors = savepv(SvPV(sv,PL_orslen));
e3c19b7b 1761 else {
3280af22
NIS
1762 PL_ors = Nullch;
1763 PL_orslen = 0;
e3c19b7b 1764 }
79072805
LW
1765 break;
1766 case ',':
3280af22
NIS
1767 if (PL_ofs)
1768 Safefree(PL_ofs);
1769 PL_ofs = savepv(SvPV(sv, PL_ofslen));
79072805
LW
1770 break;
1771 case '#':
3280af22
NIS
1772 if (PL_ofmt)
1773 Safefree(PL_ofmt);
2d8e6c8d 1774 PL_ofmt = savepv(SvPV(sv,len));
79072805
LW
1775 break;
1776 case '[':
3280af22 1777 PL_compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
79072805
LW
1778 break;
1779 case '?':
ff0cee69 1780#ifdef COMPLEX_STATUS
6b88bc9c
GS
1781 if (PL_localizing == 2) {
1782 PL_statusvalue = LvTARGOFF(sv);
1783 PL_statusvalue_vms = LvTARGLEN(sv);
ff0cee69
PP
1784 }
1785 else
1786#endif
1787#ifdef VMSISH_STATUS
1788 if (VMSISH_STATUS)
1789 STATUS_NATIVE_SET((U32)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)));
1790 else
1791#endif
1792 STATUS_POSIX_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
79072805
LW
1793 break;
1794 case '!':
78987ded 1795 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
f86702cc 1796 (SvIV(sv) == EVMSERR) ? 4 : vaxc$errno);
79072805
LW
1797 break;
1798 case '<':
3280af22
NIS
1799 PL_uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1800 if (PL_delaymagic) {
1801 PL_delaymagic |= DM_RUID;
79072805
LW
1802 break; /* don't do magic till later */
1803 }
1804#ifdef HAS_SETRUID
b28d0864 1805 (void)setruid((Uid_t)PL_uid);
79072805
LW
1806#else
1807#ifdef HAS_SETREUID
3280af22 1808 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
748a9306 1809#else
85e6fe83 1810#ifdef HAS_SETRESUID
b28d0864 1811 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
79072805 1812#else
b28d0864
NIS
1813 if (PL_uid == PL_euid) /* special case $< = $> */
1814 (void)PerlProc_setuid(PL_uid);
a0d0e21e 1815 else {
b28d0864 1816 PL_uid = (I32)PerlProc_getuid();
cea2e8a9 1817 Perl_croak(aTHX_ "setruid() not implemented");
a0d0e21e 1818 }
79072805
LW
1819#endif
1820#endif
85e6fe83 1821#endif
3280af22
NIS
1822 PL_uid = (I32)PerlProc_getuid();
1823 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
79072805
LW
1824 break;
1825 case '>':
3280af22
NIS
1826 PL_euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1827 if (PL_delaymagic) {
1828 PL_delaymagic |= DM_EUID;
79072805
LW
1829 break; /* don't do magic till later */
1830 }
1831#ifdef HAS_SETEUID
3280af22 1832 (void)seteuid((Uid_t)PL_euid);
79072805
LW
1833#else
1834#ifdef HAS_SETREUID
b28d0864 1835 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
85e6fe83
LW
1836#else
1837#ifdef HAS_SETRESUID
6b88bc9c 1838 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
79072805 1839#else
b28d0864
NIS
1840 if (PL_euid == PL_uid) /* special case $> = $< */
1841 PerlProc_setuid(PL_euid);
a0d0e21e 1842 else {
b28d0864 1843 PL_euid = (I32)PerlProc_geteuid();
cea2e8a9 1844 Perl_croak(aTHX_ "seteuid() not implemented");
a0d0e21e 1845 }
79072805
LW
1846#endif
1847#endif
85e6fe83 1848#endif
3280af22
NIS
1849 PL_euid = (I32)PerlProc_geteuid();
1850 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
79072805
LW
1851 break;
1852 case '(':
3280af22
NIS
1853 PL_gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1854 if (PL_delaymagic) {
1855 PL_delaymagic |= DM_RGID;
79072805
LW
1856 break; /* don't do magic till later */
1857 }
1858#ifdef HAS_SETRGID
b28d0864 1859 (void)setrgid((Gid_t)PL_gid);
79072805
LW
1860#else
1861#ifdef HAS_SETREGID
3280af22 1862 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
85e6fe83
LW
1863#else
1864#ifdef HAS_SETRESGID
b28d0864 1865 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
79072805 1866#else
b28d0864
NIS
1867 if (PL_gid == PL_egid) /* special case $( = $) */
1868 (void)PerlProc_setgid(PL_gid);
748a9306 1869 else {
b28d0864 1870 PL_gid = (I32)PerlProc_getgid();
cea2e8a9 1871 Perl_croak(aTHX_ "setrgid() not implemented");
748a9306 1872 }
79072805
LW
1873#endif
1874#endif
85e6fe83 1875#endif
3280af22
NIS
1876 PL_gid = (I32)PerlProc_getgid();
1877 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
79072805
LW
1878 break;
1879 case ')':
5cd24f17
PP
1880#ifdef HAS_SETGROUPS
1881 {
2d8e6c8d 1882 char *p = SvPV(sv, len);
5cd24f17
PP
1883 Groups_t gary[NGROUPS];
1884
5cd24f17
PP
1885 while (isSPACE(*p))
1886 ++p;
cf2093f6 1887 PL_egid = I_V(Atol(p));
5cd24f17
PP
1888 for (i = 0; i < NGROUPS; ++i) {
1889 while (*p && !isSPACE(*p))
1890 ++p;
1891 while (isSPACE(*p))
1892 ++p;
1893 if (!*p)
1894 break;
cf2093f6 1895 gary[i] = I_V(Atol(p));
5cd24f17 1896 }
8cc95fdb
PP
1897 if (i)
1898 (void)setgroups(i, gary);
5cd24f17
PP
1899 }
1900#else /* HAS_SETGROUPS */
b28d0864 1901 PL_egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
5cd24f17 1902#endif /* HAS_SETGROUPS */
3280af22
NIS
1903 if (PL_delaymagic) {
1904 PL_delaymagic |= DM_EGID;
79072805
LW
1905 break; /* don't do magic till later */
1906 }
1907#ifdef HAS_SETEGID
3280af22 1908 (void)setegid((Gid_t)PL_egid);
79072805
LW
1909#else
1910#ifdef HAS_SETREGID
b28d0864 1911 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
85e6fe83
LW
1912#else
1913#ifdef HAS_SETRESGID
b28d0864 1914 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
79072805 1915#else
b28d0864
NIS
1916 if (PL_egid == PL_gid) /* special case $) = $( */
1917 (void)PerlProc_setgid(PL_egid);
748a9306 1918 else {
b28d0864 1919 PL_egid = (I32)PerlProc_getegid();
cea2e8a9 1920 Perl_croak(aTHX_ "setegid() not implemented");
748a9306 1921 }
79072805
LW
1922#endif
1923#endif
85e6fe83 1924#endif
3280af22
NIS
1925 PL_egid = (I32)PerlProc_getegid();
1926 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
79072805
LW
1927 break;
1928 case ':':
2d8e6c8d 1929 PL_chopset = SvPV_force(sv,len);
79072805
LW
1930 break;
1931 case '0':
3280af22
NIS
1932 if (!PL_origalen) {
1933 s = PL_origargv[0];
79072805
LW
1934 s += strlen(s);
1935 /* See if all the arguments are contiguous in memory */
3280af22
NIS
1936 for (i = 1; i < PL_origargc; i++) {
1937 if (PL_origargv[i] == s + 1
fb73857a 1938#ifdef OS2
6b88bc9c 1939 || PL_origargv[i] == s + 2
fb73857a
PP
1940#endif
1941 )
379c4362
GS
1942 {
1943 ++s;
1944 s += strlen(s); /* this one is ok too */
1945 }
fb73857a
PP
1946 else
1947 break;
79072805 1948 }
bbce6d69 1949 /* can grab env area too? */
3280af22 1950 if (PL_origenviron && (PL_origenviron[0] == s + 1
fb73857a 1951#ifdef OS2
6b88bc9c 1952 || (PL_origenviron[0] == s + 9 && (s += 8))
fb73857a
PP
1953#endif
1954 )) {
66b1d557 1955 my_setenv("NoNe SuCh", Nullch);
79072805 1956 /* force copy of environment */
3280af22 1957 for (i = 0; PL_origenviron[i]; i++)
379c4362
GS
1958 if (PL_origenviron[i] == s + 1) {
1959 ++s;
1960 s += strlen(s);
1961 }
fb73857a
PP
1962 else
1963 break;
79072805 1964 }
3280af22 1965 PL_origalen = s - PL_origargv[0];
79072805 1966 }
a0d0e21e 1967 s = SvPV_force(sv,len);
8990e307 1968 i = len;
3280af22
NIS
1969 if (i >= PL_origalen) {
1970 i = PL_origalen;
fb73857a
PP
1971 /* don't allow system to limit $0 seen by script */
1972 /* SvCUR_set(sv, i); *SvEND(sv) = '\0'; */
3280af22
NIS
1973 Copy(s, PL_origargv[0], i, char);
1974 s = PL_origargv[0]+i;
fb73857a 1975 *s = '\0';
79072805
LW
1976 }
1977 else {
3280af22
NIS
1978 Copy(s, PL_origargv[0], i, char);
1979 s = PL_origargv[0]+i;
79072805 1980 *s++ = '\0';
3280af22 1981 while (++i < PL_origalen)
8990e307 1982 *s++ = ' ';
3280af22
NIS
1983 s = PL_origargv[0]+i;
1984 for (i = 1; i < PL_origargc; i++)
1985 PL_origargv[i] = Nullch;
79072805
LW
1986 }
1987 break;
a863c7d1
MB
1988#ifdef USE_THREADS
1989 case '@':
38a03e6e 1990 sv_setsv(thr->errsv, sv);
a863c7d1
MB
1991 break;
1992#endif /* USE_THREADS */
79072805
LW
1993 }
1994 return 0;
1995}
1996
f93b4edd
MB
1997#ifdef USE_THREADS
1998int
864dbfa3 1999Perl_magic_mutexfree(pTHX_ SV *sv, MAGIC *mg)
f93b4edd
MB
2000{
2001 dTHR;
8b73bbec 2002 DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: magic_mutexfree 0x%lx\n",
bc1f4c86 2003 (unsigned long)thr, (unsigned long)sv);)
f93b4edd 2004 if (MgOWNER(mg))
cea2e8a9 2005 Perl_croak(aTHX_ "panic: magic_mutexfree");
f93b4edd
MB
2006 MUTEX_DESTROY(MgMUTEXP(mg));
2007 COND_DESTROY(MgCONDP(mg));
2008 return 0;
2009}
2010#endif /* USE_THREADS */
2011
79072805 2012I32
864dbfa3 2013Perl_whichsig(pTHX_ char *sig)
79072805
LW
2014{
2015 register char **sigv;
2016
22c35a8c 2017 for (sigv = PL_sig_name+1; *sigv; sigv++)
79072805 2018 if (strEQ(sig,*sigv))
22c35a8c 2019 return PL_sig_num[sigv - PL_sig_name];
79072805
LW
2020#ifdef SIGCLD
2021 if (strEQ(sig,"CHLD"))
2022 return SIGCLD;
2023#endif
2024#ifdef SIGCHLD
2025 if (strEQ(sig,"CLD"))
2026 return SIGCHLD;
2027#endif
2028 return 0;
2029}
2030
84902520
TB
2031static SV* sig_sv;
2032
ecfc5424 2033Signal_t
cea2e8a9 2034Perl_sighandler(int sig)
79072805 2035{
cea2e8a9 2036 dTHX;
79072805 2037 dSP;
00d579c5 2038 GV *gv = Nullgv;
a0d0e21e 2039 HV *st;
3280af22 2040 SV *sv, *tSv = PL_Sv;
00d579c5 2041 CV *cv = Nullcv;
533c011a 2042 OP *myop = PL_op;
84902520 2043 U32 flags = 0;
3280af22
NIS
2044 I32 o_save_i = PL_savestack_ix, type;
2045 XPV *tXpv = PL_Xpv;
84902520 2046
3280af22 2047 if (PL_savestack_ix + 15 <= PL_savestack_max)
84902520 2048 flags |= 1;
3280af22 2049 if (PL_markstack_ptr < PL_markstack_max - 2)
84902520 2050 flags |= 4;
3280af22 2051 if (PL_retstack_ix < PL_retstack_max - 2)
84902520 2052 flags |= 8;
3280af22 2053 if (PL_scopestack_ix < PL_scopestack_max - 3)
84902520
TB
2054 flags |= 16;
2055
22c35a8c 2056 if (!PL_psig_ptr[sig])
cea2e8a9 2057 Perl_die(aTHX_ "Signal SIG%s received, but no signal handler set.\n",
22c35a8c 2058 PL_sig_name[sig]);
ff0cee69 2059
84902520
TB
2060 /* Max number of items pushed there is 3*n or 4. We cannot fix
2061 infinity, so we fix 4 (in fact 5): */
2062 if (flags & 1) {
3280af22
NIS
2063 PL_savestack_ix += 5; /* Protect save in progress. */
2064 o_save_i = PL_savestack_ix;
51371543 2065 SAVEDESTRUCTOR(unwind_handler_stack, (void*)&flags);
84902520
TB
2066 }
2067 if (flags & 4)
3280af22 2068 PL_markstack_ptr++; /* Protect mark. */
84902520 2069 if (flags & 8) {
3280af22
NIS
2070 PL_retstack_ix++;
2071 PL_retstack[PL_retstack_ix] = NULL;
84902520
TB
2072 }
2073 if (flags & 16)
3280af22 2074 PL_scopestack_ix += 1;
84902520 2075 /* sv_2cv is too complicated, try a simpler variant first: */
22c35a8c 2076 if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
84902520 2077 || SvTYPE(cv) != SVt_PVCV)
22c35a8c 2078 cv = sv_2cv(PL_psig_ptr[sig],&st,&gv,TRUE);
84902520 2079
a0d0e21e 2080 if (!cv || !CvROOT(cv)) {
599cee73 2081 if (ckWARN(WARN_SIGNAL))
cea2e8a9 2082 Perl_warner(aTHX_ WARN_SIGNAL, "SIG%s handler \"%s\" not defined.\n",
22c35a8c 2083 PL_sig_name[sig], (gv ? GvENAME(gv)
00d579c5
GS
2084 : ((cv && CvGV(cv))
2085 ? GvENAME(CvGV(cv))
2086 : "__ANON__")));
2087 goto cleanup;
79072805
LW
2088 }
2089
22c35a8c
GS
2090 if(PL_psig_name[sig]) {
2091 sv = SvREFCNT_inc(PL_psig_name[sig]);
84902520
TB
2092 flags |= 64;
2093 sig_sv = sv;
2094 } else {
ff0cee69 2095 sv = sv_newmortal();
22c35a8c 2096 sv_setpv(sv,PL_sig_name[sig]);
88e89b8a 2097 }
e336de0d 2098
e788e7d3 2099 PUSHSTACKi(PERLSI_SIGNAL);
924508f0 2100 PUSHMARK(SP);
79072805 2101 PUSHs(sv);
79072805 2102 PUTBACK;
a0d0e21e 2103
864dbfa3 2104 call_sv((SV*)cv, G_DISCARD);
79072805 2105
d3acc0f7 2106 POPSTACK;
00d579c5 2107cleanup:
84902520 2108 if (flags & 1)
3280af22 2109 PL_savestack_ix -= 8; /* Unprotect save in progress. */
84902520 2110 if (flags & 4)
3280af22 2111 PL_markstack_ptr--;
84902520 2112 if (flags & 8)
3280af22 2113 PL_retstack_ix--;
84902520 2114 if (flags & 16)
3280af22 2115 PL_scopestack_ix -= 1;
84902520
TB
2116 if (flags & 64)
2117 SvREFCNT_dec(sv);
533c011a 2118 PL_op = myop; /* Apparently not needed... */
84902520 2119
3280af22
NIS
2120 PL_Sv = tSv; /* Restore global temporaries. */
2121 PL_Xpv = tXpv;
79072805
LW
2122 return;
2123}
4e35701f
NIS
2124
2125
51371543
GS
2126#ifdef PERL_OBJECT
2127#define NO_XSLOCKS
2128#include "XSUB.h"
2129#endif
2130
2131static void
2132restore_magic(pTHXo_ void *p)
2133{
2134 dTHR;
2135 MGS* mgs = SSPTR((I32)p, MGS*);
2136 SV* sv = mgs->mgs_sv;
2137
2138 if (!sv)
2139 return;
2140
2141 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2142 {
2143 if (mgs->mgs_flags)
2144 SvFLAGS(sv) |= mgs->mgs_flags;
2145 else
2146 mg_magical(sv);
2147 if (SvGMAGICAL(sv))
2148 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
2149 }
2150
2151 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
2152
2153 /* If we're still on top of the stack, pop us off. (That condition
2154 * will be satisfied if restore_magic was called explicitly, but *not*
2155 * if it's being called via leave_scope.)
2156 * The reason for doing this is that otherwise, things like sv_2cv()
2157 * may leave alloc gunk on the savestack, and some code
2158 * (e.g. sighandler) doesn't expect that...
2159 */
2160 if (PL_savestack_ix == mgs->mgs_ss_ix)
2161 {
2162 I32 popval = SSPOPINT;
2163 assert(popval == SAVEt_DESTRUCTOR);
2164 PL_savestack_ix -= 2;
2165 popval = SSPOPINT;
2166 assert(popval == SAVEt_ALLOC);
2167 popval = SSPOPINT;
2168 PL_savestack_ix -= popval;
2169 }
2170
2171}
2172
2173static void
2174unwind_handler_stack(pTHXo_ void *p)
2175{
2176 dTHR;
2177 U32 flags = *(U32*)p;
2178
2179 if (flags & 1)
2180 PL_savestack_ix -= 5; /* Unprotect save in progress. */
2181 /* cxstack_ix-- Not needed, die already unwound it. */
2182 if (flags & 64)
2183 SvREFCNT_dec(sig_sv);
2184}