projects / p5sagit/p5-mst-13.2.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | history | HEAD
Consting part 4
[p5sagit/p5-mst-13.2.git] / mg.c
CommitLineData
a0d0e21e 1/* mg.c
79072805 2 *
4bb101f2 3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
cbdf9ef8 4 * 2000, 2001, 2002, 2003, 2004, 2005 by Larry Wall and others
79072805 5 *
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
8 *
a0d0e21e 9 */
10
11/*
12 * "Sam sat on the ground and put his head in his hands. 'I wish I had never
13 * come here, and I don't want to see no more magic,' he said, and fell silent."
79072805 14 */
15
ccfc67b7 16/*
17=head1 Magical Functions
166f8a29 18
19"Magic" is special data attached to SV structures in order to give them
20"magical" properties. When any Perl code tries to read from, or assign to,
21an SV marked as magical, it calls the 'get' or 'set' function associated
22with that SV's magic. A get is called prior to reading an SV, in order to
ddfa107c 23give it a chance to update its internal value (get on $. writes the line
166f8a29 24number of the last read filehandle into to the SV's IV slot), while
25set is called after an SV has been written to, in order to allow it to make
ddfa107c 26use of its changed value (set on $/ copies the SV's new value to the
166f8a29 27PL_rs global variable).
28
29Magic is implemented as a linked list of MAGIC structures attached to the
30SV. Each MAGIC struct holds the type of the magic, a pointer to an array
31of functions that implement the get(), set(), length() etc functions,
32plus space for some flags and pointers. For example, a tied variable has
33a MAGIC structure that contains a pointer to the object associated with the
34tie.
35
ccfc67b7 36*/
37
79072805 38#include "EXTERN.h"
864dbfa3 39#define PERL_IN_MG_C
79072805 40#include "perl.h"
41
5cd24f17 42#if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS)
188ea221 43# ifndef NGROUPS
44# define NGROUPS 32
45# endif
b7953727 46# ifdef I_GRP
47# include <grp.h>
48# endif
188ea221 49#endif
50
17aa7f3d 51#ifdef __hpux
52# include <sys/pstat.h>
53#endif
54
e69880a5 55Signal_t Perl_csighandler(int sig);
56
23ada85b 57/* if you only have signal() and it resets on each signal, FAKE_PERSISTENT_SIGNAL_HANDLERS fixes */
85b332e2 58#if !defined(HAS_SIGACTION) && defined(VMS)
23ada85b 59# define FAKE_PERSISTENT_SIGNAL_HANDLERS
85b332e2 60#endif
2e34cc90 61/* if we're doing kill() with sys$sigprc on VMS, FAKE_DEFAULT_SIGNAL_HANDLERS */
7719e241 62#if defined(KILL_BY_SIGPRC)
2e34cc90 63# define FAKE_DEFAULT_SIGNAL_HANDLERS
64#endif
85b332e2 65
35a4481c 66static void restore_magic(pTHX_ const void *p);
67static void unwind_handler_stack(pTHX_ const void *p);
51371543 68
9cffb111 69#ifdef __Lynx__
70/* Missing protos on LynxOS */
71void setruid(uid_t id);
72void seteuid(uid_t id);
73void setrgid(uid_t id);
74void setegid(uid_t id);
75#endif
76
c07a80fd 77/*
78 * Use the "DESTRUCTOR" scope cleanup to reinstate magic.
79 */
80
81struct magic_state {
82 SV* mgs_sv;
83 U32 mgs_flags;
455ece5e 84 I32 mgs_ss_ix;
c07a80fd 85};
455ece5e 86/* MGS is typedef'ed to struct magic_state in perl.h */
76e3520e 87
88STATIC void
8fb26106 89S_save_magic(pTHX_ I32 mgs_ix, SV *sv)
c07a80fd 90{
455ece5e 91 MGS* mgs;
c07a80fd 92 assert(SvMAGICAL(sv));
765f542d 93#ifdef PERL_COPY_ON_WRITE
94 /* Turning READONLY off for a copy-on-write scalar is a bad idea. */
95 if (SvIsCOW(sv))
96 sv_force_normal(sv);
97#endif
c07a80fd 98
685f876f 99 SAVEDESTRUCTOR_X(restore_magic, INT2PTR(void*, (IV)mgs_ix));
455ece5e 100
101 mgs = SSPTR(mgs_ix, MGS*);
c07a80fd 102 mgs->mgs_sv = sv;
103 mgs->mgs_flags = SvMAGICAL(sv) | SvREADONLY(sv);
455ece5e 104 mgs->mgs_ss_ix = PL_savestack_ix; /* points after the saved destructor */
c07a80fd 105
106 SvMAGICAL_off(sv);
107 SvREADONLY_off(sv);
06759ea0 108 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
c07a80fd 109}
110
954c1994 111/*
112=for apidoc mg_magical
113
114Turns on the magical status of an SV. See C<sv_magic>.
115
116=cut
117*/
118
8990e307 119void
864dbfa3 120Perl_mg_magical(pTHX_ SV *sv)
8990e307 121{
e1ec3a88 122 const MAGIC* mg;
8990e307 123 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
35a4481c 124 const MGVTBL* const vtbl = mg->mg_virtual;
8990e307 125 if (vtbl) {
2b260de0 126 if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
8990e307 127 SvGMAGICAL_on(sv);
128 if (vtbl->svt_set)
129 SvSMAGICAL_on(sv);
2b260de0 130 if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)) || vtbl->svt_clear)
8990e307 131 SvRMAGICAL_on(sv);
132 }
133 }
134}
135
954c1994 136/*
137=for apidoc mg_get
138
139Do magic after a value is retrieved from the SV. See C<sv_magic>.
140
141=cut
142*/
143
79072805 144int
864dbfa3 145Perl_mg_get(pTHX_ SV *sv)
79072805 146{
35a4481c 147 const I32 mgs_ix = SSNEW(sizeof(MGS));
148 const bool was_temp = SvTEMP(sv);
ff76feab 149 int new = 0;
150 MAGIC *newmg, *head, *cur, *mg;
20135930 151 /* guard against sv having being freed midway by holding a private
6683b158 152 reference. */
153
154 /* sv_2mortal has this side effect of turning on the TEMP flag, which can
155 cause the SV's buffer to get stolen (and maybe other stuff).
156 So restore it.
157 */
158 sv_2mortal(SvREFCNT_inc(sv));
159 if (!was_temp) {
160 SvTEMP_off(sv);
161 }
162
455ece5e 163 save_magic(mgs_ix, sv);
463ee0b2 164
ff76feab 165 /* We must call svt_get(sv, mg) for each valid entry in the linked
166 list of magic. svt_get() may delete the current entry, add new
167 magic to the head of the list, or upgrade the SV. AMS 20010810 */
168
169 newmg = cur = head = mg = SvMAGIC(sv);
170 while (mg) {
35a4481c 171 const MGVTBL * const vtbl = mg->mg_virtual;
ff76feab 172
2b260de0 173 if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
316ad4fe 174 CALL_FPTR(vtbl->svt_get)(aTHX_ sv, mg);
b77f7d40 175
58f82c5c 176 /* guard against magic having been deleted - eg FETCH calling
177 * untie */
178 if (!SvMAGIC(sv))
179 break;
b77f7d40 180
ff76feab 181 /* Don't restore the flags for this entry if it was deleted. */
182 if (mg->mg_flags & MGf_GSKIP)
183 (SSPTR(mgs_ix, MGS *))->mgs_flags = 0;
a0d0e21e 184 }
ff76feab 185
186 mg = mg->mg_moremagic;
187
188 if (new) {
189 /* Have we finished with the new entries we saw? Start again
190 where we left off (unless there are more new entries). */
191 if (mg == head) {
192 new = 0;
193 mg = cur;
194 head = newmg;
195 }
196 }
197
198 /* Were any new entries added? */
199 if (!new && (newmg = SvMAGIC(sv)) != head) {
200 new = 1;
201 cur = mg;
202 mg = newmg;
760ac839 203 }
79072805 204 }
463ee0b2 205
acfe0abc 206 restore_magic(aTHX_ INT2PTR(void *, (IV)mgs_ix));
6683b158 207
208 if (SvREFCNT(sv) == 1) {
209 /* We hold the last reference to this SV, which implies that the
210 SV was deleted as a side effect of the routines we called. */
0c34ef67 211 SvOK_off(sv);
6683b158 212 }
79072805 213 return 0;
214}
215
954c1994 216/*
217=for apidoc mg_set
218
219Do magic after a value is assigned to the SV. See C<sv_magic>.
220
221=cut
222*/
223
79072805 224int
864dbfa3 225Perl_mg_set(pTHX_ SV *sv)
79072805 226{
35a4481c 227 const I32 mgs_ix = SSNEW(sizeof(MGS));
79072805 228 MAGIC* mg;
463ee0b2 229 MAGIC* nextmg;
230
455ece5e 231 save_magic(mgs_ix, sv);
463ee0b2 232
233 for (mg = SvMAGIC(sv); mg; mg = nextmg) {
e1ec3a88 234 const MGVTBL* vtbl = mg->mg_virtual;
463ee0b2 235 nextmg = mg->mg_moremagic; /* it may delete itself */
a0d0e21e 236 if (mg->mg_flags & MGf_GSKIP) {
237 mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */
455ece5e 238 (SSPTR(mgs_ix, MGS*))->mgs_flags = 0;
a0d0e21e 239 }
2b260de0 240 if (vtbl && vtbl->svt_set)
fc0dc3b3 241 CALL_FPTR(vtbl->svt_set)(aTHX_ sv, mg);
79072805 242 }
463ee0b2 243
acfe0abc 244 restore_magic(aTHX_ INT2PTR(void*, (IV)mgs_ix));
79072805 245 return 0;
246}
247
954c1994 248/*
249=for apidoc mg_length
250
251Report on the SV's length. See C<sv_magic>.
252
253=cut
254*/
255
79072805 256U32
864dbfa3 257Perl_mg_length(pTHX_ SV *sv)
79072805 258{
259 MAGIC* mg;
463ee0b2 260 STRLEN len;
463ee0b2 261
79072805 262 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
35a4481c 263 const MGVTBL * const vtbl = mg->mg_virtual;
2b260de0 264 if (vtbl && vtbl->svt_len) {
35a4481c 265 const I32 mgs_ix = SSNEW(sizeof(MGS));
455ece5e 266 save_magic(mgs_ix, sv);
a0d0e21e 267 /* omit MGf_GSKIP -- not changed here */
fc0dc3b3 268 len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
acfe0abc 269 restore_magic(aTHX_ INT2PTR(void*, (IV)mgs_ix));
85e6fe83 270 return len;
271 }
272 }
273
35a4481c 274 if (DO_UTF8(sv)) {
5636d518 275 U8 *s = (U8*)SvPV(sv, len);
276 len = Perl_utf8_length(aTHX_ s, s + len);
277 }
278 else
279 (void)SvPV(sv, len);
463ee0b2 280 return len;
79072805 281}
282
8fb26106 283I32
864dbfa3 284Perl_mg_size(pTHX_ SV *sv)
93965878 285{
286 MAGIC* mg;
ac27b0f5 287
93965878 288 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
35a4481c 289 const MGVTBL* const vtbl = mg->mg_virtual;
2b260de0 290 if (vtbl && vtbl->svt_len) {
35a4481c 291 const I32 mgs_ix = SSNEW(sizeof(MGS));
292 I32 len;
455ece5e 293 save_magic(mgs_ix, sv);
93965878 294 /* omit MGf_GSKIP -- not changed here */
fc0dc3b3 295 len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
acfe0abc 296 restore_magic(aTHX_ INT2PTR(void*, (IV)mgs_ix));
93965878 297 return len;
298 }
299 }
300
301 switch(SvTYPE(sv)) {
302 case SVt_PVAV:
35a4481c 303 return AvFILLp((AV *) sv); /* Fallback to non-tied array */
93965878 304 case SVt_PVHV:
305 /* FIXME */
306 default:
cea2e8a9 307 Perl_croak(aTHX_ "Size magic not implemented");
93965878 308 break;
309 }
310 return 0;
311}
312
954c1994 313/*
314=for apidoc mg_clear
315
316Clear something magical that the SV represents. See C<sv_magic>.
317
318=cut
319*/
320
79072805 321int
864dbfa3 322Perl_mg_clear(pTHX_ SV *sv)
79072805 323{
35a4481c 324 const I32 mgs_ix = SSNEW(sizeof(MGS));
79072805 325 MAGIC* mg;
463ee0b2 326
455ece5e 327 save_magic(mgs_ix, sv);
463ee0b2 328
79072805 329 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
35a4481c 330 const MGVTBL* const vtbl = mg->mg_virtual;
a0d0e21e 331 /* omit GSKIP -- never set here */
727405f8 332
2b260de0 333 if (vtbl && vtbl->svt_clear)
fc0dc3b3 334 CALL_FPTR(vtbl->svt_clear)(aTHX_ sv, mg);
79072805 335 }
463ee0b2 336
acfe0abc 337 restore_magic(aTHX_ INT2PTR(void*, (IV)mgs_ix));
79072805 338 return 0;
339}
340
954c1994 341/*
342=for apidoc mg_find
343
344Finds the magic pointer for type matching the SV. See C<sv_magic>.
345
346=cut
347*/
348
93a17b20 349MAGIC*
35a4481c 350Perl_mg_find(pTHX_ const SV *sv, int type)
93a17b20 351{
35a4481c 352 if (sv) {
353 MAGIC *mg;
354 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
355 if (mg->mg_type == type)
356 return mg;
357 }
93a17b20 358 }
359 return 0;
360}
361
954c1994 362/*
363=for apidoc mg_copy
364
365Copies the magic from one SV to another. See C<sv_magic>.
366
367=cut
368*/
369
79072805 370int
864dbfa3 371Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
79072805 372{
463ee0b2 373 int count = 0;
79072805 374 MAGIC* mg;
463ee0b2 375 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
35a4481c 376 const MGVTBL* const vtbl = mg->mg_virtual;
68795e93 377 if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){
378 count += CALL_FPTR(vtbl->svt_copy)(aTHX_ sv, mg, nsv, key, klen);
379 }
380 else if (isUPPER(mg->mg_type)) {
33c27489 381 sv_magic(nsv,
14befaf4 382 mg->mg_type == PERL_MAGIC_tied ? SvTIED_obj(sv, mg) :
383 (mg->mg_type == PERL_MAGIC_regdata && mg->mg_obj)
384 ? sv : mg->mg_obj,
33c27489 385 toLOWER(mg->mg_type), key, klen);
463ee0b2 386 count++;
79072805 387 }
79072805 388 }
463ee0b2 389 return count;
79072805 390}
391
954c1994 392/*
393=for apidoc mg_free
394
395Free any magic storage used by the SV. See C<sv_magic>.
396
397=cut
398*/
399
79072805 400int
864dbfa3 401Perl_mg_free(pTHX_ SV *sv)
79072805 402{
403 MAGIC* mg;
404 MAGIC* moremagic;
405 for (mg = SvMAGIC(sv); mg; mg = moremagic) {
35a4481c 406 const MGVTBL* const vtbl = mg->mg_virtual;
79072805 407 moremagic = mg->mg_moremagic;
2b260de0 408 if (vtbl && vtbl->svt_free)
fc0dc3b3 409 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
14befaf4 410 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
979acdb5 411 if (mg->mg_len > 0 || mg->mg_type == PERL_MAGIC_utf8)
88e89b8a 412 Safefree(mg->mg_ptr);
565764a8 413 else if (mg->mg_len == HEf_SVKEY)
88e89b8a 414 SvREFCNT_dec((SV*)mg->mg_ptr);
d460ef45 415 }
b881518d 416 if (mg->mg_flags & MGf_REFCOUNTED)
417 SvREFCNT_dec(mg->mg_obj);
79072805 418 Safefree(mg);
419 }
420 SvMAGIC(sv) = 0;
421 return 0;
422}
423
79072805 424#include <signal.h>
79072805 425
942e002e 426U32
864dbfa3 427Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
6cef1e77 428{
35a4481c 429 register const REGEXP *rx;
6cef1e77 430
aaa362c4 431 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
8f580fb8 432 if (mg->mg_obj) /* @+ */
433 return rx->nparens;
434 else /* @- */
435 return rx->lastparen;
436 }
ac27b0f5 437
942e002e 438 return (U32)-1;
6cef1e77 439}
440
441int
864dbfa3 442Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
6cef1e77 443{
6cef1e77 444 register REGEXP *rx;
6cef1e77 445
aaa362c4 446 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
35a4481c 447 register const I32 paren = mg->mg_len;
448 register I32 s;
449 register I32 t;
6cef1e77 450 if (paren < 0)
451 return 0;
eb160463 452 if (paren <= (I32)rx->nparens &&
cf93c79d 453 (s = rx->startp[paren]) != -1 &&
454 (t = rx->endp[paren]) != -1)
6cef1e77 455 {
35a4481c 456 register I32 i;
6cef1e77 457 if (mg->mg_obj) /* @+ */
cf93c79d 458 i = t;
6cef1e77 459 else /* @- */
cf93c79d 460 i = s;
727405f8 461
a30b2f1f 462 if (i > 0 && RX_MATCH_UTF8(rx)) {
1aa99e6b 463 char *b = rx->subbeg;
0064a8a9 464 if (b)
465 i = Perl_utf8_length(aTHX_ (U8*)b, (U8*)(b+i));
1aa99e6b 466 }
0064a8a9 467
468 sv_setiv(sv, i);
6cef1e77 469 }
470 }
471 return 0;
472}
473
e4b89193 474int
a29d06ed 475Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
476{
a29d06ed 477 Perl_croak(aTHX_ PL_no_modify);
e4b89193 478 /* NOT REACHED */
73d840c0 479 (void)sv; (void)mg;
e4b89193 480 return 0;
a29d06ed 481}
482
93a17b20 483U32
864dbfa3 484Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
93a17b20 485{
486 register I32 paren;
93a17b20 487 register I32 i;
d9f97599 488 register REGEXP *rx;
a197cbdd 489 I32 s1, t1;
93a17b20 490
491 switch (*mg->mg_ptr) {
492 case '1': case '2': case '3': case '4':
493 case '5': case '6': case '7': case '8': case '9': case '&':
aaa362c4 494 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
cf93c79d 495
ffc61ed2 496 paren = atoi(mg->mg_ptr); /* $& is in [0] */
93a17b20 497 getparen:
eb160463 498 if (paren <= (I32)rx->nparens &&
cf93c79d 499 (s1 = rx->startp[paren]) != -1 &&
500 (t1 = rx->endp[paren]) != -1)
bbce6d69 501 {
cf93c79d 502 i = t1 - s1;
a197cbdd 503 getlen:
a30b2f1f 504 if (i > 0 && RX_MATCH_UTF8(rx)) {
ffc61ed2 505 char *s = rx->subbeg + s1;
a197cbdd 506 char *send = rx->subbeg + t1;
ffc61ed2 507
6d5fa195 508 i = t1 - s1;
60425c38 509 if (is_utf8_string((U8*)s, i))
510 i = Perl_utf8_length(aTHX_ (U8*)s, (U8*)send);
a197cbdd 511 }
ffc61ed2 512 if (i < 0)
0844c848 513 Perl_croak(aTHX_ "panic: magic_len: %"IVdf, (IV)i);
ffc61ed2 514 return i;
93a17b20 515 }
235bddc8 516 else {
517 if (ckWARN(WARN_UNINITIALIZED))
29489e7c 518 report_uninit(sv);
235bddc8 519 }
520 }
521 else {
522 if (ckWARN(WARN_UNINITIALIZED))
29489e7c 523 report_uninit(sv);
93a17b20 524 }
748a9306 525 return 0;
93a17b20 526 case '+':
aaa362c4 527 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
d9f97599 528 paren = rx->lastparen;
13f57bf8 529 if (paren)
530 goto getparen;
93a17b20 531 }
748a9306 532 return 0;
a01268b5 533 case '\016': /* ^N */
534 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
535 paren = rx->lastcloseparen;
536 if (paren)
537 goto getparen;
538 }
539 return 0;
93a17b20 540 case '`':
aaa362c4 541 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
cf93c79d 542 if (rx->startp[0] != -1) {
543 i = rx->startp[0];
a197cbdd 544 if (i > 0) {
545 s1 = 0;
546 t1 = i;
547 goto getlen;
548 }
93a17b20 549 }
93a17b20 550 }
748a9306 551 return 0;
93a17b20 552 case '\'':
aaa362c4 553 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
cf93c79d 554 if (rx->endp[0] != -1) {
555 i = rx->sublen - rx->endp[0];
a197cbdd 556 if (i > 0) {
557 s1 = rx->endp[0];
558 t1 = rx->sublen;
559 goto getlen;
560 }
93a17b20 561 }
93a17b20 562 }
748a9306 563 return 0;
93a17b20 564 }
565 magic_get(sv,mg);
2d8e6c8d 566 if (!SvPOK(sv) && SvNIOK(sv)) {
567 STRLEN n_a;
568 sv_2pv(sv, &n_a);
569 }
93a17b20 570 if (SvPOK(sv))
571 return SvCUR(sv);
572 return 0;
573}
574
79072805 575int
864dbfa3 576Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
79072805 577{
578 register I32 paren;
35272f84 579 register char *s = NULL;
79072805 580 register I32 i;
d9f97599 581 register REGEXP *rx;
79072805 582
583 switch (*mg->mg_ptr) {
748a9306 584 case '\001': /* ^A */
3280af22 585 sv_setsv(sv, PL_bodytarget);
748a9306 586 break;
49460fe6 587 case '\003': /* ^C */
588 sv_setiv(sv, (IV)PL_minus_c);
589 break;
590
79072805 591 case '\004': /* ^D */
aea4f609 592 sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
79072805 593 break;
28f23441 594 case '\005': /* ^E */
0a378802 595 if (*(mg->mg_ptr+1) == '\0') {
cd39f2b6 596#ifdef MACOS_TRADITIONAL
0a378802 597 {
598 char msg[256];
727405f8 599
0a378802 600 sv_setnv(sv,(double)gMacPerl_OSErr);
727405f8 601 sv_setpv(sv, gMacPerl_OSErr ? GetSysErrText(gMacPerl_OSErr, msg) : "");
0a378802 602 }
727405f8 603#else
28f23441 604#ifdef VMS
0a378802 605 {
606# include <descrip.h>
607# include <starlet.h>
608 char msg[255];
609 $DESCRIPTOR(msgdsc,msg);
610 sv_setnv(sv,(NV) vaxc$errno);
611 if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
612 sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
613 else
614 sv_setpv(sv,"");
615 }
28f23441 616#else
88e89b8a 617#ifdef OS2
0a378802 618 if (!(_emx_env & 0x200)) { /* Under DOS */
619 sv_setnv(sv, (NV)errno);
620 sv_setpv(sv, errno ? Strerror(errno) : "");
621 } else {
622 if (errno != errno_isOS2) {
623 int tmp = _syserrno();
624 if (tmp) /* 2nd call to _syserrno() makes it 0 */
625 Perl_rc = tmp;
626 }
627 sv_setnv(sv, (NV)Perl_rc);
628 sv_setpv(sv, os2error(Perl_rc));
629 }
88e89b8a 630#else
22fae026 631#ifdef WIN32
0a378802 632 {
633 DWORD dwErr = GetLastError();
634 sv_setnv(sv, (NV)dwErr);
635 if (dwErr)
636 {
637 PerlProc_GetOSError(sv, dwErr);
638 }
639 else
640 sv_setpv(sv, "");
641 SetLastError(dwErr);
642 }
22fae026 643#else
f6c8f21d 644 {
645 int saveerrno = errno;
646 sv_setnv(sv, (NV)errno);
647 sv_setpv(sv, errno ? Strerror(errno) : "");
648 errno = saveerrno;
649 }
28f23441 650#endif
88e89b8a 651#endif
22fae026 652#endif
cd39f2b6 653#endif
0a378802 654 SvNOK_on(sv); /* what a wonderful hack! */
655 }
656 else if (strEQ(mg->mg_ptr+1, "NCODING"))
657 sv_setsv(sv, PL_encoding);
658 break;
79072805 659 case '\006': /* ^F */
3280af22 660 sv_setiv(sv, (IV)PL_maxsysfd);
79072805 661 break;
a0d0e21e 662 case '\010': /* ^H */
3280af22 663 sv_setiv(sv, (IV)PL_hints);
a0d0e21e 664 break;
9d116dd7 665 case '\011': /* ^I */ /* NOT \t in EBCDIC */
3280af22 666 if (PL_inplace)
667 sv_setpv(sv, PL_inplace);
79072805 668 else
3280af22 669 sv_setsv(sv, &PL_sv_undef);
79072805 670 break;
ac27b0f5 671 case '\017': /* ^O & ^OPEN */
3511154c 672 if (*(mg->mg_ptr+1) == '\0') {
ac27b0f5 673 sv_setpv(sv, PL_osname);
3511154c 674 SvTAINTED_off(sv);
675 }
ac27b0f5 676 else if (strEQ(mg->mg_ptr, "\017PEN")) {
677 if (!PL_compiling.cop_io)
678 sv_setsv(sv, &PL_sv_undef);
679 else {
680 sv_setsv(sv, PL_compiling.cop_io);
681 }
682 }
28f23441 683 break;
79072805 684 case '\020': /* ^P */
3280af22 685 sv_setiv(sv, (IV)PL_perldb);
79072805 686 break;
fb73857a 687 case '\023': /* ^S */
4ffa73a3 688 if (*(mg->mg_ptr+1) == '\0') {
3280af22 689 if (PL_lex_state != LEX_NOTPARSING)
0c34ef67 690 SvOK_off(sv);
3280af22 691 else if (PL_in_eval)
6dc8a9e4 692 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
a4268c0a 693 else
694 sv_setiv(sv, 0);
d58bf5aa 695 }
fb73857a 696 break;
79072805 697 case '\024': /* ^T */
7c36658b 698 if (*(mg->mg_ptr+1) == '\0') {
88e89b8a 699#ifdef BIG_TIME
7c36658b 700 sv_setnv(sv, PL_basetime);
88e89b8a 701#else
7c36658b 702 sv_setiv(sv, (IV)PL_basetime);
88e89b8a 703#endif
7c36658b 704 }
705 else if (strEQ(mg->mg_ptr, "\024AINT"))
9aa05f58 706 sv_setiv(sv, PL_tainting
707 ? (PL_taint_warn || PL_unsafe ? -1 : 1)
708 : 0);
7c36658b 709 break;
7cebcbc0 710 case '\025': /* $^UNICODE, $^UTF8LOCALE */
a05d7ebb 711 if (strEQ(mg->mg_ptr, "\025NICODE"))
712 sv_setuv(sv, (UV) PL_unicode);
7cebcbc0 713 else if (strEQ(mg->mg_ptr, "\025TF8LOCALE"))
714 sv_setuv(sv, (UV) PL_utf8locale);
fde18df1 715 break;
716 case '\027': /* ^W & $^WARNING_BITS */
4438c4b7 717 if (*(mg->mg_ptr+1) == '\0')
718 sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
0a378802 719 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
d3a7d8c7 720 if (PL_compiling.cop_warnings == pWARN_NONE ||
721 PL_compiling.cop_warnings == pWARN_STD)
4438c4b7 722 {
723 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
724 }
d3a7d8c7 725 else if (PL_compiling.cop_warnings == pWARN_ALL) {
75b6c4ca 726 /* Get the bit mask for $warnings::Bits{all}, because
727 * it could have been extended by warnings::register */
728 SV **bits_all;
729 HV *bits=get_hv("warnings::Bits", FALSE);
730 if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) {
731 sv_setsv(sv, *bits_all);
732 }
733 else {
734 sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
735 }
ac27b0f5 736 }
4438c4b7 737 else {
738 sv_setsv(sv, PL_compiling.cop_warnings);
ac27b0f5 739 }
d3a7d8c7 740 SvPOK_only(sv);
4438c4b7 741 }
79072805 742 break;
743 case '1': case '2': case '3': case '4':
744 case '5': case '6': case '7': case '8': case '9': case '&':
aaa362c4 745 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
cf93c79d 746 I32 s1, t1;
747
a863c7d1 748 /*
749 * Pre-threads, this was paren = atoi(GvENAME((GV*)mg->mg_obj));
750 * XXX Does the new way break anything?
751 */
ffc61ed2 752 paren = atoi(mg->mg_ptr); /* $& is in [0] */
79072805 753 getparen:
eb160463 754 if (paren <= (I32)rx->nparens &&
cf93c79d 755 (s1 = rx->startp[paren]) != -1 &&
756 (t1 = rx->endp[paren]) != -1)
bbce6d69 757 {
cf93c79d 758 i = t1 - s1;
759 s = rx->subbeg + s1;
01ec43d0 760 if (!rx->subbeg)
c2e66d9e 761 break;
762
13f57bf8 763 getrx:
748a9306 764 if (i >= 0) {
cf93c79d 765 sv_setpvn(sv, s, i);
a30b2f1f 766 if (RX_MATCH_UTF8(rx) && is_utf8_string((U8*)s, i))
7e2040f0 767 SvUTF8_on(sv);
768 else
769 SvUTF8_off(sv);
e9814ee1 770 if (PL_tainting) {
771 if (RX_MATCH_TAINTED(rx)) {
772 MAGIC* mg = SvMAGIC(sv);
773 MAGIC* mgt;
774 PL_tainted = 1;
775 SvMAGIC(sv) = mg->mg_moremagic;
776 SvTAINT(sv);
777 if ((mgt = SvMAGIC(sv))) {
778 mg->mg_moremagic = mgt;
779 SvMAGIC(sv) = mg;
780 }
781 } else
782 SvTAINTED_off(sv);
783 }
748a9306 784 break;
785 }
79072805 786 }
79072805 787 }
3280af22 788 sv_setsv(sv,&PL_sv_undef);
79072805 789 break;
790 case '+':
aaa362c4 791 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
d9f97599 792 paren = rx->lastparen;
a0d0e21e 793 if (paren)
794 goto getparen;
79072805 795 }
3280af22 796 sv_setsv(sv,&PL_sv_undef);
79072805 797 break;
a01268b5 798 case '\016': /* ^N */
799 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
800 paren = rx->lastcloseparen;
801 if (paren)
802 goto getparen;
803 }
804 sv_setsv(sv,&PL_sv_undef);
805 break;
79072805 806 case '`':
aaa362c4 807 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
cf93c79d 808 if ((s = rx->subbeg) && rx->startp[0] != -1) {
809 i = rx->startp[0];
13f57bf8 810 goto getrx;
79072805 811 }
79072805 812 }
3280af22 813 sv_setsv(sv,&PL_sv_undef);
79072805 814 break;
815 case '\'':
aaa362c4 816 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
cf93c79d 817 if (rx->subbeg && rx->endp[0] != -1) {
818 s = rx->subbeg + rx->endp[0];
819 i = rx->sublen - rx->endp[0];
13f57bf8 820 goto getrx;
79072805 821 }
79072805 822 }
3280af22 823 sv_setsv(sv,&PL_sv_undef);
79072805 824 break;
825 case '.':
826#ifndef lint
3280af22 827 if (GvIO(PL_last_in_gv)) {
357c8808 828 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
79072805 829 }
830#endif
831 break;
832 case '?':
809a5acc 833 {
809a5acc 834 sv_setiv(sv, (IV)STATUS_CURRENT);
ff0cee69 835#ifdef COMPLEX_STATUS
6b88bc9c 836 LvTARGOFF(sv) = PL_statusvalue;
837 LvTARGLEN(sv) = PL_statusvalue_vms;
ff0cee69 838#endif
809a5acc 839 }
79072805 840 break;
841 case '^':
0daa599b 842 if (GvIOp(PL_defoutgv))
843 s = IoTOP_NAME(GvIOp(PL_defoutgv));
79072805 844 if (s)
845 sv_setpv(sv,s);
846 else {
3280af22 847 sv_setpv(sv,GvENAME(PL_defoutgv));
79072805 848 sv_catpv(sv,"_TOP");
849 }
850 break;
851 case '~':
0daa599b 852 if (GvIOp(PL_defoutgv))
853 s = IoFMT_NAME(GvIOp(PL_defoutgv));
79072805 854 if (!s)
3280af22 855 s = GvENAME(PL_defoutgv);
79072805 856 sv_setpv(sv,s);
857 break;
858#ifndef lint
859 case '=':
0daa599b 860 if (GvIOp(PL_defoutgv))
861 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
79072805 862 break;
863 case '-':
0daa599b 864 if (GvIOp(PL_defoutgv))
865 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
79072805 866 break;
867 case '%':
0daa599b 868 if (GvIOp(PL_defoutgv))
869 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
79072805 870 break;
871#endif
872 case ':':
873 break;
874 case '/':
875 break;
876 case '[':
3280af22 877 WITH_THR(sv_setiv(sv, (IV)PL_curcop->cop_arybase));
79072805 878 break;
879 case '|':
0daa599b 880 if (GvIOp(PL_defoutgv))
881 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
79072805 882 break;
883 case ',':
79072805 884 break;
885 case '\\':
b2ce0fda 886 if (PL_ors_sv)
f28098ff 887 sv_copypv(sv, PL_ors_sv);
79072805 888 break;
889 case '#':
3280af22 890 sv_setpv(sv,PL_ofmt);
79072805 891 break;
892 case '!':
a5f75d66 893#ifdef VMS
65202027 894 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
88e89b8a 895 sv_setpv(sv, errno ? Strerror(errno) : "");
a5f75d66 896#else
88e89b8a 897 {
898 int saveerrno = errno;
65202027 899 sv_setnv(sv, (NV)errno);
88e89b8a 900#ifdef OS2
ed344e4f 901 if (errno == errno_isOS2 || errno == errno_isOS2_set)
902 sv_setpv(sv, os2error(Perl_rc));
88e89b8a 903 else
a5f75d66 904#endif
2304df62 905 sv_setpv(sv, errno ? Strerror(errno) : "");
88e89b8a 906 errno = saveerrno;
907 }
908#endif
946ec16e 909 SvNOK_on(sv); /* what a wonderful hack! */
79072805 910 break;
911 case '<':
3280af22 912 sv_setiv(sv, (IV)PL_uid);
79072805 913 break;
914 case '>':
3280af22 915 sv_setiv(sv, (IV)PL_euid);
79072805 916 break;
917 case '(':
3280af22 918 sv_setiv(sv, (IV)PL_gid);
a52cb5f7 919#ifdef HAS_GETGROUPS
785fb66b 920 Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, PL_gid);
a52cb5f7 921#endif
79072805 922 goto add_groups;
923 case ')':
3280af22 924 sv_setiv(sv, (IV)PL_egid);
a52cb5f7 925#ifdef HAS_GETGROUPS
785fb66b 926 Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, PL_egid);
a52cb5f7 927#endif
79072805 928 add_groups:
79072805 929#ifdef HAS_GETGROUPS
79072805 930 {
a0d0e21e 931 Groups_t gary[NGROUPS];
79072805 932 i = getgroups(NGROUPS,gary);
46fc3d4c 933 while (--i >= 0)
785fb66b 934 Perl_sv_catpvf(aTHX_ sv, " %"Gid_t_f, gary[i]);
79072805 935 }
936#endif
155aba94 937 (void)SvIOK_on(sv); /* what a wonderful hack! */
79072805 938 break;
cd39f2b6 939#ifndef MACOS_TRADITIONAL
79072805 940 case '0':
941 break;
cd39f2b6 942#endif
79072805 943 }
a0d0e21e 944 return 0;
79072805 945}
946
947int
864dbfa3 948Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
79072805 949{
950 struct ufuncs *uf = (struct ufuncs *)mg->mg_ptr;
951
952 if (uf && uf->uf_val)
24f81a43 953 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
79072805 954 return 0;
955}
956
957int
864dbfa3 958Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
79072805 959{
960 register char *s;
88e89b8a 961 char *ptr;
5aabfad6 962 STRLEN len, klen;
1e422769 963
a0d0e21e 964 s = SvPV(sv,len);
5aabfad6 965 ptr = MgPV(mg,klen);
88e89b8a 966 my_setenv(ptr, s);
1e422769 967
a0d0e21e 968#ifdef DYNAMIC_ENV_FETCH
969 /* We just undefd an environment var. Is a replacement */
970 /* waiting in the wings? */
971 if (!len) {
5aabfad6 972 SV **valp;
6b88bc9c 973 if ((valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE)))
5aabfad6 974 s = SvPV(*valp, len);
a0d0e21e 975 }
976#endif
1e422769 977
39e571d4 978#if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
79072805 979 /* And you'll never guess what the dog had */
980 /* in its mouth... */
3280af22 981 if (PL_tainting) {
1e422769 982 MgTAINTEDDIR_off(mg);
983#ifdef VMS
5aabfad6 984 if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
1e422769 985 char pathbuf[256], eltbuf[256], *cp, *elt = s;
c623ac67 986 Stat_t sbuf;
1e422769 987 int i = 0, j = 0;
988
989 do { /* DCL$PATH may be a search list */
990 while (1) { /* as may dev portion of any element */
991 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
992 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
993 cando_by_name(S_IWUSR,0,elt) ) {
994 MgTAINTEDDIR_on(mg);
995 return 0;
996 }
997 }
998 if ((cp = strchr(elt, ':')) != Nullch)
999 *cp = '\0';
1000 if (my_trnlnm(elt, eltbuf, j++))
1001 elt = eltbuf;
1002 else
1003 break;
1004 }
1005 j = 0;
1006 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1007 }
1008#endif /* VMS */
5aabfad6 1009 if (s && klen == 4 && strEQ(ptr,"PATH")) {
a0d0e21e 1010 char *strend = s + len;
463ee0b2 1011
1012 while (s < strend) {
96827780 1013 char tmpbuf[256];
c623ac67 1014 Stat_t st;
5f74f29c 1015 I32 i;
96827780 1016 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
fc36a67e 1017 s, strend, ':', &i);
463ee0b2 1018 s++;
96827780 1019 if (i >= sizeof tmpbuf /* too long -- assume the worst */
1020 || *tmpbuf != '/'
c6ed36e1 1021 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
8990e307 1022 MgTAINTEDDIR_on(mg);
1e422769 1023 return 0;
1024 }
463ee0b2 1025 }
79072805 1026 }
1027 }
39e571d4 1028#endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1e422769 1029
79072805 1030 return 0;
1031}
1032
1033int
864dbfa3 1034Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
85e6fe83 1035{
2d8e6c8d 1036 STRLEN n_a;
1037 my_setenv(MgPV(mg,n_a),Nullch);
85e6fe83 1038 return 0;
1039}
1040
88e89b8a 1041int
864dbfa3 1042Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
fb73857a 1043{
1044#if defined(VMS)
cea2e8a9 1045 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
fb73857a 1046#else
3280af22 1047 if (PL_localizing) {
fb73857a 1048 HE* entry;
2d8e6c8d 1049 STRLEN n_a;
fb73857a 1050 magic_clear_all_env(sv,mg);
1051 hv_iterinit((HV*)sv);
155aba94 1052 while ((entry = hv_iternext((HV*)sv))) {
fb73857a 1053 I32 keylen;
1054 my_setenv(hv_iterkey(entry, &keylen),
2d8e6c8d 1055 SvPV(hv_iterval((HV*)sv, entry), n_a));
fb73857a 1056 }
1057 }
1058#endif
1059 return 0;
1060}
1061
1062int
864dbfa3 1063Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
66b1d557 1064{
2f42fcb0 1065#ifndef PERL_MICRO
ed79a026 1066#if defined(VMS) || defined(EPOC)
cea2e8a9 1067 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
3e3baf6d 1068#else
4efc5df6 1069# if defined(PERL_IMPLICIT_SYS) || defined(WIN32)
7766f137 1070 PerlEnv_clearenv();
4efc5df6 1071# else
1072# ifdef USE_ENVIRON_ARRAY
1073# if defined(USE_ITHREADS)
1074 /* only the parent thread can clobber the process environment */
1075 if (PL_curinterp == aTHX)
1076# endif
1077 {
1078# ifndef PERL_USE_SAFE_PUTENV
50acdf95 1079 if (!PL_use_safe_putenv) {
66b1d557 1080 I32 i;
1081
3280af22 1082 if (environ == PL_origenviron)
f2517201 1083 environ = (char**)safesysmalloc(sizeof(char*));
66b1d557 1084 else
1085 for (i = 0; environ[i]; i++)
f2517201 1086 safesysfree(environ[i]);
50acdf95 1087 }
4efc5df6 1088# endif /* PERL_USE_SAFE_PUTENV */
f2517201 1089
66b1d557 1090 environ[0] = Nullch;
4efc5df6 1091 }
1092# endif /* USE_ENVIRON_ARRAY */
052c2dc6 1093# endif /* PERL_IMPLICIT_SYS || WIN32 */
2f42fcb0 1094#endif /* VMS || EPOC */
1095#endif /* !PERL_MICRO */
3e3baf6d 1096 return 0;
66b1d557 1097}
1098
2e34cc90 1099#if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS)||defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1100static int sig_handlers_initted = 0;
1101#endif
7719e241 1102#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
85b332e2 1103static int sig_ignoring[SIG_SIZE]; /* which signals we are ignoring */
1104#endif
2e34cc90 1105#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1106static int sig_defaulting[SIG_SIZE];
1107#endif
85b332e2 1108
64ca3a65 1109#ifndef PERL_MICRO
2d4fcd5e 1110#ifdef HAS_SIGPROCMASK
1111static void
1112restore_sigmask(pTHX_ SV *save_sv)
1113{
1114 sigset_t *ossetp = (sigset_t *) SvPV_nolen( save_sv );
1115 (void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0);
1116}
1117#endif
66b1d557 1118int
864dbfa3 1119Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
88e89b8a 1120{
1121 I32 i;
2d8e6c8d 1122 STRLEN n_a;
88e89b8a 1123 /* Are we fetching a signal entry? */
2d8e6c8d 1124 i = whichsig(MgPV(mg,n_a));
e02bfb16 1125 if (i > 0) {
22c35a8c 1126 if(PL_psig_ptr[i])
1127 sv_setsv(sv,PL_psig_ptr[i]);
88e89b8a 1128 else {
85b332e2 1129 Sighandler_t sigstate;
2e34cc90 1130 sigstate = rsignal_state(i);
23ada85b 1131#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
2e34cc90 1132 if (sig_handlers_initted && sig_ignoring[i]) sigstate = SIG_IGN;
1133#endif
1134#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1135 if (sig_handlers_initted && sig_defaulting[i]) sigstate = SIG_DFL;
85b332e2 1136#endif
88e89b8a 1137 /* cache state so we don't fetch it again */
ff68c719 1138 if(sigstate == SIG_IGN)
88e89b8a 1139 sv_setpv(sv,"IGNORE");
1140 else
3280af22 1141 sv_setsv(sv,&PL_sv_undef);
22c35a8c 1142 PL_psig_ptr[i] = SvREFCNT_inc(sv);
88e89b8a 1143 SvTEMP_off(sv);
1144 }
1145 }
1146 return 0;
1147}
1148int
864dbfa3 1149Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
88e89b8a 1150{
2d4fcd5e 1151 /* XXX Some of this code was copied from Perl_magic_setsig. A little
1152 * refactoring might be in order.
1153 */
2d8e6c8d 1154 STRLEN n_a;
2d4fcd5e 1155 SV* to_dec;
35a4481c 1156 register const char *s = MgPV(mg,n_a);
2d4fcd5e 1157 if (*s == '_') {
1158 SV** svp;
1159 if (strEQ(s,"__DIE__"))
1160 svp = &PL_diehook;
1161 else if (strEQ(s,"__WARN__"))
1162 svp = &PL_warnhook;
1163 else
1164 Perl_croak(aTHX_ "No such hook: %s", s);
1165 if (*svp) {
1166 to_dec = *svp;
1167 *svp = 0;
1168 SvREFCNT_dec(to_dec);
1169 }
1170 }
1171 else {
1172 I32 i;
1173 /* Are we clearing a signal entry? */
1174 i = whichsig(s);
e02bfb16 1175 if (i > 0) {
2d4fcd5e 1176#ifdef HAS_SIGPROCMASK
1177 sigset_t set, save;
1178 SV* save_sv;
1179 /* Avoid having the signal arrive at a bad time, if possible. */
1180 sigemptyset(&set);
1181 sigaddset(&set,i);
1182 sigprocmask(SIG_BLOCK, &set, &save);
1183 ENTER;
1184 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1185 SAVEFREESV(save_sv);
1186 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1187#endif
1188 PERL_ASYNC_CHECK();
1189#if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1190 if (!sig_handlers_initted) Perl_csighandler_init();
1191#endif
1192#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1193 sig_defaulting[i] = 1;
5c1546dc 1194 (void)rsignal(i, PL_csighandlerp);
2d4fcd5e 1195#else
1196 (void)rsignal(i, SIG_DFL);
1197#endif
1198 if(PL_psig_name[i]) {
1199 SvREFCNT_dec(PL_psig_name[i]);
1200 PL_psig_name[i]=0;
1201 }
1202 if(PL_psig_ptr[i]) {
1203 to_dec=PL_psig_ptr[i];
1204 PL_psig_ptr[i]=0;
1205 LEAVE;
1206 SvREFCNT_dec(to_dec);
1207 }
1208 else
1209 LEAVE;
1210 }
88e89b8a 1211 }
1212 return 0;
1213}
3d37d572 1214
0a8e0eff 1215void
1216Perl_raise_signal(pTHX_ int sig)
1217{
1218 /* Set a flag to say this signal is pending */
1219 PL_psig_pend[sig]++;
1220 /* And one to say _a_ signal is pending */
1221 PL_sig_pending = 1;
1222}
1223
1224Signal_t
1225Perl_csighandler(int sig)
1226{
1018e26f 1227#ifdef PERL_GET_SIG_CONTEXT
1228 dTHXa(PERL_GET_SIG_CONTEXT);
1229#else
85b332e2 1230 dTHX;
1231#endif
23ada85b 1232#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
5c1546dc 1233 (void) rsignal(sig, PL_csighandlerp);
85b332e2 1234 if (sig_ignoring[sig]) return;
1235#endif
2e34cc90 1236#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
7719e241 1237 if (sig_defaulting[sig])
2e34cc90 1238#ifdef KILL_BY_SIGPRC
1239 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1240#else
1241 exit(1);
1242#endif
1243#endif
4ffa73a3 1244 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
1245 /* Call the perl level handler now--
1246 * with risk we may be in malloc() etc. */
1247 (*PL_sighandlerp)(sig);
1248 else
1249 Perl_raise_signal(aTHX_ sig);
0a8e0eff 1250}
1251
2e34cc90 1252#if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1253void
1254Perl_csighandler_init(void)
1255{
1256 int sig;
1257 if (sig_handlers_initted) return;
1258
1259 for (sig = 1; sig < SIG_SIZE; sig++) {
1260#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
218fdd94 1261 dTHX;
2e34cc90 1262 sig_defaulting[sig] = 1;
5c1546dc 1263 (void) rsignal(sig, PL_csighandlerp);
2e34cc90 1264#endif
1265#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1266 sig_ignoring[sig] = 0;
1267#endif
1268 }
1269 sig_handlers_initted = 1;
1270}
1271#endif
1272
0a8e0eff 1273void
1274Perl_despatch_signals(pTHX)
1275{
1276 int sig;
1277 PL_sig_pending = 0;
1278 for (sig = 1; sig < SIG_SIZE; sig++) {
1279 if (PL_psig_pend[sig]) {
25da4428 1280 PERL_BLOCKSIG_ADD(set, sig);
1281 PL_psig_pend[sig] = 0;
1282 PERL_BLOCKSIG_BLOCK(set);
f5203343 1283 (*PL_sighandlerp)(sig);
25da4428 1284 PERL_BLOCKSIG_UNBLOCK(set);
0a8e0eff 1285 }
1286 }
1287}
1288
85e6fe83 1289int
864dbfa3 1290Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
79072805 1291{
79072805 1292 I32 i;
b7953727 1293 SV** svp = 0;
2d4fcd5e 1294 /* Need to be careful with SvREFCNT_dec(), because that can have side
1295 * effects (due to closures). We must make sure that the new disposition
1296 * is in place before it is called.
1297 */
1298 SV* to_dec = 0;
e72dc28c 1299 STRLEN len;
2d4fcd5e 1300#ifdef HAS_SIGPROCMASK
1301 sigset_t set, save;
1302 SV* save_sv;
1303#endif
a0d0e21e 1304
35a4481c 1305 register const char *s = MgPV(mg,len);
748a9306 1306 if (*s == '_') {
1307 if (strEQ(s,"__DIE__"))
3280af22 1308 svp = &PL_diehook;
748a9306 1309 else if (strEQ(s,"__WARN__"))
3280af22 1310 svp = &PL_warnhook;
748a9306 1311 else
cea2e8a9 1312 Perl_croak(aTHX_ "No such hook: %s", s);
748a9306 1313 i = 0;
4633a7c4 1314 if (*svp) {
2d4fcd5e 1315 to_dec = *svp;
4633a7c4 1316 *svp = 0;
1317 }
748a9306 1318 }
1319 else {
1320 i = whichsig(s); /* ...no, a brick */
e02bfb16 1321 if (i < 0) {
e476b1b5 1322 if (ckWARN(WARN_SIGNAL))
9014280d 1323 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
748a9306 1324 return 0;
1325 }
2d4fcd5e 1326#ifdef HAS_SIGPROCMASK
1327 /* Avoid having the signal arrive at a bad time, if possible. */
1328 sigemptyset(&set);
1329 sigaddset(&set,i);
1330 sigprocmask(SIG_BLOCK, &set, &save);
1331 ENTER;
1332 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1333 SAVEFREESV(save_sv);
1334 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1335#endif
1336 PERL_ASYNC_CHECK();
2e34cc90 1337#if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1338 if (!sig_handlers_initted) Perl_csighandler_init();
1339#endif
23ada85b 1340#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
85b332e2 1341 sig_ignoring[i] = 0;
1342#endif
2e34cc90 1343#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
2d4fcd5e 1344 sig_defaulting[i] = 0;
2e34cc90 1345#endif
22c35a8c 1346 SvREFCNT_dec(PL_psig_name[i]);
2d4fcd5e 1347 to_dec = PL_psig_ptr[i];
22c35a8c 1348 PL_psig_ptr[i] = SvREFCNT_inc(sv);
88e89b8a 1349 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
e72dc28c 1350 PL_psig_name[i] = newSVpvn(s, len);
22c35a8c 1351 SvREADONLY_on(PL_psig_name[i]);
748a9306 1352 }
a0d0e21e 1353 if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
2d4fcd5e 1354 if (i) {
5c1546dc 1355 (void)rsignal(i, PL_csighandlerp);
2d4fcd5e 1356#ifdef HAS_SIGPROCMASK
1357 LEAVE;
1358#endif
1359 }
748a9306 1360 else
1361 *svp = SvREFCNT_inc(sv);
2d4fcd5e 1362 if(to_dec)
1363 SvREFCNT_dec(to_dec);
a0d0e21e 1364 return 0;
1365 }
e72dc28c 1366 s = SvPV_force(sv,len);
748a9306 1367 if (strEQ(s,"IGNORE")) {
85b332e2 1368 if (i) {
23ada85b 1369#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
85b332e2 1370 sig_ignoring[i] = 1;
5c1546dc 1371 (void)rsignal(i, PL_csighandlerp);
85b332e2 1372#else
ff68c719 1373 (void)rsignal(i, SIG_IGN);
85b332e2 1374#endif
2d4fcd5e 1375 }
748a9306 1376 }
1377 else if (strEQ(s,"DEFAULT") || !*s) {
1378 if (i)
2e34cc90 1379#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1380 {
1381 sig_defaulting[i] = 1;
5c1546dc 1382 (void)rsignal(i, PL_csighandlerp);
2e34cc90 1383 }
1384#else
ff68c719 1385 (void)rsignal(i, SIG_DFL);
2e34cc90 1386#endif
748a9306 1387 }
79072805 1388 else {
5aabfad6 1389 /*
1390 * We should warn if HINT_STRICT_REFS, but without
1391 * access to a known hint bit in a known OP, we can't
1392 * tell whether HINT_STRICT_REFS is in force or not.
1393 */
46fc3d4c 1394 if (!strchr(s,':') && !strchr(s,'\''))
e72dc28c 1395 sv_insert(sv, 0, 0, "main::", 6);
748a9306 1396 if (i)
5c1546dc 1397 (void)rsignal(i, PL_csighandlerp);
748a9306 1398 else
1399 *svp = SvREFCNT_inc(sv);
79072805 1400 }
2d4fcd5e 1401#ifdef HAS_SIGPROCMASK
1402 if(i)
1403 LEAVE;
1404#endif
1405 if(to_dec)
1406 SvREFCNT_dec(to_dec);
79072805 1407 return 0;
1408}
64ca3a65 1409#endif /* !PERL_MICRO */
79072805 1410
1411int
864dbfa3 1412Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
79072805 1413{
3280af22 1414 PL_sub_generation++;
463ee0b2 1415 return 0;
1416}
1417
1418int
864dbfa3 1419Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
463ee0b2 1420{
a0d0e21e 1421 /* HV_badAMAGIC_on(Sv_STASH(sv)); */
3280af22 1422 PL_amagic_generation++;
463ee0b2 1423
a0d0e21e 1424 return 0;
1425}
463ee0b2 1426
946ec16e 1427int
864dbfa3 1428Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
6ff81951 1429{
1430 HV *hv = (HV*)LvTARG(sv);
6ff81951 1431 I32 i = 0;
7719e241 1432
6ff81951 1433 if (hv) {
497b47a8 1434 (void) hv_iterinit(hv);
1435 if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
1436 i = HvKEYS(hv);
1437 else {
1438 while (hv_iternext(hv))
1439 i++;
1440 }
6ff81951 1441 }
1442
1443 sv_setiv(sv, (IV)i);
1444 return 0;
1445}
1446
1447int
864dbfa3 1448Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
946ec16e 1449{
1450 if (LvTARG(sv)) {
1451 hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
946ec16e 1452 }
1453 return 0;
ac27b0f5 1454}
946ec16e 1455
e336de0d 1456/* caller is responsible for stack switching/cleanup */
565764a8 1457STATIC int
e1ec3a88 1458S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV *val)
a0d0e21e 1459{
1460 dSP;
463ee0b2 1461
924508f0 1462 PUSHMARK(SP);
1463 EXTEND(SP, n);
33c27489 1464 PUSHs(SvTIED_obj(sv, mg));
ac27b0f5 1465 if (n > 1) {
93965878 1466 if (mg->mg_ptr) {
565764a8 1467 if (mg->mg_len >= 0)
79cb57f6 1468 PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len)));
565764a8 1469 else if (mg->mg_len == HEf_SVKEY)
93965878 1470 PUSHs((SV*)mg->mg_ptr);
1471 }
14befaf4 1472 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
565764a8 1473 PUSHs(sv_2mortal(newSViv(mg->mg_len)));
93965878 1474 }
1475 }
1476 if (n > 2) {
1477 PUSHs(val);
88e89b8a 1478 }
463ee0b2 1479 PUTBACK;
1480
864dbfa3 1481 return call_method(meth, flags);
946ec16e 1482}
1483
76e3520e 1484STATIC int
e1ec3a88 1485S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
a0d0e21e 1486{
1487 dSP;
463ee0b2 1488
a0d0e21e 1489 ENTER;
1490 SAVETMPS;
e788e7d3 1491 PUSHSTACKi(PERLSI_MAGIC);
463ee0b2 1492
33c27489 1493 if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
3280af22 1494 sv_setsv(sv, *PL_stack_sp--);
93965878 1495 }
463ee0b2 1496
d3acc0f7 1497 POPSTACK;
a0d0e21e 1498 FREETMPS;
1499 LEAVE;
1500 return 0;
1501}
463ee0b2 1502
a0d0e21e 1503int
864dbfa3 1504Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e 1505{
a0d0e21e 1506 if (mg->mg_ptr)
1507 mg->mg_flags |= MGf_GSKIP;
58f82c5c 1508 magic_methpack(sv,mg,"FETCH");
463ee0b2 1509 return 0;
1510}
1511
1512int
864dbfa3 1513Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
e336de0d 1514{
1515 dSP;
a60c0954 1516 ENTER;
e788e7d3 1517 PUSHSTACKi(PERLSI_MAGIC);
33c27489 1518 magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
d3acc0f7 1519 POPSTACK;
a60c0954 1520 LEAVE;
463ee0b2 1521 return 0;
1522}
1523
1524int
864dbfa3 1525Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
463ee0b2 1526{
a0d0e21e 1527 return magic_methpack(sv,mg,"DELETE");
1528}
463ee0b2 1529
93965878 1530
1531U32
864dbfa3 1532Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
ac27b0f5 1533{
e336de0d 1534 dSP;
93965878 1535 U32 retval = 0;
1536
1537 ENTER;
1538 SAVETMPS;
e788e7d3 1539 PUSHSTACKi(PERLSI_MAGIC);
33c27489 1540 if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
3280af22 1541 sv = *PL_stack_sp--;
a60c0954 1542 retval = (U32) SvIV(sv)-1;
93965878 1543 }
d3acc0f7 1544 POPSTACK;
93965878 1545 FREETMPS;
1546 LEAVE;
1547 return retval;
1548}
1549
cea2e8a9 1550int
1551Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e 1552{
1553 dSP;
463ee0b2 1554
e336de0d 1555 ENTER;
e788e7d3 1556 PUSHSTACKi(PERLSI_MAGIC);
924508f0 1557 PUSHMARK(SP);
33c27489 1558 XPUSHs(SvTIED_obj(sv, mg));
463ee0b2 1559 PUTBACK;
864dbfa3 1560 call_method("CLEAR", G_SCALAR|G_DISCARD);
d3acc0f7 1561 POPSTACK;
a60c0954 1562 LEAVE;
a3bcc51e 1563
463ee0b2 1564 return 0;
1565}
1566
1567int
864dbfa3 1568Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
463ee0b2 1569{
463ee0b2 1570 dSP;
35a4481c 1571 const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
463ee0b2 1572
1573 ENTER;
a0d0e21e 1574 SAVETMPS;
e788e7d3 1575 PUSHSTACKi(PERLSI_MAGIC);
924508f0 1576 PUSHMARK(SP);
1577 EXTEND(SP, 2);
33c27489 1578 PUSHs(SvTIED_obj(sv, mg));
463ee0b2 1579 if (SvOK(key))
1580 PUSHs(key);
1581 PUTBACK;
1582
864dbfa3 1583 if (call_method(meth, G_SCALAR))
3280af22 1584 sv_setsv(key, *PL_stack_sp--);
463ee0b2 1585
d3acc0f7 1586 POPSTACK;
a0d0e21e 1587 FREETMPS;
1588 LEAVE;
79072805 1589 return 0;
1590}
1591
1592int
864dbfa3 1593Perl_magic_existspack(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e 1594{
1595 return magic_methpack(sv,mg,"EXISTS");
ac27b0f5 1596}
a0d0e21e 1597
a3bcc51e 1598SV *
1599Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1600{
1601 dSP;
1602 SV *retval = &PL_sv_undef;
1603 SV *tied = SvTIED_obj((SV*)hv, mg);
1604 HV *pkg = SvSTASH((SV*)SvRV(tied));
1605
1606 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1607 SV *key;
1608 if (HvEITER(hv))
1609 /* we are in an iteration so the hash cannot be empty */
1610 return &PL_sv_yes;
1611 /* no xhv_eiter so now use FIRSTKEY */
1612 key = sv_newmortal();
1613 magic_nextpack((SV*)hv, mg, key);
1614 HvEITER(hv) = NULL; /* need to reset iterator */
1615 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1616 }
1617
1618 /* there is a SCALAR method that we can call */
1619 ENTER;
1620 PUSHSTACKi(PERLSI_MAGIC);
1621 PUSHMARK(SP);
1622 EXTEND(SP, 1);
1623 PUSHs(tied);
1624 PUTBACK;
1625
1626 if (call_method("SCALAR", G_SCALAR))
1627 retval = *PL_stack_sp--;
1628 POPSTACK;
1629 LEAVE;
1630 return retval;
1631}
1632
a0d0e21e 1633int
864dbfa3 1634Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
79072805 1635{
1636 OP *o;
1637 I32 i;
1638 GV* gv;
1639 SV** svp;
2d8e6c8d 1640 STRLEN n_a;
79072805 1641
3280af22 1642 gv = PL_DBline;
79072805 1643 i = SvTRUE(sv);
188ea221 1644 svp = av_fetch(GvAV(gv),
2d8e6c8d 1645 atoi(MgPV(mg,n_a)), FALSE);
5df8de69 1646 if (svp && SvIOKp(*svp) && (o = INT2PTR(OP*,SvIVX(*svp)))) {
1647 /* set or clear breakpoint in the relevant control op */
1648 if (i)
1649 o->op_flags |= OPf_SPECIAL;
1650 else
1651 o->op_flags &= ~OPf_SPECIAL;
1652 }
79072805 1653 return 0;
1654}
1655
1656int
864dbfa3 1657Perl_magic_getarylen(pTHX_ SV *sv, MAGIC *mg)
79072805 1658{
3280af22 1659 sv_setiv(sv, AvFILL((AV*)mg->mg_obj) + PL_curcop->cop_arybase);
79072805 1660 return 0;
1661}
1662
1663int
864dbfa3 1664Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
79072805 1665{
3280af22 1666 av_fill((AV*)mg->mg_obj, SvIV(sv) - PL_curcop->cop_arybase);
a0d0e21e 1667 return 0;
1668}
1669
1670int
864dbfa3 1671Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e 1672{
1673 SV* lsv = LvTARG(sv);
ac27b0f5 1674
a0d0e21e 1675 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
14befaf4 1676 mg = mg_find(lsv, PERL_MAGIC_regex_global);
565764a8 1677 if (mg && mg->mg_len >= 0) {
a0ed51b3 1678 I32 i = mg->mg_len;
7e2040f0 1679 if (DO_UTF8(lsv))
a0ed51b3 1680 sv_pos_b2u(lsv, &i);
1681 sv_setiv(sv, i + PL_curcop->cop_arybase);
a0d0e21e 1682 return 0;
1683 }
1684 }
0c34ef67 1685 SvOK_off(sv);
a0d0e21e 1686 return 0;
1687}
1688
1689int
864dbfa3 1690Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e 1691{
1692 SV* lsv = LvTARG(sv);
1693 SSize_t pos;
1694 STRLEN len;
c00206c8 1695 STRLEN ulen = 0;
a0d0e21e 1696
1697 mg = 0;
ac27b0f5 1698
a0d0e21e 1699 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
14befaf4 1700 mg = mg_find(lsv, PERL_MAGIC_regex_global);
a0d0e21e 1701 if (!mg) {
1702 if (!SvOK(sv))
1703 return 0;
14befaf4 1704 sv_magic(lsv, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1705 mg = mg_find(lsv, PERL_MAGIC_regex_global);
a0d0e21e 1706 }
1707 else if (!SvOK(sv)) {
565764a8 1708 mg->mg_len = -1;
a0d0e21e 1709 return 0;
1710 }
1711 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1712
c485e607 1713 pos = SvIV(sv) - PL_curcop->cop_arybase;
a0ed51b3 1714
7e2040f0 1715 if (DO_UTF8(lsv)) {
a0ed51b3 1716 ulen = sv_len_utf8(lsv);
1717 if (ulen)
1718 len = ulen;
a0ed51b3 1719 }
1720
a0d0e21e 1721 if (pos < 0) {
1722 pos += len;
1723 if (pos < 0)
1724 pos = 0;
1725 }
eb160463 1726 else if (pos > (SSize_t)len)
a0d0e21e 1727 pos = len;
a0ed51b3 1728
1729 if (ulen) {
1730 I32 p = pos;
1731 sv_pos_u2b(lsv, &p, 0);
1732 pos = p;
1733 }
727405f8 1734
565764a8 1735 mg->mg_len = pos;
71be2cbc 1736 mg->mg_flags &= ~MGf_MINMATCH;
a0d0e21e 1737
79072805 1738 return 0;
1739}
1740
1741int
864dbfa3 1742Perl_magic_getglob(pTHX_ SV *sv, MAGIC *mg)
79072805 1743{
8646b087 1744 if (SvFAKE(sv)) { /* FAKE globs can get coerced */
1745 SvFAKE_off(sv);
946ec16e 1746 gv_efullname3(sv,((GV*)sv), "*");
8646b087 1747 SvFAKE_on(sv);
1748 }
1749 else
946ec16e 1750 gv_efullname3(sv,((GV*)sv), "*"); /* a gv value, be nice */
79072805 1751 return 0;
1752}
1753
1754int
864dbfa3 1755Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg)
79072805 1756{
79072805 1757 GV* gv;
7a5fd60d 1758
79072805 1759 if (!SvOK(sv))
1760 return 0;
7a5fd60d 1761 gv = gv_fetchsv(sv,TRUE, SVt_PVGV);
79072805 1762 if (sv == (SV*)gv)
1763 return 0;
1764 if (GvGP(sv))
88e89b8a 1765 gp_free((GV*)sv);
79072805 1766 GvGP(sv) = gp_ref(GvGP(gv));
79072805 1767 return 0;
1768}
1769
1770int
864dbfa3 1771Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
6ff81951 1772{
1773 STRLEN len;
35a4481c 1774 SV * const lsv = LvTARG(sv);
1775 const char * const tmps = SvPV(lsv,len);
6ff81951 1776 I32 offs = LvTARGOFF(sv);
1777 I32 rem = LvTARGLEN(sv);
1778
9aa983d2 1779 if (SvUTF8(lsv))
1780 sv_pos_u2b(lsv, &offs, &rem);
eb160463 1781 if (offs > (I32)len)
6ff81951 1782 offs = len;
eb160463 1783 if (rem + offs > (I32)len)
6ff81951 1784 rem = len - offs;
1785 sv_setpvn(sv, tmps + offs, (STRLEN)rem);
9aa983d2 1786 if (SvUTF8(lsv))
2ef4b674 1787 SvUTF8_on(sv);
6ff81951 1788 return 0;
1789}
1790
1791int
864dbfa3 1792Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
79072805 1793{
9aa983d2 1794 STRLEN len;
1795 char *tmps = SvPV(sv, len);
1796 SV *lsv = LvTARG(sv);
1797 I32 lvoff = LvTARGOFF(sv);
1798 I32 lvlen = LvTARGLEN(sv);
075a4a2b 1799
1aa99e6b 1800 if (DO_UTF8(sv)) {
9aa983d2 1801 sv_utf8_upgrade(lsv);
1802 sv_pos_u2b(lsv, &lvoff, &lvlen);
1803 sv_insert(lsv, lvoff, lvlen, tmps, len);
b76f3ce2 1804 LvTARGLEN(sv) = sv_len_utf8(sv);
9aa983d2 1805 SvUTF8_on(lsv);
1806 }
9bf12eaf 1807 else if (lsv && SvUTF8(lsv)) {
9aa983d2 1808 sv_pos_u2b(lsv, &lvoff, &lvlen);
b76f3ce2 1809 LvTARGLEN(sv) = len;
e95af362 1810 tmps = (char*)bytes_to_utf8((U8*)tmps, &len);
9aa983d2 1811 sv_insert(lsv, lvoff, lvlen, tmps, len);
1812 Safefree(tmps);
1aa99e6b 1813 }
b76f3ce2 1814 else {
1815 sv_insert(lsv, lvoff, lvlen, tmps, len);
1816 LvTARGLEN(sv) = len;
1817 }
1818
1aa99e6b 1819
79072805 1820 return 0;
1821}
1822
1823int
864dbfa3 1824Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
463ee0b2 1825{
565764a8 1826 TAINT_IF((mg->mg_len & 1) ||
155aba94 1827 ((mg->mg_len & 2) && mg->mg_obj == sv)); /* kludge */
463ee0b2 1828 return 0;
1829}
1830
1831int
864dbfa3 1832Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
463ee0b2 1833{
3280af22 1834 if (PL_localizing) {
1835 if (PL_localizing == 1)
565764a8 1836 mg->mg_len <<= 1;
748a9306 1837 else
565764a8 1838 mg->mg_len >>= 1;
a0d0e21e 1839 }
3280af22 1840 else if (PL_tainted)
565764a8 1841 mg->mg_len |= 1;
748a9306 1842 else
565764a8 1843 mg->mg_len &= ~1;
463ee0b2 1844 return 0;
1845}
1846
1847int
864dbfa3 1848Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
6ff81951 1849{
35a4481c 1850 SV * const lsv = LvTARG(sv);
6ff81951 1851
1852 if (!lsv) {
0c34ef67 1853 SvOK_off(sv);
6ff81951 1854 return 0;
1855 }
6ff81951 1856
81e118e0 1857 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
6ff81951 1858 return 0;
1859}
1860
1861int
864dbfa3 1862Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
79072805 1863{
1864 do_vecset(sv); /* XXX slurp this routine */
1865 return 0;
1866}
1867
1868int
864dbfa3 1869Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
5f05dabc 1870{
71be2cbc 1871 SV *targ = Nullsv;
5f05dabc 1872 if (LvTARGLEN(sv)) {
68dc0745 1873 if (mg->mg_obj) {
74e13ce4 1874 SV *ahv = LvTARG(sv);
6d822dc4 1875 HE *he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
1876 if (he)
1877 targ = HeVAL(he);
68dc0745 1878 }
1879 else {
3c78fafa 1880 AV* av = (AV*)LvTARG(sv);
68dc0745 1881 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
1882 targ = AvARRAY(av)[LvTARGOFF(sv)];
1883 }
3280af22 1884 if (targ && targ != &PL_sv_undef) {
68dc0745 1885 /* somebody else defined it for us */
1886 SvREFCNT_dec(LvTARG(sv));
1887 LvTARG(sv) = SvREFCNT_inc(targ);
1888 LvTARGLEN(sv) = 0;
1889 SvREFCNT_dec(mg->mg_obj);
1890 mg->mg_obj = Nullsv;
1891 mg->mg_flags &= ~MGf_REFCOUNTED;
1892 }
5f05dabc 1893 }
71be2cbc 1894 else
1895 targ = LvTARG(sv);
3280af22 1896 sv_setsv(sv, targ ? targ : &PL_sv_undef);
71be2cbc 1897 return 0;
1898}
1899
1900int
864dbfa3 1901Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
71be2cbc 1902{
1903 if (LvTARGLEN(sv))
68dc0745 1904 vivify_defelem(sv);
1905 if (LvTARG(sv)) {
5f05dabc 1906 sv_setsv(LvTARG(sv), sv);
68dc0745 1907 SvSETMAGIC(LvTARG(sv));
1908 }
5f05dabc 1909 return 0;
1910}
1911
71be2cbc 1912void
864dbfa3 1913Perl_vivify_defelem(pTHX_ SV *sv)
71be2cbc 1914{
74e13ce4 1915 MAGIC *mg;
1916 SV *value = Nullsv;
71be2cbc 1917
14befaf4 1918 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
71be2cbc 1919 return;
68dc0745 1920 if (mg->mg_obj) {
74e13ce4 1921 SV *ahv = LvTARG(sv);
2d8e6c8d 1922 STRLEN n_a;
6d822dc4 1923 HE *he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
1924 if (he)
1925 value = HeVAL(he);
3280af22 1926 if (!value || value == &PL_sv_undef)
cea2e8a9 1927 Perl_croak(aTHX_ PL_no_helem, SvPV(mg->mg_obj, n_a));
71be2cbc 1928 }
68dc0745 1929 else {
1930 AV* av = (AV*)LvTARG(sv);
5aabfad6 1931 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
68dc0745 1932 LvTARG(sv) = Nullsv; /* array can't be extended */
1933 else {
1934 SV** svp = av_fetch(av, LvTARGOFF(sv), TRUE);
3280af22 1935 if (!svp || (value = *svp) == &PL_sv_undef)
cea2e8a9 1936 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
68dc0745 1937 }
1938 }
3e3baf6d 1939 (void)SvREFCNT_inc(value);
68dc0745 1940 SvREFCNT_dec(LvTARG(sv));
1941 LvTARG(sv) = value;
71be2cbc 1942 LvTARGLEN(sv) = 0;
68dc0745 1943 SvREFCNT_dec(mg->mg_obj);
1944 mg->mg_obj = Nullsv;
1945 mg->mg_flags &= ~MGf_REFCOUNTED;
5f05dabc 1946}
1947
1948int
864dbfa3 1949Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
810b8aa5 1950{
1951 AV *av = (AV*)mg->mg_obj;
1952 SV **svp = AvARRAY(av);
1953 I32 i = AvFILLp(av);
1954 while (i >= 0) {
fdc9a813 1955 if (svp[i]) {
810b8aa5 1956 if (!SvWEAKREF(svp[i]))
cea2e8a9 1957 Perl_croak(aTHX_ "panic: magic_killbackrefs");
810b8aa5 1958 /* XXX Should we check that it hasn't changed? */
1959 SvRV(svp[i]) = 0;
0c34ef67 1960 SvOK_off(svp[i]);
810b8aa5 1961 SvWEAKREF_off(svp[i]);
fdc9a813 1962 svp[i] = Nullsv;
810b8aa5 1963 }
1964 i--;
1965 }
d99b02a1 1966 SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */
810b8aa5 1967 return 0;
1968}
1969
1970int
864dbfa3 1971Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
93a17b20 1972{
565764a8 1973 mg->mg_len = -1;
c6496cc7 1974 SvSCREAM_off(sv);
93a17b20 1975 return 0;
1976}
1977
1978int
864dbfa3 1979Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
79072805 1980{
14befaf4 1981 sv_unmagic(sv, PERL_MAGIC_bm);
79072805 1982 SvVALID_off(sv);
1983 return 0;
1984}
1985
1986int
864dbfa3 1987Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
55497cff 1988{
14befaf4 1989 sv_unmagic(sv, PERL_MAGIC_fm);
55497cff 1990 SvCOMPILED_off(sv);
1991 return 0;
1992}
1993
1994int
864dbfa3 1995Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
79072805 1996{
35a4481c 1997 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
79072805 1998
1999 if (uf && uf->uf_set)
24f81a43 2000 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
79072805 2001 return 0;
2002}
2003
c277df42 2004int
faf82a0b 2005Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2006{
2007 sv_unmagic(sv, PERL_MAGIC_qr);
2008 return 0;
2009}
2010
2011int
864dbfa3 2012Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
c277df42 2013{
2014 regexp *re = (regexp *)mg->mg_obj;
2015 ReREFCNT_dec(re);
2016 return 0;
2017}
2018
7a4c00b4 2019#ifdef USE_LOCALE_COLLATE
79072805 2020int
864dbfa3 2021Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
bbce6d69 2022{
2023 /*
838b5b74 2024 * RenE<eacute> Descartes said "I think not."
bbce6d69 2025 * and vanished with a faint plop.
2026 */
7a4c00b4 2027 if (mg->mg_ptr) {
2028 Safefree(mg->mg_ptr);
2029 mg->mg_ptr = NULL;
565764a8 2030 mg->mg_len = -1;
7a4c00b4 2031 }
bbce6d69 2032 return 0;
2033}
7a4c00b4 2034#endif /* USE_LOCALE_COLLATE */
bbce6d69 2035
7e8c5dac 2036/* Just clear the UTF-8 cache data. */
2037int
2038Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2039{
2040 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2041 mg->mg_ptr = 0;
2042 mg->mg_len = -1; /* The mg_len holds the len cache. */
2043 return 0;
2044}
2045
bbce6d69 2046int
864dbfa3 2047Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
79072805 2048{
e1ec3a88 2049 register const char *s;
79072805 2050 I32 i;
8990e307 2051 STRLEN len;
79072805 2052 switch (*mg->mg_ptr) {
748a9306 2053 case '\001': /* ^A */
3280af22 2054 sv_setsv(PL_bodytarget, sv);
748a9306 2055 break;
49460fe6 2056 case '\003': /* ^C */
eb160463 2057 PL_minus_c = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
49460fe6 2058 break;
2059
79072805 2060 case '\004': /* ^D */
b4ab917c 2061#ifdef DEBUGGING
2062 s = SvPV_nolen(sv);
ddcf8bc1 2063 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
79072805 2064 DEBUG_x(dump_all());
b4ab917c 2065#else
2066 PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | DEBUG_TOP_FLAG;
2067#endif
79072805 2068 break;
28f23441 2069 case '\005': /* ^E */
d0063567 2070 if (*(mg->mg_ptr+1) == '\0') {
cd39f2b6 2071#ifdef MACOS_TRADITIONAL
d0063567 2072 gMacPerl_OSErr = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
28f23441 2073#else
cd39f2b6 2074# ifdef VMS
d0063567 2075 set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
048c1ddf 2076# else
cd39f2b6 2077# ifdef WIN32
d0063567 2078 SetLastError( SvIV(sv) );
cd39f2b6 2079# else
9fed8b87 2080# ifdef OS2
d0063567 2081 os2_setsyserrno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
9fed8b87 2082# else
d0063567 2083 /* will anyone ever use this? */
2084 SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4);
cd39f2b6 2085# endif
048c1ddf 2086# endif
2087# endif
22fae026 2088#endif
d0063567 2089 }
2090 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2091 if (PL_encoding)
2092 SvREFCNT_dec(PL_encoding);
2093 if (SvOK(sv) || SvGMAGICAL(sv)) {
2094 PL_encoding = newSVsv(sv);
2095 }
2096 else {
2097 PL_encoding = Nullsv;
2098 }
2099 }
2100 break;
79072805 2101 case '\006': /* ^F */
3280af22 2102 PL_maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
79072805 2103 break;
a0d0e21e 2104 case '\010': /* ^H */
3280af22 2105 PL_hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
a0d0e21e 2106 break;
9d116dd7 2107 case '\011': /* ^I */ /* NOT \t in EBCDIC */
3280af22 2108 if (PL_inplace)
2109 Safefree(PL_inplace);
79072805 2110 if (SvOK(sv))
2e0de35c 2111 PL_inplace = savesvpv(sv);
79072805 2112 else
3280af22 2113 PL_inplace = Nullch;
79072805 2114 break;
28f23441 2115 case '\017': /* ^O */
ac27b0f5 2116 if (*(mg->mg_ptr+1) == '\0') {
1bf29663 2117 if (PL_osname) {
ac27b0f5 2118 Safefree(PL_osname);
1bf29663 2119 PL_osname = Nullch;
2120 }
3511154c 2121 if (SvOK(sv)) {
2122 TAINT_PROPER("assigning to $^O");
2e0de35c 2123 PL_osname = savesvpv(sv);
3511154c 2124 }
ac27b0f5 2125 }
2126 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2127 if (!PL_compiling.cop_io)
2128 PL_compiling.cop_io = newSVsv(sv);
2129 else
2130 sv_setsv(PL_compiling.cop_io,sv);
2131 }
28f23441 2132 break;
79072805 2133 case '\020': /* ^P */
3280af22 2134 PL_perldb = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
39bd0f18 2135 if ((PERLDB_SUB || PERLDB_LINE || PERLDB_SUBLINE || PERLDB_ASSERTION)
2136 && !PL_DBsingle)
1ee4443e 2137 init_debugger();
79072805 2138 break;
2139 case '\024': /* ^T */
88e89b8a 2140#ifdef BIG_TIME
6b88bc9c 2141 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
88e89b8a 2142#else
3280af22 2143 PL_basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
88e89b8a 2144#endif
79072805 2145 break;
fde18df1 2146 case '\027': /* ^W & $^WARNING_BITS */
4438c4b7 2147 if (*(mg->mg_ptr+1) == '\0') {
2148 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2149 i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
ac27b0f5 2150 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
0453d815 2151 | (i ? G_WARN_ON : G_WARN_OFF) ;
4438c4b7 2152 }
599cee73 2153 }
0a378802 2154 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
4438c4b7 2155 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
d775746e 2156 if (!SvPOK(sv) && PL_localizing) {
2157 sv_setpvn(sv, WARN_NONEstring, WARNsize);
d3a7d8c7 2158 PL_compiling.cop_warnings = pWARN_NONE;
d775746e 2159 break;
2160 }
f4fc7782 2161 {
b5477537 2162 STRLEN len, i;
d3a7d8c7 2163 int accumulate = 0 ;
f4fc7782 2164 int any_fatals = 0 ;
35a4481c 2165 const char * const ptr = (char*)SvPV(sv, len) ;
f4fc7782 2166 for (i = 0 ; i < len ; ++i) {
2167 accumulate |= ptr[i] ;
2168 any_fatals |= (ptr[i] & 0xAA) ;
2169 }
d3a7d8c7 2170 if (!accumulate)
2171 PL_compiling.cop_warnings = pWARN_NONE;
f4fc7782 2172 else if (isWARN_on(sv, WARN_ALL) && !any_fatals) {
2173 PL_compiling.cop_warnings = pWARN_ALL;
2174 PL_dowarn |= G_WARN_ONCE ;
727405f8 2175 }
d3a7d8c7 2176 else {
2177 if (specialWARN(PL_compiling.cop_warnings))
2178 PL_compiling.cop_warnings = newSVsv(sv) ;
2179 else
2180 sv_setsv(PL_compiling.cop_warnings, sv);
2181 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2182 PL_dowarn |= G_WARN_ONCE ;
2183 }
f4fc7782 2184
d3a7d8c7 2185 }
4438c4b7 2186 }
971a9dd3 2187 }
79072805 2188 break;
2189 case '.':
3280af22 2190 if (PL_localizing) {
2191 if (PL_localizing == 1)
7766f137 2192 SAVESPTR(PL_last_in_gv);
748a9306 2193 }
3280af22 2194 else if (SvOK(sv) && GvIO(PL_last_in_gv))
632db599 2195 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
79072805 2196 break;
2197 case '^':
3280af22 2198 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
e1ec3a88 2199 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
7a5fd60d 2200 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv,TRUE, SVt_PVIO);
79072805 2201 break;
2202 case '~':
3280af22 2203 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
e1ec3a88 2204 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
7a5fd60d 2205 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv,TRUE, SVt_PVIO);
79072805 2206 break;
2207 case '=':
632db599 2208 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
79072805 2209 break;
2210 case '-':
632db599 2211 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
3280af22 2212 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2213 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
79072805 2214 break;
2215 case '%':
632db599 2216 IoPAGE(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
79072805 2217 break;
2218 case '|':
4b65379b 2219 {
3280af22 2220 IO *io = GvIOp(PL_defoutgv);
720f287d 2221 if(!io)
2222 break;
4b65379b 2223 if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) == 0)
2224 IoFLAGS(io) &= ~IOf_FLUSH;
2225 else {
2226 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2227 PerlIO *ofp = IoOFP(io);
2228 if (ofp)
2229 (void)PerlIO_flush(ofp);
2230 IoFLAGS(io) |= IOf_FLUSH;
2231 }
2232 }
79072805 2233 }
2234 break;
79072805 2235 case '/':
3280af22 2236 SvREFCNT_dec(PL_rs);
8bfdd7d9 2237 PL_rs = newSVsv(sv);
79072805 2238 break;
2239 case '\\':
7889fe52 2240 if (PL_ors_sv)
2241 SvREFCNT_dec(PL_ors_sv);
009c130f 2242 if (SvOK(sv) || SvGMAGICAL(sv)) {
7889fe52 2243 PL_ors_sv = newSVsv(sv);
009c130f 2244 }
e3c19b7b 2245 else {
7889fe52 2246 PL_ors_sv = Nullsv;
e3c19b7b 2247 }
79072805 2248 break;
2249 case ',':
7889fe52 2250 if (PL_ofs_sv)
2251 SvREFCNT_dec(PL_ofs_sv);
2252 if (SvOK(sv) || SvGMAGICAL(sv)) {
2253 PL_ofs_sv = newSVsv(sv);
2254 }
2255 else {
2256 PL_ofs_sv = Nullsv;
2257 }
79072805 2258 break;
2259 case '#':
3280af22 2260 if (PL_ofmt)
2261 Safefree(PL_ofmt);
2e0de35c 2262 PL_ofmt = savesvpv(sv);
79072805 2263 break;
2264 case '[':
3280af22 2265 PL_compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
79072805 2266 break;
2267 case '?':
ff0cee69 2268#ifdef COMPLEX_STATUS
6b88bc9c 2269 if (PL_localizing == 2) {
2270 PL_statusvalue = LvTARGOFF(sv);
2271 PL_statusvalue_vms = LvTARGLEN(sv);
ff0cee69 2272 }
2273 else
2274#endif
2275#ifdef VMSISH_STATUS
2276 if (VMSISH_STATUS)
2277 STATUS_NATIVE_SET((U32)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)));
2278 else
2279#endif
2280 STATUS_POSIX_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
79072805 2281 break;
2282 case '!':
93189314 2283 {
2284#ifdef VMS
2285# define PERL_VMS_BANG vaxc$errno
2286#else
2287# define PERL_VMS_BANG 0
2288#endif
91487cfc 2289 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
93189314 2290 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2291 }
79072805 2292 break;
2293 case '<':
3280af22 2294 PL_uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2295 if (PL_delaymagic) {
2296 PL_delaymagic |= DM_RUID;
79072805 2297 break; /* don't do magic till later */
2298 }
2299#ifdef HAS_SETRUID
b28d0864 2300 (void)setruid((Uid_t)PL_uid);
79072805 2301#else
2302#ifdef HAS_SETREUID
3280af22 2303 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
748a9306 2304#else
85e6fe83 2305#ifdef HAS_SETRESUID
b28d0864 2306 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
79072805 2307#else
75870ed3 2308 if (PL_uid == PL_euid) { /* special case $< = $> */
2309#ifdef PERL_DARWIN
2310 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2311 if (PL_uid != 0 && PerlProc_getuid() == 0)
2312 (void)PerlProc_setuid(0);
2313#endif
b28d0864 2314 (void)PerlProc_setuid(PL_uid);
75870ed3 2315 } else {
d8eceb89 2316 PL_uid = PerlProc_getuid();
cea2e8a9 2317 Perl_croak(aTHX_ "setruid() not implemented");
a0d0e21e 2318 }
79072805 2319#endif
2320#endif
85e6fe83 2321#endif
d8eceb89 2322 PL_uid = PerlProc_getuid();
3280af22 2323 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
79072805 2324 break;
2325 case '>':
3280af22 2326 PL_euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2327 if (PL_delaymagic) {
2328 PL_delaymagic |= DM_EUID;
79072805 2329 break; /* don't do magic till later */
2330 }
2331#ifdef HAS_SETEUID
3280af22 2332 (void)seteuid((Uid_t)PL_euid);
79072805 2333#else
2334#ifdef HAS_SETREUID
b28d0864 2335 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
85e6fe83 2336#else
2337#ifdef HAS_SETRESUID
6b88bc9c 2338 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
79072805 2339#else
b28d0864 2340 if (PL_euid == PL_uid) /* special case $> = $< */
2341 PerlProc_setuid(PL_euid);
a0d0e21e 2342 else {
e8ee3774 2343 PL_euid = PerlProc_geteuid();
cea2e8a9 2344 Perl_croak(aTHX_ "seteuid() not implemented");
a0d0e21e 2345 }
79072805 2346#endif
2347#endif
85e6fe83 2348#endif
d8eceb89 2349 PL_euid = PerlProc_geteuid();
3280af22 2350 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
79072805 2351 break;
2352 case '(':
3280af22 2353 PL_gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2354 if (PL_delaymagic) {
2355 PL_delaymagic |= DM_RGID;
79072805 2356 break; /* don't do magic till later */
2357 }
2358#ifdef HAS_SETRGID
b28d0864 2359 (void)setrgid((Gid_t)PL_gid);
79072805 2360#else
2361#ifdef HAS_SETREGID
3280af22 2362 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
85e6fe83 2363#else
2364#ifdef HAS_SETRESGID
b28d0864 2365 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
79072805 2366#else
b28d0864 2367 if (PL_gid == PL_egid) /* special case $( = $) */
2368 (void)PerlProc_setgid(PL_gid);
748a9306 2369 else {
d8eceb89 2370 PL_gid = PerlProc_getgid();
cea2e8a9 2371 Perl_croak(aTHX_ "setrgid() not implemented");
748a9306 2372 }
79072805 2373#endif
2374#endif
85e6fe83 2375#endif
d8eceb89 2376 PL_gid = PerlProc_getgid();
3280af22 2377 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
79072805 2378 break;
2379 case ')':
5cd24f17 2380#ifdef HAS_SETGROUPS
2381 {
35a4481c 2382 const char *p = SvPV(sv, len);
5cd24f17 2383 Groups_t gary[NGROUPS];
2384
5cd24f17 2385 while (isSPACE(*p))
2386 ++p;
2d4389e4 2387 PL_egid = Atol(p);
5cd24f17 2388 for (i = 0; i < NGROUPS; ++i) {
2389 while (*p && !isSPACE(*p))
2390 ++p;
2391 while (isSPACE(*p))
2392 ++p;
2393 if (!*p)
2394 break;
2d4389e4 2395 gary[i] = Atol(p);
5cd24f17 2396 }
8cc95fdb 2397 if (i)
2398 (void)setgroups(i, gary);
5cd24f17 2399 }
2400#else /* HAS_SETGROUPS */
b28d0864 2401 PL_egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
5cd24f17 2402#endif /* HAS_SETGROUPS */
3280af22 2403 if (PL_delaymagic) {
2404 PL_delaymagic |= DM_EGID;
79072805 2405 break; /* don't do magic till later */
2406 }
2407#ifdef HAS_SETEGID
3280af22 2408 (void)setegid((Gid_t)PL_egid);
79072805 2409#else
2410#ifdef HAS_SETREGID
b28d0864 2411 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
85e6fe83 2412#else
2413#ifdef HAS_SETRESGID
b28d0864 2414 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
79072805 2415#else
b28d0864 2416 if (PL_egid == PL_gid) /* special case $) = $( */
2417 (void)PerlProc_setgid(PL_egid);
748a9306 2418 else {
d8eceb89 2419 PL_egid = PerlProc_getegid();
cea2e8a9 2420 Perl_croak(aTHX_ "setegid() not implemented");
748a9306 2421 }
79072805 2422#endif
2423#endif
85e6fe83 2424#endif
d8eceb89 2425 PL_egid = PerlProc_getegid();
3280af22 2426 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
79072805 2427 break;
2428 case ':':
2d8e6c8d 2429 PL_chopset = SvPV_force(sv,len);
79072805 2430 break;
cd39f2b6 2431#ifndef MACOS_TRADITIONAL
79072805 2432 case '0':
e2975953 2433 LOCK_DOLLARZERO_MUTEX;
4bc88a62 2434#ifdef HAS_SETPROCTITLE
2435 /* The BSDs don't show the argv[] in ps(1) output, they
2436 * show a string from the process struct and provide
2437 * the setproctitle() routine to manipulate that. */
2438 {
2439 s = SvPV(sv, len);
98b76f99 2440# if __FreeBSD_version > 410001
9aad2c0e 2441 /* The leading "-" removes the "perl: " prefix,
4bc88a62 2442 * but not the "(perl) suffix from the ps(1)
2443 * output, because that's what ps(1) shows if the
2444 * argv[] is modified. */
6f2ad931 2445 setproctitle("-%s", s);
9aad2c0e 2446# else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
4bc88a62 2447 /* This doesn't really work if you assume that
2448 * $0 = 'foobar'; will wipe out 'perl' from the $0
2449 * because in ps(1) output the result will be like
2450 * sprintf("perl: %s (perl)", s)
2451 * I guess this is a security feature:
2452 * one (a user process) cannot get rid of the original name.
2453 * --jhi */
2454 setproctitle("%s", s);
2455# endif
2456 }
2457#endif
17aa7f3d 2458#if defined(__hpux) && defined(PSTAT_SETCMD)
2459 {
2460 union pstun un;
2461 s = SvPV(sv, len);
2462 un.pst_command = s;
2463 pstat(PSTAT_SETCMD, un, len, 0, 0);
2464 }
2465#endif
3cb9023d 2466 /* PL_origalen is set in perl_parse(). */
a0d0e21e 2467 s = SvPV_force(sv,len);
6f698202 2468 if (len >= (STRLEN)PL_origalen-1) {
2469 /* Longer than original, will be truncated. We assume that
2470 * PL_origalen bytes are available. */
2471 Copy(s, PL_origargv[0], PL_origalen-1, char);
79072805 2472 }
2473 else {
54bfe034 2474 /* Shorter than original, will be padded. */
2475 Copy(s, PL_origargv[0], len, char);
2476 PL_origargv[0][len] = 0;
2477 memset(PL_origargv[0] + len + 1,
2478 /* Is the space counterintuitive? Yes.
2479 * (You were expecting \0?)
3cb9023d 2480 * Does it work? Seems to. (In Linux 2.4.20 at least.)
54bfe034 2481 * --jhi */
2482 (int)' ',
2483 PL_origalen - len - 1);
79072805 2484 }
ad7eccf4 2485 PL_origargv[0][PL_origalen-1] = 0;
2486 for (i = 1; i < PL_origargc; i++)
2487 PL_origargv[i] = 0;
e2975953 2488 UNLOCK_DOLLARZERO_MUTEX;
79072805 2489 break;
cd39f2b6 2490#endif
79072805 2491 }
2492 return 0;
2493}
2494
2495I32
35a4481c 2496Perl_whichsig(pTHX_ const char *sig)
79072805 2497{
e1ec3a88 2498 register const char **sigv;
79072805 2499
e02bfb16 2500 for (sigv = PL_sig_name; *sigv; sigv++)
79072805 2501 if (strEQ(sig,*sigv))
22c35a8c 2502 return PL_sig_num[sigv - PL_sig_name];
79072805 2503#ifdef SIGCLD
2504 if (strEQ(sig,"CHLD"))
2505 return SIGCLD;
2506#endif
2507#ifdef SIGCHLD
2508 if (strEQ(sig,"CLD"))
2509 return SIGCHLD;
2510#endif
7f1236c0 2511 return -1;
79072805 2512}
2513
df3728a2 2514#if !defined(PERL_IMPLICIT_CONTEXT)
84902520 2515static SV* sig_sv;
df3728a2 2516#endif
84902520 2517
ecfc5424 2518Signal_t
cea2e8a9 2519Perl_sighandler(int sig)
79072805 2520{
1018e26f 2521#ifdef PERL_GET_SIG_CONTEXT
2522 dTHXa(PERL_GET_SIG_CONTEXT);
71d280e3 2523#else
cea2e8a9 2524 dTHX;
71d280e3 2525#endif
79072805 2526 dSP;
00d579c5 2527 GV *gv = Nullgv;
a0d0e21e 2528 HV *st;
b7953727 2529 SV *sv = Nullsv, *tSv = PL_Sv;
00d579c5 2530 CV *cv = Nullcv;
533c011a 2531 OP *myop = PL_op;
84902520 2532 U32 flags = 0;
3280af22 2533 XPV *tXpv = PL_Xpv;
71d280e3 2534
3280af22 2535 if (PL_savestack_ix + 15 <= PL_savestack_max)
84902520 2536 flags |= 1;
3280af22 2537 if (PL_markstack_ptr < PL_markstack_max - 2)
84902520 2538 flags |= 4;
3280af22 2539 if (PL_scopestack_ix < PL_scopestack_max - 3)
84902520 2540 flags |= 16;
2541
727405f8 2542 if (!PL_psig_ptr[sig]) {
99ef548b 2543 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
727405f8 2544 PL_sig_name[sig]);
2545 exit(sig);
2546 }
ff0cee69 2547
84902520 2548 /* Max number of items pushed there is 3*n or 4. We cannot fix
2549 infinity, so we fix 4 (in fact 5): */
2550 if (flags & 1) {
3280af22 2551 PL_savestack_ix += 5; /* Protect save in progress. */
c76ac1ee 2552 SAVEDESTRUCTOR_X(unwind_handler_stack, (void*)&flags);
84902520 2553 }
ac27b0f5 2554 if (flags & 4)
3280af22 2555 PL_markstack_ptr++; /* Protect mark. */
84902520 2556 if (flags & 16)
3280af22 2557 PL_scopestack_ix += 1;
84902520 2558 /* sv_2cv is too complicated, try a simpler variant first: */
ac27b0f5 2559 if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
84902520 2560 || SvTYPE(cv) != SVt_PVCV)
22c35a8c 2561 cv = sv_2cv(PL_psig_ptr[sig],&st,&gv,TRUE);
84902520 2562
a0d0e21e 2563 if (!cv || !CvROOT(cv)) {
599cee73 2564 if (ckWARN(WARN_SIGNAL))
9014280d 2565 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
22c35a8c 2566 PL_sig_name[sig], (gv ? GvENAME(gv)
00d579c5 2567 : ((cv && CvGV(cv))
2568 ? GvENAME(CvGV(cv))
2569 : "__ANON__")));
2570 goto cleanup;
79072805 2571 }
2572
22c35a8c 2573 if(PL_psig_name[sig]) {
2574 sv = SvREFCNT_inc(PL_psig_name[sig]);
84902520 2575 flags |= 64;
df3728a2 2576#if !defined(PERL_IMPLICIT_CONTEXT)
84902520 2577 sig_sv = sv;
df3728a2 2578#endif
84902520 2579 } else {
ff0cee69 2580 sv = sv_newmortal();
22c35a8c 2581 sv_setpv(sv,PL_sig_name[sig]);
88e89b8a 2582 }
e336de0d 2583
e788e7d3 2584 PUSHSTACKi(PERLSI_SIGNAL);
924508f0 2585 PUSHMARK(SP);
79072805 2586 PUSHs(sv);
79072805 2587 PUTBACK;
a0d0e21e 2588
1b266415 2589 call_sv((SV*)cv, G_DISCARD|G_EVAL);
79072805 2590
d3acc0f7 2591 POPSTACK;
1b266415 2592 if (SvTRUE(ERRSV)) {
1d615522 2593#ifndef PERL_MICRO
983dbef6 2594#ifdef HAS_SIGPROCMASK
1b266415 2595 /* Handler "died", for example to get out of a restart-able read().
2596 * Before we re-do that on its behalf re-enable the signal which was
2597 * blocked by the system when we entered.
2598 */
2599 sigset_t set;
2600 sigemptyset(&set);
2601 sigaddset(&set,sig);
2602 sigprocmask(SIG_UNBLOCK, &set, NULL);
2603#else
2604 /* Not clear if this will work */
2605 (void)rsignal(sig, SIG_IGN);
5c1546dc 2606 (void)rsignal(sig, PL_csighandlerp);
1b266415 2607#endif
1d615522 2608#endif /* !PERL_MICRO */
5df617be 2609 DieNull;
1b266415 2610 }
00d579c5 2611cleanup:
84902520 2612 if (flags & 1)
3280af22 2613 PL_savestack_ix -= 8; /* Unprotect save in progress. */
ac27b0f5 2614 if (flags & 4)
3280af22 2615 PL_markstack_ptr--;
84902520 2616 if (flags & 16)
3280af22 2617 PL_scopestack_ix -= 1;
84902520 2618 if (flags & 64)
2619 SvREFCNT_dec(sv);
533c011a 2620 PL_op = myop; /* Apparently not needed... */
ac27b0f5 2621
3280af22 2622 PL_Sv = tSv; /* Restore global temporaries. */
2623 PL_Xpv = tXpv;
53bb94e2 2624 return;
79072805 2625}
4e35701f 2626
2627
51371543 2628static void
35a4481c 2629restore_magic(pTHX_ const void *p)
51371543 2630{
48944bdf 2631 MGS* mgs = SSPTR(PTR2IV(p), MGS*);
51371543 2632 SV* sv = mgs->mgs_sv;
2633
2634 if (!sv)
2635 return;
2636
2637 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2638 {
f9701176 2639#ifdef PERL_COPY_ON_WRITE
2640 /* While magic was saved (and off) sv_setsv may well have seen
2641 this SV as a prime candidate for COW. */
2642 if (SvIsCOW(sv))
2643 sv_force_normal(sv);
2644#endif
2645
51371543 2646 if (mgs->mgs_flags)
2647 SvFLAGS(sv) |= mgs->mgs_flags;
2648 else
2649 mg_magical(sv);
2650 if (SvGMAGICAL(sv))
2651 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
2652 }
2653
2654 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
2655
2656 /* If we're still on top of the stack, pop us off. (That condition
2657 * will be satisfied if restore_magic was called explicitly, but *not*
2658 * if it's being called via leave_scope.)
2659 * The reason for doing this is that otherwise, things like sv_2cv()
2660 * may leave alloc gunk on the savestack, and some code
2661 * (e.g. sighandler) doesn't expect that...
2662 */
2663 if (PL_savestack_ix == mgs->mgs_ss_ix)
2664 {
2665 I32 popval = SSPOPINT;
c76ac1ee 2666 assert(popval == SAVEt_DESTRUCTOR_X);
51371543 2667 PL_savestack_ix -= 2;
2668 popval = SSPOPINT;
2669 assert(popval == SAVEt_ALLOC);
2670 popval = SSPOPINT;
2671 PL_savestack_ix -= popval;
2672 }
2673
2674}
2675
2676static void
35a4481c 2677unwind_handler_stack(pTHX_ const void *p)
51371543 2678{
e1ec3a88 2679 const U32 flags = *(const U32*)p;
51371543 2680
2681 if (flags & 1)
2682 PL_savestack_ix -= 5; /* Unprotect save in progress. */
2683 /* cxstack_ix-- Not needed, die already unwound it. */
df3728a2 2684#if !defined(PERL_IMPLICIT_CONTEXT)
51371543 2685 if (flags & 64)
2686 SvREFCNT_dec(sig_sv);
df3728a2 2687#endif
51371543 2688}
1018e26f 2689
2690
Unnamed repository; edit this file to name it for gitweb.