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