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