line |
stmt |
bran |
cond |
sub |
time |
code |
1
|
|
|
|
|
|
/* mg.c |
2
|
|
|
|
|
|
* |
3
|
|
|
|
|
|
* Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, |
4
|
|
|
|
|
|
* 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others |
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
|
|
|
|
|
|
* |
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. |
14
|
|
|
|
|
|
* |
15
|
|
|
|
|
|
* [p.363 of _The Lord of the Rings_, II/vii: "The Mirror of Galadriel"] |
16
|
|
|
|
|
|
*/ |
17
|
|
|
|
|
|
|
18
|
|
|
|
|
|
/* |
19
|
|
|
|
|
|
=head1 Magical Functions |
20
|
|
|
|
|
|
|
21
|
|
|
|
|
|
"Magic" is special data attached to SV structures in order to give them |
22
|
|
|
|
|
|
"magical" properties. When any Perl code tries to read from, or assign to, |
23
|
|
|
|
|
|
an SV marked as magical, it calls the 'get' or 'set' function associated |
24
|
|
|
|
|
|
with that SV's magic. A get is called prior to reading an SV, in order to |
25
|
|
|
|
|
|
give it a chance to update its internal value (get on $. writes the line |
26
|
|
|
|
|
|
number of the last read filehandle into to the SV's IV slot), while |
27
|
|
|
|
|
|
set is called after an SV has been written to, in order to allow it to make |
28
|
|
|
|
|
|
use of its changed value (set on $/ copies the SV's new value to the |
29
|
|
|
|
|
|
PL_rs global variable). |
30
|
|
|
|
|
|
|
31
|
|
|
|
|
|
Magic is implemented as a linked list of MAGIC structures attached to the |
32
|
|
|
|
|
|
SV. Each MAGIC struct holds the type of the magic, a pointer to an array |
33
|
|
|
|
|
|
of functions that implement the get(), set(), length() etc functions, |
34
|
|
|
|
|
|
plus space for some flags and pointers. For example, a tied variable has |
35
|
|
|
|
|
|
a MAGIC structure that contains a pointer to the object associated with the |
36
|
|
|
|
|
|
tie. |
37
|
|
|
|
|
|
|
38
|
|
|
|
|
|
*/ |
39
|
|
|
|
|
|
|
40
|
|
|
|
|
|
#include "EXTERN.h" |
41
|
|
|
|
|
|
#define PERL_IN_MG_C |
42
|
|
|
|
|
|
#include "perl.h" |
43
|
|
|
|
|
|
|
44
|
|
|
|
|
|
#if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS) |
45
|
|
|
|
|
|
# ifdef I_GRP |
46
|
|
|
|
|
|
# include |
47
|
|
|
|
|
|
# endif |
48
|
|
|
|
|
|
#endif |
49
|
|
|
|
|
|
|
50
|
|
|
|
|
|
#if defined(HAS_SETGROUPS) |
51
|
|
|
|
|
|
# ifndef NGROUPS |
52
|
|
|
|
|
|
# define NGROUPS 32 |
53
|
|
|
|
|
|
# endif |
54
|
|
|
|
|
|
#endif |
55
|
|
|
|
|
|
|
56
|
|
|
|
|
|
#ifdef __hpux |
57
|
|
|
|
|
|
# include |
58
|
|
|
|
|
|
#endif |
59
|
|
|
|
|
|
|
60
|
|
|
|
|
|
#ifdef HAS_PRCTL_SET_NAME |
61
|
|
|
|
|
|
# include |
62
|
|
|
|
|
|
#endif |
63
|
|
|
|
|
|
|
64
|
|
|
|
|
|
#if defined(HAS_SIGACTION) && defined(SA_SIGINFO) |
65
|
|
|
|
|
|
Signal_t Perl_csighandler(int sig, siginfo_t *, void *); |
66
|
|
|
|
|
|
#else |
67
|
|
|
|
|
|
Signal_t Perl_csighandler(int sig); |
68
|
|
|
|
|
|
#endif |
69
|
|
|
|
|
|
|
70
|
|
|
|
|
|
#ifdef __Lynx__ |
71
|
|
|
|
|
|
/* Missing protos on LynxOS */ |
72
|
|
|
|
|
|
void setruid(uid_t id); |
73
|
|
|
|
|
|
void seteuid(uid_t id); |
74
|
|
|
|
|
|
void setrgid(uid_t id); |
75
|
|
|
|
|
|
void setegid(uid_t id); |
76
|
|
|
|
|
|
#endif |
77
|
|
|
|
|
|
|
78
|
|
|
|
|
|
/* |
79
|
|
|
|
|
|
* Pre-magic setup and post-magic takedown. |
80
|
|
|
|
|
|
* Use the "DESTRUCTOR" scope cleanup to reinstate magic. |
81
|
|
|
|
|
|
*/ |
82
|
|
|
|
|
|
|
83
|
|
|
|
|
|
struct magic_state { |
84
|
|
|
|
|
|
SV* mgs_sv; |
85
|
|
|
|
|
|
I32 mgs_ss_ix; |
86
|
|
|
|
|
|
U32 mgs_magical; |
87
|
|
|
|
|
|
bool mgs_readonly; |
88
|
|
|
|
|
|
bool mgs_bumped; |
89
|
|
|
|
|
|
}; |
90
|
|
|
|
|
|
/* MGS is typedef'ed to struct magic_state in perl.h */ |
91
|
|
|
|
|
|
|
92
|
|
|
|
|
|
STATIC void |
93
|
113850077
|
|
|
|
|
S_save_magic_flags(pTHX_ I32 mgs_ix, SV *sv, U32 flags) |
94
|
|
|
|
|
|
{ |
95
|
|
|
|
|
|
dVAR; |
96
|
|
|
|
|
|
MGS* mgs; |
97
|
|
|
|
|
|
bool bumped = FALSE; |
98
|
|
|
|
|
|
|
99
|
|
|
|
|
|
PERL_ARGS_ASSERT_SAVE_MAGIC_FLAGS; |
100
|
|
|
|
|
|
|
101
|
|
|
|
|
|
assert(SvMAGICAL(sv)); |
102
|
|
|
|
|
|
|
103
|
|
|
|
|
|
/* we shouldn't really be called here with RC==0, but it can sometimes |
104
|
|
|
|
|
|
* happen via mg_clear() (which also shouldn't be called when RC==0, |
105
|
|
|
|
|
|
* but it can happen). Handle this case gracefully(ish) by not RC++ |
106
|
|
|
|
|
|
* and thus avoiding the resultant double free */ |
107
|
113850077
|
50
|
|
|
|
if (SvREFCNT(sv) > 0) { |
108
|
|
|
|
|
|
/* guard against sv getting freed midway through the mg clearing, |
109
|
|
|
|
|
|
* by holding a private reference for the duration. */ |
110
|
113850077
|
|
|
|
|
SvREFCNT_inc_simple_void_NN(sv); |
111
|
|
|
|
|
|
bumped = TRUE; |
112
|
|
|
|
|
|
} |
113
|
|
|
|
|
|
|
114
|
113850077
|
|
|
|
|
SAVEDESTRUCTOR_X(S_restore_magic, INT2PTR(void*, (IV)mgs_ix)); |
115
|
|
|
|
|
|
|
116
|
113850077
|
|
|
|
|
mgs = SSPTR(mgs_ix, MGS*); |
117
|
113850077
|
|
|
|
|
mgs->mgs_sv = sv; |
118
|
113850077
|
|
|
|
|
mgs->mgs_magical = SvMAGICAL(sv); |
119
|
113850077
|
|
|
|
|
mgs->mgs_readonly = SvREADONLY(sv) != 0; |
120
|
113850077
|
|
|
|
|
mgs->mgs_ss_ix = PL_savestack_ix; /* points after the saved destructor */ |
121
|
113850077
|
|
|
|
|
mgs->mgs_bumped = bumped; |
122
|
|
|
|
|
|
|
123
|
113850077
|
|
|
|
|
SvFLAGS(sv) &= ~flags; |
124
|
113850077
|
|
|
|
|
SvREADONLY_off(sv); |
125
|
113850077
|
|
|
|
|
} |
126
|
|
|
|
|
|
|
127
|
|
|
|
|
|
#define save_magic(a,b) save_magic_flags(a,b,SVs_GMG|SVs_SMG|SVs_RMG) |
128
|
|
|
|
|
|
|
129
|
|
|
|
|
|
/* |
130
|
|
|
|
|
|
=for apidoc mg_magical |
131
|
|
|
|
|
|
|
132
|
|
|
|
|
|
Turns on the magical status of an SV. See C. |
133
|
|
|
|
|
|
|
134
|
|
|
|
|
|
=cut |
135
|
|
|
|
|
|
*/ |
136
|
|
|
|
|
|
|
137
|
|
|
|
|
|
void |
138
|
108262592
|
|
|
|
|
Perl_mg_magical(pTHX_ SV *sv) |
139
|
|
|
|
|
|
{ |
140
|
|
|
|
|
|
const MAGIC* mg; |
141
|
|
|
|
|
|
PERL_ARGS_ASSERT_MG_MAGICAL; |
142
|
|
|
|
|
|
PERL_UNUSED_CONTEXT; |
143
|
|
|
|
|
|
|
144
|
108262592
|
|
|
|
|
SvMAGICAL_off(sv); |
145
|
108262592
|
100
|
|
|
|
if ((mg = SvMAGIC(sv))) { |
146
|
|
|
|
|
|
do { |
147
|
110011290
|
|
|
|
|
const MGVTBL* const vtbl = mg->mg_virtual; |
148
|
110011290
|
100
|
|
|
|
if (vtbl) { |
149
|
109729950
|
100
|
|
|
|
if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP)) |
|
|
100
|
|
|
|
|
150
|
43874425
|
|
|
|
|
SvGMAGICAL_on(sv); |
151
|
109729950
|
100
|
|
|
|
if (vtbl->svt_set) |
152
|
88786568
|
|
|
|
|
SvSMAGICAL_on(sv); |
153
|
109729950
|
100
|
|
|
|
if (vtbl->svt_clear) |
154
|
29035927
|
|
|
|
|
SvRMAGICAL_on(sv); |
155
|
|
|
|
|
|
} |
156
|
110011290
|
100
|
|
|
|
} while ((mg = mg->mg_moremagic)); |
157
|
108262586
|
100
|
|
|
|
if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG))) |
158
|
21184458
|
|
|
|
|
SvRMAGICAL_on(sv); |
159
|
|
|
|
|
|
} |
160
|
108262592
|
|
|
|
|
} |
161
|
|
|
|
|
|
|
162
|
|
|
|
|
|
/* |
163
|
|
|
|
|
|
=for apidoc mg_get |
164
|
|
|
|
|
|
|
165
|
|
|
|
|
|
Do magic before a value is retrieved from the SV. The type of SV must |
166
|
|
|
|
|
|
be >= SVt_PVMG. See C. |
167
|
|
|
|
|
|
|
168
|
|
|
|
|
|
=cut |
169
|
|
|
|
|
|
*/ |
170
|
|
|
|
|
|
|
171
|
|
|
|
|
|
int |
172
|
69245964
|
|
|
|
|
Perl_mg_get(pTHX_ SV *sv) |
173
|
|
|
|
|
|
{ |
174
|
|
|
|
|
|
dVAR; |
175
|
69245964
|
|
|
|
|
const I32 mgs_ix = SSNEW(sizeof(MGS)); |
176
|
|
|
|
|
|
bool saved = FALSE; |
177
|
|
|
|
|
|
bool have_new = 0; |
178
|
|
|
|
|
|
MAGIC *newmg, *head, *cur, *mg; |
179
|
|
|
|
|
|
|
180
|
|
|
|
|
|
PERL_ARGS_ASSERT_MG_GET; |
181
|
|
|
|
|
|
|
182
|
69245964
|
100
|
|
|
|
if (PL_localizing == 1 && sv == DEFSV) return 0; |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
183
|
|
|
|
|
|
|
184
|
|
|
|
|
|
/* We must call svt_get(sv, mg) for each valid entry in the linked |
185
|
|
|
|
|
|
list of magic. svt_get() may delete the current entry, add new |
186
|
|
|
|
|
|
magic to the head of the list, or upgrade the SV. AMS 20010810 */ |
187
|
|
|
|
|
|
|
188
|
69245934
|
|
|
|
|
newmg = cur = head = mg = SvMAGIC(sv); |
189
|
172517790
|
100
|
|
|
|
while (mg) { |
190
|
69264266
|
|
|
|
|
const MGVTBL * const vtbl = mg->mg_virtual; |
191
|
69264266
|
|
|
|
|
MAGIC * const nextmg = mg->mg_moremagic; /* it may delete itself */ |
192
|
|
|
|
|
|
|
193
|
69264266
|
50
|
|
|
|
if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) { |
|
|
100
|
|
|
|
|
194
|
|
|
|
|
|
|
195
|
|
|
|
|
|
/* taint's mg get is so dumb it doesn't need flag saving */ |
196
|
69246102
|
100
|
|
|
|
if (!saved && mg->mg_type != PERL_MAGIC_taint) { |
|
|
100
|
|
|
|
|
197
|
68118238
|
|
|
|
|
save_magic(mgs_ix, sv); |
198
|
|
|
|
|
|
saved = TRUE; |
199
|
|
|
|
|
|
} |
200
|
|
|
|
|
|
|
201
|
69246102
|
|
|
|
|
vtbl->svt_get(aTHX_ sv, mg); |
202
|
|
|
|
|
|
|
203
|
|
|
|
|
|
/* guard against magic having been deleted - eg FETCH calling |
204
|
|
|
|
|
|
* untie */ |
205
|
69246024
|
100
|
|
|
|
if (!SvMAGIC(sv)) { |
206
|
10
|
|
|
|
|
(SSPTR(mgs_ix, MGS *))->mgs_magical = 0; /* recalculate flags */ |
207
|
10
|
|
|
|
|
break; |
208
|
|
|
|
|
|
} |
209
|
|
|
|
|
|
|
210
|
|
|
|
|
|
/* recalculate flags if this entry was deleted. */ |
211
|
69246014
|
100
|
|
|
|
if (mg->mg_flags & MGf_GSKIP) |
212
|
2296125
|
|
|
|
|
(SSPTR(mgs_ix, MGS *))->mgs_magical = 0; |
213
|
|
|
|
|
|
} |
214
|
18164
|
50
|
|
|
|
else if (vtbl == &PL_vtbl_utf8) { |
215
|
|
|
|
|
|
/* get-magic can reallocate the PV */ |
216
|
|
|
|
|
|
magic_setutf8(sv, mg); |
217
|
|
|
|
|
|
} |
218
|
|
|
|
|
|
|
219
|
|
|
|
|
|
mg = nextmg; |
220
|
|
|
|
|
|
|
221
|
69264178
|
100
|
|
|
|
if (have_new) { |
222
|
|
|
|
|
|
/* Have we finished with the new entries we saw? Start again |
223
|
|
|
|
|
|
where we left off (unless there are more new entries). */ |
224
|
2
|
50
|
|
|
|
if (mg == head) { |
225
|
|
|
|
|
|
have_new = 0; |
226
|
|
|
|
|
|
mg = cur; |
227
|
|
|
|
|
|
head = newmg; |
228
|
|
|
|
|
|
} |
229
|
|
|
|
|
|
} |
230
|
|
|
|
|
|
|
231
|
|
|
|
|
|
/* Were any new entries added? */ |
232
|
69264178
|
50
|
|
|
|
if (!have_new && (newmg = SvMAGIC(sv)) != head) { |
|
|
100
|
|
|
|
|
233
|
|
|
|
|
|
have_new = 1; |
234
|
|
|
|
|
|
cur = mg; |
235
|
|
|
|
|
|
mg = newmg; |
236
|
35247379
|
|
|
|
|
(SSPTR(mgs_ix, MGS *))->mgs_magical = 0; /* recalculate flags */ |
237
|
|
|
|
|
|
} |
238
|
|
|
|
|
|
} |
239
|
|
|
|
|
|
|
240
|
69245856
|
100
|
|
|
|
if (saved) |
241
|
68682023
|
|
|
|
|
restore_magic(INT2PTR(void *, (IV)mgs_ix)); |
242
|
|
|
|
|
|
|
243
|
|
|
|
|
|
return 0; |
244
|
|
|
|
|
|
} |
245
|
|
|
|
|
|
|
246
|
|
|
|
|
|
/* |
247
|
|
|
|
|
|
=for apidoc mg_set |
248
|
|
|
|
|
|
|
249
|
|
|
|
|
|
Do magic after a value is assigned to the SV. See C. |
250
|
|
|
|
|
|
|
251
|
|
|
|
|
|
=cut |
252
|
|
|
|
|
|
*/ |
253
|
|
|
|
|
|
|
254
|
|
|
|
|
|
int |
255
|
42137736
|
|
|
|
|
Perl_mg_set(pTHX_ SV *sv) |
256
|
|
|
|
|
|
{ |
257
|
|
|
|
|
|
dVAR; |
258
|
42137736
|
|
|
|
|
const I32 mgs_ix = SSNEW(sizeof(MGS)); |
259
|
|
|
|
|
|
MAGIC* mg; |
260
|
|
|
|
|
|
MAGIC* nextmg; |
261
|
|
|
|
|
|
|
262
|
|
|
|
|
|
PERL_ARGS_ASSERT_MG_SET; |
263
|
|
|
|
|
|
|
264
|
42137736
|
100
|
|
|
|
if (PL_localizing == 2 && sv == DEFSV) return 0; |
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
265
|
|
|
|
|
|
|
266
|
42097406
|
|
|
|
|
save_magic_flags(mgs_ix, sv, SVs_GMG|SVs_SMG); /* leave SVs_RMG on */ |
267
|
|
|
|
|
|
|
268
|
105133130
|
100
|
|
|
|
for (mg = SvMAGIC(sv); mg; mg = nextmg) { |
269
|
42098218
|
|
|
|
|
const MGVTBL* vtbl = mg->mg_virtual; |
270
|
42098218
|
|
|
|
|
nextmg = mg->mg_moremagic; /* it may delete itself */ |
271
|
42098218
|
100
|
|
|
|
if (mg->mg_flags & MGf_GSKIP) { |
272
|
776
|
|
|
|
|
mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */ |
273
|
776
|
|
|
|
|
(SSPTR(mgs_ix, MGS*))->mgs_magical = 0; |
274
|
|
|
|
|
|
} |
275
|
42098218
|
100
|
|
|
|
if (PL_localizing == 2 |
276
|
12995516
|
100
|
|
|
|
&& PERL_MAGIC_TYPE_IS_VALUE_MAGIC(mg->mg_type)) |
277
|
12
|
|
|
|
|
continue; |
278
|
42098206
|
100
|
|
|
|
if (vtbl && vtbl->svt_set) |
|
|
100
|
|
|
|
|
279
|
42098180
|
|
|
|
|
vtbl->svt_set(aTHX_ sv, mg); |
280
|
|
|
|
|
|
} |
281
|
|
|
|
|
|
|
282
|
42097258
|
|
|
|
|
restore_magic(INT2PTR(void*, (IV)mgs_ix)); |
283
|
42117423
|
|
|
|
|
return 0; |
284
|
|
|
|
|
|
} |
285
|
|
|
|
|
|
|
286
|
|
|
|
|
|
/* |
287
|
|
|
|
|
|
=for apidoc mg_length |
288
|
|
|
|
|
|
|
289
|
|
|
|
|
|
Reports on the SV's length in bytes, calling length magic if available, |
290
|
|
|
|
|
|
but does not set the UTF8 flag on the sv. It will fall back to 'get' |
291
|
|
|
|
|
|
magic if there is no 'length' magic, but with no indication as to |
292
|
|
|
|
|
|
whether it called 'get' magic. It assumes the sv is a PVMG or |
293
|
|
|
|
|
|
higher. Use sv_len() instead. |
294
|
|
|
|
|
|
|
295
|
|
|
|
|
|
=cut |
296
|
|
|
|
|
|
*/ |
297
|
|
|
|
|
|
|
298
|
|
|
|
|
|
U32 |
299
|
0
|
|
|
|
|
Perl_mg_length(pTHX_ SV *sv) |
300
|
|
|
|
|
|
{ |
301
|
|
|
|
|
|
dVAR; |
302
|
|
|
|
|
|
MAGIC* mg; |
303
|
|
|
|
|
|
STRLEN len; |
304
|
|
|
|
|
|
|
305
|
|
|
|
|
|
PERL_ARGS_ASSERT_MG_LENGTH; |
306
|
|
|
|
|
|
|
307
|
0
|
0
|
|
|
|
for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { |
308
|
0
|
|
|
|
|
const MGVTBL * const vtbl = mg->mg_virtual; |
309
|
0
|
0
|
|
|
|
if (vtbl && vtbl->svt_len) { |
|
|
0
|
|
|
|
|
310
|
0
|
|
|
|
|
const I32 mgs_ix = SSNEW(sizeof(MGS)); |
311
|
0
|
|
|
|
|
save_magic(mgs_ix, sv); |
312
|
|
|
|
|
|
/* omit MGf_GSKIP -- not changed here */ |
313
|
0
|
|
|
|
|
len = vtbl->svt_len(aTHX_ sv, mg); |
314
|
0
|
|
|
|
|
restore_magic(INT2PTR(void*, (IV)mgs_ix)); |
315
|
0
|
|
|
|
|
return len; |
316
|
|
|
|
|
|
} |
317
|
|
|
|
|
|
} |
318
|
|
|
|
|
|
|
319
|
0
|
0
|
|
|
|
(void)SvPV_const(sv, len); |
320
|
0
|
|
|
|
|
return len; |
321
|
|
|
|
|
|
} |
322
|
|
|
|
|
|
|
323
|
|
|
|
|
|
I32 |
324
|
122276
|
|
|
|
|
Perl_mg_size(pTHX_ SV *sv) |
325
|
|
|
|
|
|
{ |
326
|
|
|
|
|
|
MAGIC* mg; |
327
|
|
|
|
|
|
|
328
|
|
|
|
|
|
PERL_ARGS_ASSERT_MG_SIZE; |
329
|
|
|
|
|
|
|
330
|
242718
|
100
|
|
|
|
for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { |
331
|
122456
|
|
|
|
|
const MGVTBL* const vtbl = mg->mg_virtual; |
332
|
122456
|
50
|
|
|
|
if (vtbl && vtbl->svt_len) { |
|
|
100
|
|
|
|
|
333
|
2014
|
|
|
|
|
const I32 mgs_ix = SSNEW(sizeof(MGS)); |
334
|
|
|
|
|
|
I32 len; |
335
|
2014
|
|
|
|
|
save_magic(mgs_ix, sv); |
336
|
|
|
|
|
|
/* omit MGf_GSKIP -- not changed here */ |
337
|
2014
|
|
|
|
|
len = vtbl->svt_len(aTHX_ sv, mg); |
338
|
2004
|
|
|
|
|
restore_magic(INT2PTR(void*, (IV)mgs_ix)); |
339
|
62135
|
|
|
|
|
return len; |
340
|
|
|
|
|
|
} |
341
|
|
|
|
|
|
} |
342
|
|
|
|
|
|
|
343
|
120262
|
50
|
|
|
|
switch(SvTYPE(sv)) { |
344
|
|
|
|
|
|
case SVt_PVAV: |
345
|
120262
|
|
|
|
|
return AvFILLp((const AV *) sv); /* Fallback to non-tied array */ |
346
|
|
|
|
|
|
case SVt_PVHV: |
347
|
|
|
|
|
|
/* FIXME */ |
348
|
|
|
|
|
|
default: |
349
|
0
|
|
|
|
|
Perl_croak(aTHX_ "Size magic not implemented"); |
350
|
|
|
|
|
|
break; |
351
|
|
|
|
|
|
} |
352
|
|
|
|
|
|
return 0; |
353
|
|
|
|
|
|
} |
354
|
|
|
|
|
|
|
355
|
|
|
|
|
|
/* |
356
|
|
|
|
|
|
=for apidoc mg_clear |
357
|
|
|
|
|
|
|
358
|
|
|
|
|
|
Clear something magical that the SV represents. See C. |
359
|
|
|
|
|
|
|
360
|
|
|
|
|
|
=cut |
361
|
|
|
|
|
|
*/ |
362
|
|
|
|
|
|
|
363
|
|
|
|
|
|
int |
364
|
3632419
|
|
|
|
|
Perl_mg_clear(pTHX_ SV *sv) |
365
|
|
|
|
|
|
{ |
366
|
3632419
|
|
|
|
|
const I32 mgs_ix = SSNEW(sizeof(MGS)); |
367
|
|
|
|
|
|
MAGIC* mg; |
368
|
|
|
|
|
|
MAGIC *nextmg; |
369
|
|
|
|
|
|
|
370
|
|
|
|
|
|
PERL_ARGS_ASSERT_MG_CLEAR; |
371
|
|
|
|
|
|
|
372
|
3632419
|
|
|
|
|
save_magic(mgs_ix, sv); |
373
|
|
|
|
|
|
|
374
|
9063086
|
100
|
|
|
|
for (mg = SvMAGIC(sv); mg; mg = nextmg) { |
375
|
3632465
|
|
|
|
|
const MGVTBL* const vtbl = mg->mg_virtual; |
376
|
|
|
|
|
|
/* omit GSKIP -- never set here */ |
377
|
|
|
|
|
|
|
378
|
3632465
|
|
|
|
|
nextmg = mg->mg_moremagic; /* it may delete itself */ |
379
|
|
|
|
|
|
|
380
|
3632465
|
100
|
|
|
|
if (vtbl && vtbl->svt_clear) |
|
|
100
|
|
|
|
|
381
|
3632457
|
|
|
|
|
vtbl->svt_clear(aTHX_ sv, mg); |
382
|
|
|
|
|
|
} |
383
|
|
|
|
|
|
|
384
|
3632407
|
|
|
|
|
restore_magic(INT2PTR(void*, (IV)mgs_ix)); |
385
|
3632407
|
|
|
|
|
return 0; |
386
|
|
|
|
|
|
} |
387
|
|
|
|
|
|
|
388
|
|
|
|
|
|
static MAGIC* |
389
|
|
|
|
|
|
S_mg_findext_flags(pTHX_ const SV *sv, int type, const MGVTBL *vtbl, U32 flags) |
390
|
|
|
|
|
|
{ |
391
|
|
|
|
|
|
PERL_UNUSED_CONTEXT; |
392
|
|
|
|
|
|
|
393
|
|
|
|
|
|
assert(flags <= 1); |
394
|
|
|
|
|
|
|
395
|
913872221
|
50
|
|
|
|
if (sv) { |
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
396
|
|
|
|
|
|
MAGIC *mg; |
397
|
|
|
|
|
|
|
398
|
|
|
|
|
|
assert(!(SvTYPE(sv) == SVt_PVAV && AvPAD_NAMELIST(sv))); |
399
|
|
|
|
|
|
|
400
|
1723687413
|
50
|
|
|
|
for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { |
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
401
|
899997147
|
50
|
|
|
|
if (mg->mg_type == type && (!flags || mg->mg_virtual == vtbl)) { |
|
|
0
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
402
|
|
|
|
|
|
return mg; |
403
|
|
|
|
|
|
} |
404
|
|
|
|
|
|
} |
405
|
|
|
|
|
|
} |
406
|
|
|
|
|
|
|
407
|
|
|
|
|
|
return NULL; |
408
|
|
|
|
|
|
} |
409
|
|
|
|
|
|
|
410
|
|
|
|
|
|
/* |
411
|
|
|
|
|
|
=for apidoc mg_find |
412
|
|
|
|
|
|
|
413
|
|
|
|
|
|
Finds the magic pointer for type matching the SV. See C. |
414
|
|
|
|
|
|
|
415
|
|
|
|
|
|
=cut |
416
|
|
|
|
|
|
*/ |
417
|
|
|
|
|
|
|
418
|
|
|
|
|
|
MAGIC* |
419
|
886244481
|
|
|
|
|
Perl_mg_find(pTHX_ const SV *sv, int type) |
420
|
|
|
|
|
|
{ |
421
|
886244481
|
|
|
|
|
return S_mg_findext_flags(aTHX_ sv, type, NULL, 0); |
422
|
|
|
|
|
|
} |
423
|
|
|
|
|
|
|
424
|
|
|
|
|
|
/* |
425
|
|
|
|
|
|
=for apidoc mg_findext |
426
|
|
|
|
|
|
|
427
|
|
|
|
|
|
Finds the magic pointer of C with the given C for the C. See |
428
|
|
|
|
|
|
C. |
429
|
|
|
|
|
|
|
430
|
|
|
|
|
|
=cut |
431
|
|
|
|
|
|
*/ |
432
|
|
|
|
|
|
|
433
|
|
|
|
|
|
MAGIC* |
434
|
20
|
|
|
|
|
Perl_mg_findext(pTHX_ const SV *sv, int type, const MGVTBL *vtbl) |
435
|
|
|
|
|
|
{ |
436
|
20
|
|
|
|
|
return S_mg_findext_flags(aTHX_ sv, type, vtbl, 1); |
437
|
|
|
|
|
|
} |
438
|
|
|
|
|
|
|
439
|
|
|
|
|
|
MAGIC * |
440
|
32401847
|
|
|
|
|
Perl_mg_find_mglob(pTHX_ SV *sv) |
441
|
|
|
|
|
|
{ |
442
|
|
|
|
|
|
PERL_ARGS_ASSERT_MG_FIND_MGLOB; |
443
|
32401847
|
100
|
|
|
|
if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') { |
|
|
100
|
|
|
|
|
444
|
|
|
|
|
|
/* This sv is only a delegate. //g magic must be attached to |
445
|
|
|
|
|
|
its target. */ |
446
|
18
|
|
|
|
|
vivify_defelem(sv); |
447
|
18
|
|
|
|
|
sv = LvTARG(sv); |
448
|
|
|
|
|
|
} |
449
|
32401847
|
100
|
|
|
|
if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) |
|
|
100
|
|
|
|
|
450
|
29995203
|
|
|
|
|
return S_mg_findext_flags(aTHX_ sv, PERL_MAGIC_regex_global, 0, 0); |
451
|
|
|
|
|
|
return NULL; |
452
|
|
|
|
|
|
} |
453
|
|
|
|
|
|
|
454
|
|
|
|
|
|
/* |
455
|
|
|
|
|
|
=for apidoc mg_copy |
456
|
|
|
|
|
|
|
457
|
|
|
|
|
|
Copies the magic from one SV to another. See C. |
458
|
|
|
|
|
|
|
459
|
|
|
|
|
|
=cut |
460
|
|
|
|
|
|
*/ |
461
|
|
|
|
|
|
|
462
|
|
|
|
|
|
int |
463
|
8651937
|
|
|
|
|
Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen) |
464
|
|
|
|
|
|
{ |
465
|
|
|
|
|
|
int count = 0; |
466
|
|
|
|
|
|
MAGIC* mg; |
467
|
|
|
|
|
|
|
468
|
|
|
|
|
|
PERL_ARGS_ASSERT_MG_COPY; |
469
|
|
|
|
|
|
|
470
|
17304396
|
100
|
|
|
|
for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { |
471
|
8652459
|
|
|
|
|
const MGVTBL* const vtbl = mg->mg_virtual; |
472
|
8652459
|
100
|
|
|
|
if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){ |
|
|
50
|
|
|
|
|
473
|
2
|
|
|
|
|
count += vtbl->svt_copy(aTHX_ sv, mg, nsv, key, klen); |
474
|
|
|
|
|
|
} |
475
|
|
|
|
|
|
else { |
476
|
8652457
|
|
|
|
|
const char type = mg->mg_type; |
477
|
8652457
|
100
|
|
|
|
if (isUPPER(type) && type != PERL_MAGIC_uvar) { |
478
|
8611679
|
50
|
|
|
|
sv_magic(nsv, |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
479
|
|
|
|
|
|
(type == PERL_MAGIC_tied) |
480
|
|
|
|
|
|
? SvTIED_obj(sv, mg) |
481
|
|
|
|
|
|
: (type == PERL_MAGIC_regdata && mg->mg_obj) |
482
|
|
|
|
|
|
? sv |
483
|
|
|
|
|
|
: mg->mg_obj, |
484
|
|
|
|
|
|
toLOWER(type), key, klen); |
485
|
8611679
|
|
|
|
|
count++; |
486
|
|
|
|
|
|
} |
487
|
|
|
|
|
|
} |
488
|
|
|
|
|
|
} |
489
|
8651937
|
|
|
|
|
return count; |
490
|
|
|
|
|
|
} |
491
|
|
|
|
|
|
|
492
|
|
|
|
|
|
/* |
493
|
|
|
|
|
|
=for apidoc mg_localize |
494
|
|
|
|
|
|
|
495
|
|
|
|
|
|
Copy some of the magic from an existing SV to new localized version of that |
496
|
|
|
|
|
|
SV. Container magic (eg %ENV, $1, tie) gets copied, value magic doesn't (eg |
497
|
|
|
|
|
|
taint, pos). |
498
|
|
|
|
|
|
|
499
|
|
|
|
|
|
If setmagic is false then no set magic will be called on the new (empty) SV. |
500
|
|
|
|
|
|
This typically means that assignment will soon follow (e.g. 'local $x = $y'), |
501
|
|
|
|
|
|
and that will handle the magic. |
502
|
|
|
|
|
|
|
503
|
|
|
|
|
|
=cut |
504
|
|
|
|
|
|
*/ |
505
|
|
|
|
|
|
|
506
|
|
|
|
|
|
void |
507
|
13035848
|
|
|
|
|
Perl_mg_localize(pTHX_ SV *sv, SV *nsv, bool setmagic) |
508
|
|
|
|
|
|
{ |
509
|
|
|
|
|
|
dVAR; |
510
|
|
|
|
|
|
MAGIC *mg; |
511
|
|
|
|
|
|
|
512
|
|
|
|
|
|
PERL_ARGS_ASSERT_MG_LOCALIZE; |
513
|
|
|
|
|
|
|
514
|
13035848
|
100
|
|
|
|
if (nsv == DEFSV) |
|
|
100
|
|
|
|
|
515
|
13035848
|
|
|
|
|
return; |
516
|
|
|
|
|
|
|
517
|
25991046
|
100
|
|
|
|
for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { |
518
|
12995524
|
|
|
|
|
const MGVTBL* const vtbl = mg->mg_virtual; |
519
|
12995524
|
100
|
|
|
|
if (PERL_MAGIC_TYPE_IS_VALUE_MAGIC(mg->mg_type)) |
520
|
24
|
|
|
|
|
continue; |
521
|
|
|
|
|
|
|
522
|
12995500
|
50
|
|
|
|
if ((mg->mg_flags & MGf_LOCAL) && vtbl->svt_local) |
|
|
0
|
|
|
|
|
523
|
0
|
|
|
|
|
(void)vtbl->svt_local(aTHX_ nsv, mg); |
524
|
|
|
|
|
|
else |
525
|
12995500
|
|
|
|
|
sv_magicext(nsv, mg->mg_obj, mg->mg_type, vtbl, |
526
|
|
|
|
|
|
mg->mg_ptr, mg->mg_len); |
527
|
|
|
|
|
|
|
528
|
|
|
|
|
|
/* container types should remain read-only across localization */ |
529
|
12995500
|
|
|
|
|
SvFLAGS(nsv) |= SvREADONLY(sv); |
530
|
|
|
|
|
|
} |
531
|
|
|
|
|
|
|
532
|
12995522
|
100
|
|
|
|
if (SvTYPE(nsv) >= SVt_PVMG && SvMAGIC(nsv)) { |
|
|
100
|
|
|
|
|
533
|
12995500
|
|
|
|
|
SvFLAGS(nsv) |= SvMAGICAL(sv); |
534
|
12995500
|
100
|
|
|
|
if (setmagic) { |
535
|
12989178
|
|
|
|
|
PL_localizing = 1; |
536
|
12989178
|
100
|
|
|
|
SvSETMAGIC(nsv); |
537
|
12989178
|
|
|
|
|
PL_localizing = 0; |
538
|
|
|
|
|
|
} |
539
|
|
|
|
|
|
} |
540
|
|
|
|
|
|
} |
541
|
|
|
|
|
|
|
542
|
|
|
|
|
|
#define mg_free_struct(sv, mg) S_mg_free_struct(aTHX_ sv, mg) |
543
|
|
|
|
|
|
static void |
544
|
39862801
|
|
|
|
|
S_mg_free_struct(pTHX_ SV *sv, MAGIC *mg) |
545
|
|
|
|
|
|
{ |
546
|
39862801
|
|
|
|
|
const MGVTBL* const vtbl = mg->mg_virtual; |
547
|
39862801
|
100
|
|
|
|
if (vtbl && vtbl->svt_free) |
|
|
100
|
|
|
|
|
548
|
15416
|
|
|
|
|
vtbl->svt_free(aTHX_ sv, mg); |
549
|
39862801
|
100
|
|
|
|
if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) { |
|
|
50
|
|
|
|
|
550
|
25327532
|
100
|
|
|
|
if (mg->mg_len > 0 || mg->mg_type == PERL_MAGIC_utf8) |
|
|
100
|
|
|
|
|
551
|
15158900
|
|
|
|
|
Safefree(mg->mg_ptr); |
552
|
10168632
|
100
|
|
|
|
else if (mg->mg_len == HEf_SVKEY) |
553
|
9457561
|
|
|
|
|
SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr)); |
554
|
|
|
|
|
|
} |
555
|
39862801
|
100
|
|
|
|
if (mg->mg_flags & MGf_REFCOUNTED) |
556
|
2667003
|
|
|
|
|
SvREFCNT_dec(mg->mg_obj); |
557
|
39862801
|
|
|
|
|
Safefree(mg); |
558
|
39862801
|
|
|
|
|
} |
559
|
|
|
|
|
|
|
560
|
|
|
|
|
|
/* |
561
|
|
|
|
|
|
=for apidoc mg_free |
562
|
|
|
|
|
|
|
563
|
|
|
|
|
|
Free any magic storage used by the SV. See C. |
564
|
|
|
|
|
|
|
565
|
|
|
|
|
|
=cut |
566
|
|
|
|
|
|
*/ |
567
|
|
|
|
|
|
|
568
|
|
|
|
|
|
int |
569
|
40526303
|
|
|
|
|
Perl_mg_free(pTHX_ SV *sv) |
570
|
|
|
|
|
|
{ |
571
|
|
|
|
|
|
MAGIC* mg; |
572
|
|
|
|
|
|
MAGIC* moremagic; |
573
|
|
|
|
|
|
|
574
|
|
|
|
|
|
PERL_ARGS_ASSERT_MG_FREE; |
575
|
|
|
|
|
|
|
576
|
100578629
|
100
|
|
|
|
for (mg = SvMAGIC(sv); mg; mg = moremagic) { |
577
|
39862791
|
|
|
|
|
moremagic = mg->mg_moremagic; |
578
|
39862791
|
|
|
|
|
mg_free_struct(sv, mg); |
579
|
39862791
|
|
|
|
|
SvMAGIC_set(sv, moremagic); |
580
|
|
|
|
|
|
} |
581
|
40526303
|
|
|
|
|
SvMAGIC_set(sv, NULL); |
582
|
40526303
|
|
|
|
|
SvMAGICAL_off(sv); |
583
|
40526303
|
|
|
|
|
return 0; |
584
|
|
|
|
|
|
} |
585
|
|
|
|
|
|
|
586
|
|
|
|
|
|
/* |
587
|
|
|
|
|
|
=for apidoc Am|void|mg_free_type|SV *sv|int how |
588
|
|
|
|
|
|
|
589
|
|
|
|
|
|
Remove any magic of type I from the SV I. See L. |
590
|
|
|
|
|
|
|
591
|
|
|
|
|
|
=cut |
592
|
|
|
|
|
|
*/ |
593
|
|
|
|
|
|
|
594
|
|
|
|
|
|
void |
595
|
12
|
|
|
|
|
Perl_mg_free_type(pTHX_ SV *sv, int how) |
596
|
|
|
|
|
|
{ |
597
|
|
|
|
|
|
MAGIC *mg, *prevmg, *moremg; |
598
|
|
|
|
|
|
PERL_ARGS_ASSERT_MG_FREE_TYPE; |
599
|
36
|
100
|
|
|
|
for (prevmg = NULL, mg = SvMAGIC(sv); mg; prevmg = mg, mg = moremg) { |
600
|
|
|
|
|
|
MAGIC *newhead; |
601
|
18
|
|
|
|
|
moremg = mg->mg_moremagic; |
602
|
18
|
100
|
|
|
|
if (mg->mg_type == how) { |
603
|
|
|
|
|
|
/* temporarily move to the head of the magic chain, in case |
604
|
|
|
|
|
|
custom free code relies on this historical aspect of mg_free */ |
605
|
10
|
100
|
|
|
|
if (prevmg) { |
606
|
2
|
|
|
|
|
prevmg->mg_moremagic = moremg; |
607
|
2
|
|
|
|
|
mg->mg_moremagic = SvMAGIC(sv); |
608
|
2
|
|
|
|
|
SvMAGIC_set(sv, mg); |
609
|
|
|
|
|
|
} |
610
|
10
|
|
|
|
|
newhead = mg->mg_moremagic; |
611
|
10
|
|
|
|
|
mg_free_struct(sv, mg); |
612
|
14
|
|
|
|
|
SvMAGIC_set(sv, newhead); |
613
|
|
|
|
|
|
mg = prevmg; |
614
|
|
|
|
|
|
} |
615
|
|
|
|
|
|
} |
616
|
12
|
|
|
|
|
mg_magical(sv); |
617
|
12
|
|
|
|
|
} |
618
|
|
|
|
|
|
|
619
|
|
|
|
|
|
#include |
620
|
|
|
|
|
|
|
621
|
|
|
|
|
|
U32 |
622
|
274
|
|
|
|
|
Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg) |
623
|
|
|
|
|
|
{ |
624
|
|
|
|
|
|
dVAR; |
625
|
|
|
|
|
|
PERL_UNUSED_ARG(sv); |
626
|
|
|
|
|
|
|
627
|
|
|
|
|
|
PERL_ARGS_ASSERT_MAGIC_REGDATA_CNT; |
628
|
|
|
|
|
|
|
629
|
274
|
100
|
|
|
|
if (PL_curpm) { |
630
|
254
|
|
|
|
|
const REGEXP * const rx = PM_GETRE(PL_curpm); |
631
|
254
|
50
|
|
|
|
if (rx) { |
632
|
254
|
100
|
|
|
|
if (mg->mg_obj) { /* @+ */ |
633
|
|
|
|
|
|
/* return the number possible */ |
634
|
124
|
|
|
|
|
return RX_NPARENS(rx); |
635
|
|
|
|
|
|
} else { /* @- */ |
636
|
130
|
|
|
|
|
I32 paren = RX_LASTPAREN(rx); |
637
|
|
|
|
|
|
|
638
|
|
|
|
|
|
/* return the last filled */ |
639
|
195
|
50
|
|
|
|
while ( paren >= 0 |
640
|
130
|
50
|
|
|
|
&& (RX_OFFS(rx)[paren].start == -1 |
641
|
130
|
50
|
|
|
|
|| RX_OFFS(rx)[paren].end == -1) ) |
642
|
0
|
|
|
|
|
paren--; |
643
|
202
|
|
|
|
|
return (U32)paren; |
644
|
|
|
|
|
|
} |
645
|
|
|
|
|
|
} |
646
|
|
|
|
|
|
} |
647
|
|
|
|
|
|
|
648
|
|
|
|
|
|
return (U32)-1; |
649
|
|
|
|
|
|
} |
650
|
|
|
|
|
|
|
651
|
|
|
|
|
|
/* @-, @+ */ |
652
|
|
|
|
|
|
|
653
|
|
|
|
|
|
int |
654
|
133520
|
|
|
|
|
Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg) |
655
|
|
|
|
|
|
{ |
656
|
|
|
|
|
|
dVAR; |
657
|
|
|
|
|
|
|
658
|
|
|
|
|
|
PERL_ARGS_ASSERT_MAGIC_REGDATUM_GET; |
659
|
|
|
|
|
|
|
660
|
133520
|
50
|
|
|
|
if (PL_curpm) { |
661
|
133520
|
|
|
|
|
const REGEXP * const rx = PM_GETRE(PL_curpm); |
662
|
133520
|
50
|
|
|
|
if (rx) { |
663
|
133520
|
|
|
|
|
const I32 paren = mg->mg_len; |
664
|
|
|
|
|
|
SSize_t s; |
665
|
|
|
|
|
|
SSize_t t; |
666
|
133520
|
50
|
|
|
|
if (paren < 0) |
667
|
|
|
|
|
|
return 0; |
668
|
200280
|
50
|
|
|
|
if (paren <= (I32)RX_NPARENS(rx) && |
|
|
100
|
|
|
|
|
669
|
200024
|
50
|
|
|
|
(s = RX_OFFS(rx)[paren].start) != -1 && |
670
|
133264
|
|
|
|
|
(t = RX_OFFS(rx)[paren].end) != -1) |
671
|
|
|
|
|
|
{ |
672
|
|
|
|
|
|
SSize_t i; |
673
|
133264
|
100
|
|
|
|
if (mg->mg_obj) /* @+ */ |
674
|
|
|
|
|
|
i = t; |
675
|
|
|
|
|
|
else /* @- */ |
676
|
|
|
|
|
|
i = s; |
677
|
|
|
|
|
|
|
678
|
133264
|
100
|
|
|
|
if (RX_MATCH_UTF8(rx)) { |
679
|
8444
|
|
|
|
|
const char * const b = RX_SUBBEG(rx); |
680
|
8444
|
50
|
|
|
|
if (b) |
681
|
12666
|
|
|
|
|
i = RX_SUBCOFFSET(rx) + |
682
|
12666
|
|
|
|
|
utf8_length((U8*)b, |
683
|
|
|
|
|
|
(U8*)(b-RX_SUBOFFSET(rx)+i)); |
684
|
|
|
|
|
|
} |
685
|
|
|
|
|
|
|
686
|
133264
|
|
|
|
|
sv_setuv(sv, i); |
687
|
133264
|
|
|
|
|
return 0; |
688
|
|
|
|
|
|
} |
689
|
|
|
|
|
|
} |
690
|
|
|
|
|
|
} |
691
|
256
|
|
|
|
|
sv_setsv(sv, NULL); |
692
|
66888
|
|
|
|
|
return 0; |
693
|
|
|
|
|
|
} |
694
|
|
|
|
|
|
|
695
|
|
|
|
|
|
/* @-, @+ */ |
696
|
|
|
|
|
|
|
697
|
|
|
|
|
|
int |
698
|
0
|
|
|
|
|
Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg) |
699
|
|
|
|
|
|
{ |
700
|
|
|
|
|
|
PERL_ARGS_ASSERT_MAGIC_REGDATUM_SET; |
701
|
|
|
|
|
|
PERL_UNUSED_ARG(sv); |
702
|
|
|
|
|
|
PERL_UNUSED_ARG(mg); |
703
|
0
|
|
|
|
|
Perl_croak_no_modify(); |
704
|
|
|
|
|
|
NORETURN_FUNCTION_END; |
705
|
|
|
|
|
|
} |
706
|
|
|
|
|
|
|
707
|
|
|
|
|
|
#define SvRTRIM(sv) STMT_START { \ |
708
|
|
|
|
|
|
if (SvPOK(sv)) { \ |
709
|
|
|
|
|
|
STRLEN len = SvCUR(sv); \ |
710
|
|
|
|
|
|
char * const p = SvPVX(sv); \ |
711
|
|
|
|
|
|
while (len > 0 && isSPACE(p[len-1])) \ |
712
|
|
|
|
|
|
--len; \ |
713
|
|
|
|
|
|
SvCUR_set(sv, len); \ |
714
|
|
|
|
|
|
p[len] = '\0'; \ |
715
|
|
|
|
|
|
} \ |
716
|
|
|
|
|
|
} STMT_END |
717
|
|
|
|
|
|
|
718
|
|
|
|
|
|
void |
719
|
458
|
|
|
|
|
Perl_emulate_cop_io(pTHX_ const COP *const c, SV *const sv) |
720
|
|
|
|
|
|
{ |
721
|
|
|
|
|
|
PERL_ARGS_ASSERT_EMULATE_COP_IO; |
722
|
|
|
|
|
|
|
723
|
458
|
100
|
|
|
|
if (!(CopHINTS_get(c) & (HINT_LEXICAL_IO_IN|HINT_LEXICAL_IO_OUT))) |
724
|
432
|
|
|
|
|
sv_setsv(sv, &PL_sv_undef); |
725
|
|
|
|
|
|
else { |
726
|
26
|
|
|
|
|
sv_setpvs(sv, ""); |
727
|
26
|
|
|
|
|
SvUTF8_off(sv); |
728
|
26
|
50
|
|
|
|
if ((CopHINTS_get(c) & HINT_LEXICAL_IO_IN)) { |
729
|
26
|
|
|
|
|
SV *const value = cop_hints_fetch_pvs(c, "open<", 0); |
730
|
|
|
|
|
|
assert(value); |
731
|
26
|
|
|
|
|
sv_catsv(sv, value); |
732
|
|
|
|
|
|
} |
733
|
26
|
|
|
|
|
sv_catpvs(sv, "\0"); |
734
|
26
|
50
|
|
|
|
if ((CopHINTS_get(c) & HINT_LEXICAL_IO_OUT)) { |
735
|
26
|
|
|
|
|
SV *const value = cop_hints_fetch_pvs(c, "open>", 0); |
736
|
|
|
|
|
|
assert(value); |
737
|
26
|
|
|
|
|
sv_catsv(sv, value); |
738
|
|
|
|
|
|
} |
739
|
|
|
|
|
|
} |
740
|
458
|
|
|
|
|
} |
741
|
|
|
|
|
|
|
742
|
|
|
|
|
|
#ifdef VMS |
743
|
|
|
|
|
|
#include |
744
|
|
|
|
|
|
#include |
745
|
|
|
|
|
|
#endif |
746
|
|
|
|
|
|
|
747
|
|
|
|
|
|
int |
748
|
65176561
|
|
|
|
|
Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) |
749
|
|
|
|
|
|
{ |
750
|
|
|
|
|
|
dVAR; |
751
|
|
|
|
|
|
I32 paren; |
752
|
|
|
|
|
|
const char *s = NULL; |
753
|
|
|
|
|
|
REGEXP *rx; |
754
|
65176561
|
|
|
|
|
const char * const remaining = mg->mg_ptr + 1; |
755
|
65176561
|
|
|
|
|
const char nextchar = *remaining; |
756
|
|
|
|
|
|
|
757
|
|
|
|
|
|
PERL_ARGS_ASSERT_MAGIC_GET; |
758
|
|
|
|
|
|
|
759
|
65176561
|
|
|
|
|
switch (*mg->mg_ptr) { |
760
|
|
|
|
|
|
case '\001': /* ^A */ |
761
|
2324
|
100
|
|
|
|
if (SvOK(PL_bodytarget)) sv_copypv(sv, PL_bodytarget); |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
762
|
730
|
|
|
|
|
else sv_setsv(sv, &PL_sv_undef); |
763
|
2324
|
50
|
|
|
|
if (SvTAINTED(PL_bodytarget)) |
|
|
0
|
|
|
|
|
764
|
0
|
0
|
|
|
|
SvTAINTED_on(sv); |
765
|
|
|
|
|
|
break; |
766
|
|
|
|
|
|
case '\003': /* ^C, ^CHILD_ERROR_NATIVE */ |
767
|
523510
|
100
|
|
|
|
if (nextchar == '\0') { |
768
|
523482
|
|
|
|
|
sv_setiv(sv, (IV)PL_minus_c); |
769
|
|
|
|
|
|
} |
770
|
28
|
50
|
|
|
|
else if (strEQ(remaining, "HILD_ERROR_NATIVE")) { |
771
|
28
|
|
|
|
|
sv_setiv(sv, (IV)STATUS_NATIVE); |
772
|
|
|
|
|
|
} |
773
|
|
|
|
|
|
break; |
774
|
|
|
|
|
|
|
775
|
|
|
|
|
|
case '\004': /* ^D */ |
776
|
271318
|
|
|
|
|
sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK)); |
777
|
271318
|
|
|
|
|
break; |
778
|
|
|
|
|
|
case '\005': /* ^E */ |
779
|
86480
|
100
|
|
|
|
if (nextchar == '\0') { |
780
|
|
|
|
|
|
#if defined(VMS) |
781
|
|
|
|
|
|
{ |
782
|
|
|
|
|
|
char msg[255]; |
783
|
|
|
|
|
|
$DESCRIPTOR(msgdsc,msg); |
784
|
|
|
|
|
|
sv_setnv(sv,(NV) vaxc$errno); |
785
|
|
|
|
|
|
if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1) |
786
|
|
|
|
|
|
sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length); |
787
|
|
|
|
|
|
else |
788
|
|
|
|
|
|
sv_setpvs(sv,""); |
789
|
|
|
|
|
|
} |
790
|
|
|
|
|
|
#elif defined(OS2) |
791
|
|
|
|
|
|
if (!(_emx_env & 0x200)) { /* Under DOS */ |
792
|
|
|
|
|
|
sv_setnv(sv, (NV)errno); |
793
|
|
|
|
|
|
sv_setpv(sv, errno ? Strerror(errno) : ""); |
794
|
|
|
|
|
|
} else { |
795
|
|
|
|
|
|
if (errno != errno_isOS2) { |
796
|
|
|
|
|
|
const int tmp = _syserrno(); |
797
|
|
|
|
|
|
if (tmp) /* 2nd call to _syserrno() makes it 0 */ |
798
|
|
|
|
|
|
Perl_rc = tmp; |
799
|
|
|
|
|
|
} |
800
|
|
|
|
|
|
sv_setnv(sv, (NV)Perl_rc); |
801
|
|
|
|
|
|
sv_setpv(sv, os2error(Perl_rc)); |
802
|
|
|
|
|
|
} |
803
|
|
|
|
|
|
#elif defined(WIN32) |
804
|
|
|
|
|
|
{ |
805
|
|
|
|
|
|
const DWORD dwErr = GetLastError(); |
806
|
|
|
|
|
|
sv_setnv(sv, (NV)dwErr); |
807
|
|
|
|
|
|
if (dwErr) { |
808
|
|
|
|
|
|
PerlProc_GetOSError(sv, dwErr); |
809
|
|
|
|
|
|
} |
810
|
|
|
|
|
|
else |
811
|
|
|
|
|
|
sv_setpvs(sv, ""); |
812
|
|
|
|
|
|
SetLastError(dwErr); |
813
|
|
|
|
|
|
} |
814
|
|
|
|
|
|
#else |
815
|
|
|
|
|
|
{ |
816
|
71558
|
|
|
|
|
dSAVE_ERRNO; |
817
|
71558
|
|
|
|
|
sv_setnv(sv, (NV)errno); |
818
|
71558
|
100
|
|
|
|
sv_setpv(sv, errno ? Strerror(errno) : ""); |
819
|
71558
|
|
|
|
|
RESTORE_ERRNO; |
820
|
|
|
|
|
|
} |
821
|
|
|
|
|
|
#endif |
822
|
71558
|
50
|
|
|
|
SvRTRIM(sv); |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
823
|
71558
|
|
|
|
|
SvNOK_on(sv); /* what a wonderful hack! */ |
824
|
|
|
|
|
|
} |
825
|
14922
|
50
|
|
|
|
else if (strEQ(remaining, "NCODING")) |
826
|
14922
|
|
|
|
|
sv_setsv(sv, PL_encoding); |
827
|
|
|
|
|
|
break; |
828
|
|
|
|
|
|
case '\006': /* ^F */ |
829
|
448
|
|
|
|
|
sv_setiv(sv, (IV)PL_maxsysfd); |
830
|
448
|
|
|
|
|
break; |
831
|
|
|
|
|
|
case '\007': /* ^GLOBAL_PHASE */ |
832
|
14
|
50
|
|
|
|
if (strEQ(remaining, "LOBAL_PHASE")) { |
833
|
14
|
|
|
|
|
sv_setpvn(sv, PL_phase_names[PL_phase], |
834
|
|
|
|
|
|
strlen(PL_phase_names[PL_phase])); |
835
|
|
|
|
|
|
} |
836
|
|
|
|
|
|
break; |
837
|
|
|
|
|
|
case '\010': /* ^H */ |
838
|
2266398
|
|
|
|
|
sv_setiv(sv, (IV)PL_hints); |
839
|
2266398
|
|
|
|
|
break; |
840
|
|
|
|
|
|
case '\011': /* ^I */ /* NOT \t in EBCDIC */ |
841
|
20
|
|
|
|
|
sv_setpv(sv, PL_inplace); /* Will undefine sv if PL_inplace is NULL */ |
842
|
20
|
|
|
|
|
break; |
843
|
|
|
|
|
|
case '\014': /* ^LAST_FH */ |
844
|
0
|
0
|
|
|
|
if (strEQ(remaining, "AST_FH")) { |
845
|
0
|
0
|
|
|
|
if (PL_last_in_gv) { |
846
|
|
|
|
|
|
assert(isGV_with_GP(PL_last_in_gv)); |
847
|
0
|
0
|
|
|
|
SV_CHECK_THINKFIRST_COW_DROP(sv); |
848
|
0
|
0
|
|
|
|
prepare_SV_for_RV(sv); |
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
849
|
0
|
0
|
|
|
|
SvOK_off(sv); |
850
|
0
|
|
|
|
|
SvRV_set(sv, SvREFCNT_inc_simple_NN(PL_last_in_gv)); |
851
|
0
|
|
|
|
|
SvROK_on(sv); |
852
|
0
|
|
|
|
|
sv_rvweaken(sv); |
853
|
|
|
|
|
|
} |
854
|
0
|
|
|
|
|
else sv_setsv_nomg(sv, NULL); |
855
|
|
|
|
|
|
} |
856
|
|
|
|
|
|
break; |
857
|
|
|
|
|
|
case '\017': /* ^O & ^OPEN */ |
858
|
1118700
|
100
|
|
|
|
if (nextchar == '\0') { |
859
|
1118242
|
|
|
|
|
sv_setpv(sv, PL_osname); |
860
|
1118242
|
100
|
|
|
|
SvTAINTED_off(sv); |
861
|
|
|
|
|
|
} |
862
|
458
|
50
|
|
|
|
else if (strEQ(remaining, "PEN")) { |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
863
|
458
|
|
|
|
|
Perl_emulate_cop_io(aTHX_ &PL_compiling, sv); |
864
|
|
|
|
|
|
} |
865
|
|
|
|
|
|
break; |
866
|
|
|
|
|
|
case '\020': |
867
|
5908
|
100
|
|
|
|
if (nextchar == '\0') { /* ^P */ |
868
|
5550
|
|
|
|
|
sv_setiv(sv, (IV)PL_perldb); |
869
|
358
|
100
|
|
|
|
} else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */ |
870
|
|
|
|
|
|
|
871
|
|
|
|
|
|
paren = RX_BUFF_IDX_CARET_PREMATCH; |
872
|
|
|
|
|
|
goto do_numbuf_fetch; |
873
|
48
|
50
|
|
|
|
} else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */ |
874
|
|
|
|
|
|
paren = RX_BUFF_IDX_CARET_POSTMATCH; |
875
|
|
|
|
|
|
goto do_numbuf_fetch; |
876
|
|
|
|
|
|
} |
877
|
|
|
|
|
|
break; |
878
|
|
|
|
|
|
case '\023': /* ^S */ |
879
|
448
|
50
|
|
|
|
if (nextchar == '\0') { |
880
|
448
|
100
|
|
|
|
if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING) |
|
|
50
|
|
|
|
|
881
|
368
|
50
|
|
|
|
SvOK_off(sv); |
882
|
80
|
100
|
|
|
|
else if (PL_in_eval) |
883
|
52
|
|
|
|
|
sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE)); |
884
|
|
|
|
|
|
else |
885
|
28
|
|
|
|
|
sv_setiv(sv, 0); |
886
|
|
|
|
|
|
} |
887
|
|
|
|
|
|
break; |
888
|
|
|
|
|
|
case '\024': /* ^T */ |
889
|
34052
|
100
|
|
|
|
if (nextchar == '\0') { |
890
|
|
|
|
|
|
#ifdef BIG_TIME |
891
|
|
|
|
|
|
sv_setnv(sv, PL_basetime); |
892
|
|
|
|
|
|
#else |
893
|
730
|
|
|
|
|
sv_setiv(sv, (IV)PL_basetime); |
894
|
|
|
|
|
|
#endif |
895
|
|
|
|
|
|
} |
896
|
33322
|
50
|
|
|
|
else if (strEQ(remaining, "AINT")) |
897
|
33322
|
100
|
|
|
|
sv_setiv(sv, TAINTING_get |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
898
|
|
|
|
|
|
? (TAINT_WARN_get || PL_unsafe ? -1 : 1) |
899
|
|
|
|
|
|
: 0); |
900
|
|
|
|
|
|
break; |
901
|
|
|
|
|
|
case '\025': /* $^UNICODE, $^UTF8LOCALE, $^UTF8CACHE */ |
902
|
606
|
100
|
|
|
|
if (strEQ(remaining, "NICODE")) |
903
|
338
|
|
|
|
|
sv_setuv(sv, (UV) PL_unicode); |
904
|
268
|
100
|
|
|
|
else if (strEQ(remaining, "TF8LOCALE")) |
905
|
256
|
|
|
|
|
sv_setuv(sv, (UV) PL_utf8locale); |
906
|
12
|
50
|
|
|
|
else if (strEQ(remaining, "TF8CACHE")) |
907
|
12
|
|
|
|
|
sv_setiv(sv, (IV) PL_utf8cache); |
908
|
|
|
|
|
|
break; |
909
|
|
|
|
|
|
case '\027': /* ^W & $^WARNING_BITS */ |
910
|
8950204
|
100
|
|
|
|
if (nextchar == '\0') |
911
|
8451886
|
100
|
|
|
|
sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE)); |
912
|
498318
|
50
|
|
|
|
else if (strEQ(remaining, "ARNING_BITS")) { |
913
|
498318
|
100
|
|
|
|
if (PL_compiling.cop_warnings == pWARN_NONE) { |
914
|
638
|
|
|
|
|
sv_setpvn(sv, WARN_NONEstring, WARNsize) ; |
915
|
|
|
|
|
|
} |
916
|
497680
|
100
|
|
|
|
else if (PL_compiling.cop_warnings == pWARN_STD) { |
917
|
237804
|
|
|
|
|
sv_setsv(sv, &PL_sv_undef); |
918
|
237804
|
|
|
|
|
break; |
919
|
|
|
|
|
|
} |
920
|
259876
|
100
|
|
|
|
else if (PL_compiling.cop_warnings == pWARN_ALL) { |
921
|
|
|
|
|
|
/* Get the bit mask for $warnings::Bits{all}, because |
922
|
|
|
|
|
|
* it could have been extended by warnings::register */ |
923
|
212080
|
|
|
|
|
HV * const bits = get_hv("warnings::Bits", 0); |
924
|
212080
|
50
|
|
|
|
SV ** const bits_all = bits ? hv_fetchs(bits, "all", FALSE) : NULL; |
925
|
212080
|
50
|
|
|
|
if (bits_all) |
926
|
212080
|
|
|
|
|
sv_copypv(sv, *bits_all); |
927
|
|
|
|
|
|
else |
928
|
0
|
|
|
|
|
sv_setpvn(sv, WARN_ALLstring, WARNsize); |
929
|
|
|
|
|
|
} |
930
|
|
|
|
|
|
else { |
931
|
47796
|
|
|
|
|
sv_setpvn(sv, (char *) (PL_compiling.cop_warnings + 1), |
932
|
|
|
|
|
|
*PL_compiling.cop_warnings); |
933
|
|
|
|
|
|
} |
934
|
|
|
|
|
|
} |
935
|
|
|
|
|
|
break; |
936
|
|
|
|
|
|
case '\015': /* $^MATCH */ |
937
|
52
|
50
|
|
|
|
if (strEQ(remaining, "ATCH")) { |
938
|
|
|
|
|
|
paren = RX_BUFF_IDX_CARET_FULLMATCH; |
939
|
|
|
|
|
|
goto do_numbuf_fetch; |
940
|
|
|
|
|
|
} |
941
|
|
|
|
|
|
|
942
|
|
|
|
|
|
case '1': case '2': case '3': case '4': |
943
|
|
|
|
|
|
case '5': case '6': case '7': case '8': case '9': case '&': |
944
|
|
|
|
|
|
/* |
945
|
|
|
|
|
|
* Pre-threads, this was paren = atoi(GvENAME((const GV *)mg->mg_obj)); |
946
|
|
|
|
|
|
* XXX Does the new way break anything? |
947
|
|
|
|
|
|
*/ |
948
|
46410391
|
|
|
|
|
paren = atoi(mg->mg_ptr); /* $& is in [0] */ |
949
|
|
|
|
|
|
do_numbuf_fetch: |
950
|
46422869
|
100
|
|
|
|
if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { |
|
|
50
|
|
|
|
|
951
|
46420713
|
|
|
|
|
CALLREG_NUMBUF_FETCH(rx,paren,sv); |
952
|
46420713
|
|
|
|
|
break; |
953
|
|
|
|
|
|
} |
954
|
2156
|
|
|
|
|
sv_setsv(sv,&PL_sv_undef); |
955
|
2156
|
|
|
|
|
break; |
956
|
|
|
|
|
|
case '+': |
957
|
10550
|
50
|
|
|
|
if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { |
|
|
50
|
|
|
|
|
958
|
10550
|
|
|
|
|
paren = RX_LASTPAREN(rx); |
959
|
10550
|
100
|
|
|
|
if (paren) |
960
|
|
|
|
|
|
goto do_numbuf_fetch; |
961
|
|
|
|
|
|
} |
962
|
2
|
|
|
|
|
sv_setsv(sv,&PL_sv_undef); |
963
|
2
|
|
|
|
|
break; |
964
|
|
|
|
|
|
case '\016': /* ^N */ |
965
|
572
|
50
|
|
|
|
if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { |
|
|
50
|
|
|
|
|
966
|
572
|
|
|
|
|
paren = RX_LASTCLOSEPAREN(rx); |
967
|
572
|
100
|
|
|
|
if (paren) |
968
|
|
|
|
|
|
goto do_numbuf_fetch; |
969
|
|
|
|
|
|
} |
970
|
2
|
|
|
|
|
sv_setsv(sv,&PL_sv_undef); |
971
|
2
|
|
|
|
|
break; |
972
|
|
|
|
|
|
case '`': |
973
|
|
|
|
|
|
paren = RX_BUFF_IDX_PREMATCH; |
974
|
|
|
|
|
|
goto do_numbuf_fetch; |
975
|
|
|
|
|
|
case '\'': |
976
|
|
|
|
|
|
paren = RX_BUFF_IDX_POSTMATCH; |
977
|
876
|
|
|
|
|
goto do_numbuf_fetch; |
978
|
|
|
|
|
|
case '.': |
979
|
1287856
|
100
|
|
|
|
if (GvIO(PL_last_in_gv)) { |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
980
|
532718
|
|
|
|
|
sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv))); |
981
|
|
|
|
|
|
} |
982
|
|
|
|
|
|
break; |
983
|
|
|
|
|
|
case '?': |
984
|
|
|
|
|
|
{ |
985
|
45782
|
|
|
|
|
sv_setiv(sv, (IV)STATUS_CURRENT); |
986
|
|
|
|
|
|
#ifdef COMPLEX_STATUS |
987
|
|
|
|
|
|
SvUPGRADE(sv, SVt_PVLV); |
988
|
|
|
|
|
|
LvTARGOFF(sv) = PL_statusvalue; |
989
|
|
|
|
|
|
LvTARGLEN(sv) = PL_statusvalue_vms; |
990
|
|
|
|
|
|
#endif |
991
|
|
|
|
|
|
} |
992
|
45782
|
|
|
|
|
break; |
993
|
|
|
|
|
|
case '^': |
994
|
18
|
50
|
|
|
|
if (GvIOp(PL_defoutgv)) |
995
|
18
|
|
|
|
|
s = IoTOP_NAME(GvIOp(PL_defoutgv)); |
996
|
18
|
100
|
|
|
|
if (s) |
997
|
6
|
|
|
|
|
sv_setpv(sv,s); |
998
|
|
|
|
|
|
else { |
999
|
12
|
50
|
|
|
|
sv_setpv(sv,GvENAME(PL_defoutgv)); |
1000
|
12
|
|
|
|
|
sv_catpvs(sv,"_TOP"); |
1001
|
|
|
|
|
|
} |
1002
|
|
|
|
|
|
break; |
1003
|
|
|
|
|
|
case '~': |
1004
|
52
|
50
|
|
|
|
if (GvIOp(PL_defoutgv)) |
1005
|
52
|
|
|
|
|
s = IoFMT_NAME(GvIOp(PL_defoutgv)); |
1006
|
52
|
100
|
|
|
|
if (!s) |
1007
|
18
|
50
|
|
|
|
s = GvENAME(PL_defoutgv); |
1008
|
52
|
|
|
|
|
sv_setpv(sv,s); |
1009
|
52
|
|
|
|
|
break; |
1010
|
|
|
|
|
|
case '=': |
1011
|
24
|
50
|
|
|
|
if (GvIO(PL_defoutgv)) |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
1012
|
24
|
|
|
|
|
sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv))); |
1013
|
|
|
|
|
|
break; |
1014
|
|
|
|
|
|
case '-': |
1015
|
22
|
50
|
|
|
|
if (GvIO(PL_defoutgv)) |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
1016
|
22
|
|
|
|
|
sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv))); |
1017
|
|
|
|
|
|
break; |
1018
|
|
|
|
|
|
case '%': |
1019
|
16
|
50
|
|
|
|
if (GvIO(PL_defoutgv)) |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
1020
|
16
|
|
|
|
|
sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv))); |
1021
|
|
|
|
|
|
break; |
1022
|
|
|
|
|
|
case ':': |
1023
|
|
|
|
|
|
break; |
1024
|
|
|
|
|
|
case '/': |
1025
|
|
|
|
|
|
break; |
1026
|
|
|
|
|
|
case '[': |
1027
|
0
|
|
|
|
|
sv_setiv(sv, 0); |
1028
|
0
|
|
|
|
|
break; |
1029
|
|
|
|
|
|
case '|': |
1030
|
2284
|
50
|
|
|
|
if (GvIO(PL_defoutgv)) |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
1031
|
2284
|
|
|
|
|
sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 ); |
1032
|
|
|
|
|
|
break; |
1033
|
|
|
|
|
|
case '\\': |
1034
|
1077656
|
100
|
|
|
|
if (PL_ors_sv) |
1035
|
2614
|
|
|
|
|
sv_copypv(sv, PL_ors_sv); |
1036
|
|
|
|
|
|
else |
1037
|
1075042
|
|
|
|
|
sv_setsv(sv, &PL_sv_undef); |
1038
|
|
|
|
|
|
break; |
1039
|
|
|
|
|
|
case '$': /* $$ */ |
1040
|
|
|
|
|
|
{ |
1041
|
372454
|
|
|
|
|
IV const pid = (IV)PerlProc_getpid(); |
1042
|
372454
|
100
|
|
|
|
if (isGV(mg->mg_obj) || SvIV(mg->mg_obj) != pid) { |
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
1043
|
|
|
|
|
|
/* never set manually, or at least not since last fork */ |
1044
|
372452
|
|
|
|
|
sv_setiv(sv, pid); |
1045
|
|
|
|
|
|
/* never unsafe, even if reading in a tainted expression */ |
1046
|
372452
|
100
|
|
|
|
SvTAINTED_off(sv); |
1047
|
|
|
|
|
|
} |
1048
|
|
|
|
|
|
/* else a value has been assigned manually, so do nothing */ |
1049
|
|
|
|
|
|
} |
1050
|
|
|
|
|
|
break; |
1051
|
|
|
|
|
|
|
1052
|
|
|
|
|
|
case '!': |
1053
|
|
|
|
|
|
{ |
1054
|
2401776
|
|
|
|
|
dSAVE_ERRNO; |
1055
|
|
|
|
|
|
#ifdef VMS |
1056
|
|
|
|
|
|
sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno)); |
1057
|
|
|
|
|
|
#else |
1058
|
2401776
|
|
|
|
|
sv_setnv(sv, (NV)errno); |
1059
|
|
|
|
|
|
#endif |
1060
|
|
|
|
|
|
#ifdef OS2 |
1061
|
|
|
|
|
|
if (errno == errno_isOS2 || errno == errno_isOS2_set) |
1062
|
|
|
|
|
|
sv_setpv(sv, os2error(Perl_rc)); |
1063
|
|
|
|
|
|
else |
1064
|
|
|
|
|
|
#endif |
1065
|
2401776
|
100
|
|
|
|
if (! errno) { |
1066
|
1913186
|
|
|
|
|
sv_setpvs(sv, ""); |
1067
|
|
|
|
|
|
} |
1068
|
|
|
|
|
|
else { |
1069
|
|
|
|
|
|
|
1070
|
|
|
|
|
|
/* Strerror can return NULL on some platforms, which will result in |
1071
|
|
|
|
|
|
* 'sv' not being considered SvOK. The SvNOK_on() below will cause |
1072
|
|
|
|
|
|
* just the number part to be valid */ |
1073
|
488590
|
|
|
|
|
sv_setpv(sv, Strerror(errno)); |
1074
|
|
|
|
|
|
|
1075
|
|
|
|
|
|
/* In some locales the error string may come back as UTF-8, in |
1076
|
|
|
|
|
|
* which case we should turn on that flag. This didn't use to |
1077
|
|
|
|
|
|
* happen, and to avoid any possible backward compatibility issues, |
1078
|
|
|
|
|
|
* we don't turn on the flag unless we have to. So the flag stays |
1079
|
|
|
|
|
|
* off for an entirely ASCII string. We assume that if the string |
1080
|
|
|
|
|
|
* looks like UTF-8, it really is UTF-8: "text in any other |
1081
|
|
|
|
|
|
* encoding that uses bytes with the high bit set is extremely |
1082
|
|
|
|
|
|
* unlikely to pass a UTF-8 validity test" |
1083
|
|
|
|
|
|
* (http://en.wikipedia.org/wiki/Charset_detection). There is a |
1084
|
|
|
|
|
|
* potential that we will get it wrong however, especially on short |
1085
|
|
|
|
|
|
* error message text. (If it turns out to be necessary, we could |
1086
|
|
|
|
|
|
* also keep track if the current LC_MESSAGES locale is UTF-8) */ |
1087
|
488590
|
50
|
|
|
|
if (SvOK(sv) /* It could be that Strerror returned invalid */ |
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
1088
|
488590
|
50
|
|
|
|
&& ! is_ascii_string((U8*) SvPVX_const(sv), SvCUR(sv)) |
1089
|
0
|
0
|
|
|
|
&& is_utf8_string((U8*) SvPVX_const(sv), SvCUR(sv))) |
1090
|
|
|
|
|
|
{ |
1091
|
0
|
|
|
|
|
SvUTF8_on(sv); |
1092
|
|
|
|
|
|
} |
1093
|
|
|
|
|
|
} |
1094
|
2401776
|
|
|
|
|
RESTORE_ERRNO; |
1095
|
|
|
|
|
|
} |
1096
|
|
|
|
|
|
|
1097
|
2401776
|
50
|
|
|
|
SvRTRIM(sv); |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
1098
|
2401776
|
|
|
|
|
SvNOK_on(sv); /* what a wonderful hack! */ |
1099
|
2401776
|
|
|
|
|
break; |
1100
|
|
|
|
|
|
case '<': |
1101
|
610
|
|
|
|
|
sv_setuid(sv, PerlProc_getuid()); |
1102
|
610
|
|
|
|
|
break; |
1103
|
|
|
|
|
|
case '>': |
1104
|
790
|
|
|
|
|
sv_setuid(sv, PerlProc_geteuid()); |
1105
|
790
|
|
|
|
|
break; |
1106
|
|
|
|
|
|
case '(': |
1107
|
18
|
|
|
|
|
sv_setgid(sv, PerlProc_getgid()); |
1108
|
18
|
|
|
|
|
goto add_groups; |
1109
|
|
|
|
|
|
case ')': |
1110
|
140
|
|
|
|
|
sv_setgid(sv, PerlProc_getegid()); |
1111
|
|
|
|
|
|
add_groups: |
1112
|
|
|
|
|
|
#ifdef HAS_GETGROUPS |
1113
|
|
|
|
|
|
{ |
1114
|
|
|
|
|
|
Groups_t *gary = NULL; |
1115
|
|
|
|
|
|
I32 i, num_groups = getgroups(0, gary); |
1116
|
158
|
50
|
|
|
|
Newx(gary, num_groups, Groups_t); |
1117
|
|
|
|
|
|
num_groups = getgroups(num_groups, gary); |
1118
|
474
|
100
|
|
|
|
for (i = 0; i < num_groups; i++) |
1119
|
316
|
|
|
|
|
Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]); |
1120
|
158
|
|
|
|
|
Safefree(gary); |
1121
|
|
|
|
|
|
} |
1122
|
158
|
|
|
|
|
(void)SvIOK_on(sv); /* what a wonderful hack! */ |
1123
|
|
|
|
|
|
#endif |
1124
|
158
|
|
|
|
|
break; |
1125
|
|
|
|
|
|
case '0': |
1126
|
|
|
|
|
|
break; |
1127
|
|
|
|
|
|
} |
1128
|
65176561
|
|
|
|
|
return 0; |
1129
|
|
|
|
|
|
} |
1130
|
|
|
|
|
|
|
1131
|
|
|
|
|
|
int |
1132
|
80688
|
|
|
|
|
Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg) |
1133
|
|
|
|
|
|
{ |
1134
|
80688
|
|
|
|
|
struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr; |
1135
|
|
|
|
|
|
|
1136
|
|
|
|
|
|
PERL_ARGS_ASSERT_MAGIC_GETUVAR; |
1137
|
|
|
|
|
|
|
1138
|
80688
|
50
|
|
|
|
if (uf && uf->uf_val) |
|
|
100
|
|
|
|
|
1139
|
80682
|
|
|
|
|
(*uf->uf_val)(aTHX_ uf->uf_index, sv); |
1140
|
80688
|
|
|
|
|
return 0; |
1141
|
|
|
|
|
|
} |
1142
|
|
|
|
|
|
|
1143
|
|
|
|
|
|
int |
1144
|
365952
|
|
|
|
|
Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg) |
1145
|
365952
|
50
|
|
|
|
{ |
1146
|
|
|
|
|
|
dVAR; |
1147
|
|
|
|
|
|
STRLEN len = 0, klen; |
1148
|
365952
|
100
|
|
|
|
const char * const key = MgPV_const(mg,klen); |
|
|
50
|
|
|
|
|
1149
|
|
|
|
|
|
const char *s = ""; |
1150
|
|
|
|
|
|
|
1151
|
|
|
|
|
|
PERL_ARGS_ASSERT_MAGIC_SETENV; |
1152
|
|
|
|
|
|
|
1153
|
182976
|
|
|
|
|
SvGETMAGIC(sv); |
1154
|
365952
|
100
|
|
|
|
if (SvOK(sv)) { |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
1155
|
|
|
|
|
|
/* defined environment variables are byte strings; unfortunately |
1156
|
|
|
|
|
|
there is no SvPVbyte_force_nomg(), so we must do this piecewise */ |
1157
|
362566
|
50
|
|
|
|
(void)SvPV_force_nomg_nolen(sv); |
1158
|
362566
|
|
|
|
|
sv_utf8_downgrade(sv, /* fail_ok */ TRUE); |
1159
|
362566
|
50
|
|
|
|
if (SvUTF8(sv)) { |
1160
|
0
|
|
|
|
|
Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8), "Wide character in %s", "setenv"); |
1161
|
0
|
|
|
|
|
SvUTF8_off(sv); |
1162
|
|
|
|
|
|
} |
1163
|
362566
|
|
|
|
|
s = SvPVX(sv); |
1164
|
362566
|
|
|
|
|
len = SvCUR(sv); |
1165
|
|
|
|
|
|
} |
1166
|
365952
|
|
|
|
|
my_setenv(key, s); /* does the deed */ |
1167
|
|
|
|
|
|
|
1168
|
|
|
|
|
|
#ifdef DYNAMIC_ENV_FETCH |
1169
|
|
|
|
|
|
/* We just undefd an environment var. Is a replacement */ |
1170
|
|
|
|
|
|
/* waiting in the wings? */ |
1171
|
|
|
|
|
|
if (!len) { |
1172
|
|
|
|
|
|
SV ** const valp = hv_fetch(GvHVn(PL_envgv), key, klen, FALSE); |
1173
|
|
|
|
|
|
if (valp) |
1174
|
|
|
|
|
|
s = SvOK(*valp) ? SvPV_const(*valp, len) : ""; |
1175
|
|
|
|
|
|
} |
1176
|
|
|
|
|
|
#endif |
1177
|
|
|
|
|
|
|
1178
|
|
|
|
|
|
#if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS) |
1179
|
|
|
|
|
|
/* And you'll never guess what the dog had */ |
1180
|
|
|
|
|
|
/* in its mouth... */ |
1181
|
365952
|
100
|
|
|
|
if (TAINTING_get) { |
1182
|
2
|
|
|
|
|
MgTAINTEDDIR_off(mg); |
1183
|
|
|
|
|
|
#ifdef VMS |
1184
|
|
|
|
|
|
if (s && klen == 8 && strEQ(key, "DCL$PATH")) { |
1185
|
|
|
|
|
|
char pathbuf[256], eltbuf[256], *cp, *elt; |
1186
|
|
|
|
|
|
int i = 0, j = 0; |
1187
|
|
|
|
|
|
|
1188
|
|
|
|
|
|
my_strlcpy(eltbuf, s, sizeof(eltbuf)); |
1189
|
|
|
|
|
|
elt = eltbuf; |
1190
|
|
|
|
|
|
do { /* DCL$PATH may be a search list */ |
1191
|
|
|
|
|
|
while (1) { /* as may dev portion of any element */ |
1192
|
|
|
|
|
|
if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) { |
1193
|
|
|
|
|
|
if ( *(cp+1) == '.' || *(cp+1) == '-' || |
1194
|
|
|
|
|
|
cando_by_name(S_IWUSR,0,elt) ) { |
1195
|
|
|
|
|
|
MgTAINTEDDIR_on(mg); |
1196
|
|
|
|
|
|
return 0; |
1197
|
|
|
|
|
|
} |
1198
|
|
|
|
|
|
} |
1199
|
|
|
|
|
|
if ((cp = strchr(elt, ':')) != NULL) |
1200
|
|
|
|
|
|
*cp = '\0'; |
1201
|
|
|
|
|
|
if (my_trnlnm(elt, eltbuf, j++)) |
1202
|
|
|
|
|
|
elt = eltbuf; |
1203
|
|
|
|
|
|
else |
1204
|
|
|
|
|
|
break; |
1205
|
|
|
|
|
|
} |
1206
|
|
|
|
|
|
j = 0; |
1207
|
|
|
|
|
|
} while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf)); |
1208
|
|
|
|
|
|
} |
1209
|
|
|
|
|
|
#endif /* VMS */ |
1210
|
2
|
50
|
|
|
|
if (s && klen == 4 && strEQ(key,"PATH")) { |
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
1211
|
0
|
|
|
|
|
const char * const strend = s + len; |
1212
|
|
|
|
|
|
|
1213
|
182976
|
0
|
|
|
|
while (s < strend) { |
1214
|
|
|
|
|
|
char tmpbuf[256]; |
1215
|
|
|
|
|
|
Stat_t st; |
1216
|
|
|
|
|
|
I32 i; |
1217
|
|
|
|
|
|
#ifdef VMS /* Hmm. How do we get $Config{path_sep} from C? */ |
1218
|
|
|
|
|
|
const char path_sep = '|'; |
1219
|
|
|
|
|
|
#else |
1220
|
|
|
|
|
|
const char path_sep = ':'; |
1221
|
|
|
|
|
|
#endif |
1222
|
0
|
|
|
|
|
s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, |
1223
|
|
|
|
|
|
s, strend, path_sep, &i); |
1224
|
0
|
|
|
|
|
s++; |
1225
|
0
|
0
|
|
|
|
if (i >= (I32)sizeof tmpbuf /* too long -- assume the worst */ |
1226
|
|
|
|
|
|
#ifdef VMS |
1227
|
|
|
|
|
|
|| !strchr(tmpbuf, ':') /* no colon thus no device name -- assume relative path */ |
1228
|
|
|
|
|
|
#else |
1229
|
0
|
0
|
|
|
|
|| *tmpbuf != '/' /* no starting slash -- assume relative path */ |
1230
|
|
|
|
|
|
#endif |
1231
|
0
|
0
|
|
|
|
|| (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) { |
|
|
0
|
|
|
|
|
1232
|
0
|
|
|
|
|
MgTAINTEDDIR_on(mg); |
1233
|
0
|
|
|
|
|
return 0; |
1234
|
|
|
|
|
|
} |
1235
|
|
|
|
|
|
} |
1236
|
|
|
|
|
|
} |
1237
|
|
|
|
|
|
} |
1238
|
|
|
|
|
|
#endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */ |
1239
|
|
|
|
|
|
|
1240
|
|
|
|
|
|
return 0; |
1241
|
|
|
|
|
|
} |
1242
|
|
|
|
|
|
|
1243
|
|
|
|
|
|
int |
1244
|
63878
|
|
|
|
|
Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg) |
1245
|
|
|
|
|
|
{ |
1246
|
|
|
|
|
|
PERL_ARGS_ASSERT_MAGIC_CLEARENV; |
1247
|
|
|
|
|
|
PERL_UNUSED_ARG(sv); |
1248
|
63878
|
100
|
|
|
|
my_setenv(MgPV_nolen_const(mg),NULL); |
|
|
50
|
|
|
|
|
1249
|
63878
|
|
|
|
|
return 0; |
1250
|
|
|
|
|
|
} |
1251
|
|
|
|
|
|
|
1252
|
|
|
|
|
|
int |
1253
|
10152
|
|
|
|
|
Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg) |
1254
|
|
|
|
|
|
{ |
1255
|
|
|
|
|
|
dVAR; |
1256
|
|
|
|
|
|
PERL_ARGS_ASSERT_MAGIC_SET_ALL_ENV; |
1257
|
|
|
|
|
|
PERL_UNUSED_ARG(mg); |
1258
|
|
|
|
|
|
#if defined(VMS) |
1259
|
|
|
|
|
|
Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system"); |
1260
|
|
|
|
|
|
#else |
1261
|
10152
|
50
|
|
|
|
if (PL_localizing) { |
1262
|
|
|
|
|
|
HE* entry; |
1263
|
10152
|
|
|
|
|
my_clearenv(); |
1264
|
10152
|
|
|
|
|
hv_iterinit(MUTABLE_HV(sv)); |
1265
|
384922
|
100
|
|
|
|
while ((entry = hv_iternext(MUTABLE_HV(sv)))) { |
1266
|
|
|
|
|
|
I32 keylen; |
1267
|
369694
|
50
|
|
|
|
my_setenv(hv_iterkey(entry, &keylen), |
1268
|
|
|
|
|
|
SvPV_nolen_const(hv_iterval(MUTABLE_HV(sv), entry))); |
1269
|
|
|
|
|
|
} |
1270
|
|
|
|
|
|
} |
1271
|
|
|
|
|
|
#endif |
1272
|
10152
|
|
|
|
|
return 0; |
1273
|
|
|
|
|
|
} |
1274
|
|
|
|
|
|
|
1275
|
|
|
|
|
|
int |
1276
|
4636
|
|
|
|
|
Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg) |
1277
|
|
|
|
|
|
{ |
1278
|
|
|
|
|
|
dVAR; |
1279
|
|
|
|
|
|
PERL_ARGS_ASSERT_MAGIC_CLEAR_ALL_ENV; |
1280
|
|
|
|
|
|
PERL_UNUSED_ARG(sv); |
1281
|
|
|
|
|
|
PERL_UNUSED_ARG(mg); |
1282
|
|
|
|
|
|
#if defined(VMS) |
1283
|
|
|
|
|
|
Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system"); |
1284
|
|
|
|
|
|
#else |
1285
|
4636
|
|
|
|
|
my_clearenv(); |
1286
|
|
|
|
|
|
#endif |
1287
|
4636
|
|
|
|
|
return 0; |
1288
|
|
|
|
|
|
} |
1289
|
|
|
|
|
|
|
1290
|
|
|
|
|
|
#ifndef PERL_MICRO |
1291
|
|
|
|
|
|
#ifdef HAS_SIGPROCMASK |
1292
|
|
|
|
|
|
static void |
1293
|
4518
|
|
|
|
|
restore_sigmask(pTHX_ SV *save_sv) |
1294
|
|
|
|
|
|
{ |
1295
|
4518
|
50
|
|
|
|
const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv ); |
1296
|
4518
|
|
|
|
|
(void)sigprocmask(SIG_SETMASK, ossetp, NULL); |
1297
|
4518
|
|
|
|
|
} |
1298
|
|
|
|
|
|
#endif |
1299
|
|
|
|
|
|
int |
1300
|
315260
|
|
|
|
|
Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg) |
1301
|
|
|
|
|
|
{ |
1302
|
|
|
|
|
|
dVAR; |
1303
|
|
|
|
|
|
/* Are we fetching a signal entry? */ |
1304
|
315260
|
|
|
|
|
int i = (I16)mg->mg_private; |
1305
|
|
|
|
|
|
|
1306
|
|
|
|
|
|
PERL_ARGS_ASSERT_MAGIC_GETSIG; |
1307
|
|
|
|
|
|
|
1308
|
315260
|
100
|
|
|
|
if (!i) { |
1309
|
|
|
|
|
|
STRLEN siglen; |
1310
|
169724
|
100
|
|
|
|
const char * sig = MgPV_const(mg, siglen); |
|
|
50
|
|
|
|
|
1311
|
169724
|
|
|
|
|
mg->mg_private = i = whichsig_pvn(sig, siglen); |
1312
|
|
|
|
|
|
} |
1313
|
|
|
|
|
|
|
1314
|
315260
|
100
|
|
|
|
if (i > 0) { |
1315
|
2602
|
100
|
|
|
|
if(PL_psig_ptr[i]) |
1316
|
2396
|
|
|
|
|
sv_setsv(sv,PL_psig_ptr[i]); |
1317
|
|
|
|
|
|
else { |
1318
|
206
|
|
|
|
|
Sighandler_t sigstate = rsignal_state(i); |
1319
|
|
|
|
|
|
#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS |
1320
|
|
|
|
|
|
if (PL_sig_handlers_initted && PL_sig_ignoring[i]) |
1321
|
|
|
|
|
|
sigstate = SIG_IGN; |
1322
|
|
|
|
|
|
#endif |
1323
|
|
|
|
|
|
#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS |
1324
|
|
|
|
|
|
if (PL_sig_handlers_initted && PL_sig_defaulting[i]) |
1325
|
|
|
|
|
|
sigstate = SIG_DFL; |
1326
|
|
|
|
|
|
#endif |
1327
|
|
|
|
|
|
/* cache state so we don't fetch it again */ |
1328
|
206
|
100
|
|
|
|
if(sigstate == (Sighandler_t) SIG_IGN) |
1329
|
10
|
|
|
|
|
sv_setpvs(sv,"IGNORE"); |
1330
|
|
|
|
|
|
else |
1331
|
196
|
|
|
|
|
sv_setsv(sv,&PL_sv_undef); |
1332
|
206
|
|
|
|
|
PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv); |
1333
|
206
|
|
|
|
|
SvTEMP_off(sv); |
1334
|
|
|
|
|
|
} |
1335
|
|
|
|
|
|
} |
1336
|
315260
|
|
|
|
|
return 0; |
1337
|
|
|
|
|
|
} |
1338
|
|
|
|
|
|
int |
1339
|
2924102
|
|
|
|
|
Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg) |
1340
|
|
|
|
|
|
{ |
1341
|
|
|
|
|
|
PERL_ARGS_ASSERT_MAGIC_CLEARSIG; |
1342
|
|
|
|
|
|
|
1343
|
2924102
|
|
|
|
|
magic_setsig(NULL, mg); |
1344
|
2924102
|
|
|
|
|
return sv_unmagic(sv, mg->mg_type); |
1345
|
|
|
|
|
|
} |
1346
|
|
|
|
|
|
|
1347
|
|
|
|
|
|
Signal_t |
1348
|
|
|
|
|
|
#if defined(HAS_SIGACTION) && defined(SA_SIGINFO) |
1349
|
154
|
|
|
|
|
Perl_csighandler(int sig, siginfo_t *sip PERL_UNUSED_DECL, void *uap PERL_UNUSED_DECL) |
1350
|
|
|
|
|
|
#else |
1351
|
|
|
|
|
|
Perl_csighandler(int sig) |
1352
|
|
|
|
|
|
#endif |
1353
|
|
|
|
|
|
{ |
1354
|
|
|
|
|
|
#ifdef PERL_GET_SIG_CONTEXT |
1355
|
|
|
|
|
|
dTHXa(PERL_GET_SIG_CONTEXT); |
1356
|
|
|
|
|
|
#else |
1357
|
|
|
|
|
|
dTHX; |
1358
|
|
|
|
|
|
#endif |
1359
|
|
|
|
|
|
#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS |
1360
|
|
|
|
|
|
(void) rsignal(sig, PL_csighandlerp); |
1361
|
|
|
|
|
|
if (PL_sig_ignoring[sig]) return; |
1362
|
|
|
|
|
|
#endif |
1363
|
|
|
|
|
|
#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS |
1364
|
|
|
|
|
|
if (PL_sig_defaulting[sig]) |
1365
|
|
|
|
|
|
#ifdef KILL_BY_SIGPRC |
1366
|
|
|
|
|
|
exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG); |
1367
|
|
|
|
|
|
#else |
1368
|
|
|
|
|
|
exit(1); |
1369
|
|
|
|
|
|
#endif |
1370
|
|
|
|
|
|
#endif |
1371
|
154
|
50
|
|
|
|
if ( |
1372
|
|
|
|
|
|
#ifdef SIGILL |
1373
|
308
|
|
|
|
|
sig == SIGILL || |
1374
|
|
|
|
|
|
#endif |
1375
|
|
|
|
|
|
#ifdef SIGBUS |
1376
|
231
|
50
|
|
|
|
sig == SIGBUS || |
1377
|
|
|
|
|
|
#endif |
1378
|
|
|
|
|
|
#ifdef SIGSEGV |
1379
|
154
|
50
|
|
|
|
sig == SIGSEGV || |
1380
|
|
|
|
|
|
#endif |
1381
|
|
|
|
|
|
(PL_signals & PERL_SIGNALS_UNSAFE_FLAG)) |
1382
|
|
|
|
|
|
/* Call the perl level handler now-- |
1383
|
|
|
|
|
|
* with risk we may be in malloc() or being destructed etc. */ |
1384
|
|
|
|
|
|
#if defined(HAS_SIGACTION) && defined(SA_SIGINFO) |
1385
|
0
|
|
|
|
|
(*PL_sighandlerp)(sig, NULL, NULL); |
1386
|
|
|
|
|
|
#else |
1387
|
|
|
|
|
|
(*PL_sighandlerp)(sig); |
1388
|
|
|
|
|
|
#endif |
1389
|
|
|
|
|
|
else { |
1390
|
308
|
50
|
|
|
|
if (!PL_psig_pend) return; |
1391
|
|
|
|
|
|
/* Set a flag to say this signal is pending, that is awaiting delivery after |
1392
|
|
|
|
|
|
* the current Perl opcode completes */ |
1393
|
154
|
|
|
|
|
PL_psig_pend[sig]++; |
1394
|
|
|
|
|
|
|
1395
|
|
|
|
|
|
#ifndef SIG_PENDING_DIE_COUNT |
1396
|
|
|
|
|
|
# define SIG_PENDING_DIE_COUNT 120 |
1397
|
|
|
|
|
|
#endif |
1398
|
|
|
|
|
|
/* Add one to say _a_ signal is pending */ |
1399
|
154
|
50
|
|
|
|
if (++PL_sig_pending >= SIG_PENDING_DIE_COUNT) |
1400
|
0
|
|
|
|
|
Perl_croak(aTHX_ "Maximal count of pending signals (%lu) exceeded", |
1401
|
|
|
|
|
|
(unsigned long)SIG_PENDING_DIE_COUNT); |
1402
|
|
|
|
|
|
} |
1403
|
|
|
|
|
|
} |
1404
|
|
|
|
|
|
|
1405
|
|
|
|
|
|
#if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS) |
1406
|
|
|
|
|
|
void |
1407
|
|
|
|
|
|
Perl_csighandler_init(void) |
1408
|
|
|
|
|
|
{ |
1409
|
|
|
|
|
|
int sig; |
1410
|
|
|
|
|
|
if (PL_sig_handlers_initted) return; |
1411
|
|
|
|
|
|
|
1412
|
|
|
|
|
|
for (sig = 1; sig < SIG_SIZE; sig++) { |
1413
|
|
|
|
|
|
#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS |
1414
|
|
|
|
|
|
dTHX; |
1415
|
|
|
|
|
|
PL_sig_defaulting[sig] = 1; |
1416
|
|
|
|
|
|
(void) rsignal(sig, PL_csighandlerp); |
1417
|
|
|
|
|
|
#endif |
1418
|
|
|
|
|
|
#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS |
1419
|
|
|
|
|
|
PL_sig_ignoring[sig] = 0; |
1420
|
|
|
|
|
|
#endif |
1421
|
|
|
|
|
|
} |
1422
|
|
|
|
|
|
PL_sig_handlers_initted = 1; |
1423
|
|
|
|
|
|
} |
1424
|
|
|
|
|
|
#endif |
1425
|
|
|
|
|
|
|
1426
|
|
|
|
|
|
#if defined HAS_SIGPROCMASK |
1427
|
|
|
|
|
|
static void |
1428
|
150
|
|
|
|
|
unblock_sigmask(pTHX_ void* newset) |
1429
|
|
|
|
|
|
{ |
1430
|
150
|
|
|
|
|
sigprocmask(SIG_UNBLOCK, (sigset_t*)newset, NULL); |
1431
|
150
|
|
|
|
|
} |
1432
|
|
|
|
|
|
#endif |
1433
|
|
|
|
|
|
|
1434
|
|
|
|
|
|
void |
1435
|
154
|
|
|
|
|
Perl_despatch_signals(pTHX) |
1436
|
|
|
|
|
|
{ |
1437
|
|
|
|
|
|
dVAR; |
1438
|
|
|
|
|
|
int sig; |
1439
|
154
|
|
|
|
|
PL_sig_pending = 0; |
1440
|
8896
|
100
|
|
|
|
for (sig = 1; sig < SIG_SIZE; sig++) { |
1441
|
8772
|
100
|
|
|
|
if (PL_psig_pend[sig]) { |
1442
|
154
|
|
|
|
|
dSAVE_ERRNO; |
1443
|
|
|
|
|
|
#ifdef HAS_SIGPROCMASK |
1444
|
|
|
|
|
|
/* From sigaction(2) (FreeBSD man page): |
1445
|
|
|
|
|
|
* | Signal routines normally execute with the signal that |
1446
|
|
|
|
|
|
* | caused their invocation blocked, but other signals may |
1447
|
|
|
|
|
|
* | yet occur. |
1448
|
|
|
|
|
|
* Emulation of this behavior (from within Perl) is enabled |
1449
|
|
|
|
|
|
* using sigprocmask |
1450
|
|
|
|
|
|
*/ |
1451
|
|
|
|
|
|
int was_blocked; |
1452
|
|
|
|
|
|
sigset_t newset, oldset; |
1453
|
|
|
|
|
|
|
1454
|
154
|
|
|
|
|
sigemptyset(&newset); |
1455
|
154
|
|
|
|
|
sigaddset(&newset, sig); |
1456
|
154
|
|
|
|
|
sigprocmask(SIG_BLOCK, &newset, &oldset); |
1457
|
154
|
|
|
|
|
was_blocked = sigismember(&oldset, sig); |
1458
|
154
|
100
|
|
|
|
if (!was_blocked) { |
1459
|
150
|
|
|
|
|
SV* save_sv = newSVpvn((char *)(&newset), sizeof(sigset_t)); |
1460
|
150
|
|
|
|
|
ENTER; |
1461
|
150
|
|
|
|
|
SAVEFREESV(save_sv); |
1462
|
150
|
50
|
|
|
|
SAVEDESTRUCTOR_X(unblock_sigmask, SvPV_nolen(save_sv)); |
1463
|
|
|
|
|
|
} |
1464
|
|
|
|
|
|
#endif |
1465
|
154
|
|
|
|
|
PL_psig_pend[sig] = 0; |
1466
|
|
|
|
|
|
#if defined(HAS_SIGACTION) && defined(SA_SIGINFO) |
1467
|
154
|
|
|
|
|
(*PL_sighandlerp)(sig, NULL, NULL); |
1468
|
|
|
|
|
|
#else |
1469
|
|
|
|
|
|
(*PL_sighandlerp)(sig); |
1470
|
|
|
|
|
|
#endif |
1471
|
|
|
|
|
|
#ifdef HAS_SIGPROCMASK |
1472
|
124
|
100
|
|
|
|
if (!was_blocked) |
1473
|
122
|
|
|
|
|
LEAVE; |
1474
|
|
|
|
|
|
#endif |
1475
|
124
|
|
|
|
|
RESTORE_ERRNO; |
1476
|
|
|
|
|
|
} |
1477
|
|
|
|
|
|
} |
1478
|
124
|
|
|
|
|
} |
1479
|
|
|
|
|
|
|
1480
|
|
|
|
|
|
/* sv of NULL signifies that we're acting as magic_clearsig. */ |
1481
|
|
|
|
|
|
int |
1482
|
3814323
|
|
|
|
|
Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg) |
1483
|
|
|
|
|
|
{ |
1484
|
|
|
|
|
|
dVAR; |
1485
|
|
|
|
|
|
I32 i; |
1486
|
|
|
|
|
|
SV** svp = NULL; |
1487
|
|
|
|
|
|
/* Need to be careful with SvREFCNT_dec(), because that can have side |
1488
|
|
|
|
|
|
* effects (due to closures). We must make sure that the new disposition |
1489
|
|
|
|
|
|
* is in place before it is called. |
1490
|
|
|
|
|
|
*/ |
1491
|
|
|
|
|
|
SV* to_dec = NULL; |
1492
|
|
|
|
|
|
STRLEN len; |
1493
|
|
|
|
|
|
#ifdef HAS_SIGPROCMASK |
1494
|
|
|
|
|
|
sigset_t set, save; |
1495
|
|
|
|
|
|
SV* save_sv; |
1496
|
|
|
|
|
|
#endif |
1497
|
3814323
|
100
|
|
|
|
const char *s = MgPV_const(mg,len); |
|
|
50
|
|
|
|
|
1498
|
|
|
|
|
|
|
1499
|
|
|
|
|
|
PERL_ARGS_ASSERT_MAGIC_SETSIG; |
1500
|
|
|
|
|
|
|
1501
|
3814323
|
100
|
|
|
|
if (*s == '_') { |
1502
|
3809777
|
100
|
|
|
|
if (memEQs(s, len, "__DIE__")) |
|
|
100
|
|
|
|
|
1503
|
|
|
|
|
|
svp = &PL_diehook; |
1504
|
1151434
|
100
|
|
|
|
else if (memEQs(s, len, "__WARN__") |
|
|
50
|
|
|
|
|
1505
|
1151428
|
100
|
|
|
|
&& (sv ? 1 : PL_warnhook != PERL_WARNHOOK_FATAL)) { |
|
|
50
|
|
|
|
|
1506
|
|
|
|
|
|
/* Merge the existing behaviours, which are as follows: |
1507
|
|
|
|
|
|
magic_setsig, we always set svp to &PL_warnhook |
1508
|
|
|
|
|
|
(hence we always change the warnings handler) |
1509
|
|
|
|
|
|
For magic_clearsig, we don't change the warnings handler if it's |
1510
|
|
|
|
|
|
set to the &PL_warnhook. */ |
1511
|
|
|
|
|
|
svp = &PL_warnhook; |
1512
|
6
|
50
|
|
|
|
} else if (sv) { |
1513
|
6
|
|
|
|
|
SV *tmp = sv_newmortal(); |
1514
|
6
|
|
|
|
|
Perl_croak(aTHX_ "No such hook: %s", |
1515
|
|
|
|
|
|
pv_pretty(tmp, s, len, 0, NULL, NULL, 0)); |
1516
|
|
|
|
|
|
} |
1517
|
|
|
|
|
|
i = 0; |
1518
|
3809771
|
50
|
|
|
|
if (svp && *svp) { |
|
|
100
|
|
|
|
|
1519
|
603909
|
50
|
|
|
|
if (*svp != PERL_WARNHOOK_FATAL) |
1520
|
603909
|
|
|
|
|
to_dec = *svp; |
1521
|
603909
|
|
|
|
|
*svp = NULL; |
1522
|
|
|
|
|
|
} |
1523
|
|
|
|
|
|
} |
1524
|
|
|
|
|
|
else { |
1525
|
4546
|
|
|
|
|
i = (I16)mg->mg_private; |
1526
|
4546
|
100
|
|
|
|
if (!i) { |
1527
|
2652
|
|
|
|
|
i = whichsig_pvn(s, len); /* ...no, a brick */ |
1528
|
2652
|
|
|
|
|
mg->mg_private = (U16)i; |
1529
|
|
|
|
|
|
} |
1530
|
4546
|
100
|
|
|
|
if (i <= 0) { |
1531
|
28
|
50
|
|
|
|
if (sv) { |
1532
|
28
|
|
|
|
|
SV *tmp = sv_newmortal(); |
1533
|
28
|
|
|
|
|
Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", |
1534
|
|
|
|
|
|
pv_pretty(tmp, s, len, 0, NULL, NULL, 0)); |
1535
|
|
|
|
|
|
} |
1536
|
|
|
|
|
|
return 0; |
1537
|
|
|
|
|
|
} |
1538
|
|
|
|
|
|
#ifdef HAS_SIGPROCMASK |
1539
|
|
|
|
|
|
/* Avoid having the signal arrive at a bad time, if possible. */ |
1540
|
4518
|
|
|
|
|
sigemptyset(&set); |
1541
|
4518
|
|
|
|
|
sigaddset(&set,i); |
1542
|
4518
|
|
|
|
|
sigprocmask(SIG_BLOCK, &set, &save); |
1543
|
4518
|
|
|
|
|
ENTER; |
1544
|
4518
|
|
|
|
|
save_sv = newSVpvn((char *)(&save), sizeof(sigset_t)); |
1545
|
4518
|
|
|
|
|
SAVEFREESV(save_sv); |
1546
|
4518
|
|
|
|
|
SAVEDESTRUCTOR_X(restore_sigmask, save_sv); |
1547
|
|
|
|
|
|
#endif |
1548
|
4518
|
50
|
|
|
|
PERL_ASYNC_CHECK(); |
1549
|
|
|
|
|
|
#if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS) |
1550
|
|
|
|
|
|
if (!PL_sig_handlers_initted) Perl_csighandler_init(); |
1551
|
|
|
|
|
|
#endif |
1552
|
|
|
|
|
|
#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS |
1553
|
|
|
|
|
|
PL_sig_ignoring[i] = 0; |
1554
|
|
|
|
|
|
#endif |
1555
|
|
|
|
|
|
#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS |
1556
|
|
|
|
|
|
PL_sig_defaulting[i] = 0; |
1557
|
|
|
|
|
|
#endif |
1558
|
4518
|
|
|
|
|
to_dec = PL_psig_ptr[i]; |
1559
|
4518
|
100
|
|
|
|
if (sv) { |
1560
|
4504
|
|
|
|
|
PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv); |
1561
|
4504
|
|
|
|
|
SvTEMP_off(sv); /* Make sure it doesn't go away on us */ |
1562
|
|
|
|
|
|
|
1563
|
|
|
|
|
|
/* Signals don't change name during the program's execution, so once |
1564
|
|
|
|
|
|
they're cached in the appropriate slot of PL_psig_name, they can |
1565
|
|
|
|
|
|
stay there. |
1566
|
|
|
|
|
|
|
1567
|
|
|
|
|
|
Ideally we'd find some way of making SVs at (C) compile time, or |
1568
|
|
|
|
|
|
at least, doing most of the work. */ |
1569
|
4504
|
100
|
|
|
|
if (!PL_psig_name[i]) { |
1570
|
960
|
|
|
|
|
PL_psig_name[i] = newSVpvn(s, len); |
1571
|
960
|
|
|
|
|
SvREADONLY_on(PL_psig_name[i]); |
1572
|
|
|
|
|
|
} |
1573
|
|
|
|
|
|
} else { |
1574
|
14
|
|
|
|
|
SvREFCNT_dec(PL_psig_name[i]); |
1575
|
14
|
|
|
|
|
PL_psig_name[i] = NULL; |
1576
|
14
|
|
|
|
|
PL_psig_ptr[i] = NULL; |
1577
|
|
|
|
|
|
} |
1578
|
|
|
|
|
|
} |
1579
|
3814289
|
100
|
|
|
|
if (sv && (isGV_with_GP(sv) || SvROK(sv))) { |
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
100
|
|
|
|
|
1580
|
606749
|
100
|
|
|
|
if (i) { |
1581
|
2236
|
|
|
|
|
(void)rsignal(i, PL_csighandlerp); |
1582
|
|
|
|
|
|
} |
1583
|
|
|
|
|
|
else |
1584
|
604513
|
|
|
|
|
*svp = SvREFCNT_inc_simple_NN(sv); |
1585
|
|
|
|
|
|
} else { |
1586
|
3207540
|
100
|
|
|
|
if (sv && SvOK(sv)) { |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
1587
|
1606
|
50
|
|
|
|
s = SvPV_force(sv, len); |
1588
|
|
|
|
|
|
} else { |
1589
|
|
|
|
|
|
sv = NULL; |
1590
|
|
|
|
|
|
} |
1591
|
3207540
|
100
|
|
|
|
if (sv && memEQs(s, len,"IGNORE")) { |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
1592
|
700
|
50
|
|
|
|
if (i) { |
1593
|
|
|
|
|
|
#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS |
1594
|
|
|
|
|
|
PL_sig_ignoring[i] = 1; |
1595
|
|
|
|
|
|
(void)rsignal(i, PL_csighandlerp); |
1596
|
|
|
|
|
|
#else |
1597
|
700
|
|
|
|
|
(void)rsignal(i, (Sighandler_t) SIG_IGN); |
1598
|
|
|
|
|
|
#endif |
1599
|
|
|
|
|
|
} |
1600
|
|
|
|
|
|
} |
1601
|
3206840
|
100
|
|
|
|
else if (!sv || memEQs(s, len,"DEFAULT") || !len) { |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
1602
|
3206796
|
100
|
|
|
|
if (i) { |
1603
|
|
|
|
|
|
#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS |
1604
|
|
|
|
|
|
PL_sig_defaulting[i] = 1; |
1605
|
|
|
|
|
|
(void)rsignal(i, PL_csighandlerp); |
1606
|
|
|
|
|
|
#else |
1607
|
1540
|
|
|
|
|
(void)rsignal(i, (Sighandler_t) SIG_DFL); |
1608
|
|
|
|
|
|
#endif |
1609
|
|
|
|
|
|
} |
1610
|
|
|
|
|
|
} |
1611
|
|
|
|
|
|
else { |
1612
|
|
|
|
|
|
/* |
1613
|
|
|
|
|
|
* We should warn if HINT_STRICT_REFS, but without |
1614
|
|
|
|
|
|
* access to a known hint bit in a known OP, we can't |
1615
|
|
|
|
|
|
* tell whether HINT_STRICT_REFS is in force or not. |
1616
|
|
|
|
|
|
*/ |
1617
|
44
|
100
|
|
|
|
if (!strchr(s,':') && !strchr(s,'\'')) |
|
|
50
|
|
|
|
|
1618
|
32
|
|
|
|
|
Perl_sv_insert_flags(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"), |
1619
|
|
|
|
|
|
SV_GMAGIC); |
1620
|
44
|
100
|
|
|
|
if (i) |
1621
|
42
|
|
|
|
|
(void)rsignal(i, PL_csighandlerp); |
1622
|
|
|
|
|
|
else |
1623
|
2
|
|
|
|
|
*svp = SvREFCNT_inc_simple_NN(sv); |
1624
|
|
|
|
|
|
} |
1625
|
|
|
|
|
|
} |
1626
|
|
|
|
|
|
|
1627
|
|
|
|
|
|
#ifdef HAS_SIGPROCMASK |
1628
|
3814289
|
100
|
|
|
|
if(i) |
1629
|
4518
|
|
|
|
|
LEAVE; |
1630
|
|
|
|
|
|
#endif |
1631
|
3814289
|
|
|
|
|
SvREFCNT_dec(to_dec); |
1632
|
3814303
|
|
|
|
|
return 0; |
1633
|
|
|
|
|
|
} |
1634
|
|
|
|
|
|
#endif /* !PERL_MICRO */ |
1635
|
|
|
|
|
|
|
1636
|
|
|
|
|
|
int |
1637
|
880654
|
|
|
|
|
Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg) |
1638
|
|
|
|
|
|
{ |
1639
|
|
|
|
|
|
dVAR; |
1640
|
|
|
|
|
|
PERL_ARGS_ASSERT_MAGIC_SETISA; |
1641
|
|
|
|
|
|
PERL_UNUSED_ARG(sv); |
1642
|
|
|
|
|
|
|
1643
|
|
|
|
|
|
/* Skip _isaelem because _isa will handle it shortly */ |
1644
|
880654
|
100
|
|
|
|
if (PL_delaymagic & DM_ARRAY_ISA && mg->mg_type == PERL_MAGIC_isaelem) |
|
|
100
|
|
|
|
|
1645
|
|
|
|
|
|
return 0; |
1646
|
|
|
|
|
|
|
1647
|
704319
|
|
|
|
|
return magic_clearisa(NULL, mg); |
1648
|
|
|
|
|
|
} |
1649
|
|
|
|
|
|
|
1650
|
|
|
|
|
|
/* sv of NULL signifies that we're acting as magic_setisa. */ |
1651
|
|
|
|
|
|
int |
1652
|
510076
|
|
|
|
|
Perl_magic_clearisa(pTHX_ SV *sv, MAGIC *mg) |
1653
|
|
|
|
|
|
{ |
1654
|
|
|
|
|
|
dVAR; |
1655
|
|
|
|
|
|
HV* stash; |
1656
|
|
|
|
|
|
|
1657
|
|
|
|
|
|
PERL_ARGS_ASSERT_MAGIC_CLEARISA; |
1658
|
|
|
|
|
|
|
1659
|
|
|
|
|
|
/* Bail out if destruction is going on */ |
1660
|
510076
|
50
|
|
|
|
if(PL_phase == PERL_PHASE_DESTRUCT) return 0; |
1661
|
|
|
|
|
|
|
1662
|
510076
|
100
|
|
|
|
if (sv) |
1663
|
16
|
|
|
|
|
av_clear(MUTABLE_AV(sv)); |
1664
|
|
|
|
|
|
|
1665
|
510076
|
100
|
|
|
|
if (SvTYPE(mg->mg_obj) != SVt_PVGV && SvSMAGICAL(mg->mg_obj)) |
|
|
100
|
|
|
|
|
1666
|
|
|
|
|
|
/* This occurs with setisa_elem magic, which calls this |
1667
|
|
|
|
|
|
same function. */ |
1668
|
8
|
|
|
|
|
mg = mg_find(mg->mg_obj, PERL_MAGIC_isa); |
1669
|
|
|
|
|
|
|
1670
|
510076
|
100
|
|
|
|
if (SvTYPE(mg->mg_obj) == SVt_PVAV) { /* multiple stashes */ |
1671
|
74
|
|
|
|
|
SV **svp = AvARRAY((AV *)mg->mg_obj); |
1672
|
74
|
|
|
|
|
I32 items = AvFILLp((AV *)mg->mg_obj) + 1; |
1673
|
341
|
100
|
|
|
|
while (items--) { |
1674
|
230
|
|
|
|
|
stash = GvSTASH((GV *)*svp++); |
1675
|
230
|
100
|
|
|
|
if (stash && HvENAME(stash)) mro_isa_changed_in(stash); |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
1676
|
|
|
|
|
|
} |
1677
|
|
|
|
|
|
|
1678
|
|
|
|
|
|
return 0; |
1679
|
|
|
|
|
|
} |
1680
|
|
|
|
|
|
|
1681
|
510002
|
|
|
|
|
stash = GvSTASH( |
1682
|
|
|
|
|
|
(const GV *)mg->mg_obj |
1683
|
|
|
|
|
|
); |
1684
|
|
|
|
|
|
|
1685
|
|
|
|
|
|
/* The stash may have been detached from the symbol table, so check its |
1686
|
|
|
|
|
|
name before doing anything. */ |
1687
|
510002
|
100
|
|
|
|
if (stash && HvENAME_get(stash)) |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
1688
|
510037
|
|
|
|
|
mro_isa_changed_in(stash); |
1689
|
|
|
|
|
|
|
1690
|
|
|
|
|
|
return 0; |
1691
|
|
|
|
|
|
} |
1692
|
|
|
|
|
|
|
1693
|
|
|
|
|
|
int |
1694
|
172
|
|
|
|
|
Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg) |
1695
|
|
|
|
|
|
{ |
1696
|
172
|
|
|
|
|
HV * const hv = MUTABLE_HV(LvTARG(sv)); |
1697
|
|
|
|
|
|
I32 i = 0; |
1698
|
|
|
|
|
|
|
1699
|
|
|
|
|
|
PERL_ARGS_ASSERT_MAGIC_GETNKEYS; |
1700
|
|
|
|
|
|
PERL_UNUSED_ARG(mg); |
1701
|
|
|
|
|
|
|
1702
|
172
|
50
|
|
|
|
if (hv) { |
1703
|
172
|
|
|
|
|
(void) hv_iterinit(hv); |
1704
|
172
|
50
|
|
|
|
if (! SvTIED_mg((const SV *)hv, PERL_MAGIC_tied)) |
|
|
0
|
|
|
|
|
1705
|
172
|
100
|
|
|
|
i = HvUSEDKEYS(hv); |
1706
|
|
|
|
|
|
else { |
1707
|
0
|
0
|
|
|
|
while (hv_iternext(hv)) |
1708
|
0
|
|
|
|
|
i++; |
1709
|
|
|
|
|
|
} |
1710
|
|
|
|
|
|
} |
1711
|
|
|
|
|
|
|
1712
|
172
|
|
|
|
|
sv_setiv(sv, (IV)i); |
1713
|
172
|
|
|
|
|
return 0; |
1714
|
|
|
|
|
|
} |
1715
|
|
|
|
|
|
|
1716
|
|
|
|
|
|
int |
1717
|
14
|
|
|
|
|
Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg) |
1718
|
|
|
|
|
|
{ |
1719
|
|
|
|
|
|
PERL_ARGS_ASSERT_MAGIC_SETNKEYS; |
1720
|
|
|
|
|
|
PERL_UNUSED_ARG(mg); |
1721
|
14
|
50
|
|
|
|
if (LvTARG(sv)) { |
1722
|
14
|
100
|
|
|
|
hv_ksplit(MUTABLE_HV(LvTARG(sv)), SvIV(sv)); |
1723
|
|
|
|
|
|
} |
1724
|
14
|
|
|
|
|
return 0; |
1725
|
|
|
|
|
|
} |
1726
|
|
|
|
|
|
|
1727
|
|
|
|
|
|
/* |
1728
|
|
|
|
|
|
=for apidoc magic_methcall |
1729
|
|
|
|
|
|
|
1730
|
|
|
|
|
|
Invoke a magic method (like FETCH). |
1731
|
|
|
|
|
|
|
1732
|
|
|
|
|
|
C and C are the tied thingy and the tie magic. |
1733
|
|
|
|
|
|
|
1734
|
|
|
|
|
|
C is the name of the method to call. |
1735
|
|
|
|
|
|
|
1736
|
|
|
|
|
|
C is the number of args (in addition to $self) to pass to the method. |
1737
|
|
|
|
|
|
|
1738
|
|
|
|
|
|
The C can be: |
1739
|
|
|
|
|
|
|
1740
|
|
|
|
|
|
G_DISCARD invoke method with G_DISCARD flag and don't |
1741
|
|
|
|
|
|
return a value |
1742
|
|
|
|
|
|
G_UNDEF_FILL fill the stack with argc pointers to |
1743
|
|
|
|
|
|
PL_sv_undef |
1744
|
|
|
|
|
|
|
1745
|
|
|
|
|
|
The arguments themselves are any values following the C argument. |
1746
|
|
|
|
|
|
|
1747
|
|
|
|
|
|
Returns the SV (if any) returned by the method, or NULL on failure. |
1748
|
|
|
|
|
|
|
1749
|
|
|
|
|
|
|
1750
|
|
|
|
|
|
=cut |
1751
|
|
|
|
|
|
*/ |
1752
|
|
|
|
|
|
|
1753
|
|
|
|
|
|
SV* |
1754
|
4422851
|
|
|
|
|
Perl_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, SV *meth, U32 flags, |
1755
|
|
|
|
|
|
U32 argc, ...) |
1756
|
4422851
|
50
|
|
|
|
{ |
1757
|
|
|
|
|
|
dVAR; |
1758
|
4422851
|
|
|
|
|
dSP; |
1759
|
|
|
|
|
|
SV* ret = NULL; |
1760
|
|
|
|
|
|
|
1761
|
|
|
|
|
|
PERL_ARGS_ASSERT_MAGIC_METHCALL; |
1762
|
|
|
|
|
|
|
1763
|
4422851
|
|
|
|
|
ENTER; |
1764
|
|
|
|
|
|
|
1765
|
4422851
|
100
|
|
|
|
if (flags & G_WRITING_TO_STDERR) { |
1766
|
16
|
|
|
|
|
SAVETMPS; |
1767
|
|
|
|
|
|
|
1768
|
16
|
|
|
|
|
save_re_context(); |
1769
|
16
|
|
|
|
|
SAVESPTR(PL_stderrgv); |
1770
|
16
|
|
|
|
|
PL_stderrgv = NULL; |
1771
|
|
|
|
|
|
} |
1772
|
|
|
|
|
|
|
1773
|
4422851
|
100
|
|
|
|
PUSHSTACKi(PERLSI_MAGIC); |
1774
|
4422851
|
50
|
|
|
|
PUSHMARK(SP); |
1775
|
|
|
|
|
|
|
1776
|
2211246
|
|
|
|
|
EXTEND(SP, argc+1); |
1777
|
4422851
|
100
|
|
|
|
PUSHs(SvTIED_obj(sv, mg)); |
1778
|
4422851
|
50
|
|
|
|
if (flags & G_UNDEF_FILL) { |
1779
|
0
|
0
|
|
|
|
while (argc--) { |
1780
|
0
|
|
|
|
|
PUSHs(&PL_sv_undef); |
1781
|
|
|
|
|
|
} |
1782
|
4422851
|
100
|
|
|
|
} else if (argc > 0) { |
1783
|
|
|
|
|
|
va_list args; |
1784
|
4416005
|
|
|
|
|
va_start(args, argc); |
1785
|
|
|
|
|
|
|
1786
|
|
|
|
|
|
do { |
1787
|
4426311
|
100
|
|
|
|
SV *const sv = va_arg(args, SV *); |
1788
|
4426311
|
|
|
|
|
PUSHs(sv); |
1789
|
4426311
|
100
|
|
|
|
} while (--argc); |
1790
|
|
|
|
|
|
|
1791
|
4416005
|
|
|
|
|
va_end(args); |
1792
|
|
|
|
|
|
} |
1793
|
4422851
|
|
|
|
|
PUTBACK; |
1794
|
4422851
|
100
|
|
|
|
if (flags & G_DISCARD) { |
1795
|
11750
|
|
|
|
|
call_sv(meth, G_SCALAR|G_DISCARD|G_METHOD_NAMED); |
1796
|
|
|
|
|
|
} |
1797
|
|
|
|
|
|
else { |
1798
|
4411101
|
50
|
|
|
|
if (call_sv(meth, G_SCALAR|G_METHOD_NAMED)) |
1799
|
4411005
|
|
|
|
|
ret = *PL_stack_sp--; |
1800
|
|
|
|
|
|
} |
1801
|
4422711
|
50
|
|
|
|
POPSTACK; |
1802
|
4422711
|
100
|
|
|
|
if (flags & G_WRITING_TO_STDERR) |
1803
|
14
|
50
|
|
|
|
FREETMPS; |
1804
|
4422711
|
|
|
|
|
LEAVE; |
1805
|
4422711
|
|
|
|
|
return ret; |
1806
|
|
|
|
|
|
} |
1807
|
|
|
|
|
|
|
1808
|
|
|
|
|
|
/* wrapper for magic_methcall that creates the first arg */ |
1809
|
|
|
|
|
|
|
1810
|
|
|
|
|
|
STATIC SV* |
1811
|
2400907
|
|
|
|
|
S_magic_methcall1(pTHX_ SV *sv, const MAGIC *mg, SV *meth, U32 flags, |
1812
|
|
|
|
|
|
int n, SV *val) |
1813
|
|
|
|
|
|
{ |
1814
|
|
|
|
|
|
dVAR; |
1815
|
|
|
|
|
|
SV* arg1 = NULL; |
1816
|
|
|
|
|
|
|
1817
|
|
|
|
|
|
PERL_ARGS_ASSERT_MAGIC_METHCALL1; |
1818
|
|
|
|
|
|
|
1819
|
2400907
|
100
|
|
|
|
if (mg->mg_ptr) { |
1820
|
2390457
|
100
|
|
|
|
if (mg->mg_len >= 0) { |
1821
|
12
|
|
|
|
|
arg1 = newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP); |
1822
|
|
|
|
|
|
} |
1823
|
2390445
|
50
|
|
|
|
else if (mg->mg_len == HEf_SVKEY) |
1824
|
2390445
|
|
|
|
|
arg1 = MUTABLE_SV(mg->mg_ptr); |
1825
|
|
|
|
|
|
} |
1826
|
10450
|
100
|
|
|
|
else if (mg->mg_type == PERL_MAGIC_tiedelem) { |
1827
|
6454
|
|
|
|
|
arg1 = newSViv((IV)(mg->mg_len)); |
1828
|
6454
|
|
|
|
|
sv_2mortal(arg1); |
1829
|
|
|
|
|
|
} |
1830
|
2400907
|
100
|
|
|
|
if (!arg1) { |
1831
|
3996
|
|
|
|
|
return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n - 1, val); |
1832
|
|
|
|
|
|
} |
1833
|
2398866
|
|
|
|
|
return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n, arg1, val); |
1834
|
|
|
|
|
|
} |
1835
|
|
|
|
|
|
|
1836
|
|
|
|
|
|
STATIC int |
1837
|
2388063
|
|
|
|
|
S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, SV *meth) |
1838
|
|
|
|
|
|
{ |
1839
|
|
|
|
|
|
dVAR; |
1840
|
|
|
|
|
|
SV* ret; |
1841
|
|
|
|
|
|
|
1842
|
|
|
|
|
|
PERL_ARGS_ASSERT_MAGIC_METHPACK; |
1843
|
|
|
|
|
|
|
1844
|
2388063
|
|
|
|
|
ret = magic_methcall1(sv, mg, meth, 0, 1, NULL); |
1845
|
2387979
|
50
|
|
|
|
if (ret) |
1846
|
2387979
|
|
|
|
|
sv_setsv(sv, ret); |
1847
|
2387977
|
|
|
|
|
return 0; |
1848
|
|
|
|
|
|
} |
1849
|
|
|
|
|
|
|
1850
|
|
|
|
|
|
int |
1851
|
2297595
|
|
|
|
|
Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg) |
1852
|
|
|
|
|
|
{ |
1853
|
|
|
|
|
|
PERL_ARGS_ASSERT_MAGIC_GETPACK; |
1854
|
|
|
|
|
|
|
1855
|
2297595
|
100
|
|
|
|
if (mg->mg_type == PERL_MAGIC_tiedelem) |
1856
|
2296137
|
|
|
|
|
mg->mg_flags |= MGf_GSKIP; |
1857
|
2297595
|
100
|
|
|
|
magic_methpack(sv,mg,SV_CONST(FETCH)); |
1858
|
2297517
|
|
|
|
|
return 0; |
1859
|
|
|
|
|
|
} |
1860
|
|
|
|
|
|
|
1861
|
|
|
|
|
|
int |
1862
|
11104
|
|
|
|
|
Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg) |
1863
|
|
|
|
|
|
{ |
1864
|
|
|
|
|
|
dVAR; |
1865
|
|
|
|
|
|
MAGIC *tmg; |
1866
|
|
|
|
|
|
SV *val; |
1867
|
|
|
|
|
|
|
1868
|
|
|
|
|
|
PERL_ARGS_ASSERT_MAGIC_SETPACK; |
1869
|
|
|
|
|
|
|
1870
|
|
|
|
|
|
/* in the code C<$tied{foo} = $val>, the "thing" that gets passed to |
1871
|
|
|
|
|
|
* STORE() is not $val, but rather a PVLV (the sv in this call), whose |
1872
|
|
|
|
|
|
* public flags indicate its value based on copying from $val. Doing |
1873
|
|
|
|
|
|
* mg_set() on the PVLV temporarily does SvMAGICAL_off(), then calls us. |
1874
|
|
|
|
|
|
* So STORE()'s $_[2] arg is a temporarily disarmed PVLV. This goes |
1875
|
|
|
|
|
|
* wrong if $val happened to be tainted, as sv hasn't got magic |
1876
|
|
|
|
|
|
* enabled, even though taint magic is in the chain. In which case, |
1877
|
|
|
|
|
|
* fake up a temporary tainted value (this is easier than temporarily |
1878
|
|
|
|
|
|
* re-enabling magic on sv). */ |
1879
|
|
|
|
|
|
|
1880
|
11104
|
50
|
|
|
|
if (TAINTING_get && (tmg = mg_find(sv, PERL_MAGIC_taint)) |
|
|
0
|
|
|
|
|
1881
|
0
|
0
|
|
|
|
&& (tmg->mg_len & 1)) |
1882
|
|
|
|
|
|
{ |
1883
|
0
|
|
|
|
|
val = sv_mortalcopy(sv); |
1884
|
0
|
0
|
|
|
|
SvTAINTED_on(val); |
1885
|
|
|
|
|
|
} |
1886
|
|
|
|
|
|
else |
1887
|
|
|
|
|
|
val = sv; |
1888
|
|
|
|
|
|
|
1889
|
11104
|
100
|
|
|
|
magic_methcall1(sv, mg, SV_CONST(STORE), G_DISCARD, 2, val); |
1890
|
11066
|
|
|
|
|
return 0; |
1891
|
|
|
|
|
|
} |
1892
|
|
|
|
|
|
|
1893
|
|
|
|
|
|
int |
1894
|
1610
|
|
|
|
|
Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg) |
1895
|
|
|
|
|
|
{ |
1896
|
|
|
|
|
|
PERL_ARGS_ASSERT_MAGIC_CLEARPACK; |
1897
|
|
|
|
|
|
|
1898
|
1610
|
100
|
|
|
|
if (mg->mg_type == PERL_MAGIC_tiedscalar) return 0; |
1899
|
1608
|
100
|
|
|
|
return magic_methpack(sv,mg,SV_CONST(DELETE)); |
1900
|
|
|
|
|
|
} |
1901
|
|
|
|
|
|
|
1902
|
|
|
|
|
|
|
1903
|
|
|
|
|
|
U32 |
1904
|
1740
|
|
|
|
|
Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg) |
1905
|
|
|
|
|
|
{ |
1906
|
|
|
|
|
|
dVAR; |
1907
|
|
|
|
|
|
I32 retval = 0; |
1908
|
|
|
|
|
|
SV* retsv; |
1909
|
|
|
|
|
|
|
1910
|
|
|
|
|
|
PERL_ARGS_ASSERT_MAGIC_SIZEPACK; |
1911
|
|
|
|
|
|
|
1912
|
1740
|
100
|
|
|
|
retsv = magic_methcall1(sv, mg, SV_CONST(FETCHSIZE), 0, 1, NULL); |
1913
|
1732
|
50
|
|
|
|
if (retsv) { |
1914
|
1732
|
50
|
|
|
|
retval = SvIV(retsv)-1; |
1915
|
1732
|
100
|
|
|
|
if (retval < -1) |
1916
|
2
|
|
|
|
|
Perl_croak(aTHX_ "FETCHSIZE returned a negative value"); |
1917
|
|
|
|
|
|
} |
1918
|
1730
|
|
|
|
|
return (U32) retval; |
1919
|
|
|
|
|
|
} |
1920
|
|
|
|
|
|
|
1921
|
|
|
|
|
|
int |
1922
|
312
|
|
|
|
|
Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg) |
1923
|
|
|
|
|
|
{ |
1924
|
|
|
|
|
|
dVAR; |
1925
|
|
|
|
|
|
|
1926
|
|
|
|
|
|
PERL_ARGS_ASSERT_MAGIC_WIPEPACK; |
1927
|
|
|
|
|
|
|
1928
|
312
|
100
|
|
|
|
Perl_magic_methcall(aTHX_ sv, mg, SV_CONST(CLEAR), G_DISCARD, 0); |
1929
|
308
|
|
|
|
|
return 0; |
1930
|
|
|
|
|
|
} |
1931
|
|
|
|
|
|
|
1932
|
|
|
|
|
|
int |
1933
|
2021206
|
|
|
|
|
Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key) |
1934
|
|
|
|
|
|
{ |
1935
|
|
|
|
|
|
dVAR; |
1936
|
|
|
|
|
|
SV* ret; |
1937
|
|
|
|
|
|
|
1938
|
|
|
|
|
|
PERL_ARGS_ASSERT_MAGIC_NEXTPACK; |
1939
|
|
|
|
|
|
|
1940
|
2022828
|
50
|
|
|
|
ret = SvOK(key) ? Perl_magic_methcall(aTHX_ sv, mg, SV_CONST(NEXTKEY), 0, 1, key) |
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
1941
|
4040790
|
100
|
|
|
|
: Perl_magic_methcall(aTHX_ sv, mg, SV_CONST(FIRSTKEY), 0, 0); |
|
|
100
|
|
|
|
|
1942
|
2021202
|
50
|
|
|
|
if (ret) |
1943
|
2021202
|
|
|
|
|
sv_setsv(key,ret); |
1944
|
2021202
|
|
|
|
|
return 0; |
1945
|
|
|
|
|
|
} |
1946
|
|
|
|
|
|
|
1947
|
|
|
|
|
|
int |
1948
|
88862
|
|
|
|
|
Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg) |
1949
|
|
|
|
|
|
{ |
1950
|
|
|
|
|
|
PERL_ARGS_ASSERT_MAGIC_EXISTSPACK; |
1951
|
|
|
|
|
|
|
1952
|
88862
|
100
|
|
|
|
return magic_methpack(sv,mg,SV_CONST(EXISTS)); |
1953
|
|
|
|
|
|
} |
1954
|
|
|
|
|
|
|
1955
|
|
|
|
|
|
SV * |
1956
|
40
|
|
|
|
|
Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg) |
1957
|
|
|
|
|
|
{ |
1958
|
|
|
|
|
|
dVAR; |
1959
|
|
|
|
|
|
SV *retval; |
1960
|
40
|
50
|
|
|
|
SV * const tied = SvTIED_obj(MUTABLE_SV(hv), mg); |
1961
|
40
|
|
|
|
|
HV * const pkg = SvSTASH((const SV *)SvRV(tied)); |
1962
|
|
|
|
|
|
|
1963
|
|
|
|
|
|
PERL_ARGS_ASSERT_MAGIC_SCALARPACK; |
1964
|
|
|
|
|
|
|
1965
|
40
|
100
|
|
|
|
if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) { |
1966
|
|
|
|
|
|
SV *key; |
1967
|
10
|
100
|
|
|
|
if (HvEITER_get(hv)) |
|
|
100
|
|
|
|
|
1968
|
|
|
|
|
|
/* we are in an iteration so the hash cannot be empty */ |
1969
|
|
|
|
|
|
return &PL_sv_yes; |
1970
|
|
|
|
|
|
/* no xhv_eiter so now use FIRSTKEY */ |
1971
|
8
|
|
|
|
|
key = sv_newmortal(); |
1972
|
8
|
|
|
|
|
magic_nextpack(MUTABLE_SV(hv), mg, key); |
1973
|
8
|
|
|
|
|
HvEITER_set(hv, NULL); /* need to reset iterator */ |
1974
|
8
|
100
|
|
|
|
return SvOK(key) ? &PL_sv_yes : &PL_sv_no; |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
1975
|
|
|
|
|
|
} |
1976
|
|
|
|
|
|
|
1977
|
|
|
|
|
|
/* there is a SCALAR method that we can call */ |
1978
|
30
|
100
|
|
|
|
retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(hv), mg, SV_CONST(SCALAR), 0, 0); |
1979
|
30
|
50
|
|
|
|
if (!retval) |
1980
|
|
|
|
|
|
retval = &PL_sv_undef; |
1981
|
35
|
|
|
|
|
return retval; |
1982
|
|
|
|
|
|
} |
1983
|
|
|
|
|
|
|
1984
|
|
|
|
|
|
int |
1985
|
130
|
|
|
|
|
Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg) |
1986
|
|
|
|
|
|
{ |
1987
|
|
|
|
|
|
dVAR; |
1988
|
|
|
|
|
|
SV **svp; |
1989
|
|
|
|
|
|
|
1990
|
|
|
|
|
|
PERL_ARGS_ASSERT_MAGIC_SETDBLINE; |
1991
|
|
|
|
|
|
|
1992
|
|
|
|
|
|
/* The magic ptr/len for the debugger's hash should always be an SV. */ |
1993
|
130
|
50
|
|
|
|
if (UNLIKELY(mg->mg_len != HEf_SVKEY)) { |
1994
|
0
|
|
|
|
|
Perl_croak(aTHX_ "panic: magic_setdbline len=%"IVdf", ptr='%s'", |
1995
|
|
|
|
|
|
mg->mg_len, mg->mg_ptr); |
1996
|
|
|
|
|
|
} |
1997
|
|
|
|
|
|
|
1998
|
|
|
|
|
|
/* Use sv_2iv instead of SvIV() as the former generates smaller code, and |
1999
|
|
|
|
|
|
setting/clearing debugger breakpoints is not a hot path. */ |
2000
|
130
|
|
|
|
|
svp = av_fetch(GvAV(PL_DBline), sv_2iv(MUTABLE_SV((mg)->mg_ptr)), FALSE); |
2001
|
|
|
|
|
|
|
2002
|
130
|
50
|
|
|
|
if (svp && SvIOKp(*svp)) { |
|
|
50
|
|
|
|
|
2003
|
130
|
|
|
|
|
OP * const o = INT2PTR(OP*,SvIVX(*svp)); |
2004
|
130
|
50
|
|
|
|
if (o) { |
2005
|
|
|
|
|
|
#ifdef PERL_DEBUG_READONLY_OPS |
2006
|
|
|
|
|
|
Slab_to_rw(OpSLAB(o)); |
2007
|
|
|
|
|
|
#endif |
2008
|
|
|
|
|
|
/* set or clear breakpoint in the relevant control op */ |
2009
|
130
|
50
|
|
|
|
if (SvTRUE(sv)) |
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
2010
|
118
|
|
|
|
|
o->op_flags |= OPf_SPECIAL; |
2011
|
|
|
|
|
|
else |
2012
|
12
|
|
|
|
|
o->op_flags &= ~OPf_SPECIAL; |
2013
|
|
|
|
|
|
#ifdef PERL_DEBUG_READONLY_OPS |
2014
|
|
|
|
|
|
Slab_to_ro(OpSLAB(o)); |
2015
|
|
|
|
|
|
#endif |
2016
|
|
|
|
|
|
} |
2017
|
|
|
|
|
|
} |
2018
|
130
|
|
|
|
|
return 0; |
2019
|
|
|
|
|
|
} |
2020
|
|
|
|
|
|
|
2021
|
|
|
|
|
|
int |
2022
|
354
|
|
|
|
|
Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg) |
2023
|
|
|
|
|
|
{ |
2024
|
|
|
|
|
|
dVAR; |
2025
|
354
|
|
|
|
|
AV * const obj = MUTABLE_AV(mg->mg_obj); |
2026
|
|
|
|
|
|
|
2027
|
|
|
|
|
|
PERL_ARGS_ASSERT_MAGIC_GETARYLEN; |
2028
|
|
|
|
|
|
|
2029
|
354
|
100
|
|
|
|
if (obj) { |
2030
|
338
|
50
|
|
|
|
sv_setiv(sv, AvFILL(obj)); |
2031
|
|
|
|
|
|
} else { |
2032
|
16
|
|
|
|
|
sv_setsv(sv, NULL); |
2033
|
|
|
|
|
|
} |
2034
|
354
|
|
|
|
|
return 0; |
2035
|
|
|
|
|
|
} |
2036
|
|
|
|
|
|
|
2037
|
|
|
|
|
|
int |
2038
|
50210
|
|
|
|
|
Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg) |
2039
|
|
|
|
|
|
{ |
2040
|
|
|
|
|
|
dVAR; |
2041
|
50210
|
|
|
|
|
AV * const obj = MUTABLE_AV(mg->mg_obj); |
2042
|
|
|
|
|
|
|
2043
|
|
|
|
|
|
PERL_ARGS_ASSERT_MAGIC_SETARYLEN; |
2044
|
|
|
|
|
|
|
2045
|
50210
|
100
|
|
|
|
if (obj) { |
2046
|
50190
|
100
|
|
|
|
av_fill(obj, SvIV(sv)); |
2047
|
|
|
|
|
|
} else { |
2048
|
20
|
|
|
|
|
Perl_ck_warner(aTHX_ packWARN(WARN_MISC), |
2049
|
|
|
|
|
|
"Attempt to set length of freed array"); |
2050
|
|
|
|
|
|
} |
2051
|
50208
|
|
|
|
|
return 0; |
2052
|
|
|
|
|
|
} |
2053
|
|
|
|
|
|
|
2054
|
|
|
|
|
|
int |
2055
|
14778
|
|
|
|
|
Perl_magic_cleararylen_p(pTHX_ SV *sv, MAGIC *mg) |
2056
|
|
|
|
|
|
{ |
2057
|
|
|
|
|
|
dVAR; |
2058
|
|
|
|
|
|
|
2059
|
|
|
|
|
|
PERL_ARGS_ASSERT_MAGIC_CLEARARYLEN_P; |
2060
|
|
|
|
|
|
PERL_UNUSED_ARG(sv); |
2061
|
|
|
|
|
|
|
2062
|
|
|
|
|
|
/* Reset the iterator when the array is cleared */ |
2063
|
|
|
|
|
|
#if IVSIZE == I32SIZE |
2064
|
|
|
|
|
|
*((IV *) &(mg->mg_len)) = 0; |
2065
|
|
|
|
|
|
#else |
2066
|
14778
|
100
|
|
|
|
if (mg->mg_ptr) |
2067
|
10
|
|
|
|
|
*((IV *) mg->mg_ptr) = 0; |
2068
|
|
|
|
|
|
#endif |
2069
|
|
|
|
|
|
|
2070
|
14778
|
|
|
|
|
return 0; |
2071
|
|
|
|
|
|
} |
2072
|
|
|
|
|
|
|
2073
|
|
|
|
|
|
int |
2074
|
15240
|
|
|
|
|
Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg) |
2075
|
|
|
|
|
|
{ |
2076
|
|
|
|
|
|
dVAR; |
2077
|
|
|
|
|
|
|
2078
|
|
|
|
|
|
PERL_ARGS_ASSERT_MAGIC_FREEARYLEN_P; |
2079
|
|
|
|
|
|
PERL_UNUSED_ARG(sv); |
2080
|
|
|
|
|
|
|
2081
|
|
|
|
|
|
/* during global destruction, mg_obj may already have been freed */ |
2082
|
15240
|
50
|
|
|
|
if (PL_in_clean_all) |
2083
|
|
|
|
|
|
return 0; |
2084
|
|
|
|
|
|
|
2085
|
15240
|
|
|
|
|
mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen); |
2086
|
|
|
|
|
|
|
2087
|
15240
|
100
|
|
|
|
if (mg) { |
2088
|
|
|
|
|
|
/* arylen scalar holds a pointer back to the array, but doesn't own a |
2089
|
|
|
|
|
|
reference. Hence the we (the array) are about to go away with it |
2090
|
|
|
|
|
|
still pointing at us. Clear its pointer, else it would be pointing |
2091
|
|
|
|
|
|
at free memory. See the comment in sv_magic about reference loops, |
2092
|
|
|
|
|
|
and why it can't own a reference to us. */ |
2093
|
15231
|
|
|
|
|
mg->mg_obj = 0; |
2094
|
|
|
|
|
|
} |
2095
|
|
|
|
|
|
return 0; |
2096
|
|
|
|
|
|
} |
2097
|
|
|
|
|
|
|
2098
|
|
|
|
|
|
int |
2099
|
9316
|
|
|
|
|
Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg) |
2100
|
|
|
|
|
|
{ |
2101
|
|
|
|
|
|
dVAR; |
2102
|
9316
|
|
|
|
|
SV* const lsv = LvTARG(sv); |
2103
|
9316
|
|
|
|
|
MAGIC * const found = mg_find_mglob(lsv); |
2104
|
|
|
|
|
|
|
2105
|
|
|
|
|
|
PERL_ARGS_ASSERT_MAGIC_GETPOS; |
2106
|
|
|
|
|
|
PERL_UNUSED_ARG(mg); |
2107
|
|
|
|
|
|
|
2108
|
9316
|
100
|
|
|
|
if (found && found->mg_len != -1) { |
|
|
100
|
|
|
|
|
2109
|
9182
|
|
|
|
|
STRLEN i = found->mg_len; |
2110
|
9182
|
100
|
|
|
|
if (found->mg_flags & MGf_BYTES && DO_UTF8(lsv)) |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
2111
|
2
|
|
|
|
|
i = sv_pos_b2u_flags(lsv, i, SV_GMAGIC|SV_CONST_RETURN); |
2112
|
9182
|
|
|
|
|
sv_setuv(sv, i); |
2113
|
9182
|
|
|
|
|
return 0; |
2114
|
|
|
|
|
|
} |
2115
|
134
|
|
|
|
|
sv_setsv(sv,NULL); |
2116
|
4725
|
|
|
|
|
return 0; |
2117
|
|
|
|
|
|
} |
2118
|
|
|
|
|
|
|
2119
|
|
|
|
|
|
int |
2120
|
74644
|
|
|
|
|
Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg) |
2121
|
|
|
|
|
|
{ |
2122
|
|
|
|
|
|
dVAR; |
2123
|
74644
|
|
|
|
|
SV* const lsv = LvTARG(sv); |
2124
|
|
|
|
|
|
SSize_t pos; |
2125
|
|
|
|
|
|
STRLEN len; |
2126
|
|
|
|
|
|
STRLEN ulen = 0; |
2127
|
|
|
|
|
|
MAGIC* found; |
2128
|
|
|
|
|
|
const char *s; |
2129
|
|
|
|
|
|
|
2130
|
|
|
|
|
|
PERL_ARGS_ASSERT_MAGIC_SETPOS; |
2131
|
|
|
|
|
|
PERL_UNUSED_ARG(mg); |
2132
|
|
|
|
|
|
|
2133
|
74644
|
|
|
|
|
found = mg_find_mglob(lsv); |
2134
|
74644
|
100
|
|
|
|
if (!found) { |
2135
|
63544
|
100
|
|
|
|
if (!SvOK(sv)) |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
2136
|
|
|
|
|
|
return 0; |
2137
|
63246
|
|
|
|
|
found = sv_magicext_mglob(lsv); |
2138
|
|
|
|
|
|
} |
2139
|
11100
|
100
|
|
|
|
else if (!SvOK(sv)) { |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
2140
|
46
|
|
|
|
|
found->mg_len = -1; |
2141
|
46
|
|
|
|
|
return 0; |
2142
|
|
|
|
|
|
} |
2143
|
74300
|
100
|
|
|
|
s = SvPV_const(lsv, len); |
2144
|
|
|
|
|
|
|
2145
|
74300
|
100
|
|
|
|
pos = SvIV(sv); |
2146
|
|
|
|
|
|
|
2147
|
74300
|
100
|
|
|
|
if (DO_UTF8(lsv)) { |
|
|
50
|
|
|
|
|
2148
|
1046
|
100
|
|
|
|
ulen = sv_or_pv_len_utf8(lsv, s, len); |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
2149
|
1046
|
50
|
|
|
|
if (ulen) |
2150
|
1046
|
|
|
|
|
len = ulen; |
2151
|
|
|
|
|
|
} |
2152
|
|
|
|
|
|
|
2153
|
74300
|
50
|
|
|
|
if (pos < 0) { |
2154
|
0
|
|
|
|
|
pos += len; |
2155
|
0
|
0
|
|
|
|
if (pos < 0) |
2156
|
|
|
|
|
|
pos = 0; |
2157
|
|
|
|
|
|
} |
2158
|
74300
|
100
|
|
|
|
else if (pos > (SSize_t)len) |
2159
|
4
|
|
|
|
|
pos = len; |
2160
|
|
|
|
|
|
|
2161
|
74300
|
|
|
|
|
found->mg_len = pos; |
2162
|
74300
|
|
|
|
|
found->mg_flags &= ~(MGf_MINMATCH|MGf_BYTES); |
2163
|
|
|
|
|
|
|
2164
|
74472
|
|
|
|
|
return 0; |
2165
|
|
|
|
|
|
} |
2166
|
|
|
|
|
|
|
2167
|
|
|
|
|
|
int |
2168
|
65064
|
|
|
|
|
Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg) |
2169
|
|
|
|
|
|
{ |
2170
|
|
|
|
|
|
STRLEN len; |
2171
|
65064
|
|
|
|
|
SV * const lsv = LvTARG(sv); |
2172
|
65064
|
100
|
|
|
|
const char * const tmps = SvPV_const(lsv,len); |
2173
|
65064
|
|
|
|
|
STRLEN offs = LvTARGOFF(sv); |
2174
|
65064
|
|
|
|
|
STRLEN rem = LvTARGLEN(sv); |
2175
|
65064
|
|
|
|
|
const bool negoff = LvFLAGS(sv) & 1; |
2176
|
65064
|
|
|
|
|
const bool negrem = LvFLAGS(sv) & 2; |
2177
|
|
|
|
|
|
|
2178
|
|
|
|
|
|
PERL_ARGS_ASSERT_MAGIC_GETSUBSTR; |
2179
|
|
|
|
|
|
PERL_UNUSED_ARG(mg); |
2180
|
|
|
|
|
|
|
2181
|
65064
|
100
|
|
|
|
if (!translate_substr_offsets( |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
2182
|
|
|
|
|
|
SvUTF8(lsv) ? sv_or_pv_len_utf8(lsv, tmps, len) : len, |
2183
|
|
|
|
|
|
negoff ? -(IV)offs : (IV)offs, !negoff, |
2184
|
|
|
|
|
|
negrem ? -(IV)rem : (IV)rem, !negrem, &offs, &rem |
2185
|
|
|
|
|
|
)) { |
2186
|
2
|
|
|
|
|
Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string"); |
2187
|
2
|
|
|
|
|
sv_setsv_nomg(sv, &PL_sv_undef); |
2188
|
2
|
|
|
|
|
return 0; |
2189
|
|
|
|
|
|
} |
2190
|
|
|
|
|
|
|
2191
|
65062
|
100
|
|
|
|
if (SvUTF8(lsv)) |
2192
|
4002
|
|
|
|
|
offs = sv_or_pv_pos_u2b(lsv, tmps, offs, &rem); |
2193
|
65062
|
|
|
|
|
sv_setpvn(sv, tmps + offs, rem); |
2194
|
65062
|
100
|
|
|
|
if (SvUTF8(lsv)) |
2195
|
33866
|
|
|
|
|
SvUTF8_on(sv); |
2196
|
|
|
|
|
|
return 0; |
2197
|
|
|
|
|
|
} |
2198
|
|
|
|
|
|
|
2199
|
|
|
|
|
|
int |
2200
|
4120
|
|
|
|
|
Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg) |
2201
|
4120
|
50
|
|
|
|
{ |
2202
|
|
|
|
|
|
dVAR; |
2203
|
|
|
|
|
|
STRLEN len, lsv_len, oldtarglen, newtarglen; |
2204
|
4120
|
100
|
|
|
|
const char * const tmps = SvPV_const(sv, len); |
2205
|
4120
|
|
|
|
|
SV * const lsv = LvTARG(sv); |
2206
|
4120
|
|
|
|
|
STRLEN lvoff = LvTARGOFF(sv); |
2207
|
4120
|
|
|
|
|
STRLEN lvlen = LvTARGLEN(sv); |
2208
|
4120
|
|
|
|
|
const bool negoff = LvFLAGS(sv) & 1; |
2209
|
4120
|
|
|
|
|
const bool neglen = LvFLAGS(sv) & 2; |
2210
|
|
|
|
|
|
|
2211
|
|
|
|
|
|
PERL_ARGS_ASSERT_MAGIC_SETSUBSTR; |
2212
|
|
|
|
|
|
PERL_UNUSED_ARG(mg); |
2213
|
|
|
|
|
|
|
2214
|
2060
|
|
|
|
|
SvGETMAGIC(lsv); |
2215
|
4120
|
100
|
|
|
|
if (SvROK(lsv)) |
2216
|
6
|
|
|
|
|
Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), |
2217
|
|
|
|
|
|
"Attempt to use reference as lvalue in substr" |
2218
|
|
|
|
|
|
); |
2219
|
4120
|
100
|
|
|
|
SvPV_force_nomg(lsv,lsv_len); |
2220
|
4120
|
100
|
|
|
|
if (SvUTF8(lsv)) lsv_len = sv_len_utf8_nomg(lsv); |
2221
|
4120
|
100
|
|
|
|
if (!translate_substr_offsets( |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
2222
|
|
|
|
|
|
lsv_len, |
2223
|
|
|
|
|
|
negoff ? -(IV)lvoff : (IV)lvoff, !negoff, |
2224
|
|
|
|
|
|
neglen ? -(IV)lvlen : (IV)lvlen, !neglen, &lvoff, &lvlen |
2225
|
|
|
|
|
|
)) |
2226
|
0
|
|
|
|
|
Perl_croak(aTHX_ "substr outside of string"); |
2227
|
4120
|
|
|
|
|
oldtarglen = lvlen; |
2228
|
4120
|
100
|
|
|
|
if (DO_UTF8(sv)) { |
|
|
50
|
|
|
|
|
2229
|
6
|
|
|
|
|
sv_utf8_upgrade_nomg(lsv); |
2230
|
6
|
|
|
|
|
lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN); |
2231
|
6
|
|
|
|
|
sv_insert_flags(lsv, lvoff, lvlen, tmps, len, 0); |
2232
|
6
|
50
|
|
|
|
newtarglen = sv_or_pv_len_utf8(sv, tmps, len); |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
2233
|
6
|
|
|
|
|
SvUTF8_on(lsv); |
2234
|
|
|
|
|
|
} |
2235
|
4114
|
100
|
|
|
|
else if (SvUTF8(lsv)) { |
2236
|
|
|
|
|
|
const char *utf8; |
2237
|
4
|
|
|
|
|
lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN); |
2238
|
4
|
|
|
|
|
newtarglen = len; |
2239
|
4
|
|
|
|
|
utf8 = (char*)bytes_to_utf8((U8*)tmps, &len); |
2240
|
4
|
|
|
|
|
sv_insert_flags(lsv, lvoff, lvlen, utf8, len, 0); |
2241
|
4
|
|
|
|
|
Safefree(utf8); |
2242
|
|
|
|
|
|
} |
2243
|
|
|
|
|
|
else { |
2244
|
4110
|
|
|
|
|
sv_insert_flags(lsv, lvoff, lvlen, tmps, len, 0); |
2245
|
4110
|
|
|
|
|
newtarglen = len; |
2246
|
|
|
|
|
|
} |
2247
|
4120
|
100
|
|
|
|
if (!neglen) LvTARGLEN(sv) = newtarglen; |
2248
|
4120
|
100
|
|
|
|
if (negoff) LvTARGOFF(sv) += newtarglen - oldtarglen; |
2249
|
|
|
|
|
|
|
2250
|
4120
|
|
|
|
|
return 0; |
2251
|
|
|
|
|
|
} |
2252
|
|
|
|
|
|
|
2253
|
|
|
|
|
|
int |
2254
|
1127864
|
|
|
|
|
Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg) |
2255
|
|
|
|
|
|
{ |
2256
|
|
|
|
|
|
dVAR; |
2257
|
|
|
|
|
|
|
2258
|
|
|
|
|
|
PERL_ARGS_ASSERT_MAGIC_GETTAINT; |
2259
|
|
|
|
|
|
PERL_UNUSED_ARG(sv); |
2260
|
|
|
|
|
|
#ifdef NO_TAINT_SUPPORT |
2261
|
|
|
|
|
|
PERL_UNUSED_ARG(mg); |
2262
|
|
|
|
|
|
#endif |
2263
|
|
|
|
|
|
|
2264
|
1127864
|
100
|
|
|
|
TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1)); |
|
|
100
|
|
|
|
|
2265
|
1127864
|
|
|
|
|
return 0; |
2266
|
|
|
|
|
|
} |
2267
|
|
|
|
|
|
|
2268
|
|
|
|
|
|
int |
2269
|
7044
|
|
|
|
|
Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg) |
2270
|
|
|
|
|
|
{ |
2271
|
|
|
|
|
|
dVAR; |
2272
|
|
|
|
|
|
|
2273
|
|
|
|
|
|
PERL_ARGS_ASSERT_MAGIC_SETTAINT; |
2274
|
|
|
|
|
|
PERL_UNUSED_ARG(sv); |
2275
|
|
|
|
|
|
|
2276
|
|
|
|
|
|
/* update taint status */ |
2277
|
7044
|
100
|
|
|
|
if (TAINT_get) |
2278
|
5402
|
|
|
|
|
mg->mg_len |= 1; |
2279
|
|
|
|
|
|
else |
2280
|
1642
|
|
|
|
|
mg->mg_len &= ~1; |
2281
|
7044
|
|
|
|
|
return 0; |
2282
|
|
|
|
|
|
} |
2283
|
|
|
|
|
|
|
2284
|
|
|
|
|
|
int |
2285
|
40
|
|
|
|
|
Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg) |
2286
|
|
|
|
|
|
{ |
2287
|
40
|
|
|
|
|
SV * const lsv = LvTARG(sv); |
2288
|
|
|
|
|
|
|
2289
|
|
|
|
|
|
PERL_ARGS_ASSERT_MAGIC_GETVEC; |
2290
|
|
|
|
|
|
PERL_UNUSED_ARG(mg); |
2291
|
|
|
|
|
|
|
2292
|
40
|
|
|
|
|
sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv))); |
2293
|
|
|
|
|
|
|
2294
|
40
|
|
|
|
|
return 0; |
2295
|
|
|
|
|
|
} |
2296
|
|
|
|
|
|
|
2297
|
|
|
|
|
|
int |
2298
|
5038378
|
|
|
|
|
Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg) |
2299
|
|
|
|
|
|
{ |
2300
|
|
|
|
|
|
PERL_ARGS_ASSERT_MAGIC_SETVEC; |
2301
|
|
|
|
|
|
PERL_UNUSED_ARG(mg); |
2302
|
5038378
|
|
|
|
|
do_vecset(sv); /* XXX slurp this routine */ |
2303
|
5038374
|
|
|
|
|
return 0; |
2304
|
|
|
|
|
|
} |
2305
|
|
|
|
|
|
|
2306
|
|
|
|
|
|
SV * |
2307
|
120360
|
|
|
|
|
Perl_defelem_target(pTHX_ SV *sv, MAGIC *mg) |
2308
|
|
|
|
|
|
{ |
2309
|
|
|
|
|
|
dVAR; |
2310
|
|
|
|
|
|
SV *targ = NULL; |
2311
|
|
|
|
|
|
PERL_ARGS_ASSERT_DEFELEM_TARGET; |
2312
|
120360
|
100
|
|
|
|
if (!mg) mg = mg_find(sv, PERL_MAGIC_defelem); |
2313
|
|
|
|
|
|
assert(mg); |
2314
|
120360
|
100
|
|
|
|
if (LvTARGLEN(sv)) { |
2315
|
92928
|
100
|
|
|
|
if (mg->mg_obj) { |
2316
|
65876
|
|
|
|
|
SV * const ahv = LvTARG(sv); |
2317
|
65876
|
|
|
|
|
HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, FALSE, 0); |
2318
|
65876
|
100
|
|
|
|
if (he) |
2319
|
2
|
|
|
|
|
targ = HeVAL(he); |
2320
|
|
|
|
|
|
} |
2321
|
27052
|
100
|
|
|
|
else if (LvSTARGOFF(sv) >= 0) { |
2322
|
27044
|
|
|
|
|
AV *const av = MUTABLE_AV(LvTARG(sv)); |
2323
|
27044
|
50
|
|
|
|
if (LvSTARGOFF(sv) <= AvFILL(av)) |
|
|
100
|
|
|
|
|
2324
|
26608
|
|
|
|
|
targ = AvARRAY(av)[LvSTARGOFF(sv)]; |
2325
|
|
|
|
|
|
} |
2326
|
92928
|
100
|
|
|
|
if (targ && (targ != &PL_sv_undef)) { |
|
|
50
|
|
|
|
|
2327
|
|
|
|
|
|
/* somebody else defined it for us */ |
2328
|
2
|
|
|
|
|
SvREFCNT_dec(LvTARG(sv)); |
2329
|
2
|
|
|
|
|
LvTARG(sv) = SvREFCNT_inc_simple_NN(targ); |
2330
|
2
|
|
|
|
|
LvTARGLEN(sv) = 0; |
2331
|
2
|
|
|
|
|
SvREFCNT_dec(mg->mg_obj); |
2332
|
2
|
|
|
|
|
mg->mg_obj = NULL; |
2333
|
2
|
|
|
|
|
mg->mg_flags &= ~MGf_REFCOUNTED; |
2334
|
|
|
|
|
|
} |
2335
|
|
|
|
|
|
return targ; |
2336
|
|
|
|
|
|
} |
2337
|
|
|
|
|
|
else |
2338
|
73896
|
|
|
|
|
return LvTARG(sv); |
2339
|
|
|
|
|
|
} |
2340
|
|
|
|
|
|
|
2341
|
|
|
|
|
|
int |
2342
|
120350
|
|
|
|
|
Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg) |
2343
|
|
|
|
|
|
{ |
2344
|
|
|
|
|
|
PERL_ARGS_ASSERT_MAGIC_GETDEFELEM; |
2345
|
|
|
|
|
|
|
2346
|
120350
|
|
|
|
|
sv_setsv(sv, defelem_target(sv, mg)); |
2347
|
120350
|
|
|
|
|
return 0; |
2348
|
|
|
|
|
|
} |
2349
|
|
|
|
|
|
|
2350
|
|
|
|
|
|
int |
2351
|
27212
|
|
|
|
|
Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg) |
2352
|
|
|
|
|
|
{ |
2353
|
|
|
|
|
|
PERL_ARGS_ASSERT_MAGIC_SETDEFELEM; |
2354
|
|
|
|
|
|
PERL_UNUSED_ARG(mg); |
2355
|
27212
|
100
|
|
|
|
if (LvTARGLEN(sv)) |
2356
|
27130
|
|
|
|
|
vivify_defelem(sv); |
2357
|
27204
|
50
|
|
|
|
if (LvTARG(sv)) { |
2358
|
27204
|
|
|
|
|
sv_setsv(LvTARG(sv), sv); |
2359
|
27204
|
100
|
|
|
|
SvSETMAGIC(LvTARG(sv)); |
2360
|
|
|
|
|
|
} |
2361
|
27204
|
|
|
|
|
return 0; |
2362
|
|
|
|
|
|
} |
2363
|
|
|
|
|
|
|
2364
|
|
|
|
|
|
void |
2365
|
27164
|
|
|
|
|
Perl_vivify_defelem(pTHX_ SV *sv) |
2366
|
|
|
|
|
|
{ |
2367
|
|
|
|
|
|
dVAR; |
2368
|
|
|
|
|
|
MAGIC *mg; |
2369
|
|
|
|
|
|
SV *value = NULL; |
2370
|
|
|
|
|
|
|
2371
|
|
|
|
|
|
PERL_ARGS_ASSERT_VIVIFY_DEFELEM; |
2372
|
|
|
|
|
|
|
2373
|
54304
|
100
|
|
|
|
if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem))) |
|
|
50
|
|
|
|
|
2374
|
27156
|
|
|
|
|
return; |
2375
|
27140
|
100
|
|
|
|
if (mg->mg_obj) { |
2376
|
522
|
|
|
|
|
SV * const ahv = LvTARG(sv); |
2377
|
522
|
|
|
|
|
HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, TRUE, 0); |
2378
|
522
|
50
|
|
|
|
if (he) |
2379
|
522
|
|
|
|
|
value = HeVAL(he); |
2380
|
522
|
50
|
|
|
|
if (!value || value == &PL_sv_undef) |
|
|
50
|
|
|
|
|
2381
|
0
|
|
|
|
|
Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(mg->mg_obj)); |
2382
|
|
|
|
|
|
} |
2383
|
26618
|
100
|
|
|
|
else if (LvSTARGOFF(sv) < 0) |
2384
|
8
|
|
|
|
|
Perl_croak(aTHX_ PL_no_aelem, LvSTARGOFF(sv)); |
2385
|
|
|
|
|
|
else { |
2386
|
26610
|
|
|
|
|
AV *const av = MUTABLE_AV(LvTARG(sv)); |
2387
|
26610
|
100
|
|
|
|
if ((I32)LvTARGLEN(sv) < 0 && LvSTARGOFF(sv) > AvFILL(av)) |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
2388
|
0
|
|
|
|
|
LvTARG(sv) = NULL; /* array can't be extended */ |
2389
|
|
|
|
|
|
else { |
2390
|
26610
|
|
|
|
|
SV* const * const svp = av_fetch(av, LvSTARGOFF(sv), TRUE); |
2391
|
26610
|
50
|
|
|
|
if (!svp || !(value = *svp)) |
|
|
50
|
|
|
|
|
2392
|
0
|
|
|
|
|
Perl_croak(aTHX_ PL_no_aelem, LvSTARGOFF(sv)); |
2393
|
|
|
|
|
|
} |
2394
|
|
|
|
|
|
} |
2395
|
27132
|
50
|
|
|
|
SvREFCNT_inc_simple_void(value); |
2396
|
27132
|
|
|
|
|
SvREFCNT_dec(LvTARG(sv)); |
2397
|
27132
|
|
|
|
|
LvTARG(sv) = value; |
2398
|
27132
|
|
|
|
|
LvTARGLEN(sv) = 0; |
2399
|
27132
|
|
|
|
|
SvREFCNT_dec(mg->mg_obj); |
2400
|
27132
|
|
|
|
|
mg->mg_obj = NULL; |
2401
|
27132
|
|
|
|
|
mg->mg_flags &= ~MGf_REFCOUNTED; |
2402
|
|
|
|
|
|
} |
2403
|
|
|
|
|
|
|
2404
|
|
|
|
|
|
int |
2405
|
1550402
|
|
|
|
|
Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg) |
2406
|
|
|
|
|
|
{ |
2407
|
|
|
|
|
|
PERL_ARGS_ASSERT_MAGIC_KILLBACKREFS; |
2408
|
1550402
|
|
|
|
|
Perl_sv_kill_backrefs(aTHX_ sv, MUTABLE_AV(mg->mg_obj)); |
2409
|
1550402
|
|
|
|
|
return 0; |
2410
|
|
|
|
|
|
} |
2411
|
|
|
|
|
|
|
2412
|
|
|
|
|
|
int |
2413
|
4621591
|
|
|
|
|
Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg) |
2414
|
|
|
|
|
|
{ |
2415
|
|
|
|
|
|
PERL_ARGS_ASSERT_MAGIC_SETMGLOB; |
2416
|
|
|
|
|
|
PERL_UNUSED_CONTEXT; |
2417
|
|
|
|
|
|
PERL_UNUSED_ARG(sv); |
2418
|
4621591
|
|
|
|
|
mg->mg_len = -1; |
2419
|
4621591
|
|
|
|
|
return 0; |
2420
|
|
|
|
|
|
} |
2421
|
|
|
|
|
|
|
2422
|
|
|
|
|
|
int |
2423
|
40106
|
|
|
|
|
Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg) |
2424
|
|
|
|
|
|
{ |
2425
|
40106
|
|
|
|
|
const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr; |
2426
|
|
|
|
|
|
|
2427
|
|
|
|
|
|
PERL_ARGS_ASSERT_MAGIC_SETUVAR; |
2428
|
|
|
|
|
|
|
2429
|
40106
|
50
|
|
|
|
if (uf && uf->uf_set) |
|
|
100
|
|
|
|
|
2430
|
40102
|
|
|
|
|
(*uf->uf_set)(aTHX_ uf->uf_index, sv); |
2431
|
40106
|
|
|
|
|
return 0; |
2432
|
|
|
|
|
|
} |
2433
|
|
|
|
|
|
|
2434
|
|
|
|
|
|
int |
2435
|
252
|
|
|
|
|
Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg) |
2436
|
|
|
|
|
|
{ |
2437
|
252
|
|
|
|
|
const char type = mg->mg_type; |
2438
|
|
|
|
|
|
|
2439
|
|
|
|
|
|
PERL_ARGS_ASSERT_MAGIC_SETREGEXP; |
2440
|
|
|
|
|
|
|
2441
|
252
|
50
|
|
|
|
if (type == PERL_MAGIC_qr) { |
2442
|
252
|
50
|
|
|
|
} else if (type == PERL_MAGIC_bm) { |
2443
|
0
|
|
|
|
|
SvTAIL_off(sv); |
2444
|
0
|
|
|
|
|
SvVALID_off(sv); |
2445
|
|
|
|
|
|
} else { |
2446
|
|
|
|
|
|
assert(type == PERL_MAGIC_fm); |
2447
|
|
|
|
|
|
} |
2448
|
252
|
|
|
|
|
return sv_unmagic(sv, type); |
2449
|
|
|
|
|
|
} |
2450
|
|
|
|
|
|
|
2451
|
|
|
|
|
|
#ifdef USE_LOCALE_COLLATE |
2452
|
|
|
|
|
|
int |
2453
|
0
|
|
|
|
|
Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg) |
2454
|
|
|
|
|
|
{ |
2455
|
|
|
|
|
|
PERL_ARGS_ASSERT_MAGIC_SETCOLLXFRM; |
2456
|
|
|
|
|
|
|
2457
|
|
|
|
|
|
/* |
2458
|
|
|
|
|
|
* RenE Descartes said "I think not." |
2459
|
|
|
|
|
|
* and vanished with a faint plop. |
2460
|
|
|
|
|
|
*/ |
2461
|
|
|
|
|
|
PERL_UNUSED_CONTEXT; |
2462
|
|
|
|
|
|
PERL_UNUSED_ARG(sv); |
2463
|
0
|
0
|
|
|
|
if (mg->mg_ptr) { |
2464
|
0
|
|
|
|
|
Safefree(mg->mg_ptr); |
2465
|
0
|
|
|
|
|
mg->mg_ptr = NULL; |
2466
|
0
|
|
|
|
|
mg->mg_len = -1; |
2467
|
|
|
|
|
|
} |
2468
|
0
|
|
|
|
|
return 0; |
2469
|
|
|
|
|
|
} |
2470
|
|
|
|
|
|
#endif /* USE_LOCALE_COLLATE */ |
2471
|
|
|
|
|
|
|
2472
|
|
|
|
|
|
/* Just clear the UTF-8 cache data. */ |
2473
|
|
|
|
|
|
int |
2474
|
103680
|
|
|
|
|
Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg) |
2475
|
|
|
|
|
|
{ |
2476
|
|
|
|
|
|
PERL_ARGS_ASSERT_MAGIC_SETUTF8; |
2477
|
|
|
|
|
|
PERL_UNUSED_CONTEXT; |
2478
|
|
|
|
|
|
PERL_UNUSED_ARG(sv); |
2479
|
103680
|
|
|
|
|
Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */ |
2480
|
103680
|
|
|
|
|
mg->mg_ptr = NULL; |
2481
|
51840
|
|
|
|
|
mg->mg_len = -1; /* The mg_len holds the len cache. */ |
2482
|
103680
|
|
|
|
|
return 0; |
2483
|
|
|
|
|
|
} |
2484
|
|
|
|
|
|
|
2485
|
|
|
|
|
|
int |
2486
|
29860388
|
|
|
|
|
Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) |
2487
|
|
|
|
|
|
{ |
2488
|
|
|
|
|
|
dVAR; |
2489
|
|
|
|
|
|
const char *s; |
2490
|
|
|
|
|
|
I32 paren; |
2491
|
|
|
|
|
|
const REGEXP * rx; |
2492
|
29860388
|
|
|
|
|
const char * const remaining = mg->mg_ptr + 1; |
2493
|
|
|
|
|
|
I32 i; |
2494
|
|
|
|
|
|
STRLEN len; |
2495
|
|
|
|
|
|
MAGIC *tmg; |
2496
|
|
|
|
|
|
|
2497
|
|
|
|
|
|
PERL_ARGS_ASSERT_MAGIC_SET; |
2498
|
|
|
|
|
|
|
2499
|
29860388
|
|
|
|
|
switch (*mg->mg_ptr) { |
2500
|
|
|
|
|
|
case '\015': /* $^MATCH */ |
2501
|
0
|
0
|
|
|
|
if (strEQ(remaining, "ATCH")) |
2502
|
|
|
|
|
|
goto do_match; |
2503
|
|
|
|
|
|
case '`': /* ${^PREMATCH} caught below */ |
2504
|
|
|
|
|
|
do_prematch: |
2505
|
|
|
|
|
|
paren = RX_BUFF_IDX_PREMATCH; |
2506
|
|
|
|
|
|
goto setparen; |
2507
|
|
|
|
|
|
case '\'': /* ${^POSTMATCH} caught below */ |
2508
|
|
|
|
|
|
do_postmatch: |
2509
|
|
|
|
|
|
paren = RX_BUFF_IDX_POSTMATCH; |
2510
|
0
|
|
|
|
|
goto setparen; |
2511
|
|
|
|
|
|
case '&': |
2512
|
|
|
|
|
|
do_match: |
2513
|
|
|
|
|
|
paren = RX_BUFF_IDX_FULLMATCH; |
2514
|
0
|
|
|
|
|
goto setparen; |
2515
|
|
|
|
|
|
case '1': case '2': case '3': case '4': |
2516
|
|
|
|
|
|
case '5': case '6': case '7': case '8': case '9': |
2517
|
297568
|
|
|
|
|
paren = atoi(mg->mg_ptr); |
2518
|
|
|
|
|
|
setparen: |
2519
|
297568
|
100
|
|
|
|
if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { |
|
|
50
|
|
|
|
|
2520
|
|
|
|
|
|
setparen_got_rx: |
2521
|
294292
|
|
|
|
|
CALLREG_NUMBUF_STORE((REGEXP * const)rx,paren,sv); |
2522
|
|
|
|
|
|
} else { |
2523
|
|
|
|
|
|
/* Croak with a READONLY error when a numbered match var is |
2524
|
|
|
|
|
|
* set without a previous pattern match. Unless it's C |
2525
|
|
|
|
|
|
*/ |
2526
|
|
|
|
|
|
croakparen: |
2527
|
3276
|
100
|
|
|
|
if (!PL_localizing) { |
2528
|
8
|
|
|
|
|
Perl_croak_no_modify(); |
2529
|
|
|
|
|
|
} |
2530
|
|
|
|
|
|
} |
2531
|
|
|
|
|
|
break; |
2532
|
|
|
|
|
|
case '\001': /* ^A */ |
2533
|
3194
|
100
|
|
|
|
if (SvOK(sv)) sv_copypv(PL_bodytarget, sv); |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
2534
|
1598
|
100
|
|
|
|
else SvOK_off(PL_bodytarget); |
2535
|
3194
|
|
|
|
|
FmLINES(PL_bodytarget) = 0; |
2536
|
3194
|
100
|
|
|
|
if (SvPOK(PL_bodytarget)) { |
2537
|
1596
|
|
|
|
|
char *s = SvPVX(PL_bodytarget); |
2538
|
2414
|
100
|
|
|
|
while ( ((s = strchr(s, '\n'))) ) { |
2539
|
20
|
|
|
|
|
FmLINES(PL_bodytarget)++; |
2540
|
20
|
|
|
|
|
s++; |
2541
|
|
|
|
|
|
} |
2542
|
|
|
|
|
|
} |
2543
|
|
|
|
|
|
/* mg_set() has temporarily made sv non-magical */ |
2544
|
3194
|
50
|
|
|
|
if (TAINTING_get) { |
2545
|
0
|
0
|
|
|
|
if ((tmg = mg_find(sv,PERL_MAGIC_taint)) && tmg->mg_len & 1) |
|
|
0
|
|
|
|
|
2546
|
0
|
0
|
|
|
|
SvTAINTED_on(PL_bodytarget); |
2547
|
|
|
|
|
|
else |
2548
|
0
|
0
|
|
|
|
SvTAINTED_off(PL_bodytarget); |
2549
|
|
|
|
|
|
} |
2550
|
|
|
|
|
|
break; |
2551
|
|
|
|
|
|
case '\003': /* ^C */ |
2552
|
8
|
100
|
|
|
|
PL_minus_c = cBOOL(SvIV(sv)); |
2553
|
8
|
|
|
|
|
break; |
2554
|
|
|
|
|
|
|
2555
|
|
|
|
|
|
case '\004': /* ^D */ |
2556
|
|
|
|
|
|
#ifdef DEBUGGING |
2557
|
|
|
|
|
|
s = SvPV_nolen_const(sv); |
2558
|
|
|
|
|
|
PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG; |
2559
|
|
|
|
|
|
if (DEBUG_x_TEST || DEBUG_B_TEST) |
2560
|
|
|
|
|
|
dump_all_perl(!DEBUG_B_TEST); |
2561
|
|
|
|
|
|
#else |
2562
|
388
|
50
|
|
|
|
PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG; |
2563
|
|
|
|
|
|
#endif |
2564
|
388
|
|
|
|
|
break; |
2565
|
|
|
|
|
|
case '\005': /* ^E */ |
2566
|
171852
|
100
|
|
|
|
if (*(mg->mg_ptr+1) == '\0') { |
2567
|
|
|
|
|
|
#ifdef VMS |
2568
|
|
|
|
|
|
set_vaxc_errno(SvIV(sv)); |
2569
|
|
|
|
|
|
#else |
2570
|
|
|
|
|
|
# ifdef WIN32 |
2571
|
|
|
|
|
|
SetLastError( SvIV(sv) ); |
2572
|
|
|
|
|
|
# else |
2573
|
|
|
|
|
|
# ifdef OS2 |
2574
|
|
|
|
|
|
os2_setsyserrno(SvIV(sv)); |
2575
|
|
|
|
|
|
# else |
2576
|
|
|
|
|
|
/* will anyone ever use this? */ |
2577
|
141972
|
100
|
|
|
|
SETERRNO(SvIV(sv), 4); |
2578
|
|
|
|
|
|
# endif |
2579
|
|
|
|
|
|
# endif |
2580
|
|
|
|
|
|
#endif |
2581
|
|
|
|
|
|
} |
2582
|
29880
|
50
|
|
|
|
else if (strEQ(mg->mg_ptr+1, "NCODING")) { |
2583
|
29880
|
|
|
|
|
SvREFCNT_dec(PL_encoding); |
2584
|
29880
|
100
|
|
|
|
if (SvOK(sv) || SvGMAGICAL(sv)) { |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
2585
|
11530
|
|
|
|
|
PL_encoding = newSVsv(sv); |
2586
|
|
|
|
|
|
} |
2587
|
|
|
|
|
|
else { |
2588
|
18350
|
|
|
|
|
PL_encoding = NULL; |
2589
|
|
|
|
|
|
} |
2590
|
|
|
|
|
|
} |
2591
|
|
|
|
|
|
break; |
2592
|
|
|
|
|
|
case '\006': /* ^F */ |
2593
|
1294
|
100
|
|
|
|
PL_maxsysfd = SvIV(sv); |
2594
|
1294
|
|
|
|
|
break; |
2595
|
|
|
|
|
|
case '\010': /* ^H */ |
2596
|
2240448
|
100
|
|
|
|
PL_hints = SvIV(sv); |
2597
|
2240448
|
|
|
|
|
break; |
2598
|
|
|
|
|
|
case '\011': /* ^I */ /* NOT \t in EBCDIC */ |
2599
|
46
|
|
|
|
|
Safefree(PL_inplace); |
2600
|
46
|
100
|
|
|
|
PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL; |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
2601
|
46
|
|
|
|
|
break; |
2602
|
|
|
|
|
|
case '\016': /* ^N */ |
2603
|
0
|
0
|
|
|
|
if (PL_curpm && (rx = PM_GETRE(PL_curpm)) |
|
|
0
|
|
|
|
|
2604
|
0
|
0
|
|
|
|
&& (paren = RX_LASTCLOSEPAREN(rx))) goto setparen_got_rx; |
2605
|
|
|
|
|
|
goto croakparen; |
2606
|
|
|
|
|
|
case '\017': /* ^O */ |
2607
|
646
|
100
|
|
|
|
if (*(mg->mg_ptr+1) == '\0') { |
2608
|
214
|
|
|
|
|
Safefree(PL_osname); |
2609
|
214
|
|
|
|
|
PL_osname = NULL; |
2610
|
214
|
100
|
|
|
|
if (SvOK(sv)) { |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
2611
|
210
|
100
|
|
|
|
TAINT_PROPER("assigning to $^O"); |
2612
|
210
|
|
|
|
|
PL_osname = savesvpv(sv); |
2613
|
|
|
|
|
|
} |
2614
|
|
|
|
|
|
} |
2615
|
432
|
50
|
|
|
|
else if (strEQ(mg->mg_ptr, "\017PEN")) { |
2616
|
|
|
|
|
|
STRLEN len; |
2617
|
432
|
50
|
|
|
|
const char *const start = SvPV(sv, len); |
2618
|
432
|
|
|
|
|
const char *out = (const char*)memchr(start, '\0', len); |
2619
|
|
|
|
|
|
SV *tmp; |
2620
|
|
|
|
|
|
|
2621
|
|
|
|
|
|
|
2622
|
432
|
|
|
|
|
PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT; |
2623
|
432
|
|
|
|
|
PL_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT; |
2624
|
|
|
|
|
|
|
2625
|
|
|
|
|
|
/* Opening for input is more common than opening for output, so |
2626
|
|
|
|
|
|
ensure that hints for input are sooner on linked list. */ |
2627
|
432
|
|
|
|
|
tmp = out ? newSVpvn_flags(out + 1, start + len - out - 1, |
2628
|
|
|
|
|
|
SvUTF8(sv)) |
2629
|
648
|
50
|
|
|
|
: newSVpvs_flags("", SvUTF8(sv)); |
2630
|
432
|
|
|
|
|
(void)hv_stores(GvHV(PL_hintgv), "open>", tmp); |
2631
|
432
|
|
|
|
|
mg_set(tmp); |
2632
|
|
|
|
|
|
|
2633
|
432
|
50
|
|
|
|
tmp = newSVpvn_flags(start, out ? (STRLEN)(out - start) : len, |
2634
|
|
|
|
|
|
SvUTF8(sv)); |
2635
|
432
|
|
|
|
|
(void)hv_stores(GvHV(PL_hintgv), "open<", tmp); |
2636
|
432
|
|
|
|
|
mg_set(tmp); |
2637
|
|
|
|
|
|
} |
2638
|
|
|
|
|
|
break; |
2639
|
|
|
|
|
|
case '\020': /* ^P */ |
2640
|
4762
|
50
|
|
|
|
if (*remaining == '\0') { /* ^P */ |
2641
|
4762
|
100
|
|
|
|
PL_perldb = SvIV(sv); |
2642
|
4762
|
100
|
|
|
|
if (PL_perldb && !PL_DBsingle) |
|
|
100
|
|
|
|
|
2643
|
4678
|
|
|
|
|
init_debugger(); |
2644
|
|
|
|
|
|
break; |
2645
|
0
|
0
|
|
|
|
} else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */ |
2646
|
|
|
|
|
|
goto do_prematch; |
2647
|
0
|
0
|
|
|
|
} else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */ |
2648
|
|
|
|
|
|
goto do_postmatch; |
2649
|
|
|
|
|
|
} |
2650
|
|
|
|
|
|
break; |
2651
|
|
|
|
|
|
case '\024': /* ^T */ |
2652
|
|
|
|
|
|
#ifdef BIG_TIME |
2653
|
|
|
|
|
|
PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv)); |
2654
|
|
|
|
|
|
#else |
2655
|
0
|
0
|
|
|
|
PL_basetime = (Time_t)SvIV(sv); |
2656
|
|
|
|
|
|
#endif |
2657
|
0
|
|
|
|
|
break; |
2658
|
|
|
|
|
|
case '\025': /* ^UTF8CACHE */ |
2659
|
36
|
50
|
|
|
|
if (strEQ(mg->mg_ptr+1, "TF8CACHE")) { |
2660
|
36
|
|
|
|
|
PL_utf8cache = (signed char) sv_2iv(sv); |
2661
|
|
|
|
|
|
} |
2662
|
|
|
|
|
|
break; |
2663
|
|
|
|
|
|
case '\027': /* ^W & $^WARNING_BITS */ |
2664
|
16831824
|
100
|
|
|
|
if (*(mg->mg_ptr+1) == '\0') { |
2665
|
16463772
|
100
|
|
|
|
if ( ! (PL_dowarn & G_WARN_ALL_MASK)) { |
2666
|
16460234
|
100
|
|
|
|
i = SvIV(sv); |
2667
|
24690351
|
|
|
|
|
PL_dowarn = (PL_dowarn & ~G_WARN_ON) |
2668
|
16460234
|
|
|
|
|
| (i ? G_WARN_ON : G_WARN_OFF) ; |
2669
|
|
|
|
|
|
} |
2670
|
|
|
|
|
|
} |
2671
|
368052
|
50
|
|
|
|
else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) { |
2672
|
368052
|
100
|
|
|
|
if ( ! (PL_dowarn & G_WARN_ALL_MASK)) { |
2673
|
367822
|
100
|
|
|
|
if (!SvPOK(sv)) { |
2674
|
8
|
|
|
|
|
PL_compiling.cop_warnings = pWARN_STD; |
2675
|
8
|
|
|
|
|
break; |
2676
|
|
|
|
|
|
} |
2677
|
|
|
|
|
|
{ |
2678
|
|
|
|
|
|
STRLEN len, i; |
2679
|
|
|
|
|
|
int accumulate = 0 ; |
2680
|
|
|
|
|
|
int any_fatals = 0 ; |
2681
|
367814
|
50
|
|
|
|
const char * const ptr = SvPV_const(sv, len) ; |
2682
|
5900894
|
100
|
|
|
|
for (i = 0 ; i < len ; ++i) { |
2683
|
5533080
|
|
|
|
|
accumulate |= ptr[i] ; |
2684
|
5533080
|
|
|
|
|
any_fatals |= (ptr[i] & 0xAA) ; |
2685
|
|
|
|
|
|
} |
2686
|
367814
|
100
|
|
|
|
if (!accumulate) { |
2687
|
5482
|
100
|
|
|
|
if (!specialWARN(PL_compiling.cop_warnings)) |
|
|
100
|
|
|
|
|
2688
|
100
|
|
|
|
|
PerlMemShared_free(PL_compiling.cop_warnings); |
2689
|
5482
|
|
|
|
|
PL_compiling.cop_warnings = pWARN_NONE; |
2690
|
|
|
|
|
|
} |
2691
|
|
|
|
|
|
/* Yuck. I can't see how to abstract this: */ |
2692
|
362332
|
50
|
|
|
|
else if (isWARN_on( |
|
|
100
|
|
|
|
|
2693
|
|
|
|
|
|
((STRLEN *)SvPV_nolen_const(sv)) - 1, |
2694
|
|
|
|
|
|
WARN_ALL) |
2695
|
212676
|
100
|
|
|
|
&& !any_fatals) |
2696
|
|
|
|
|
|
{ |
2697
|
212510
|
100
|
|
|
|
if (!specialWARN(PL_compiling.cop_warnings)) |
|
|
100
|
|
|
|
|
2698
|
36
|
|
|
|
|
PerlMemShared_free(PL_compiling.cop_warnings); |
2699
|
212510
|
|
|
|
|
PL_compiling.cop_warnings = pWARN_ALL; |
2700
|
212510
|
|
|
|
|
PL_dowarn |= G_WARN_ONCE ; |
2701
|
|
|
|
|
|
} |
2702
|
|
|
|
|
|
else { |
2703
|
|
|
|
|
|
STRLEN len; |
2704
|
149822
|
50
|
|
|
|
const char *const p = SvPV_const(sv, len); |
2705
|
|
|
|
|
|
|
2706
|
|
|
|
|
|
PL_compiling.cop_warnings |
2707
|
149822
|
|
|
|
|
= Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings, |
2708
|
|
|
|
|
|
p, len); |
2709
|
|
|
|
|
|
|
2710
|
149822
|
100
|
|
|
|
if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE)) |
2711
|
122432
|
|
|
|
|
PL_dowarn |= G_WARN_ONCE ; |
2712
|
|
|
|
|
|
} |
2713
|
|
|
|
|
|
|
2714
|
|
|
|
|
|
} |
2715
|
|
|
|
|
|
} |
2716
|
|
|
|
|
|
} |
2717
|
|
|
|
|
|
break; |
2718
|
|
|
|
|
|
case '.': |
2719
|
1531772
|
100
|
|
|
|
if (PL_localizing) { |
2720
|
1510560
|
100
|
|
|
|
if (PL_localizing == 1) |
2721
|
755280
|
|
|
|
|
SAVESPTR(PL_last_in_gv); |
2722
|
|
|
|
|
|
} |
2723
|
21212
|
50
|
|
|
|
else if (SvOK(sv) && GvIO(PL_last_in_gv)) |
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
2724
|
6846
|
50
|
|
|
|
IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv); |
2725
|
|
|
|
|
|
break; |
2726
|
|
|
|
|
|
case '^': |
2727
|
46
|
|
|
|
|
Safefree(IoTOP_NAME(GvIOp(PL_defoutgv))); |
2728
|
46
|
|
|
|
|
s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv); |
2729
|
46
|
|
|
|
|
IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO); |
2730
|
46
|
|
|
|
|
break; |
2731
|
|
|
|
|
|
case '~': |
2732
|
182
|
|
|
|
|
Safefree(IoFMT_NAME(GvIOp(PL_defoutgv))); |
2733
|
182
|
|
|
|
|
s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv); |
2734
|
182
|
|
|
|
|
IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO); |
2735
|
182
|
|
|
|
|
break; |
2736
|
|
|
|
|
|
case '=': |
2737
|
38
|
100
|
|
|
|
IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv)); |
2738
|
38
|
|
|
|
|
break; |
2739
|
|
|
|
|
|
case '-': |
2740
|
12
|
50
|
|
|
|
IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv)); |
2741
|
12
|
50
|
|
|
|
if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L) |
2742
|
0
|
|
|
|
|
IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L; |
2743
|
|
|
|
|
|
break; |
2744
|
|
|
|
|
|
case '%': |
2745
|
2
|
50
|
|
|
|
IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv)); |
2746
|
2
|
|
|
|
|
break; |
2747
|
|
|
|
|
|
case '|': |
2748
|
|
|
|
|
|
{ |
2749
|
25998
|
50
|
|
|
|
IO * const io = GvIO(PL_defoutgv); |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
2750
|
25998
|
50
|
|
|
|
if(!io) |
2751
|
|
|
|
|
|
break; |
2752
|
25998
|
100
|
|
|
|
if ((SvIV(sv)) == 0) |
|
|
100
|
|
|
|
|
2753
|
1234
|
|
|
|
|
IoFLAGS(io) &= ~IOf_FLUSH; |
2754
|
|
|
|
|
|
else { |
2755
|
24764
|
100
|
|
|
|
if (!(IoFLAGS(io) & IOf_FLUSH)) { |
2756
|
20072
|
|
|
|
|
PerlIO *ofp = IoOFP(io); |
2757
|
20072
|
100
|
|
|
|
if (ofp) |
2758
|
19758
|
|
|
|
|
(void)PerlIO_flush(ofp); |
2759
|
20072
|
|
|
|
|
IoFLAGS(io) |= IOf_FLUSH; |
2760
|
|
|
|
|
|
} |
2761
|
|
|
|
|
|
} |
2762
|
|
|
|
|
|
} |
2763
|
|
|
|
|
|
break; |
2764
|
|
|
|
|
|
case '/': |
2765
|
658050
|
|
|
|
|
SvREFCNT_dec(PL_rs); |
2766
|
658050
|
|
|
|
|
PL_rs = newSVsv(sv); |
2767
|
658050
|
|
|
|
|
break; |
2768
|
|
|
|
|
|
case '\\': |
2769
|
3217944
|
|
|
|
|
SvREFCNT_dec(PL_ors_sv); |
2770
|
3217944
|
100
|
|
|
|
if (SvOK(sv)) { |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
2771
|
44280
|
|
|
|
|
PL_ors_sv = newSVsv(sv); |
2772
|
|
|
|
|
|
} |
2773
|
|
|
|
|
|
else { |
2774
|
3173664
|
|
|
|
|
PL_ors_sv = NULL; |
2775
|
|
|
|
|
|
} |
2776
|
|
|
|
|
|
break; |
2777
|
|
|
|
|
|
case '[': |
2778
|
2
|
50
|
|
|
|
if (SvIV(sv) != 0) |
|
|
50
|
|
|
|
|
2779
|
2
|
|
|
|
|
Perl_croak(aTHX_ "Assigning non-zero to $[ is no longer possible"); |
2780
|
|
|
|
|
|
break; |
2781
|
|
|
|
|
|
case '?': |
2782
|
|
|
|
|
|
#ifdef COMPLEX_STATUS |
2783
|
|
|
|
|
|
if (PL_localizing == 2) { |
2784
|
|
|
|
|
|
SvUPGRADE(sv, SVt_PVLV); |
2785
|
|
|
|
|
|
PL_statusvalue = LvTARGOFF(sv); |
2786
|
|
|
|
|
|
PL_statusvalue_vms = LvTARGLEN(sv); |
2787
|
|
|
|
|
|
} |
2788
|
|
|
|
|
|
else |
2789
|
|
|
|
|
|
#endif |
2790
|
|
|
|
|
|
#ifdef VMSISH_STATUS |
2791
|
|
|
|
|
|
if (VMSISH_STATUS) |
2792
|
|
|
|
|
|
STATUS_NATIVE_CHILD_SET((U32)SvIV(sv)); |
2793
|
|
|
|
|
|
else |
2794
|
|
|
|
|
|
#endif |
2795
|
68170
|
100
|
|
|
|
STATUS_UNIX_EXIT_SET(SvIV(sv)); |
|
|
100
|
|
|
|
|
2796
|
|
|
|
|
|
break; |
2797
|
|
|
|
|
|
case '!': |
2798
|
|
|
|
|
|
{ |
2799
|
|
|
|
|
|
#ifdef VMS |
2800
|
|
|
|
|
|
# define PERL_VMS_BANG vaxc$errno |
2801
|
|
|
|
|
|
#else |
2802
|
|
|
|
|
|
# define PERL_VMS_BANG 0 |
2803
|
|
|
|
|
|
#endif |
2804
|
4805852
|
100
|
|
|
|
SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0, |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
2805
|
|
|
|
|
|
(SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG); |
2806
|
|
|
|
|
|
} |
2807
|
4805852
|
|
|
|
|
break; |
2808
|
|
|
|
|
|
case '<': |
2809
|
|
|
|
|
|
{ |
2810
|
0
|
0
|
|
|
|
const Uid_t new_uid = SvUID(sv); |
2811
|
0
|
|
|
|
|
PL_delaymagic_uid = new_uid; |
2812
|
0
|
0
|
|
|
|
if (PL_delaymagic) { |
2813
|
0
|
|
|
|
|
PL_delaymagic |= DM_RUID; |
2814
|
0
|
|
|
|
|
break; /* don't do magic till later */ |
2815
|
|
|
|
|
|
} |
2816
|
|
|
|
|
|
#ifdef HAS_SETRUID |
2817
|
|
|
|
|
|
(void)setruid(new_uid); |
2818
|
|
|
|
|
|
#else |
2819
|
|
|
|
|
|
#ifdef HAS_SETREUID |
2820
|
0
|
|
|
|
|
(void)setreuid(new_uid, (Uid_t)-1); |
2821
|
|
|
|
|
|
#else |
2822
|
|
|
|
|
|
#ifdef HAS_SETRESUID |
2823
|
|
|
|
|
|
(void)setresuid(new_uid, (Uid_t)-1, (Uid_t)-1); |
2824
|
|
|
|
|
|
#else |
2825
|
|
|
|
|
|
if (new_uid == PerlProc_geteuid()) { /* special case $< = $> */ |
2826
|
|
|
|
|
|
#ifdef PERL_DARWIN |
2827
|
|
|
|
|
|
/* workaround for Darwin's setuid peculiarity, cf [perl #24122] */ |
2828
|
|
|
|
|
|
if (new_uid != 0 && PerlProc_getuid() == 0) |
2829
|
|
|
|
|
|
(void)PerlProc_setuid(0); |
2830
|
|
|
|
|
|
#endif |
2831
|
|
|
|
|
|
(void)PerlProc_setuid(new_uid); |
2832
|
|
|
|
|
|
} else { |
2833
|
|
|
|
|
|
Perl_croak(aTHX_ "setruid() not implemented"); |
2834
|
|
|
|
|
|
} |
2835
|
|
|
|
|
|
#endif |
2836
|
|
|
|
|
|
#endif |
2837
|
|
|
|
|
|
#endif |
2838
|
0
|
|
|
|
|
break; |
2839
|
|
|
|
|
|
} |
2840
|
|
|
|
|
|
case '>': |
2841
|
|
|
|
|
|
{ |
2842
|
8
|
50
|
|
|
|
const Uid_t new_euid = SvUID(sv); |
2843
|
8
|
|
|
|
|
PL_delaymagic_euid = new_euid; |
2844
|
8
|
50
|
|
|
|
if (PL_delaymagic) { |
2845
|
0
|
|
|
|
|
PL_delaymagic |= DM_EUID; |
2846
|
0
|
|
|
|
|
break; /* don't do magic till later */ |
2847
|
|
|
|
|
|
} |
2848
|
|
|
|
|
|
#ifdef HAS_SETEUID |
2849
|
8
|
|
|
|
|
(void)seteuid(new_euid); |
2850
|
|
|
|
|
|
#else |
2851
|
|
|
|
|
|
#ifdef HAS_SETREUID |
2852
|
|
|
|
|
|
(void)setreuid((Uid_t)-1, new_euid); |
2853
|
|
|
|
|
|
#else |
2854
|
|
|
|
|
|
#ifdef HAS_SETRESUID |
2855
|
|
|
|
|
|
(void)setresuid((Uid_t)-1, new_euid, (Uid_t)-1); |
2856
|
|
|
|
|
|
#else |
2857
|
|
|
|
|
|
if (new_euid == PerlProc_getuid()) /* special case $> = $< */ |
2858
|
|
|
|
|
|
PerlProc_setuid(new_euid); |
2859
|
|
|
|
|
|
else { |
2860
|
|
|
|
|
|
Perl_croak(aTHX_ "seteuid() not implemented"); |
2861
|
|
|
|
|
|
} |
2862
|
|
|
|
|
|
#endif |
2863
|
|
|
|
|
|
#endif |
2864
|
|
|
|
|
|
#endif |
2865
|
8
|
|
|
|
|
break; |
2866
|
|
|
|
|
|
} |
2867
|
|
|
|
|
|
case '(': |
2868
|
|
|
|
|
|
{ |
2869
|
0
|
0
|
|
|
|
const Gid_t new_gid = SvGID(sv); |
2870
|
0
|
|
|
|
|
PL_delaymagic_gid = new_gid; |
2871
|
0
|
0
|
|
|
|
if (PL_delaymagic) { |
2872
|
0
|
|
|
|
|
PL_delaymagic |= DM_RGID; |
2873
|
0
|
|
|
|
|
break; /* don't do magic till later */ |
2874
|
|
|
|
|
|
} |
2875
|
|
|
|
|
|
#ifdef HAS_SETRGID |
2876
|
|
|
|
|
|
(void)setrgid(new_gid); |
2877
|
|
|
|
|
|
#else |
2878
|
|
|
|
|
|
#ifdef HAS_SETREGID |
2879
|
0
|
|
|
|
|
(void)setregid(new_gid, (Gid_t)-1); |
2880
|
|
|
|
|
|
#else |
2881
|
|
|
|
|
|
#ifdef HAS_SETRESGID |
2882
|
|
|
|
|
|
(void)setresgid(new_gid, (Gid_t)-1, (Gid_t) -1); |
2883
|
|
|
|
|
|
#else |
2884
|
|
|
|
|
|
if (new_gid == PerlProc_getegid()) /* special case $( = $) */ |
2885
|
|
|
|
|
|
(void)PerlProc_setgid(new_gid); |
2886
|
|
|
|
|
|
else { |
2887
|
|
|
|
|
|
Perl_croak(aTHX_ "setrgid() not implemented"); |
2888
|
|
|
|
|
|
} |
2889
|
|
|
|
|
|
#endif |
2890
|
|
|
|
|
|
#endif |
2891
|
|
|
|
|
|
#endif |
2892
|
0
|
|
|
|
|
break; |
2893
|
|
|
|
|
|
} |
2894
|
|
|
|
|
|
case ')': |
2895
|
|
|
|
|
|
{ |
2896
|
|
|
|
|
|
Gid_t new_egid; |
2897
|
|
|
|
|
|
#ifdef HAS_SETGROUPS |
2898
|
|
|
|
|
|
{ |
2899
|
0
|
0
|
|
|
|
const char *p = SvPV_const(sv, len); |
2900
|
|
|
|
|
|
Groups_t *gary = NULL; |
2901
|
|
|
|
|
|
#ifdef _SC_NGROUPS_MAX |
2902
|
0
|
|
|
|
|
int maxgrp = sysconf(_SC_NGROUPS_MAX); |
2903
|
|
|
|
|
|
|
2904
|
0
|
0
|
|
|
|
if (maxgrp < 0) |
2905
|
|
|
|
|
|
maxgrp = NGROUPS; |
2906
|
|
|
|
|
|
#else |
2907
|
|
|
|
|
|
int maxgrp = NGROUPS; |
2908
|
|
|
|
|
|
#endif |
2909
|
|
|
|
|
|
|
2910
|
0
|
0
|
|
|
|
while (isSPACE(*p)) |
2911
|
0
|
|
|
|
|
++p; |
2912
|
0
|
|
|
|
|
new_egid = (Gid_t)Atol(p); |
2913
|
0
|
0
|
|
|
|
for (i = 0; i < maxgrp; ++i) { |
2914
|
0
|
0
|
|
|
|
while (*p && !isSPACE(*p)) |
|
|
0
|
|
|
|
|
2915
|
0
|
|
|
|
|
++p; |
2916
|
0
|
0
|
|
|
|
while (isSPACE(*p)) |
2917
|
0
|
|
|
|
|
++p; |
2918
|
0
|
0
|
|
|
|
if (!*p) |
2919
|
|
|
|
|
|
break; |
2920
|
0
|
0
|
|
|
|
if(!gary) |
2921
|
0
|
0
|
|
|
|
Newx(gary, i + 1, Groups_t); |
2922
|
|
|
|
|
|
else |
2923
|
0
|
0
|
|
|
|
Renew(gary, i + 1, Groups_t); |
2924
|
0
|
|
|
|
|
gary[i] = (Groups_t)Atol(p); |
2925
|
|
|
|
|
|
} |
2926
|
0
|
0
|
|
|
|
if (i) |
2927
|
0
|
|
|
|
|
(void)setgroups(i, gary); |
2928
|
0
|
|
|
|
|
Safefree(gary); |
2929
|
|
|
|
|
|
} |
2930
|
|
|
|
|
|
#else /* HAS_SETGROUPS */ |
2931
|
|
|
|
|
|
new_egid = SvGID(sv); |
2932
|
|
|
|
|
|
#endif /* HAS_SETGROUPS */ |
2933
|
0
|
|
|
|
|
PL_delaymagic_egid = new_egid; |
2934
|
0
|
0
|
|
|
|
if (PL_delaymagic) { |
2935
|
0
|
|
|
|
|
PL_delaymagic |= DM_EGID; |
2936
|
0
|
|
|
|
|
break; /* don't do magic till later */ |
2937
|
|
|
|
|
|
} |
2938
|
|
|
|
|
|
#ifdef HAS_SETEGID |
2939
|
0
|
|
|
|
|
(void)setegid(new_egid); |
2940
|
|
|
|
|
|
#else |
2941
|
|
|
|
|
|
#ifdef HAS_SETREGID |
2942
|
|
|
|
|
|
(void)setregid((Gid_t)-1, new_egid); |
2943
|
|
|
|
|
|
#else |
2944
|
|
|
|
|
|
#ifdef HAS_SETRESGID |
2945
|
|
|
|
|
|
(void)setresgid((Gid_t)-1, new_egid, (Gid_t)-1); |
2946
|
|
|
|
|
|
#else |
2947
|
|
|
|
|
|
if (new_egid == PerlProc_getgid()) /* special case $) = $( */ |
2948
|
|
|
|
|
|
(void)PerlProc_setgid(new_egid); |
2949
|
|
|
|
|
|
else { |
2950
|
|
|
|
|
|
Perl_croak(aTHX_ "setegid() not implemented"); |
2951
|
|
|
|
|
|
} |
2952
|
|
|
|
|
|
#endif |
2953
|
|
|
|
|
|
#endif |
2954
|
|
|
|
|
|
#endif |
2955
|
0
|
|
|
|
|
break; |
2956
|
|
|
|
|
|
} |
2957
|
|
|
|
|
|
case ':': |
2958
|
60
|
50
|
|
|
|
PL_chopset = SvPV_force(sv,len); |
2959
|
60
|
|
|
|
|
break; |
2960
|
|
|
|
|
|
case '$': /* $$ */ |
2961
|
|
|
|
|
|
/* Store the pid in mg->mg_obj so we can tell when a fork has |
2962
|
|
|
|
|
|
occurred. mg->mg_obj points to *$ by default, so clear it. */ |
2963
|
2
|
50
|
|
|
|
if (isGV(mg->mg_obj)) { |
2964
|
2
|
50
|
|
|
|
if (mg->mg_flags & MGf_REFCOUNTED) /* probably never true */ |
2965
|
0
|
|
|
|
|
SvREFCNT_dec(mg->mg_obj); |
2966
|
2
|
|
|
|
|
mg->mg_flags |= MGf_REFCOUNTED; |
2967
|
2
|
|
|
|
|
mg->mg_obj = newSViv((IV)PerlProc_getpid()); |
2968
|
|
|
|
|
|
} |
2969
|
0
|
|
|
|
|
else sv_setiv(mg->mg_obj, (IV)PerlProc_getpid()); |
2970
|
|
|
|
|
|
break; |
2971
|
|
|
|
|
|
case '0': |
2972
|
|
|
|
|
|
LOCK_DOLLARZERO_MUTEX; |
2973
|
|
|
|
|
|
#ifdef HAS_SETPROCTITLE |
2974
|
|
|
|
|
|
/* The BSDs don't show the argv[] in ps(1) output, they |
2975
|
|
|
|
|
|
* show a string from the process struct and provide |
2976
|
|
|
|
|
|
* the setproctitle() routine to manipulate that. */ |
2977
|
|
|
|
|
|
if (PL_origalen != 1) { |
2978
|
|
|
|
|
|
s = SvPV_const(sv, len); |
2979
|
|
|
|
|
|
# if __FreeBSD_version > 410001 |
2980
|
|
|
|
|
|
/* The leading "-" removes the "perl: " prefix, |
2981
|
|
|
|
|
|
* but not the "(perl) suffix from the ps(1) |
2982
|
|
|
|
|
|
* output, because that's what ps(1) shows if the |
2983
|
|
|
|
|
|
* argv[] is modified. */ |
2984
|
|
|
|
|
|
setproctitle("-%s", s); |
2985
|
|
|
|
|
|
# else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */ |
2986
|
|
|
|
|
|
/* This doesn't really work if you assume that |
2987
|
|
|
|
|
|
* $0 = 'foobar'; will wipe out 'perl' from the $0 |
2988
|
|
|
|
|
|
* because in ps(1) output the result will be like |
2989
|
|
|
|
|
|
* sprintf("perl: %s (perl)", s) |
2990
|
|
|
|
|
|
* I guess this is a security feature: |
2991
|
|
|
|
|
|
* one (a user process) cannot get rid of the original name. |
2992
|
|
|
|
|
|
* --jhi */ |
2993
|
|
|
|
|
|
setproctitle("%s", s); |
2994
|
|
|
|
|
|
# endif |
2995
|
|
|
|
|
|
} |
2996
|
|
|
|
|
|
#elif defined(__hpux) && defined(PSTAT_SETCMD) |
2997
|
|
|
|
|
|
if (PL_origalen != 1) { |
2998
|
|
|
|
|
|
union pstun un; |
2999
|
|
|
|
|
|
s = SvPV_const(sv, len); |
3000
|
|
|
|
|
|
un.pst_command = (char *)s; |
3001
|
|
|
|
|
|
pstat(PSTAT_SETCMD, un, len, 0, 0); |
3002
|
|
|
|
|
|
} |
3003
|
|
|
|
|
|
#else |
3004
|
184
|
50
|
|
|
|
if (PL_origalen > 1) { |
3005
|
|
|
|
|
|
/* PL_origalen is set in perl_parse(). */ |
3006
|
184
|
100
|
|
|
|
s = SvPV_force(sv,len); |
3007
|
184
|
50
|
|
|
|
if (len >= (STRLEN)PL_origalen-1) { |
3008
|
|
|
|
|
|
/* Longer than original, will be truncated. We assume that |
3009
|
|
|
|
|
|
* PL_origalen bytes are available. */ |
3010
|
0
|
|
|
|
|
Copy(s, PL_origargv[0], PL_origalen-1, char); |
3011
|
|
|
|
|
|
} |
3012
|
|
|
|
|
|
else { |
3013
|
|
|
|
|
|
/* Shorter than original, will be padded. */ |
3014
|
|
|
|
|
|
#ifdef PERL_DARWIN |
3015
|
|
|
|
|
|
/* Special case for Mac OS X: see [perl #38868] */ |
3016
|
|
|
|
|
|
const int pad = 0; |
3017
|
|
|
|
|
|
#else |
3018
|
|
|
|
|
|
/* Is the space counterintuitive? Yes. |
3019
|
|
|
|
|
|
* (You were expecting \0?) |
3020
|
|
|
|
|
|
* Does it work? Seems to. (In Linux 2.4.20 at least.) |
3021
|
|
|
|
|
|
* --jhi */ |
3022
|
|
|
|
|
|
const int pad = ' '; |
3023
|
|
|
|
|
|
#endif |
3024
|
184
|
|
|
|
|
Copy(s, PL_origargv[0], len, char); |
3025
|
184
|
|
|
|
|
PL_origargv[0][len] = 0; |
3026
|
184
|
|
|
|
|
memset(PL_origargv[0] + len + 1, |
3027
|
184
|
|
|
|
|
pad, PL_origalen - len - 1); |
3028
|
|
|
|
|
|
} |
3029
|
184
|
|
|
|
|
PL_origargv[0][PL_origalen-1] = 0; |
3030
|
934
|
100
|
|
|
|
for (i = 1; i < PL_origargc; i++) |
3031
|
750
|
|
|
|
|
PL_origargv[i] = 0; |
3032
|
|
|
|
|
|
#ifdef HAS_PRCTL_SET_NAME |
3033
|
|
|
|
|
|
/* Set the legacy process name in addition to the POSIX name on Linux */ |
3034
|
184
|
50
|
|
|
|
if (prctl(PR_SET_NAME, (unsigned long)s, 0, 0, 0) != 0) { |
3035
|
|
|
|
|
|
/* diag_listed_as: SKIPME */ |
3036
|
0
|
|
|
|
|
Perl_croak(aTHX_ "Can't set $0 with prctl(): %s", Strerror(errno)); |
3037
|
|
|
|
|
|
} |
3038
|
|
|
|
|
|
#endif |
3039
|
|
|
|
|
|
} |
3040
|
|
|
|
|
|
#endif |
3041
|
|
|
|
|
|
UNLOCK_DOLLARZERO_MUTEX; |
3042
|
|
|
|
|
|
break; |
3043
|
|
|
|
|
|
} |
3044
|
29860378
|
|
|
|
|
return 0; |
3045
|
|
|
|
|
|
} |
3046
|
|
|
|
|
|
|
3047
|
|
|
|
|
|
I32 |
3048
|
4
|
|
|
|
|
Perl_whichsig_sv(pTHX_ SV *sigsv) |
3049
|
|
|
|
|
|
{ |
3050
|
|
|
|
|
|
const char *sigpv; |
3051
|
|
|
|
|
|
STRLEN siglen; |
3052
|
|
|
|
|
|
PERL_ARGS_ASSERT_WHICHSIG_SV; |
3053
|
|
|
|
|
|
PERL_UNUSED_CONTEXT; |
3054
|
4
|
50
|
|
|
|
sigpv = SvPV_const(sigsv, siglen); |
3055
|
4
|
|
|
|
|
return whichsig_pvn(sigpv, siglen); |
3056
|
|
|
|
|
|
} |
3057
|
|
|
|
|
|
|
3058
|
|
|
|
|
|
I32 |
3059
|
16
|
|
|
|
|
Perl_whichsig_pv(pTHX_ const char *sig) |
3060
|
|
|
|
|
|
{ |
3061
|
|
|
|
|
|
PERL_ARGS_ASSERT_WHICHSIG_PV; |
3062
|
|
|
|
|
|
PERL_UNUSED_CONTEXT; |
3063
|
16
|
|
|
|
|
return whichsig_pvn(sig, strlen(sig)); |
3064
|
|
|
|
|
|
} |
3065
|
|
|
|
|
|
|
3066
|
|
|
|
|
|
I32 |
3067
|
172492
|
|
|
|
|
Perl_whichsig_pvn(pTHX_ const char *sig, STRLEN len) |
3068
|
|
|
|
|
|
{ |
3069
|
|
|
|
|
|
char* const* sigv; |
3070
|
|
|
|
|
|
|
3071
|
|
|
|
|
|
PERL_ARGS_ASSERT_WHICHSIG_PVN; |
3072
|
|
|
|
|
|
PERL_UNUSED_CONTEXT; |
3073
|
|
|
|
|
|
|
3074
|
11911794
|
100
|
|
|
|
for (sigv = (char* const*)PL_sig_name; *sigv; sigv++) |
3075
|
11742250
|
100
|
|
|
|
if (strlen(*sigv) == len && memEQ(sig,*sigv, len)) |
|
|
100
|
|
|
|
|
3076
|
2948
|
|
|
|
|
return PL_sig_num[sigv - (char* const*)PL_sig_name]; |
3077
|
|
|
|
|
|
#ifdef SIGCLD |
3078
|
169544
|
100
|
|
|
|
if (memEQs(sig, len, "CHLD")) |
|
|
50
|
|
|
|
|
3079
|
|
|
|
|
|
return SIGCLD; |
3080
|
|
|
|
|
|
#endif |
3081
|
|
|
|
|
|
#ifdef SIGCHLD |
3082
|
169544
|
100
|
|
|
|
if (memEQs(sig, len, "CLD")) |
|
|
50
|
|
|
|
|
3083
|
|
|
|
|
|
return SIGCHLD; |
3084
|
|
|
|
|
|
#endif |
3085
|
171018
|
|
|
|
|
return -1; |
3086
|
|
|
|
|
|
} |
3087
|
|
|
|
|
|
|
3088
|
|
|
|
|
|
Signal_t |
3089
|
|
|
|
|
|
#if defined(HAS_SIGACTION) && defined(SA_SIGINFO) |
3090
|
182
|
|
|
|
|
Perl_sighandler(int sig, siginfo_t *sip, void *uap) |
3091
|
|
|
|
|
|
#else |
3092
|
|
|
|
|
|
Perl_sighandler(int sig) |
3093
|
|
|
|
|
|
#endif |
3094
|
|
|
|
|
|
{ |
3095
|
|
|
|
|
|
#ifdef PERL_GET_SIG_CONTEXT |
3096
|
|
|
|
|
|
dTHXa(PERL_GET_SIG_CONTEXT); |
3097
|
|
|
|
|
|
#else |
3098
|
|
|
|
|
|
dTHX; |
3099
|
|
|
|
|
|
#endif |
3100
|
182
|
|
|
|
|
dSP; |
3101
|
182
|
|
|
|
|
GV *gv = NULL; |
3102
|
|
|
|
|
|
SV *sv = NULL; |
3103
|
182
|
|
|
|
|
SV * const tSv = PL_Sv; |
3104
|
|
|
|
|
|
CV *cv = NULL; |
3105
|
182
|
|
|
|
|
OP *myop = PL_op; |
3106
|
|
|
|
|
|
U32 flags = 0; |
3107
|
182
|
|
|
|
|
XPV * const tXpv = PL_Xpv; |
3108
|
182
|
|
|
|
|
I32 old_ss_ix = PL_savestack_ix; |
3109
|
|
|
|
|
|
SV *errsv_save = NULL; |
3110
|
|
|
|
|
|
|
3111
|
|
|
|
|
|
|
3112
|
182
|
50
|
|
|
|
if (!PL_psig_ptr[sig]) { |
3113
|
0
|
0
|
|
|
|
PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n", |
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
3114
|
|
|
|
|
|
PL_sig_name[sig]); |
3115
|
0
|
|
|
|
|
exit(sig); |
3116
|
|
|
|
|
|
} |
3117
|
|
|
|
|
|
|
3118
|
182
|
50
|
|
|
|
if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) { |
3119
|
|
|
|
|
|
/* Max number of items pushed there is 3*n or 4. We cannot fix |
3120
|
|
|
|
|
|
infinity, so we fix 4 (in fact 5): */ |
3121
|
0
|
0
|
|
|
|
if (PL_savestack_ix + 15 <= PL_savestack_max) { |
3122
|
|
|
|
|
|
flags |= 1; |
3123
|
0
|
|
|
|
|
PL_savestack_ix += 5; /* Protect save in progress. */ |
3124
|
0
|
|
|
|
|
SAVEDESTRUCTOR_X(S_unwind_handler_stack, NULL); |
3125
|
|
|
|
|
|
} |
3126
|
|
|
|
|
|
} |
3127
|
|
|
|
|
|
/* sv_2cv is too complicated, try a simpler variant first: */ |
3128
|
182
|
100
|
|
|
|
if (!SvROK(PL_psig_ptr[sig]) || !(cv = MUTABLE_CV(SvRV(PL_psig_ptr[sig]))) |
|
|
50
|
|
|
|
|
3129
|
150
|
50
|
|
|
|
|| SvTYPE(cv) != SVt_PVCV) { |
3130
|
|
|
|
|
|
HV *st; |
3131
|
32
|
|
|
|
|
cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD); |
3132
|
|
|
|
|
|
} |
3133
|
|
|
|
|
|
|
3134
|
182
|
50
|
|
|
|
if (!cv || !CvROOT(cv)) { |
|
|
100
|
|
|
|
|
3135
|
10
|
50
|
|
|
|
Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n", |
3136
|
6
|
50
|
|
|
|
PL_sig_name[sig], (gv ? GvENAME(gv) |
3137
|
0
|
0
|
|
|
|
: ((cv && CvGV(cv)) |
3138
|
0
|
0
|
|
|
|
? GvENAME(CvGV(cv)) |
3139
|
0
|
0
|
|
|
|
: "__ANON__"))); |
3140
|
4
|
|
|
|
|
goto cleanup; |
3141
|
|
|
|
|
|
} |
3142
|
|
|
|
|
|
|
3143
|
178
|
|
|
|
|
sv = PL_psig_name[sig] |
3144
|
178
|
|
|
|
|
? SvREFCNT_inc_NN(PL_psig_name[sig]) |
3145
|
178
|
50
|
|
|
|
: newSVpv(PL_sig_name[sig],0); |
3146
|
178
|
|
|
|
|
flags |= 8; |
3147
|
178
|
|
|
|
|
SAVEFREESV(sv); |
3148
|
|
|
|
|
|
|
3149
|
|
|
|
|
|
if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) { |
3150
|
|
|
|
|
|
/* make sure our assumption about the size of the SAVEs are correct: |
3151
|
|
|
|
|
|
* 3 for SAVEDESTRUCTOR_X, 2 for SAVEFREESV */ |
3152
|
|
|
|
|
|
assert(old_ss_ix + 2 + ((flags & 1) ? 3+5 : 0) == PL_savestack_ix); |
3153
|
|
|
|
|
|
} |
3154
|
|
|
|
|
|
|
3155
|
178
|
100
|
|
|
|
PUSHSTACKi(PERLSI_SIGNAL); |
3156
|
178
|
50
|
|
|
|
PUSHMARK(SP); |
3157
|
178
|
|
|
|
|
PUSHs(sv); |
3158
|
|
|
|
|
|
#if defined(HAS_SIGACTION) && defined(SA_SIGINFO) |
3159
|
|
|
|
|
|
{ |
3160
|
|
|
|
|
|
struct sigaction oact; |
3161
|
|
|
|
|
|
|
3162
|
178
|
50
|
|
|
|
if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) { |
|
|
100
|
|
|
|
|
3163
|
4
|
|
|
|
|
if (sip) { |
3164
|
2
|
|
|
|
|
HV *sih = newHV(); |
3165
|
2
|
|
|
|
|
SV *rv = newRV_noinc(MUTABLE_SV(sih)); |
3166
|
|
|
|
|
|
/* The siginfo fields signo, code, errno, pid, uid, |
3167
|
|
|
|
|
|
* addr, status, and band are defined by POSIX/SUSv3. */ |
3168
|
2
|
|
|
|
|
(void)hv_stores(sih, "signo", newSViv(sip->si_signo)); |
3169
|
2
|
|
|
|
|
(void)hv_stores(sih, "code", newSViv(sip->si_code)); |
3170
|
|
|
|
|
|
#if 0 /* XXX TODO: Configure scan for the existence of these, but even that does not help if the SA_SIGINFO is not implemented according to the spec. */ |
3171
|
|
|
|
|
|
hv_stores(sih, "errno", newSViv(sip->si_errno)); |
3172
|
|
|
|
|
|
hv_stores(sih, "status", newSViv(sip->si_status)); |
3173
|
|
|
|
|
|
hv_stores(sih, "uid", newSViv(sip->si_uid)); |
3174
|
|
|
|
|
|
hv_stores(sih, "pid", newSViv(sip->si_pid)); |
3175
|
|
|
|
|
|
hv_stores(sih, "addr", newSVuv(PTR2UV(sip->si_addr))); |
3176
|
|
|
|
|
|
hv_stores(sih, "band", newSViv(sip->si_band)); |
3177
|
|
|
|
|
|
#endif |
3178
|
1
|
|
|
|
|
EXTEND(SP, 2); |
3179
|
2
|
|
|
|
|
PUSHs(rv); |
3180
|
2
|
|
|
|
|
mPUSHp((char *)sip, sizeof(*sip)); |
3181
|
|
|
|
|
|
} |
3182
|
|
|
|
|
|
|
3183
|
|
|
|
|
|
} |
3184
|
|
|
|
|
|
} |
3185
|
|
|
|
|
|
#endif |
3186
|
178
|
|
|
|
|
PUTBACK; |
3187
|
|
|
|
|
|
|
3188
|
178
|
50
|
|
|
|
errsv_save = newSVsv(ERRSV); |
3189
|
|
|
|
|
|
|
3190
|
178
|
|
|
|
|
call_sv(MUTABLE_SV(cv), G_DISCARD|G_EVAL); |
3191
|
|
|
|
|
|
|
3192
|
172
|
50
|
|
|
|
POPSTACK; |
3193
|
|
|
|
|
|
{ |
3194
|
172
|
50
|
|
|
|
SV * const errsv = ERRSV; |
3195
|
172
|
50
|
|
|
|
if (SvTRUE_NN(errsv)) { |
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
100
|
|
|
|
|
3196
|
28
|
|
|
|
|
SvREFCNT_dec(errsv_save); |
3197
|
|
|
|
|
|
#ifndef PERL_MICRO |
3198
|
|
|
|
|
|
/* Handler "died", for example to get out of a restart-able read(). |
3199
|
|
|
|
|
|
* Before we re-do that on its behalf re-enable the signal which was |
3200
|
|
|
|
|
|
* blocked by the system when we entered. |
3201
|
|
|
|
|
|
*/ |
3202
|
|
|
|
|
|
#ifdef HAS_SIGPROCMASK |
3203
|
|
|
|
|
|
#if defined(HAS_SIGACTION) && defined(SA_SIGINFO) |
3204
|
28
|
100
|
|
|
|
if (sip || uap) |
3205
|
|
|
|
|
|
#endif |
3206
|
|
|
|
|
|
{ |
3207
|
|
|
|
|
|
sigset_t set; |
3208
|
4
|
|
|
|
|
sigemptyset(&set); |
3209
|
4
|
|
|
|
|
sigaddset(&set,sig); |
3210
|
4
|
|
|
|
|
sigprocmask(SIG_UNBLOCK, &set, NULL); |
3211
|
|
|
|
|
|
} |
3212
|
|
|
|
|
|
#else |
3213
|
|
|
|
|
|
/* Not clear if this will work */ |
3214
|
|
|
|
|
|
(void)rsignal(sig, SIG_IGN); |
3215
|
|
|
|
|
|
(void)rsignal(sig, PL_csighandlerp); |
3216
|
|
|
|
|
|
#endif |
3217
|
|
|
|
|
|
#endif /* !PERL_MICRO */ |
3218
|
28
|
|
|
|
|
die_sv(errsv); |
3219
|
|
|
|
|
|
} |
3220
|
|
|
|
|
|
else { |
3221
|
144
|
|
|
|
|
sv_setsv(errsv, errsv_save); |
3222
|
144
|
|
|
|
|
SvREFCNT_dec(errsv_save); |
3223
|
|
|
|
|
|
} |
3224
|
|
|
|
|
|
} |
3225
|
|
|
|
|
|
|
3226
|
|
|
|
|
|
cleanup: |
3227
|
|
|
|
|
|
/* pop any of SAVEFREESV, SAVEDESTRUCTOR_X and "save in progress" */ |
3228
|
148
|
|
|
|
|
PL_savestack_ix = old_ss_ix; |
3229
|
148
|
100
|
|
|
|
if (flags & 8) |
3230
|
|
|
|
|
|
SvREFCNT_dec_NN(sv); |
3231
|
148
|
|
|
|
|
PL_op = myop; /* Apparently not needed... */ |
3232
|
|
|
|
|
|
|
3233
|
148
|
|
|
|
|
PL_Sv = tSv; /* Restore global temporaries. */ |
3234
|
148
|
|
|
|
|
PL_Xpv = tXpv; |
3235
|
148
|
|
|
|
|
return; |
3236
|
|
|
|
|
|
} |
3237
|
|
|
|
|
|
|
3238
|
|
|
|
|
|
|
3239
|
|
|
|
|
|
static void |
3240
|
114607277
|
|
|
|
|
S_restore_magic(pTHX_ const void *p) |
3241
|
|
|
|
|
|
{ |
3242
|
|
|
|
|
|
dVAR; |
3243
|
114607277
|
|
|
|
|
MGS* const mgs = SSPTR(PTR2IV(p), MGS*); |
3244
|
114607277
|
|
|
|
|
SV* const sv = mgs->mgs_sv; |
3245
|
|
|
|
|
|
bool bumped; |
3246
|
|
|
|
|
|
|
3247
|
114607277
|
100
|
|
|
|
if (!sv) |
3248
|
114607277
|
|
|
|
|
return; |
3249
|
|
|
|
|
|
|
3250
|
113850077
|
50
|
|
|
|
if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { |
|
|
100
|
|
|
|
|
3251
|
110925713
|
|
|
|
|
SvTEMP_off(sv); /* if it's still magical, this value isn't temporary */ |
3252
|
|
|
|
|
|
#ifdef PERL_OLD_COPY_ON_WRITE |
3253
|
|
|
|
|
|
/* While magic was saved (and off) sv_setsv may well have seen |
3254
|
|
|
|
|
|
this SV as a prime candidate for COW. */ |
3255
|
|
|
|
|
|
if (SvIsCOW(sv)) |
3256
|
|
|
|
|
|
sv_force_normal_flags(sv, 0); |
3257
|
|
|
|
|
|
#endif |
3258
|
110925713
|
100
|
|
|
|
if (mgs->mgs_readonly) |
3259
|
45216
|
|
|
|
|
SvREADONLY_on(sv); |
3260
|
110925713
|
100
|
|
|
|
if (mgs->mgs_magical) |
3261
|
108628810
|
|
|
|
|
SvFLAGS(sv) |= mgs->mgs_magical; |
3262
|
|
|
|
|
|
else |
3263
|
2296903
|
|
|
|
|
mg_magical(sv); |
3264
|
|
|
|
|
|
} |
3265
|
|
|
|
|
|
|
3266
|
113850077
|
|
|
|
|
bumped = mgs->mgs_bumped; |
3267
|
113850077
|
|
|
|
|
mgs->mgs_sv = NULL; /* mark the MGS structure as restored */ |
3268
|
|
|
|
|
|
|
3269
|
|
|
|
|
|
/* If we're still on top of the stack, pop us off. (That condition |
3270
|
|
|
|
|
|
* will be satisfied if restore_magic was called explicitly, but *not* |
3271
|
|
|
|
|
|
* if it's being called via leave_scope.) |
3272
|
|
|
|
|
|
* The reason for doing this is that otherwise, things like sv_2cv() |
3273
|
|
|
|
|
|
* may leave alloc gunk on the savestack, and some code |
3274
|
|
|
|
|
|
* (e.g. sighandler) doesn't expect that... |
3275
|
|
|
|
|
|
*/ |
3276
|
113850077
|
100
|
|
|
|
if (PL_savestack_ix == mgs->mgs_ss_ix) |
3277
|
|
|
|
|
|
{ |
3278
|
113092629
|
|
|
|
|
UV popval = SSPOPUV; |
3279
|
|
|
|
|
|
assert(popval == SAVEt_DESTRUCTOR_X); |
3280
|
113092629
|
|
|
|
|
PL_savestack_ix -= 2; |
3281
|
113092629
|
|
|
|
|
popval = SSPOPUV; |
3282
|
|
|
|
|
|
assert((popval & SAVE_MASK) == SAVEt_ALLOC); |
3283
|
113092629
|
|
|
|
|
PL_savestack_ix -= popval >> SAVE_TIGHT_SHIFT; |
3284
|
|
|
|
|
|
} |
3285
|
113850077
|
50
|
|
|
|
if (bumped) { |
3286
|
113850077
|
100
|
|
|
|
if (SvREFCNT(sv) == 1) { |
3287
|
|
|
|
|
|
/* We hold the last reference to this SV, which implies that the |
3288
|
|
|
|
|
|
SV was deleted as a side effect of the routines we called. |
3289
|
|
|
|
|
|
So artificially keep it alive a bit longer. |
3290
|
|
|
|
|
|
We avoid turning on the TEMP flag, which can cause the SV's |
3291
|
|
|
|
|
|
buffer to get stolen (and maybe other stuff). */ |
3292
|
4
|
|
|
|
|
sv_2mortal(sv); |
3293
|
4
|
|
|
|
|
SvTEMP_off(sv); |
3294
|
|
|
|
|
|
} |
3295
|
|
|
|
|
|
else |
3296
|
|
|
|
|
|
SvREFCNT_dec_NN(sv); /* undo the inc in S_save_magic() */ |
3297
|
|
|
|
|
|
} |
3298
|
|
|
|
|
|
} |
3299
|
|
|
|
|
|
|
3300
|
|
|
|
|
|
/* clean up the mess created by Perl_sighandler(). |
3301
|
|
|
|
|
|
* Note that this is only called during an exit in a signal handler; |
3302
|
|
|
|
|
|
* a die is trapped by the call_sv() and the SAVEDESTRUCTOR_X manually |
3303
|
|
|
|
|
|
* skipped over. */ |
3304
|
|
|
|
|
|
|
3305
|
|
|
|
|
|
static void |
3306
|
0
|
|
|
|
|
S_unwind_handler_stack(pTHX_ const void *p) |
3307
|
|
|
|
|
|
{ |
3308
|
|
|
|
|
|
dVAR; |
3309
|
|
|
|
|
|
PERL_UNUSED_ARG(p); |
3310
|
|
|
|
|
|
|
3311
|
0
|
|
|
|
|
PL_savestack_ix -= 5; /* Unprotect save in progress. */ |
3312
|
0
|
|
|
|
|
} |
3313
|
|
|
|
|
|
|
3314
|
|
|
|
|
|
/* |
3315
|
|
|
|
|
|
=for apidoc magic_sethint |
3316
|
|
|
|
|
|
|
3317
|
|
|
|
|
|
Triggered by a store to %^H, records the key/value pair to |
3318
|
|
|
|
|
|
C. It is assumed that hints aren't storing |
3319
|
|
|
|
|
|
anything that would need a deep copy. Maybe we should warn if we find a |
3320
|
|
|
|
|
|
reference. |
3321
|
|
|
|
|
|
|
3322
|
|
|
|
|
|
=cut |
3323
|
|
|
|
|
|
*/ |
3324
|
|
|
|
|
|
int |
3325
|
113008
|
|
|
|
|
Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg) |
3326
|
|
|
|
|
|
{ |
3327
|
|
|
|
|
|
dVAR; |
3328
|
168580
|
|
|
|
|
SV *key = (mg->mg_len == HEf_SVKEY) ? MUTABLE_SV(mg->mg_ptr) |
3329
|
113474
|
100
|
|
|
|
: newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP); |
3330
|
|
|
|
|
|
|
3331
|
|
|
|
|
|
PERL_ARGS_ASSERT_MAGIC_SETHINT; |
3332
|
|
|
|
|
|
|
3333
|
|
|
|
|
|
/* mg->mg_obj isn't being used. If needed, it would be possible to store |
3334
|
|
|
|
|
|
an alternative leaf in there, with PL_compiling.cop_hints being used if |
3335
|
|
|
|
|
|
it's NULL. If needed for threads, the alternative could lock a mutex, |
3336
|
|
|
|
|
|
or take other more complex action. */ |
3337
|
|
|
|
|
|
|
3338
|
|
|
|
|
|
/* Something changed in %^H, so it will need to be restored on scope exit. |
3339
|
|
|
|
|
|
Doing this here saves a lot of doing it manually in perl code (and |
3340
|
|
|
|
|
|
forgetting to do it, and consequent subtle errors. */ |
3341
|
113008
|
|
|
|
|
PL_hints |= HINT_LOCALIZE_HH; |
3342
|
113008
|
|
|
|
|
CopHINTHASH_set(&PL_compiling, |
3343
|
|
|
|
|
|
cophh_store_sv(CopHINTHASH_get(&PL_compiling), key, 0, sv, 0)); |
3344
|
113008
|
|
|
|
|
return 0; |
3345
|
|
|
|
|
|
} |
3346
|
|
|
|
|
|
|
3347
|
|
|
|
|
|
/* |
3348
|
|
|
|
|
|
=for apidoc magic_clearhint |
3349
|
|
|
|
|
|
|
3350
|
|
|
|
|
|
Triggered by a delete from %^H, records the key to |
3351
|
|
|
|
|
|
C. |
3352
|
|
|
|
|
|
|
3353
|
|
|
|
|
|
=cut |
3354
|
|
|
|
|
|
*/ |
3355
|
|
|
|
|
|
int |
3356
|
31998
|
|
|
|
|
Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg) |
3357
|
|
|
|
|
|
{ |
3358
|
|
|
|
|
|
dVAR; |
3359
|
|
|
|
|
|
|
3360
|
|
|
|
|
|
PERL_ARGS_ASSERT_MAGIC_CLEARHINT; |
3361
|
|
|
|
|
|
PERL_UNUSED_ARG(sv); |
3362
|
|
|
|
|
|
|
3363
|
31998
|
|
|
|
|
PL_hints |= HINT_LOCALIZE_HH; |
3364
|
31998
|
50
|
|
|
|
CopHINTHASH_set(&PL_compiling, |
3365
|
|
|
|
|
|
mg->mg_len == HEf_SVKEY |
3366
|
|
|
|
|
|
? cophh_delete_sv(CopHINTHASH_get(&PL_compiling), |
3367
|
|
|
|
|
|
MUTABLE_SV(mg->mg_ptr), 0, 0) |
3368
|
|
|
|
|
|
: cophh_delete_pvn(CopHINTHASH_get(&PL_compiling), |
3369
|
|
|
|
|
|
mg->mg_ptr, mg->mg_len, 0, 0)); |
3370
|
31998
|
|
|
|
|
return 0; |
3371
|
|
|
|
|
|
} |
3372
|
|
|
|
|
|
|
3373
|
|
|
|
|
|
/* |
3374
|
|
|
|
|
|
=for apidoc magic_clearhints |
3375
|
|
|
|
|
|
|
3376
|
|
|
|
|
|
Triggered by clearing %^H, resets C. |
3377
|
|
|
|
|
|
|
3378
|
|
|
|
|
|
=cut |
3379
|
|
|
|
|
|
*/ |
3380
|
|
|
|
|
|
int |
3381
|
591119
|
|
|
|
|
Perl_magic_clearhints(pTHX_ SV *sv, MAGIC *mg) |
3382
|
|
|
|
|
|
{ |
3383
|
|
|
|
|
|
PERL_ARGS_ASSERT_MAGIC_CLEARHINTS; |
3384
|
|
|
|
|
|
PERL_UNUSED_ARG(sv); |
3385
|
|
|
|
|
|
PERL_UNUSED_ARG(mg); |
3386
|
591119
|
|
|
|
|
cophh_free(CopHINTHASH_get(&PL_compiling)); |
3387
|
591119
|
|
|
|
|
CopHINTHASH_set(&PL_compiling, cophh_new_empty()); |
3388
|
591119
|
|
|
|
|
return 0; |
3389
|
|
|
|
|
|
} |
3390
|
|
|
|
|
|
|
3391
|
|
|
|
|
|
int |
3392
|
2
|
|
|
|
|
Perl_magic_copycallchecker(pTHX_ SV *sv, MAGIC *mg, SV *nsv, |
3393
|
|
|
|
|
|
const char *name, I32 namlen) |
3394
|
|
|
|
|
|
{ |
3395
|
|
|
|
|
|
MAGIC *nmg; |
3396
|
|
|
|
|
|
|
3397
|
|
|
|
|
|
PERL_ARGS_ASSERT_MAGIC_COPYCALLCHECKER; |
3398
|
|
|
|
|
|
PERL_UNUSED_ARG(sv); |
3399
|
|
|
|
|
|
PERL_UNUSED_ARG(name); |
3400
|
|
|
|
|
|
PERL_UNUSED_ARG(namlen); |
3401
|
|
|
|
|
|
|
3402
|
2
|
|
|
|
|
sv_magic(nsv, &PL_sv_undef, mg->mg_type, NULL, 0); |
3403
|
2
|
|
|
|
|
nmg = mg_find(nsv, mg->mg_type); |
3404
|
2
|
50
|
|
|
|
if (nmg->mg_flags & MGf_REFCOUNTED) SvREFCNT_dec(nmg->mg_obj); |
3405
|
2
|
|
|
|
|
nmg->mg_ptr = mg->mg_ptr; |
3406
|
4
|
|
|
|
|
nmg->mg_obj = SvREFCNT_inc_simple(mg->mg_obj); |
3407
|
2
|
|
|
|
|
nmg->mg_flags |= MGf_REFCOUNTED; |
3408
|
2
|
|
|
|
|
return 1; |
3409
|
47285541
|
|
|
|
|
} |
3410
|
|
|
|
|
|
|
3411
|
|
|
|
|
|
/* |
3412
|
|
|
|
|
|
* Local variables: |
3413
|
|
|
|
|
|
* c-indentation-style: bsd |
3414
|
|
|
|
|
|
* c-basic-offset: 4 |
3415
|
|
|
|
|
|
* indent-tabs-mode: nil |
3416
|
|
|
|
|
|
* End: |
3417
|
|
|
|
|
|
* |
3418
|
|
|
|
|
|
* ex: set ts=8 sts=4 sw=4 et: |
3419
|
|
|
|
|
|
*/ |