line |
stmt |
bran |
cond |
sub |
time |
code |
1
|
|
|
|
|
|
#line 2 "perl.c" |
2
|
|
|
|
|
|
/* perl.c |
3
|
|
|
|
|
|
* |
4
|
|
|
|
|
|
* Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001 |
5
|
|
|
|
|
|
* 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012 |
6
|
|
|
|
|
|
* by Larry Wall and others |
7
|
|
|
|
|
|
* |
8
|
|
|
|
|
|
* You may distribute under the terms of either the GNU General Public |
9
|
|
|
|
|
|
* License or the Artistic License, as specified in the README file. |
10
|
|
|
|
|
|
* |
11
|
|
|
|
|
|
*/ |
12
|
|
|
|
|
|
|
13
|
|
|
|
|
|
/* |
14
|
|
|
|
|
|
* A ship then new they built for him |
15
|
|
|
|
|
|
* of mithril and of elven-glass |
16
|
|
|
|
|
|
* --from Bilbo's song of EƤrendil |
17
|
|
|
|
|
|
* |
18
|
|
|
|
|
|
* [p.236 of _The Lord of the Rings_, II/i: "Many Meetings"] |
19
|
|
|
|
|
|
*/ |
20
|
|
|
|
|
|
|
21
|
|
|
|
|
|
/* This file contains the top-level functions that are used to create, use |
22
|
|
|
|
|
|
* and destroy a perl interpreter, plus the functions used by XS code to |
23
|
|
|
|
|
|
* call back into perl. Note that it does not contain the actual main() |
24
|
|
|
|
|
|
* function of the interpreter; that can be found in perlmain.c |
25
|
|
|
|
|
|
*/ |
26
|
|
|
|
|
|
|
27
|
|
|
|
|
|
#if defined(PERL_IS_MINIPERL) && !defined(USE_SITECUSTOMIZE) |
28
|
|
|
|
|
|
# define USE_SITECUSTOMIZE |
29
|
|
|
|
|
|
#endif |
30
|
|
|
|
|
|
|
31
|
|
|
|
|
|
#include "EXTERN.h" |
32
|
|
|
|
|
|
#define PERL_IN_PERL_C |
33
|
|
|
|
|
|
#include "perl.h" |
34
|
|
|
|
|
|
#include "patchlevel.h" /* for local_patches */ |
35
|
|
|
|
|
|
#include "XSUB.h" |
36
|
|
|
|
|
|
|
37
|
|
|
|
|
|
#ifdef NETWARE |
38
|
|
|
|
|
|
#include "nwutil.h" |
39
|
|
|
|
|
|
#endif |
40
|
|
|
|
|
|
|
41
|
|
|
|
|
|
#ifdef USE_KERN_PROC_PATHNAME |
42
|
|
|
|
|
|
# include |
43
|
|
|
|
|
|
#endif |
44
|
|
|
|
|
|
|
45
|
|
|
|
|
|
#ifdef USE_NSGETEXECUTABLEPATH |
46
|
|
|
|
|
|
# include |
47
|
|
|
|
|
|
#endif |
48
|
|
|
|
|
|
|
49
|
|
|
|
|
|
#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP |
50
|
|
|
|
|
|
# ifdef I_SYSUIO |
51
|
|
|
|
|
|
# include |
52
|
|
|
|
|
|
# endif |
53
|
|
|
|
|
|
|
54
|
|
|
|
|
|
union control_un { |
55
|
|
|
|
|
|
struct cmsghdr cm; |
56
|
|
|
|
|
|
char control[CMSG_SPACE(sizeof(int))]; |
57
|
|
|
|
|
|
}; |
58
|
|
|
|
|
|
|
59
|
|
|
|
|
|
#endif |
60
|
|
|
|
|
|
|
61
|
|
|
|
|
|
#ifndef HZ |
62
|
|
|
|
|
|
# ifdef CLK_TCK |
63
|
|
|
|
|
|
# define HZ CLK_TCK |
64
|
|
|
|
|
|
# else |
65
|
|
|
|
|
|
# define HZ 60 |
66
|
|
|
|
|
|
# endif |
67
|
|
|
|
|
|
#endif |
68
|
|
|
|
|
|
|
69
|
|
|
|
|
|
#if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE) && !defined(PERL_MICRO) |
70
|
|
|
|
|
|
char *getenv (char *); /* Usually in */ |
71
|
|
|
|
|
|
#endif |
72
|
|
|
|
|
|
|
73
|
|
|
|
|
|
static I32 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen); |
74
|
|
|
|
|
|
|
75
|
|
|
|
|
|
#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW |
76
|
|
|
|
|
|
# define validate_suid(rsfp) NOOP |
77
|
|
|
|
|
|
#else |
78
|
|
|
|
|
|
# define validate_suid(rsfp) S_validate_suid(aTHX_ rsfp) |
79
|
|
|
|
|
|
#endif |
80
|
|
|
|
|
|
|
81
|
|
|
|
|
|
#define CALL_BODY_SUB(myop) \ |
82
|
|
|
|
|
|
if (PL_op == (myop)) \ |
83
|
|
|
|
|
|
PL_op = PL_ppaddr[OP_ENTERSUB](aTHX); \ |
84
|
|
|
|
|
|
if (PL_op) \ |
85
|
|
|
|
|
|
CALLRUNOPS(aTHX); |
86
|
|
|
|
|
|
|
87
|
|
|
|
|
|
#define CALL_LIST_BODY(cv) \ |
88
|
|
|
|
|
|
PUSHMARK(PL_stack_sp); \ |
89
|
|
|
|
|
|
call_sv(MUTABLE_SV((cv)), G_EVAL|G_DISCARD|G_VOID); |
90
|
|
|
|
|
|
|
91
|
|
|
|
|
|
static void |
92
|
|
|
|
|
|
S_init_tls_and_interp(PerlInterpreter *my_perl) |
93
|
|
|
|
|
|
{ |
94
|
|
|
|
|
|
dVAR; |
95
|
11993
|
50
|
|
|
|
if (!PL_curinterp) { |
96
|
11993
|
|
|
|
|
PERL_SET_INTERP(my_perl); |
97
|
|
|
|
|
|
#if defined(USE_ITHREADS) |
98
|
|
|
|
|
|
INIT_THREADS; |
99
|
|
|
|
|
|
ALLOC_THREAD_KEY; |
100
|
|
|
|
|
|
PERL_SET_THX(my_perl); |
101
|
|
|
|
|
|
OP_REFCNT_INIT; |
102
|
|
|
|
|
|
OP_CHECK_MUTEX_INIT; |
103
|
|
|
|
|
|
HINTS_REFCNT_INIT; |
104
|
|
|
|
|
|
MUTEX_INIT(&PL_dollarzero_mutex); |
105
|
|
|
|
|
|
MUTEX_INIT(&PL_my_ctx_mutex); |
106
|
|
|
|
|
|
# endif |
107
|
|
|
|
|
|
} |
108
|
|
|
|
|
|
#if defined(USE_ITHREADS) |
109
|
|
|
|
|
|
else |
110
|
|
|
|
|
|
#else |
111
|
|
|
|
|
|
/* This always happens for non-ithreads */ |
112
|
|
|
|
|
|
#endif |
113
|
|
|
|
|
|
{ |
114
|
|
|
|
|
|
PERL_SET_THX(my_perl); |
115
|
|
|
|
|
|
} |
116
|
|
|
|
|
|
} |
117
|
|
|
|
|
|
|
118
|
|
|
|
|
|
|
119
|
|
|
|
|
|
/* these implement the PERL_SYS_INIT, PERL_SYS_INIT3, PERL_SYS_TERM macros */ |
120
|
|
|
|
|
|
|
121
|
|
|
|
|
|
void |
122
|
0
|
|
|
|
|
Perl_sys_init(int* argc, char*** argv) |
123
|
|
|
|
|
|
{ |
124
|
|
|
|
|
|
dVAR; |
125
|
|
|
|
|
|
|
126
|
|
|
|
|
|
PERL_ARGS_ASSERT_SYS_INIT; |
127
|
|
|
|
|
|
|
128
|
|
|
|
|
|
PERL_UNUSED_ARG(argc); /* may not be used depending on _BODY macro */ |
129
|
|
|
|
|
|
PERL_UNUSED_ARG(argv); |
130
|
0
|
|
|
|
|
PERL_SYS_INIT_BODY(argc, argv); |
131
|
0
|
|
|
|
|
} |
132
|
|
|
|
|
|
|
133
|
|
|
|
|
|
void |
134
|
11993
|
|
|
|
|
Perl_sys_init3(int* argc, char*** argv, char*** env) |
135
|
|
|
|
|
|
{ |
136
|
|
|
|
|
|
dVAR; |
137
|
|
|
|
|
|
|
138
|
|
|
|
|
|
PERL_ARGS_ASSERT_SYS_INIT3; |
139
|
|
|
|
|
|
|
140
|
|
|
|
|
|
PERL_UNUSED_ARG(argc); /* may not be used depending on _BODY macro */ |
141
|
|
|
|
|
|
PERL_UNUSED_ARG(argv); |
142
|
|
|
|
|
|
PERL_UNUSED_ARG(env); |
143
|
11993
|
|
|
|
|
PERL_SYS_INIT3_BODY(argc, argv, env); |
144
|
11993
|
|
|
|
|
} |
145
|
|
|
|
|
|
|
146
|
|
|
|
|
|
void |
147
|
11991
|
|
|
|
|
Perl_sys_term() |
148
|
|
|
|
|
|
{ |
149
|
|
|
|
|
|
dVAR; |
150
|
11991
|
50
|
|
|
|
if (!PL_veto_cleanup) { |
151
|
11991
|
|
|
|
|
PERL_SYS_TERM_BODY(); |
152
|
|
|
|
|
|
} |
153
|
11991
|
|
|
|
|
} |
154
|
|
|
|
|
|
|
155
|
|
|
|
|
|
|
156
|
|
|
|
|
|
#ifdef PERL_IMPLICIT_SYS |
157
|
|
|
|
|
|
PerlInterpreter * |
158
|
|
|
|
|
|
perl_alloc_using(struct IPerlMem* ipM, struct IPerlMem* ipMS, |
159
|
|
|
|
|
|
struct IPerlMem* ipMP, struct IPerlEnv* ipE, |
160
|
|
|
|
|
|
struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO, |
161
|
|
|
|
|
|
struct IPerlDir* ipD, struct IPerlSock* ipS, |
162
|
|
|
|
|
|
struct IPerlProc* ipP) |
163
|
|
|
|
|
|
{ |
164
|
|
|
|
|
|
PerlInterpreter *my_perl; |
165
|
|
|
|
|
|
|
166
|
|
|
|
|
|
PERL_ARGS_ASSERT_PERL_ALLOC_USING; |
167
|
|
|
|
|
|
|
168
|
|
|
|
|
|
/* Newx() needs interpreter, so call malloc() instead */ |
169
|
|
|
|
|
|
my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter)); |
170
|
|
|
|
|
|
S_init_tls_and_interp(my_perl); |
171
|
|
|
|
|
|
Zero(my_perl, 1, PerlInterpreter); |
172
|
|
|
|
|
|
PL_Mem = ipM; |
173
|
|
|
|
|
|
PL_MemShared = ipMS; |
174
|
|
|
|
|
|
PL_MemParse = ipMP; |
175
|
|
|
|
|
|
PL_Env = ipE; |
176
|
|
|
|
|
|
PL_StdIO = ipStd; |
177
|
|
|
|
|
|
PL_LIO = ipLIO; |
178
|
|
|
|
|
|
PL_Dir = ipD; |
179
|
|
|
|
|
|
PL_Sock = ipS; |
180
|
|
|
|
|
|
PL_Proc = ipP; |
181
|
|
|
|
|
|
INIT_TRACK_MEMPOOL(PL_memory_debug_header, my_perl); |
182
|
|
|
|
|
|
|
183
|
|
|
|
|
|
return my_perl; |
184
|
|
|
|
|
|
} |
185
|
|
|
|
|
|
#else |
186
|
|
|
|
|
|
|
187
|
|
|
|
|
|
/* |
188
|
|
|
|
|
|
=head1 Embedding Functions |
189
|
|
|
|
|
|
|
190
|
|
|
|
|
|
=for apidoc perl_alloc |
191
|
|
|
|
|
|
|
192
|
|
|
|
|
|
Allocates a new Perl interpreter. See L. |
193
|
|
|
|
|
|
|
194
|
|
|
|
|
|
=cut |
195
|
|
|
|
|
|
*/ |
196
|
|
|
|
|
|
|
197
|
|
|
|
|
|
PerlInterpreter * |
198
|
11993
|
|
|
|
|
perl_alloc(void) |
199
|
|
|
|
|
|
{ |
200
|
|
|
|
|
|
PerlInterpreter *my_perl; |
201
|
|
|
|
|
|
|
202
|
|
|
|
|
|
/* Newx() needs interpreter, so call malloc() instead */ |
203
|
11993
|
|
|
|
|
my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter)); |
204
|
|
|
|
|
|
|
205
|
|
|
|
|
|
S_init_tls_and_interp(my_perl); |
206
|
|
|
|
|
|
#ifndef PERL_TRACK_MEMPOOL |
207
|
11993
|
|
|
|
|
return (PerlInterpreter *) ZeroD(my_perl, 1, PerlInterpreter); |
208
|
|
|
|
|
|
#else |
209
|
|
|
|
|
|
Zero(my_perl, 1, PerlInterpreter); |
210
|
|
|
|
|
|
INIT_TRACK_MEMPOOL(PL_memory_debug_header, my_perl); |
211
|
|
|
|
|
|
return my_perl; |
212
|
|
|
|
|
|
#endif |
213
|
|
|
|
|
|
} |
214
|
|
|
|
|
|
#endif /* PERL_IMPLICIT_SYS */ |
215
|
|
|
|
|
|
|
216
|
|
|
|
|
|
/* |
217
|
|
|
|
|
|
=for apidoc perl_construct |
218
|
|
|
|
|
|
|
219
|
|
|
|
|
|
Initializes a new Perl interpreter. See L. |
220
|
|
|
|
|
|
|
221
|
|
|
|
|
|
=cut |
222
|
|
|
|
|
|
*/ |
223
|
|
|
|
|
|
|
224
|
|
|
|
|
|
void |
225
|
11993
|
|
|
|
|
perl_construct(pTHXx) |
226
|
|
|
|
|
|
{ |
227
|
|
|
|
|
|
dVAR; |
228
|
|
|
|
|
|
|
229
|
|
|
|
|
|
PERL_ARGS_ASSERT_PERL_CONSTRUCT; |
230
|
|
|
|
|
|
|
231
|
|
|
|
|
|
#ifdef MULTIPLICITY |
232
|
|
|
|
|
|
init_interp(); |
233
|
|
|
|
|
|
PL_perl_destruct_level = 1; |
234
|
|
|
|
|
|
#else |
235
|
|
|
|
|
|
PERL_UNUSED_ARG(my_perl); |
236
|
11993
|
50
|
|
|
|
if (PL_perl_destruct_level > 0) |
237
|
0
|
|
|
|
|
init_interp(); |
238
|
|
|
|
|
|
#endif |
239
|
11993
|
|
|
|
|
PL_curcop = &PL_compiling; /* needed by ckWARN, right away */ |
240
|
|
|
|
|
|
|
241
|
|
|
|
|
|
#ifdef PERL_TRACE_OPS |
242
|
|
|
|
|
|
Zero(PL_op_exec_cnt, OP_max+2, UV); |
243
|
|
|
|
|
|
#endif |
244
|
|
|
|
|
|
|
245
|
11993
|
|
|
|
|
init_constants(); |
246
|
|
|
|
|
|
|
247
|
11993
|
|
|
|
|
SvREADONLY_on(&PL_sv_placeholder); |
248
|
11993
|
|
|
|
|
SvREFCNT(&PL_sv_placeholder) = SvREFCNT_IMMORTAL; |
249
|
|
|
|
|
|
|
250
|
11993
|
|
|
|
|
PL_sighandlerp = (Sighandler_t) Perl_sighandler; |
251
|
|
|
|
|
|
#ifdef PERL_USES_PL_PIDSTATUS |
252
|
|
|
|
|
|
PL_pidstatus = newHV(); |
253
|
|
|
|
|
|
#endif |
254
|
|
|
|
|
|
|
255
|
11993
|
|
|
|
|
PL_rs = newSVpvs("\n"); |
256
|
|
|
|
|
|
|
257
|
11993
|
|
|
|
|
init_stacks(); |
258
|
|
|
|
|
|
|
259
|
11993
|
|
|
|
|
init_ids(); |
260
|
|
|
|
|
|
|
261
|
11993
|
|
|
|
|
JMPENV_BOOTSTRAP; |
262
|
11993
|
|
|
|
|
STATUS_ALL_SUCCESS; |
263
|
|
|
|
|
|
|
264
|
11993
|
|
|
|
|
init_i18nl10n(1); |
265
|
11993
|
|
|
|
|
SET_NUMERIC_STANDARD(); |
266
|
|
|
|
|
|
|
267
|
|
|
|
|
|
#if defined(LOCAL_PATCH_COUNT) |
268
|
11993
|
|
|
|
|
PL_localpatches = local_patches; /* For possible -v */ |
269
|
|
|
|
|
|
#endif |
270
|
|
|
|
|
|
|
271
|
|
|
|
|
|
#ifdef HAVE_INTERP_INTERN |
272
|
|
|
|
|
|
sys_intern_init(); |
273
|
|
|
|
|
|
#endif |
274
|
|
|
|
|
|
|
275
|
11993
|
|
|
|
|
PerlIO_init(aTHX); /* Hook to IO system */ |
276
|
|
|
|
|
|
|
277
|
11993
|
|
|
|
|
PL_fdpid = newAV(); /* for remembering popen pids by fd */ |
278
|
11993
|
|
|
|
|
PL_modglobal = newHV(); /* pointers to per-interpreter module globals */ |
279
|
11993
|
|
|
|
|
PL_errors = newSVpvs(""); |
280
|
11993
|
|
|
|
|
sv_setpvs(PERL_DEBUG_PAD(0), ""); /* For regex debugging. */ |
281
|
11993
|
|
|
|
|
sv_setpvs(PERL_DEBUG_PAD(1), ""); /* ext/re needs these */ |
282
|
11993
|
|
|
|
|
sv_setpvs(PERL_DEBUG_PAD(2), ""); /* even without DEBUGGING. */ |
283
|
|
|
|
|
|
#ifdef USE_ITHREADS |
284
|
|
|
|
|
|
/* First entry is a list of empty elements. It needs to be initialised |
285
|
|
|
|
|
|
else all hell breaks loose in S_find_uninit_var(). */ |
286
|
|
|
|
|
|
Perl_av_create_and_push(aTHX_ &PL_regex_padav, newSVpvs("")); |
287
|
|
|
|
|
|
PL_regex_pad = AvARRAY(PL_regex_padav); |
288
|
|
|
|
|
|
Newxz(PL_stashpad, PL_stashpadmax, HV *); |
289
|
|
|
|
|
|
#endif |
290
|
|
|
|
|
|
#ifdef USE_REENTRANT_API |
291
|
|
|
|
|
|
Perl_reentrant_init(aTHX); |
292
|
|
|
|
|
|
#endif |
293
|
|
|
|
|
|
#if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) |
294
|
|
|
|
|
|
/* [perl #22371] Algorimic Complexity Attack on Perl 5.6.1, 5.8.0 |
295
|
|
|
|
|
|
* This MUST be done before any hash stores or fetches take place. |
296
|
|
|
|
|
|
* If you set PL_hash_seed (and presumably also PL_hash_seed_set) |
297
|
|
|
|
|
|
* yourself, it is your responsibility to provide a good random seed! |
298
|
|
|
|
|
|
* You can also define PERL_HASH_SEED in compile time, see hv.h. |
299
|
|
|
|
|
|
* |
300
|
|
|
|
|
|
* XXX: fix this comment */ |
301
|
11993
|
50
|
|
|
|
if (PL_hash_seed_set == FALSE) { |
302
|
11993
|
|
|
|
|
Perl_get_hash_seed(aTHX_ PL_hash_seed); |
303
|
11993
|
|
|
|
|
PL_hash_seed_set= TRUE; |
304
|
|
|
|
|
|
} |
305
|
|
|
|
|
|
#endif /* #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) */ |
306
|
|
|
|
|
|
|
307
|
|
|
|
|
|
/* Note that strtab is a rather special HV. Assumptions are made |
308
|
|
|
|
|
|
about not iterating on it, and not adding tie magic to it. |
309
|
|
|
|
|
|
It is properly deallocated in perl_destruct() */ |
310
|
11993
|
|
|
|
|
PL_strtab = newHV(); |
311
|
|
|
|
|
|
|
312
|
11993
|
|
|
|
|
HvSHAREKEYS_off(PL_strtab); /* mandatory */ |
313
|
11993
|
|
|
|
|
hv_ksplit(PL_strtab, 512); |
314
|
|
|
|
|
|
|
315
|
|
|
|
|
|
Zero(PL_sv_consts, SV_CONSTS_COUNT, SV*); |
316
|
|
|
|
|
|
|
317
|
|
|
|
|
|
#if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__)) |
318
|
|
|
|
|
|
_dyld_lookup_and_bind |
319
|
|
|
|
|
|
("__environ", (unsigned long *) &environ_pointer, NULL); |
320
|
|
|
|
|
|
#endif /* environ */ |
321
|
|
|
|
|
|
|
322
|
|
|
|
|
|
#ifndef PERL_MICRO |
323
|
|
|
|
|
|
# ifdef USE_ENVIRON_ARRAY |
324
|
11993
|
|
|
|
|
PL_origenviron = environ; |
325
|
|
|
|
|
|
# endif |
326
|
|
|
|
|
|
#endif |
327
|
|
|
|
|
|
|
328
|
|
|
|
|
|
/* Use sysconf(_SC_CLK_TCK) if available, if not |
329
|
|
|
|
|
|
* available or if the sysconf() fails, use the HZ. |
330
|
|
|
|
|
|
* The HZ if not originally defined has been by now |
331
|
|
|
|
|
|
* been defined as CLK_TCK, if available. */ |
332
|
|
|
|
|
|
#if defined(HAS_SYSCONF) && defined(_SC_CLK_TCK) |
333
|
11993
|
|
|
|
|
PL_clocktick = sysconf(_SC_CLK_TCK); |
334
|
11993
|
50
|
|
|
|
if (PL_clocktick <= 0) |
335
|
|
|
|
|
|
#endif |
336
|
0
|
|
|
|
|
PL_clocktick = HZ; |
337
|
|
|
|
|
|
|
338
|
11993
|
|
|
|
|
PL_stashcache = newHV(); |
339
|
|
|
|
|
|
|
340
|
11993
|
|
|
|
|
PL_patchlevel = newSVpvs("v" PERL_VERSION_STRING); |
341
|
11993
|
|
|
|
|
PL_apiversion = newSVpvs("v" PERL_API_VERSION_STRING); |
342
|
|
|
|
|
|
|
343
|
|
|
|
|
|
#ifdef HAS_MMAP |
344
|
11993
|
50
|
|
|
|
if (!PL_mmap_page_size) { |
345
|
|
|
|
|
|
#if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_MMAP_PAGE_SIZE)) |
346
|
|
|
|
|
|
{ |
347
|
11993
|
|
|
|
|
SETERRNO(0, SS_NORMAL); |
348
|
|
|
|
|
|
# ifdef _SC_PAGESIZE |
349
|
11993
|
|
|
|
|
PL_mmap_page_size = sysconf(_SC_PAGESIZE); |
350
|
|
|
|
|
|
# else |
351
|
|
|
|
|
|
PL_mmap_page_size = sysconf(_SC_MMAP_PAGE_SIZE); |
352
|
|
|
|
|
|
# endif |
353
|
11993
|
50
|
|
|
|
if ((long) PL_mmap_page_size < 0) { |
354
|
0
|
0
|
|
|
|
if (errno) { |
|
|
0
|
|
|
|
|
355
|
0
|
0
|
|
|
|
SV * const error = ERRSV; |
356
|
0
|
|
|
|
|
SvUPGRADE(error, SVt_PV); |
357
|
0
|
0
|
|
|
|
Perl_croak(aTHX_ "panic: sysconf: %s", SvPV_nolen_const(error)); |
358
|
|
|
|
|
|
} |
359
|
|
|
|
|
|
else |
360
|
0
|
|
|
|
|
Perl_croak(aTHX_ "panic: sysconf: pagesize unknown"); |
361
|
|
|
|
|
|
} |
362
|
|
|
|
|
|
} |
363
|
|
|
|
|
|
#else |
364
|
|
|
|
|
|
# ifdef HAS_GETPAGESIZE |
365
|
|
|
|
|
|
PL_mmap_page_size = getpagesize(); |
366
|
|
|
|
|
|
# else |
367
|
|
|
|
|
|
# if defined(I_SYS_PARAM) && defined(PAGESIZE) |
368
|
|
|
|
|
|
PL_mmap_page_size = PAGESIZE; /* compiletime, bad */ |
369
|
|
|
|
|
|
# endif |
370
|
|
|
|
|
|
# endif |
371
|
|
|
|
|
|
#endif |
372
|
11993
|
50
|
|
|
|
if (PL_mmap_page_size <= 0) |
373
|
0
|
|
|
|
|
Perl_croak(aTHX_ "panic: bad pagesize %" IVdf, |
374
|
|
|
|
|
|
(IV) PL_mmap_page_size); |
375
|
|
|
|
|
|
} |
376
|
|
|
|
|
|
#endif /* HAS_MMAP */ |
377
|
|
|
|
|
|
|
378
|
|
|
|
|
|
#if defined(HAS_TIMES) && defined(PERL_NEED_TIMESBASE) |
379
|
|
|
|
|
|
PL_timesbase.tms_utime = 0; |
380
|
|
|
|
|
|
PL_timesbase.tms_stime = 0; |
381
|
|
|
|
|
|
PL_timesbase.tms_cutime = 0; |
382
|
|
|
|
|
|
PL_timesbase.tms_cstime = 0; |
383
|
|
|
|
|
|
#endif |
384
|
|
|
|
|
|
|
385
|
11993
|
|
|
|
|
PL_osname = Perl_savepvn(aTHX_ STR_WITH_LEN(OSNAME)); |
386
|
|
|
|
|
|
|
387
|
11993
|
|
|
|
|
PL_registered_mros = newHV(); |
388
|
|
|
|
|
|
/* Start with 1 bucket, for DFS. It's unlikely we'll need more. */ |
389
|
11993
|
|
|
|
|
HvMAX(PL_registered_mros) = 0; |
390
|
|
|
|
|
|
|
391
|
11993
|
|
|
|
|
ENTER; |
392
|
11993
|
|
|
|
|
} |
393
|
|
|
|
|
|
|
394
|
|
|
|
|
|
/* |
395
|
|
|
|
|
|
=for apidoc nothreadhook |
396
|
|
|
|
|
|
|
397
|
|
|
|
|
|
Stub that provides thread hook for perl_destruct when there are |
398
|
|
|
|
|
|
no threads. |
399
|
|
|
|
|
|
|
400
|
|
|
|
|
|
=cut |
401
|
|
|
|
|
|
*/ |
402
|
|
|
|
|
|
|
403
|
|
|
|
|
|
int |
404
|
11993
|
|
|
|
|
Perl_nothreadhook(pTHX) |
405
|
|
|
|
|
|
{ |
406
|
|
|
|
|
|
PERL_UNUSED_CONTEXT; |
407
|
11993
|
|
|
|
|
return 0; |
408
|
|
|
|
|
|
} |
409
|
|
|
|
|
|
|
410
|
|
|
|
|
|
#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP |
411
|
|
|
|
|
|
void |
412
|
|
|
|
|
|
Perl_dump_sv_child(pTHX_ SV *sv) |
413
|
|
|
|
|
|
{ |
414
|
|
|
|
|
|
ssize_t got; |
415
|
|
|
|
|
|
const int sock = PL_dumper_fd; |
416
|
|
|
|
|
|
const int debug_fd = PerlIO_fileno(Perl_debug_log); |
417
|
|
|
|
|
|
union control_un control; |
418
|
|
|
|
|
|
struct msghdr msg; |
419
|
|
|
|
|
|
struct iovec vec[2]; |
420
|
|
|
|
|
|
struct cmsghdr *cmptr; |
421
|
|
|
|
|
|
int returned_errno; |
422
|
|
|
|
|
|
unsigned char buffer[256]; |
423
|
|
|
|
|
|
|
424
|
|
|
|
|
|
PERL_ARGS_ASSERT_DUMP_SV_CHILD; |
425
|
|
|
|
|
|
|
426
|
|
|
|
|
|
if(sock == -1 || debug_fd == -1) |
427
|
|
|
|
|
|
return; |
428
|
|
|
|
|
|
|
429
|
|
|
|
|
|
PerlIO_flush(Perl_debug_log); |
430
|
|
|
|
|
|
|
431
|
|
|
|
|
|
/* All these shenanigans are to pass a file descriptor over to our child for |
432
|
|
|
|
|
|
it to dump out to. We can't let it hold open the file descriptor when it |
433
|
|
|
|
|
|
forks, as the file descriptor it will dump to can turn out to be one end |
434
|
|
|
|
|
|
of pipe that some other process will wait on for EOF. (So as it would |
435
|
|
|
|
|
|
be open, the wait would be forever.) */ |
436
|
|
|
|
|
|
|
437
|
|
|
|
|
|
msg.msg_control = control.control; |
438
|
|
|
|
|
|
msg.msg_controllen = sizeof(control.control); |
439
|
|
|
|
|
|
/* We're a connected socket so we don't need a destination */ |
440
|
|
|
|
|
|
msg.msg_name = NULL; |
441
|
|
|
|
|
|
msg.msg_namelen = 0; |
442
|
|
|
|
|
|
msg.msg_iov = vec; |
443
|
|
|
|
|
|
msg.msg_iovlen = 1; |
444
|
|
|
|
|
|
|
445
|
|
|
|
|
|
cmptr = CMSG_FIRSTHDR(&msg); |
446
|
|
|
|
|
|
cmptr->cmsg_len = CMSG_LEN(sizeof(int)); |
447
|
|
|
|
|
|
cmptr->cmsg_level = SOL_SOCKET; |
448
|
|
|
|
|
|
cmptr->cmsg_type = SCM_RIGHTS; |
449
|
|
|
|
|
|
*((int *)CMSG_DATA(cmptr)) = 1; |
450
|
|
|
|
|
|
|
451
|
|
|
|
|
|
vec[0].iov_base = (void*)&sv; |
452
|
|
|
|
|
|
vec[0].iov_len = sizeof(sv); |
453
|
|
|
|
|
|
got = sendmsg(sock, &msg, 0); |
454
|
|
|
|
|
|
|
455
|
|
|
|
|
|
if(got < 0) { |
456
|
|
|
|
|
|
perror("Debug leaking scalars parent sendmsg failed"); |
457
|
|
|
|
|
|
abort(); |
458
|
|
|
|
|
|
} |
459
|
|
|
|
|
|
if(got < sizeof(sv)) { |
460
|
|
|
|
|
|
perror("Debug leaking scalars parent short sendmsg"); |
461
|
|
|
|
|
|
abort(); |
462
|
|
|
|
|
|
} |
463
|
|
|
|
|
|
|
464
|
|
|
|
|
|
/* Return protocol is |
465
|
|
|
|
|
|
int: errno value |
466
|
|
|
|
|
|
unsigned char: length of location string (0 for empty) |
467
|
|
|
|
|
|
unsigned char*: string (not terminated) |
468
|
|
|
|
|
|
*/ |
469
|
|
|
|
|
|
vec[0].iov_base = (void*)&returned_errno; |
470
|
|
|
|
|
|
vec[0].iov_len = sizeof(returned_errno); |
471
|
|
|
|
|
|
vec[1].iov_base = buffer; |
472
|
|
|
|
|
|
vec[1].iov_len = 1; |
473
|
|
|
|
|
|
|
474
|
|
|
|
|
|
got = readv(sock, vec, 2); |
475
|
|
|
|
|
|
|
476
|
|
|
|
|
|
if(got < 0) { |
477
|
|
|
|
|
|
perror("Debug leaking scalars parent read failed"); |
478
|
|
|
|
|
|
PerlIO_flush(PerlIO_stderr()); |
479
|
|
|
|
|
|
abort(); |
480
|
|
|
|
|
|
} |
481
|
|
|
|
|
|
if(got < sizeof(returned_errno) + 1) { |
482
|
|
|
|
|
|
perror("Debug leaking scalars parent short read"); |
483
|
|
|
|
|
|
PerlIO_flush(PerlIO_stderr()); |
484
|
|
|
|
|
|
abort(); |
485
|
|
|
|
|
|
} |
486
|
|
|
|
|
|
|
487
|
|
|
|
|
|
if (*buffer) { |
488
|
|
|
|
|
|
got = read(sock, buffer + 1, *buffer); |
489
|
|
|
|
|
|
if(got < 0) { |
490
|
|
|
|
|
|
perror("Debug leaking scalars parent read 2 failed"); |
491
|
|
|
|
|
|
PerlIO_flush(PerlIO_stderr()); |
492
|
|
|
|
|
|
abort(); |
493
|
|
|
|
|
|
} |
494
|
|
|
|
|
|
|
495
|
|
|
|
|
|
if(got < *buffer) { |
496
|
|
|
|
|
|
perror("Debug leaking scalars parent short read 2"); |
497
|
|
|
|
|
|
PerlIO_flush(PerlIO_stderr()); |
498
|
|
|
|
|
|
abort(); |
499
|
|
|
|
|
|
} |
500
|
|
|
|
|
|
} |
501
|
|
|
|
|
|
|
502
|
|
|
|
|
|
if (returned_errno || *buffer) { |
503
|
|
|
|
|
|
Perl_warn(aTHX_ "Debug leaking scalars child failed%s%.*s with errno" |
504
|
|
|
|
|
|
" %d: %s", (*buffer ? " at " : ""), (int) *buffer, buffer + 1, |
505
|
|
|
|
|
|
returned_errno, Strerror(returned_errno)); |
506
|
|
|
|
|
|
} |
507
|
|
|
|
|
|
} |
508
|
|
|
|
|
|
#endif |
509
|
|
|
|
|
|
|
510
|
|
|
|
|
|
/* |
511
|
|
|
|
|
|
=for apidoc perl_destruct |
512
|
|
|
|
|
|
|
513
|
|
|
|
|
|
Shuts down a Perl interpreter. See L. |
514
|
|
|
|
|
|
|
515
|
|
|
|
|
|
=cut |
516
|
|
|
|
|
|
*/ |
517
|
|
|
|
|
|
|
518
|
|
|
|
|
|
int |
519
|
11993
|
|
|
|
|
perl_destruct(pTHXx) |
520
|
|
|
|
|
|
{ |
521
|
|
|
|
|
|
dVAR; |
522
|
|
|
|
|
|
VOL signed char destruct_level; /* see possible values in intrpvar.h */ |
523
|
|
|
|
|
|
HV *hv; |
524
|
|
|
|
|
|
#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP |
525
|
|
|
|
|
|
pid_t child; |
526
|
|
|
|
|
|
#endif |
527
|
|
|
|
|
|
int i; |
528
|
|
|
|
|
|
|
529
|
|
|
|
|
|
PERL_ARGS_ASSERT_PERL_DESTRUCT; |
530
|
|
|
|
|
|
#ifndef MULTIPLICITY |
531
|
|
|
|
|
|
PERL_UNUSED_ARG(my_perl); |
532
|
|
|
|
|
|
#endif |
533
|
|
|
|
|
|
|
534
|
|
|
|
|
|
assert(PL_scopestack_ix == 1); |
535
|
|
|
|
|
|
|
536
|
|
|
|
|
|
/* wait for all pseudo-forked children to finish */ |
537
|
|
|
|
|
|
PERL_WAIT_FOR_CHILDREN; |
538
|
|
|
|
|
|
|
539
|
11993
|
|
|
|
|
destruct_level = PL_perl_destruct_level; |
540
|
|
|
|
|
|
#if defined(DEBUGGING) || defined(PERL_TRACK_MEMPOOL) |
541
|
|
|
|
|
|
{ |
542
|
|
|
|
|
|
const char * const s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL"); |
543
|
|
|
|
|
|
if (s) { |
544
|
|
|
|
|
|
const int i = atoi(s); |
545
|
|
|
|
|
|
#ifdef DEBUGGING |
546
|
|
|
|
|
|
if (destruct_level < i) destruct_level = i; |
547
|
|
|
|
|
|
#endif |
548
|
|
|
|
|
|
#ifdef PERL_TRACK_MEMPOOL |
549
|
|
|
|
|
|
/* RT #114496, for perl_free */ |
550
|
|
|
|
|
|
PL_perl_destruct_level = i; |
551
|
|
|
|
|
|
#endif |
552
|
|
|
|
|
|
} |
553
|
|
|
|
|
|
} |
554
|
|
|
|
|
|
#endif |
555
|
|
|
|
|
|
|
556
|
11993
|
50
|
|
|
|
if (PL_exit_flags & PERL_EXIT_DESTRUCT_END) { |
557
|
|
|
|
|
|
dJMPENV; |
558
|
|
|
|
|
|
int x = 0; |
559
|
|
|
|
|
|
|
560
|
11992
|
|
|
|
|
JMPENV_PUSH(x); |
561
|
|
|
|
|
|
PERL_UNUSED_VAR(x); |
562
|
12026
|
100
|
|
|
|
if (PL_endav && !PL_minus_c) { |
|
|
50
|
|
|
|
|
563
|
3206
|
|
|
|
|
PERL_SET_PHASE(PERL_PHASE_END); |
564
|
3206
|
|
|
|
|
call_list(PL_scopestack_ix, PL_endav); |
565
|
|
|
|
|
|
} |
566
|
11992
|
|
|
|
|
JMPENV_POP; |
567
|
|
|
|
|
|
} |
568
|
11993
|
|
|
|
|
LEAVE; |
569
|
11993
|
50
|
|
|
|
FREETMPS; |
570
|
|
|
|
|
|
assert(PL_scopestack_ix == 0); |
571
|
|
|
|
|
|
|
572
|
|
|
|
|
|
/* Need to flush since END blocks can produce output */ |
573
|
11993
|
|
|
|
|
my_fflush_all(); |
574
|
|
|
|
|
|
|
575
|
|
|
|
|
|
#ifdef PERL_TRACE_OPS |
576
|
|
|
|
|
|
/* If we traced all Perl OP usage, report and clean up */ |
577
|
|
|
|
|
|
PerlIO_printf(Perl_debug_log, "Trace of all OPs executed:\n"); |
578
|
|
|
|
|
|
for (i = 0; i <= OP_max; ++i) { |
579
|
|
|
|
|
|
PerlIO_printf(Perl_debug_log, " %s: %"UVuf"\n", PL_op_name[i], PL_op_exec_cnt[i]); |
580
|
|
|
|
|
|
PL_op_exec_cnt[i] = 0; |
581
|
|
|
|
|
|
} |
582
|
|
|
|
|
|
/* Utility slot for easily doing little tracing experiments in the runloop: */ |
583
|
|
|
|
|
|
if (PL_op_exec_cnt[OP_max+1] != 0) |
584
|
|
|
|
|
|
PerlIO_printf(Perl_debug_log, " SPECIAL: %"UVuf"\n", PL_op_exec_cnt[OP_max+1]); |
585
|
|
|
|
|
|
PerlIO_printf(Perl_debug_log, "\n"); |
586
|
|
|
|
|
|
#endif |
587
|
|
|
|
|
|
|
588
|
|
|
|
|
|
|
589
|
11993
|
50
|
|
|
|
if (PL_threadhook(aTHX)) { |
590
|
|
|
|
|
|
/* Threads hook has vetoed further cleanup */ |
591
|
0
|
|
|
|
|
PL_veto_cleanup = TRUE; |
592
|
0
|
|
|
|
|
return STATUS_EXIT; |
593
|
|
|
|
|
|
} |
594
|
|
|
|
|
|
|
595
|
|
|
|
|
|
#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP |
596
|
|
|
|
|
|
if (destruct_level != 0) { |
597
|
|
|
|
|
|
/* Fork here to create a child. Our child's job is to preserve the |
598
|
|
|
|
|
|
state of scalars prior to destruction, so that we can instruct it |
599
|
|
|
|
|
|
to dump any scalars that we later find have leaked. |
600
|
|
|
|
|
|
There's no subtlety in this code - it assumes POSIX, and it doesn't |
601
|
|
|
|
|
|
fail gracefully */ |
602
|
|
|
|
|
|
int fd[2]; |
603
|
|
|
|
|
|
|
604
|
|
|
|
|
|
if(socketpair(AF_UNIX, SOCK_STREAM, 0, fd)) { |
605
|
|
|
|
|
|
perror("Debug leaking scalars socketpair failed"); |
606
|
|
|
|
|
|
abort(); |
607
|
|
|
|
|
|
} |
608
|
|
|
|
|
|
|
609
|
|
|
|
|
|
child = fork(); |
610
|
|
|
|
|
|
if(child == -1) { |
611
|
|
|
|
|
|
perror("Debug leaking scalars fork failed"); |
612
|
|
|
|
|
|
abort(); |
613
|
|
|
|
|
|
} |
614
|
|
|
|
|
|
if (!child) { |
615
|
|
|
|
|
|
/* We are the child */ |
616
|
|
|
|
|
|
const int sock = fd[1]; |
617
|
|
|
|
|
|
const int debug_fd = PerlIO_fileno(Perl_debug_log); |
618
|
|
|
|
|
|
int f; |
619
|
|
|
|
|
|
const char *where; |
620
|
|
|
|
|
|
/* Our success message is an integer 0, and a char 0 */ |
621
|
|
|
|
|
|
static const char success[sizeof(int) + 1] = {0}; |
622
|
|
|
|
|
|
|
623
|
|
|
|
|
|
close(fd[0]); |
624
|
|
|
|
|
|
|
625
|
|
|
|
|
|
/* We need to close all other file descriptors otherwise we end up |
626
|
|
|
|
|
|
with interesting hangs, where the parent closes its end of a |
627
|
|
|
|
|
|
pipe, and sits waiting for (another) child to terminate. Only |
628
|
|
|
|
|
|
that child never terminates, because it never gets EOF, because |
629
|
|
|
|
|
|
we also have the far end of the pipe open. We even need to |
630
|
|
|
|
|
|
close the debugging fd, because sometimes it happens to be one |
631
|
|
|
|
|
|
end of a pipe, and a process is waiting on the other end for |
632
|
|
|
|
|
|
EOF. Normally it would be closed at some point earlier in |
633
|
|
|
|
|
|
destruction, but if we happen to cause the pipe to remain open, |
634
|
|
|
|
|
|
EOF never occurs, and we get an infinite hang. Hence all the |
635
|
|
|
|
|
|
games to pass in a file descriptor if it's actually needed. */ |
636
|
|
|
|
|
|
|
637
|
|
|
|
|
|
f = sysconf(_SC_OPEN_MAX); |
638
|
|
|
|
|
|
if(f < 0) { |
639
|
|
|
|
|
|
where = "sysconf failed"; |
640
|
|
|
|
|
|
goto abort; |
641
|
|
|
|
|
|
} |
642
|
|
|
|
|
|
while (f--) { |
643
|
|
|
|
|
|
if (f == sock) |
644
|
|
|
|
|
|
continue; |
645
|
|
|
|
|
|
close(f); |
646
|
|
|
|
|
|
} |
647
|
|
|
|
|
|
|
648
|
|
|
|
|
|
while (1) { |
649
|
|
|
|
|
|
SV *target; |
650
|
|
|
|
|
|
union control_un control; |
651
|
|
|
|
|
|
struct msghdr msg; |
652
|
|
|
|
|
|
struct iovec vec[1]; |
653
|
|
|
|
|
|
struct cmsghdr *cmptr; |
654
|
|
|
|
|
|
ssize_t got; |
655
|
|
|
|
|
|
int got_fd; |
656
|
|
|
|
|
|
|
657
|
|
|
|
|
|
msg.msg_control = control.control; |
658
|
|
|
|
|
|
msg.msg_controllen = sizeof(control.control); |
659
|
|
|
|
|
|
/* We're a connected socket so we don't need a source */ |
660
|
|
|
|
|
|
msg.msg_name = NULL; |
661
|
|
|
|
|
|
msg.msg_namelen = 0; |
662
|
|
|
|
|
|
msg.msg_iov = vec; |
663
|
|
|
|
|
|
msg.msg_iovlen = sizeof(vec)/sizeof(vec[0]); |
664
|
|
|
|
|
|
|
665
|
|
|
|
|
|
vec[0].iov_base = (void*)⌖ |
666
|
|
|
|
|
|
vec[0].iov_len = sizeof(target); |
667
|
|
|
|
|
|
|
668
|
|
|
|
|
|
got = recvmsg(sock, &msg, 0); |
669
|
|
|
|
|
|
|
670
|
|
|
|
|
|
if(got == 0) |
671
|
|
|
|
|
|
break; |
672
|
|
|
|
|
|
if(got < 0) { |
673
|
|
|
|
|
|
where = "recv failed"; |
674
|
|
|
|
|
|
goto abort; |
675
|
|
|
|
|
|
} |
676
|
|
|
|
|
|
if(got < sizeof(target)) { |
677
|
|
|
|
|
|
where = "short recv"; |
678
|
|
|
|
|
|
goto abort; |
679
|
|
|
|
|
|
} |
680
|
|
|
|
|
|
|
681
|
|
|
|
|
|
if(!(cmptr = CMSG_FIRSTHDR(&msg))) { |
682
|
|
|
|
|
|
where = "no cmsg"; |
683
|
|
|
|
|
|
goto abort; |
684
|
|
|
|
|
|
} |
685
|
|
|
|
|
|
if(cmptr->cmsg_len != CMSG_LEN(sizeof(int))) { |
686
|
|
|
|
|
|
where = "wrong cmsg_len"; |
687
|
|
|
|
|
|
goto abort; |
688
|
|
|
|
|
|
} |
689
|
|
|
|
|
|
if(cmptr->cmsg_level != SOL_SOCKET) { |
690
|
|
|
|
|
|
where = "wrong cmsg_level"; |
691
|
|
|
|
|
|
goto abort; |
692
|
|
|
|
|
|
} |
693
|
|
|
|
|
|
if(cmptr->cmsg_type != SCM_RIGHTS) { |
694
|
|
|
|
|
|
where = "wrong cmsg_type"; |
695
|
|
|
|
|
|
goto abort; |
696
|
|
|
|
|
|
} |
697
|
|
|
|
|
|
|
698
|
|
|
|
|
|
got_fd = *(int*)CMSG_DATA(cmptr); |
699
|
|
|
|
|
|
/* For our last little bit of trickery, put the file descriptor |
700
|
|
|
|
|
|
back into Perl_debug_log, as if we never actually closed it |
701
|
|
|
|
|
|
*/ |
702
|
|
|
|
|
|
if(got_fd != debug_fd) { |
703
|
|
|
|
|
|
if (dup2(got_fd, debug_fd) == -1) { |
704
|
|
|
|
|
|
where = "dup2"; |
705
|
|
|
|
|
|
goto abort; |
706
|
|
|
|
|
|
} |
707
|
|
|
|
|
|
} |
708
|
|
|
|
|
|
sv_dump(target); |
709
|
|
|
|
|
|
|
710
|
|
|
|
|
|
PerlIO_flush(Perl_debug_log); |
711
|
|
|
|
|
|
|
712
|
|
|
|
|
|
got = write(sock, &success, sizeof(success)); |
713
|
|
|
|
|
|
|
714
|
|
|
|
|
|
if(got < 0) { |
715
|
|
|
|
|
|
where = "write failed"; |
716
|
|
|
|
|
|
goto abort; |
717
|
|
|
|
|
|
} |
718
|
|
|
|
|
|
if(got < sizeof(success)) { |
719
|
|
|
|
|
|
where = "short write"; |
720
|
|
|
|
|
|
goto abort; |
721
|
|
|
|
|
|
} |
722
|
|
|
|
|
|
} |
723
|
|
|
|
|
|
_exit(0); |
724
|
|
|
|
|
|
abort: |
725
|
|
|
|
|
|
{ |
726
|
|
|
|
|
|
int send_errno = errno; |
727
|
|
|
|
|
|
unsigned char length = (unsigned char) strlen(where); |
728
|
|
|
|
|
|
struct iovec failure[3] = { |
729
|
|
|
|
|
|
{(void*)&send_errno, sizeof(send_errno)}, |
730
|
|
|
|
|
|
{&length, 1}, |
731
|
|
|
|
|
|
{(void*)where, length} |
732
|
|
|
|
|
|
}; |
733
|
|
|
|
|
|
int got = writev(sock, failure, 3); |
734
|
|
|
|
|
|
/* Bad news travels fast. Faster than data. We'll get a SIGPIPE |
735
|
|
|
|
|
|
in the parent if we try to read from the socketpair after the |
736
|
|
|
|
|
|
child has exited, even if there was data to read. |
737
|
|
|
|
|
|
So sleep a bit to give the parent a fighting chance of |
738
|
|
|
|
|
|
reading the data. */ |
739
|
|
|
|
|
|
sleep(2); |
740
|
|
|
|
|
|
_exit((got == -1) ? errno : 0); |
741
|
|
|
|
|
|
} |
742
|
|
|
|
|
|
/* End of child. */ |
743
|
|
|
|
|
|
} |
744
|
|
|
|
|
|
PL_dumper_fd = fd[0]; |
745
|
|
|
|
|
|
close(fd[1]); |
746
|
|
|
|
|
|
} |
747
|
|
|
|
|
|
#endif |
748
|
|
|
|
|
|
|
749
|
|
|
|
|
|
/* We must account for everything. */ |
750
|
|
|
|
|
|
|
751
|
|
|
|
|
|
/* Destroy the main CV and syntax tree */ |
752
|
|
|
|
|
|
/* Set PL_curcop now, because destroying ops can cause new SVs |
753
|
|
|
|
|
|
to be generated in Perl_pad_swipe, and when running with |
754
|
|
|
|
|
|
-DDEBUG_LEAKING_SCALARS they expect PL_curcop to point to a valid |
755
|
|
|
|
|
|
op from which the filename structure member is copied. */ |
756
|
11993
|
|
|
|
|
PL_curcop = &PL_compiling; |
757
|
11993
|
50
|
|
|
|
if (PL_main_root) { |
758
|
|
|
|
|
|
/* ensure comppad/curpad to refer to main's pad */ |
759
|
11563
|
50
|
|
|
|
if (CvPADLIST(PL_main_cv)) { |
760
|
11563
|
|
|
|
|
PAD_SET_CUR_NOSAVE(CvPADLIST(PL_main_cv), 1); |
761
|
11563
|
|
|
|
|
PL_comppad_name = PadlistNAMES(CvPADLIST(PL_main_cv)); |
762
|
|
|
|
|
|
} |
763
|
11563
|
|
|
|
|
op_free(PL_main_root); |
764
|
11563
|
|
|
|
|
PL_main_root = NULL; |
765
|
|
|
|
|
|
} |
766
|
11993
|
|
|
|
|
PL_main_start = NULL; |
767
|
|
|
|
|
|
/* note that PL_main_cv isn't usually actually freed at this point, |
768
|
|
|
|
|
|
* due to the CvOUTSIDE refs from subs compiled within it. It will |
769
|
|
|
|
|
|
* get freed once all the subs are freed in sv_clean_all(), for |
770
|
|
|
|
|
|
* destruct_level > 0 */ |
771
|
11993
|
|
|
|
|
SvREFCNT_dec(PL_main_cv); |
772
|
11993
|
|
|
|
|
PL_main_cv = NULL; |
773
|
11993
|
|
|
|
|
PERL_SET_PHASE(PERL_PHASE_DESTRUCT); |
774
|
|
|
|
|
|
|
775
|
|
|
|
|
|
/* Tell PerlIO we are about to tear things apart in case |
776
|
|
|
|
|
|
we have layers which are using resources that should |
777
|
|
|
|
|
|
be cleaned up now. |
778
|
|
|
|
|
|
*/ |
779
|
|
|
|
|
|
|
780
|
11993
|
|
|
|
|
PerlIO_destruct(aTHX); |
781
|
|
|
|
|
|
|
782
|
|
|
|
|
|
/* |
783
|
|
|
|
|
|
* Try to destruct global references. We do this first so that the |
784
|
|
|
|
|
|
* destructors and destructees still exist. Some sv's might remain. |
785
|
|
|
|
|
|
* Non-referenced objects are on their own. |
786
|
|
|
|
|
|
*/ |
787
|
11993
|
|
|
|
|
sv_clean_objs(); |
788
|
|
|
|
|
|
|
789
|
|
|
|
|
|
/* unhook hooks which will soon be, or use, destroyed data */ |
790
|
11991
|
|
|
|
|
SvREFCNT_dec(PL_warnhook); |
791
|
11991
|
|
|
|
|
PL_warnhook = NULL; |
792
|
11991
|
|
|
|
|
SvREFCNT_dec(PL_diehook); |
793
|
11991
|
|
|
|
|
PL_diehook = NULL; |
794
|
|
|
|
|
|
|
795
|
|
|
|
|
|
/* call exit list functions */ |
796
|
21965
|
50
|
|
|
|
while (PL_exitlistlen-- > 0) |
797
|
0
|
|
|
|
|
PL_exitlist[PL_exitlistlen].fn(aTHX_ PL_exitlist[PL_exitlistlen].ptr); |
798
|
|
|
|
|
|
|
799
|
11991
|
|
|
|
|
Safefree(PL_exitlist); |
800
|
|
|
|
|
|
|
801
|
11991
|
|
|
|
|
PL_exitlist = NULL; |
802
|
11991
|
|
|
|
|
PL_exitlistlen = 0; |
803
|
|
|
|
|
|
|
804
|
11991
|
|
|
|
|
SvREFCNT_dec(PL_registered_mros); |
805
|
|
|
|
|
|
|
806
|
|
|
|
|
|
/* jettison our possibly duplicated environment */ |
807
|
|
|
|
|
|
/* if PERL_USE_SAFE_PUTENV is defined environ will not have been copied |
808
|
|
|
|
|
|
* so we certainly shouldn't free it here |
809
|
|
|
|
|
|
*/ |
810
|
|
|
|
|
|
#ifndef PERL_MICRO |
811
|
|
|
|
|
|
#if defined(USE_ENVIRON_ARRAY) && !defined(PERL_USE_SAFE_PUTENV) |
812
|
11991
|
50
|
|
|
|
if (environ != PL_origenviron && !PL_use_safe_putenv |
|
|
50
|
|
|
|
|
813
|
|
|
|
|
|
#ifdef USE_ITHREADS |
814
|
|
|
|
|
|
/* only main thread can free environ[0] contents */ |
815
|
|
|
|
|
|
&& PL_curinterp == aTHX |
816
|
|
|
|
|
|
#endif |
817
|
|
|
|
|
|
) |
818
|
|
|
|
|
|
{ |
819
|
|
|
|
|
|
I32 i; |
820
|
|
|
|
|
|
|
821
|
864158
|
100
|
|
|
|
for (i = 0; environ[i]; i++) |
822
|
862141
|
|
|
|
|
safesysfree(environ[i]); |
823
|
|
|
|
|
|
|
824
|
|
|
|
|
|
/* Must use safesysfree() when working with environ. */ |
825
|
11990
|
|
|
|
|
safesysfree(environ); |
826
|
|
|
|
|
|
|
827
|
11990
|
|
|
|
|
environ = PL_origenviron; |
828
|
|
|
|
|
|
} |
829
|
|
|
|
|
|
#endif |
830
|
|
|
|
|
|
#endif /* !PERL_MICRO */ |
831
|
|
|
|
|
|
|
832
|
11991
|
50
|
|
|
|
if (destruct_level == 0) { |
833
|
|
|
|
|
|
|
834
|
|
|
|
|
|
DEBUG_P(debprofdump()); |
835
|
|
|
|
|
|
|
836
|
|
|
|
|
|
#if defined(PERLIO_LAYERS) |
837
|
|
|
|
|
|
/* No more IO - including error messages ! */ |
838
|
11991
|
|
|
|
|
PerlIO_cleanup(aTHX); |
839
|
|
|
|
|
|
#endif |
840
|
|
|
|
|
|
|
841
|
11991
|
|
|
|
|
CopFILE_free(&PL_compiling); |
842
|
|
|
|
|
|
|
843
|
|
|
|
|
|
/* The exit() function will do everything that needs doing. */ |
844
|
11991
|
|
|
|
|
return STATUS_EXIT; |
845
|
|
|
|
|
|
} |
846
|
|
|
|
|
|
|
847
|
|
|
|
|
|
#ifdef USE_ITHREADS |
848
|
|
|
|
|
|
/* the syntax tree is shared between clones |
849
|
|
|
|
|
|
* so op_free(PL_main_root) only ReREFCNT_dec's |
850
|
|
|
|
|
|
* REGEXPs in the parent interpreter |
851
|
|
|
|
|
|
* we need to manually ReREFCNT_dec for the clones |
852
|
|
|
|
|
|
*/ |
853
|
|
|
|
|
|
{ |
854
|
|
|
|
|
|
I32 i = AvFILLp(PL_regex_padav); |
855
|
|
|
|
|
|
SV **ary = AvARRAY(PL_regex_padav); |
856
|
|
|
|
|
|
|
857
|
|
|
|
|
|
for (; i; i--) { |
858
|
|
|
|
|
|
SvREFCNT_dec(ary[i]); |
859
|
|
|
|
|
|
ary[i] = &PL_sv_undef; |
860
|
|
|
|
|
|
} |
861
|
|
|
|
|
|
} |
862
|
|
|
|
|
|
#endif |
863
|
|
|
|
|
|
|
864
|
|
|
|
|
|
|
865
|
0
|
|
|
|
|
SvREFCNT_dec(MUTABLE_SV(PL_stashcache)); |
866
|
0
|
|
|
|
|
PL_stashcache = NULL; |
867
|
|
|
|
|
|
|
868
|
|
|
|
|
|
/* loosen bonds of global variables */ |
869
|
|
|
|
|
|
|
870
|
|
|
|
|
|
/* XXX can PL_parser still be non-null here? */ |
871
|
0
|
0
|
|
|
|
if(PL_parser && PL_parser->rsfp) { |
|
|
0
|
|
|
|
|
872
|
0
|
|
|
|
|
(void)PerlIO_close(PL_parser->rsfp); |
873
|
0
|
|
|
|
|
PL_parser->rsfp = NULL; |
874
|
|
|
|
|
|
} |
875
|
|
|
|
|
|
|
876
|
0
|
0
|
|
|
|
if (PL_minus_F) { |
877
|
0
|
|
|
|
|
Safefree(PL_splitstr); |
878
|
0
|
|
|
|
|
PL_splitstr = NULL; |
879
|
|
|
|
|
|
} |
880
|
|
|
|
|
|
|
881
|
|
|
|
|
|
/* switches */ |
882
|
0
|
|
|
|
|
PL_minus_n = FALSE; |
883
|
0
|
|
|
|
|
PL_minus_p = FALSE; |
884
|
0
|
|
|
|
|
PL_minus_l = FALSE; |
885
|
0
|
|
|
|
|
PL_minus_a = FALSE; |
886
|
0
|
|
|
|
|
PL_minus_F = FALSE; |
887
|
0
|
|
|
|
|
PL_doswitches = FALSE; |
888
|
0
|
|
|
|
|
PL_dowarn = G_WARN_OFF; |
889
|
|
|
|
|
|
#ifdef PERL_SAWAMPERSAND |
890
|
|
|
|
|
|
PL_sawampersand = 0; /* must save all match strings */ |
891
|
|
|
|
|
|
#endif |
892
|
0
|
|
|
|
|
PL_unsafe = FALSE; |
893
|
|
|
|
|
|
|
894
|
0
|
|
|
|
|
Safefree(PL_inplace); |
895
|
0
|
|
|
|
|
PL_inplace = NULL; |
896
|
0
|
|
|
|
|
SvREFCNT_dec(PL_patchlevel); |
897
|
0
|
|
|
|
|
SvREFCNT_dec(PL_apiversion); |
898
|
|
|
|
|
|
|
899
|
0
|
0
|
|
|
|
if (PL_e_script) { |
900
|
0
|
|
|
|
|
SvREFCNT_dec(PL_e_script); |
901
|
0
|
|
|
|
|
PL_e_script = NULL; |
902
|
|
|
|
|
|
} |
903
|
|
|
|
|
|
|
904
|
0
|
|
|
|
|
PL_perldb = 0; |
905
|
|
|
|
|
|
|
906
|
|
|
|
|
|
/* magical thingies */ |
907
|
|
|
|
|
|
|
908
|
0
|
|
|
|
|
SvREFCNT_dec(PL_ofsgv); /* *, */ |
909
|
0
|
|
|
|
|
PL_ofsgv = NULL; |
910
|
|
|
|
|
|
|
911
|
0
|
|
|
|
|
SvREFCNT_dec(PL_ors_sv); /* $\ */ |
912
|
0
|
|
|
|
|
PL_ors_sv = NULL; |
913
|
|
|
|
|
|
|
914
|
0
|
|
|
|
|
SvREFCNT_dec(PL_rs); /* $/ */ |
915
|
0
|
|
|
|
|
PL_rs = NULL; |
916
|
|
|
|
|
|
|
917
|
0
|
|
|
|
|
Safefree(PL_osname); /* $^O */ |
918
|
0
|
|
|
|
|
PL_osname = NULL; |
919
|
|
|
|
|
|
|
920
|
0
|
|
|
|
|
SvREFCNT_dec(PL_statname); |
921
|
0
|
|
|
|
|
PL_statname = NULL; |
922
|
0
|
|
|
|
|
PL_statgv = NULL; |
923
|
|
|
|
|
|
|
924
|
|
|
|
|
|
/* defgv, aka *_ should be taken care of elsewhere */ |
925
|
|
|
|
|
|
|
926
|
|
|
|
|
|
/* float buffer */ |
927
|
0
|
|
|
|
|
Safefree(PL_efloatbuf); |
928
|
0
|
|
|
|
|
PL_efloatbuf = NULL; |
929
|
0
|
|
|
|
|
PL_efloatsize = 0; |
930
|
|
|
|
|
|
|
931
|
|
|
|
|
|
/* startup and shutdown function lists */ |
932
|
0
|
|
|
|
|
SvREFCNT_dec(PL_beginav); |
933
|
0
|
|
|
|
|
SvREFCNT_dec(PL_beginav_save); |
934
|
0
|
|
|
|
|
SvREFCNT_dec(PL_endav); |
935
|
0
|
|
|
|
|
SvREFCNT_dec(PL_checkav); |
936
|
0
|
|
|
|
|
SvREFCNT_dec(PL_checkav_save); |
937
|
0
|
|
|
|
|
SvREFCNT_dec(PL_unitcheckav); |
938
|
0
|
|
|
|
|
SvREFCNT_dec(PL_unitcheckav_save); |
939
|
0
|
|
|
|
|
SvREFCNT_dec(PL_initav); |
940
|
0
|
|
|
|
|
PL_beginav = NULL; |
941
|
0
|
|
|
|
|
PL_beginav_save = NULL; |
942
|
0
|
|
|
|
|
PL_endav = NULL; |
943
|
0
|
|
|
|
|
PL_checkav = NULL; |
944
|
0
|
|
|
|
|
PL_checkav_save = NULL; |
945
|
0
|
|
|
|
|
PL_unitcheckav = NULL; |
946
|
0
|
|
|
|
|
PL_unitcheckav_save = NULL; |
947
|
0
|
|
|
|
|
PL_initav = NULL; |
948
|
|
|
|
|
|
|
949
|
|
|
|
|
|
/* shortcuts just get cleared */ |
950
|
0
|
|
|
|
|
PL_envgv = NULL; |
951
|
0
|
|
|
|
|
PL_incgv = NULL; |
952
|
0
|
|
|
|
|
PL_hintgv = NULL; |
953
|
0
|
|
|
|
|
PL_errgv = NULL; |
954
|
0
|
|
|
|
|
PL_argvgv = NULL; |
955
|
0
|
|
|
|
|
PL_argvoutgv = NULL; |
956
|
0
|
|
|
|
|
PL_stdingv = NULL; |
957
|
0
|
|
|
|
|
PL_stderrgv = NULL; |
958
|
0
|
|
|
|
|
PL_last_in_gv = NULL; |
959
|
0
|
|
|
|
|
PL_replgv = NULL; |
960
|
0
|
|
|
|
|
PL_DBgv = NULL; |
961
|
0
|
|
|
|
|
PL_DBline = NULL; |
962
|
0
|
|
|
|
|
PL_DBsub = NULL; |
963
|
0
|
|
|
|
|
PL_DBsingle = NULL; |
964
|
0
|
|
|
|
|
PL_DBtrace = NULL; |
965
|
0
|
|
|
|
|
PL_DBsignal = NULL; |
966
|
0
|
|
|
|
|
PL_DBcv = NULL; |
967
|
0
|
|
|
|
|
PL_dbargs = NULL; |
968
|
0
|
|
|
|
|
PL_debstash = NULL; |
969
|
|
|
|
|
|
|
970
|
0
|
|
|
|
|
SvREFCNT_dec(PL_argvout_stack); |
971
|
0
|
|
|
|
|
PL_argvout_stack = NULL; |
972
|
|
|
|
|
|
|
973
|
0
|
|
|
|
|
SvREFCNT_dec(PL_modglobal); |
974
|
0
|
|
|
|
|
PL_modglobal = NULL; |
975
|
0
|
|
|
|
|
SvREFCNT_dec(PL_preambleav); |
976
|
0
|
|
|
|
|
PL_preambleav = NULL; |
977
|
0
|
|
|
|
|
SvREFCNT_dec(PL_subname); |
978
|
0
|
|
|
|
|
PL_subname = NULL; |
979
|
|
|
|
|
|
#ifdef PERL_USES_PL_PIDSTATUS |
980
|
|
|
|
|
|
SvREFCNT_dec(PL_pidstatus); |
981
|
|
|
|
|
|
PL_pidstatus = NULL; |
982
|
|
|
|
|
|
#endif |
983
|
0
|
|
|
|
|
SvREFCNT_dec(PL_toptarget); |
984
|
0
|
|
|
|
|
PL_toptarget = NULL; |
985
|
0
|
|
|
|
|
SvREFCNT_dec(PL_bodytarget); |
986
|
0
|
|
|
|
|
PL_bodytarget = NULL; |
987
|
0
|
|
|
|
|
PL_formtarget = NULL; |
988
|
|
|
|
|
|
|
989
|
|
|
|
|
|
/* free locale stuff */ |
990
|
|
|
|
|
|
#ifdef USE_LOCALE_COLLATE |
991
|
0
|
|
|
|
|
Safefree(PL_collation_name); |
992
|
0
|
|
|
|
|
PL_collation_name = NULL; |
993
|
|
|
|
|
|
#endif |
994
|
|
|
|
|
|
|
995
|
|
|
|
|
|
#ifdef USE_LOCALE_NUMERIC |
996
|
0
|
|
|
|
|
Safefree(PL_numeric_name); |
997
|
0
|
|
|
|
|
PL_numeric_name = NULL; |
998
|
0
|
|
|
|
|
SvREFCNT_dec(PL_numeric_radix_sv); |
999
|
0
|
|
|
|
|
PL_numeric_radix_sv = NULL; |
1000
|
|
|
|
|
|
#endif |
1001
|
|
|
|
|
|
|
1002
|
|
|
|
|
|
/* clear character classes */ |
1003
|
0
|
0
|
|
|
|
for (i = 0; i < POSIX_SWASH_COUNT; i++) { |
1004
|
0
|
|
|
|
|
SvREFCNT_dec(PL_utf8_swash_ptrs[i]); |
1005
|
0
|
|
|
|
|
PL_utf8_swash_ptrs[i] = NULL; |
1006
|
|
|
|
|
|
} |
1007
|
0
|
|
|
|
|
SvREFCNT_dec(PL_utf8_mark); |
1008
|
0
|
|
|
|
|
SvREFCNT_dec(PL_utf8_toupper); |
1009
|
0
|
|
|
|
|
SvREFCNT_dec(PL_utf8_totitle); |
1010
|
0
|
|
|
|
|
SvREFCNT_dec(PL_utf8_tolower); |
1011
|
0
|
|
|
|
|
SvREFCNT_dec(PL_utf8_tofold); |
1012
|
0
|
|
|
|
|
SvREFCNT_dec(PL_utf8_idstart); |
1013
|
0
|
|
|
|
|
SvREFCNT_dec(PL_utf8_idcont); |
1014
|
0
|
|
|
|
|
SvREFCNT_dec(PL_utf8_foldclosures); |
1015
|
0
|
|
|
|
|
PL_utf8_mark = NULL; |
1016
|
0
|
|
|
|
|
PL_utf8_toupper = NULL; |
1017
|
0
|
|
|
|
|
PL_utf8_totitle = NULL; |
1018
|
0
|
|
|
|
|
PL_utf8_tolower = NULL; |
1019
|
0
|
|
|
|
|
PL_utf8_tofold = NULL; |
1020
|
0
|
|
|
|
|
PL_utf8_idstart = NULL; |
1021
|
0
|
|
|
|
|
PL_utf8_idcont = NULL; |
1022
|
0
|
|
|
|
|
PL_utf8_foldclosures = NULL; |
1023
|
0
|
0
|
|
|
|
for (i = 0; i < POSIX_CC_COUNT; i++) { |
1024
|
0
|
|
|
|
|
SvREFCNT_dec(PL_Posix_ptrs[i]); |
1025
|
0
|
|
|
|
|
PL_Posix_ptrs[i] = NULL; |
1026
|
|
|
|
|
|
|
1027
|
0
|
|
|
|
|
SvREFCNT_dec(PL_L1Posix_ptrs[i]); |
1028
|
0
|
|
|
|
|
PL_L1Posix_ptrs[i] = NULL; |
1029
|
|
|
|
|
|
|
1030
|
0
|
|
|
|
|
SvREFCNT_dec(PL_XPosix_ptrs[i]); |
1031
|
0
|
|
|
|
|
PL_XPosix_ptrs[i] = NULL; |
1032
|
|
|
|
|
|
} |
1033
|
|
|
|
|
|
|
1034
|
0
|
0
|
|
|
|
if (!specialWARN(PL_compiling.cop_warnings)) |
|
|
0
|
|
|
|
|
1035
|
0
|
|
|
|
|
PerlMemShared_free(PL_compiling.cop_warnings); |
1036
|
0
|
|
|
|
|
PL_compiling.cop_warnings = NULL; |
1037
|
0
|
|
|
|
|
cophh_free(CopHINTHASH_get(&PL_compiling)); |
1038
|
0
|
|
|
|
|
CopHINTHASH_set(&PL_compiling, cophh_new_empty()); |
1039
|
0
|
|
|
|
|
CopFILE_free(&PL_compiling); |
1040
|
|
|
|
|
|
|
1041
|
|
|
|
|
|
/* Prepare to destruct main symbol table. */ |
1042
|
|
|
|
|
|
|
1043
|
0
|
|
|
|
|
hv = PL_defstash; |
1044
|
|
|
|
|
|
/* break ref loop *:: <=> %:: */ |
1045
|
0
|
|
|
|
|
(void)hv_delete(hv, "main::", 6, G_DISCARD); |
1046
|
0
|
|
|
|
|
PL_defstash = 0; |
1047
|
0
|
|
|
|
|
SvREFCNT_dec(hv); |
1048
|
0
|
|
|
|
|
SvREFCNT_dec(PL_curstname); |
1049
|
0
|
|
|
|
|
PL_curstname = NULL; |
1050
|
|
|
|
|
|
|
1051
|
|
|
|
|
|
/* clear queued errors */ |
1052
|
0
|
|
|
|
|
SvREFCNT_dec(PL_errors); |
1053
|
0
|
|
|
|
|
PL_errors = NULL; |
1054
|
|
|
|
|
|
|
1055
|
0
|
|
|
|
|
SvREFCNT_dec(PL_isarev); |
1056
|
|
|
|
|
|
|
1057
|
0
|
0
|
|
|
|
FREETMPS; |
1058
|
0
|
0
|
|
|
|
if (destruct_level >= 2) { |
1059
|
0
|
0
|
|
|
|
if (PL_scopestack_ix != 0) |
1060
|
0
|
|
|
|
|
Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), |
1061
|
|
|
|
|
|
"Unbalanced scopes: %ld more ENTERs than LEAVEs\n", |
1062
|
|
|
|
|
|
(long)PL_scopestack_ix); |
1063
|
0
|
0
|
|
|
|
if (PL_savestack_ix != 0) |
1064
|
0
|
|
|
|
|
Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), |
1065
|
|
|
|
|
|
"Unbalanced saves: %ld more saves than restores\n", |
1066
|
|
|
|
|
|
(long)PL_savestack_ix); |
1067
|
0
|
0
|
|
|
|
if (PL_tmps_floor != -1) |
1068
|
0
|
|
|
|
|
Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced tmps: %ld more allocs than frees\n", |
1069
|
|
|
|
|
|
(long)PL_tmps_floor + 1); |
1070
|
0
|
0
|
|
|
|
if (cxstack_ix != -1) |
1071
|
0
|
|
|
|
|
Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced context: %ld more PUSHes than POPs\n", |
1072
|
0
|
|
|
|
|
(long)cxstack_ix + 1); |
1073
|
|
|
|
|
|
} |
1074
|
|
|
|
|
|
|
1075
|
|
|
|
|
|
#ifdef USE_ITHREADS |
1076
|
|
|
|
|
|
SvREFCNT_dec(PL_regex_padav); |
1077
|
|
|
|
|
|
PL_regex_padav = NULL; |
1078
|
|
|
|
|
|
PL_regex_pad = NULL; |
1079
|
|
|
|
|
|
#endif |
1080
|
|
|
|
|
|
|
1081
|
|
|
|
|
|
#ifdef PERL_IMPLICIT_CONTEXT |
1082
|
|
|
|
|
|
/* the entries in this list are allocated via SV PVX's, so get freed |
1083
|
|
|
|
|
|
* in sv_clean_all */ |
1084
|
|
|
|
|
|
Safefree(PL_my_cxt_list); |
1085
|
|
|
|
|
|
#endif |
1086
|
|
|
|
|
|
|
1087
|
|
|
|
|
|
/* Now absolutely destruct everything, somehow or other, loops or no. */ |
1088
|
|
|
|
|
|
|
1089
|
|
|
|
|
|
/* the 2 is for PL_fdpid and PL_strtab */ |
1090
|
0
|
0
|
|
|
|
while (sv_clean_all() > 2) |
1091
|
|
|
|
|
|
; |
1092
|
|
|
|
|
|
|
1093
|
|
|
|
|
|
#ifdef USE_ITHREADS |
1094
|
|
|
|
|
|
Safefree(PL_stashpad); /* must come after sv_clean_all */ |
1095
|
|
|
|
|
|
#endif |
1096
|
|
|
|
|
|
|
1097
|
0
|
|
|
|
|
AvREAL_off(PL_fdpid); /* no surviving entries */ |
1098
|
0
|
|
|
|
|
SvREFCNT_dec(PL_fdpid); /* needed in io_close() */ |
1099
|
0
|
|
|
|
|
PL_fdpid = NULL; |
1100
|
|
|
|
|
|
|
1101
|
|
|
|
|
|
#ifdef HAVE_INTERP_INTERN |
1102
|
|
|
|
|
|
sys_intern_clear(); |
1103
|
|
|
|
|
|
#endif |
1104
|
|
|
|
|
|
|
1105
|
|
|
|
|
|
/* constant strings */ |
1106
|
0
|
0
|
|
|
|
for (i = 0; i < SV_CONSTS_COUNT; i++) { |
1107
|
0
|
|
|
|
|
SvREFCNT_dec(PL_sv_consts[i]); |
1108
|
0
|
|
|
|
|
PL_sv_consts[i] = NULL; |
1109
|
|
|
|
|
|
} |
1110
|
|
|
|
|
|
|
1111
|
|
|
|
|
|
/* Destruct the global string table. */ |
1112
|
|
|
|
|
|
{ |
1113
|
|
|
|
|
|
/* Yell and reset the HeVAL() slots that are still holding refcounts, |
1114
|
|
|
|
|
|
* so that sv_free() won't fail on them. |
1115
|
|
|
|
|
|
* Now that the global string table is using a single hunk of memory |
1116
|
|
|
|
|
|
* for both HE and HEK, we either need to explicitly unshare it the |
1117
|
|
|
|
|
|
* correct way, or actually free things here. |
1118
|
|
|
|
|
|
*/ |
1119
|
|
|
|
|
|
I32 riter = 0; |
1120
|
0
|
|
|
|
|
const I32 max = HvMAX(PL_strtab); |
1121
|
0
|
|
|
|
|
HE * const * const array = HvARRAY(PL_strtab); |
1122
|
0
|
|
|
|
|
HE *hent = array[0]; |
1123
|
|
|
|
|
|
|
1124
|
|
|
|
|
|
for (;;) { |
1125
|
0
|
0
|
|
|
|
if (hent && ckWARN_d(WARN_INTERNAL)) { |
|
|
0
|
|
|
|
|
1126
|
0
|
|
|
|
|
HE * const next = HeNEXT(hent); |
1127
|
0
|
|
|
|
|
Perl_warner(aTHX_ packWARN(WARN_INTERNAL), |
1128
|
|
|
|
|
|
"Unbalanced string table refcount: (%ld) for \"%s\"", |
1129
|
0
|
|
|
|
|
(long)hent->he_valu.hent_refcount, HeKEY(hent)); |
1130
|
0
|
|
|
|
|
Safefree(hent); |
1131
|
|
|
|
|
|
hent = next; |
1132
|
|
|
|
|
|
} |
1133
|
0
|
0
|
|
|
|
if (!hent) { |
1134
|
0
|
0
|
|
|
|
if (++riter > max) |
1135
|
|
|
|
|
|
break; |
1136
|
0
|
|
|
|
|
hent = array[riter]; |
1137
|
|
|
|
|
|
} |
1138
|
|
|
|
|
|
} |
1139
|
|
|
|
|
|
|
1140
|
0
|
|
|
|
|
Safefree(array); |
1141
|
0
|
|
|
|
|
HvARRAY(PL_strtab) = 0; |
1142
|
0
|
|
|
|
|
HvTOTALKEYS(PL_strtab) = 0; |
1143
|
|
|
|
|
|
} |
1144
|
0
|
|
|
|
|
SvREFCNT_dec(PL_strtab); |
1145
|
|
|
|
|
|
|
1146
|
|
|
|
|
|
#ifdef USE_ITHREADS |
1147
|
|
|
|
|
|
/* free the pointer tables used for cloning */ |
1148
|
|
|
|
|
|
ptr_table_free(PL_ptr_table); |
1149
|
|
|
|
|
|
PL_ptr_table = (PTR_TBL_t*)NULL; |
1150
|
|
|
|
|
|
#endif |
1151
|
|
|
|
|
|
|
1152
|
|
|
|
|
|
/* free special SVs */ |
1153
|
|
|
|
|
|
|
1154
|
0
|
|
|
|
|
SvREFCNT(&PL_sv_yes) = 0; |
1155
|
0
|
|
|
|
|
sv_clear(&PL_sv_yes); |
1156
|
0
|
|
|
|
|
SvANY(&PL_sv_yes) = NULL; |
1157
|
0
|
|
|
|
|
SvFLAGS(&PL_sv_yes) = 0; |
1158
|
|
|
|
|
|
|
1159
|
0
|
|
|
|
|
SvREFCNT(&PL_sv_no) = 0; |
1160
|
0
|
|
|
|
|
sv_clear(&PL_sv_no); |
1161
|
0
|
|
|
|
|
SvANY(&PL_sv_no) = NULL; |
1162
|
0
|
|
|
|
|
SvFLAGS(&PL_sv_no) = 0; |
1163
|
|
|
|
|
|
|
1164
|
|
|
|
|
|
{ |
1165
|
|
|
|
|
|
int i; |
1166
|
0
|
0
|
|
|
|
for (i=0; i<=2; i++) { |
1167
|
0
|
|
|
|
|
SvREFCNT(PERL_DEBUG_PAD(i)) = 0; |
1168
|
0
|
|
|
|
|
sv_clear(PERL_DEBUG_PAD(i)); |
1169
|
0
|
|
|
|
|
SvANY(PERL_DEBUG_PAD(i)) = NULL; |
1170
|
0
|
|
|
|
|
SvFLAGS(PERL_DEBUG_PAD(i)) = 0; |
1171
|
|
|
|
|
|
} |
1172
|
|
|
|
|
|
} |
1173
|
|
|
|
|
|
|
1174
|
0
|
0
|
|
|
|
if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL)) |
|
|
0
|
|
|
|
|
1175
|
0
|
|
|
|
|
Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Scalars leaked: %ld\n", (long)PL_sv_count); |
1176
|
|
|
|
|
|
|
1177
|
|
|
|
|
|
#ifdef DEBUG_LEAKING_SCALARS |
1178
|
|
|
|
|
|
if (PL_sv_count != 0) { |
1179
|
|
|
|
|
|
SV* sva; |
1180
|
|
|
|
|
|
SV* sv; |
1181
|
|
|
|
|
|
SV* svend; |
1182
|
|
|
|
|
|
|
1183
|
|
|
|
|
|
for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) { |
1184
|
|
|
|
|
|
svend = &sva[SvREFCNT(sva)]; |
1185
|
|
|
|
|
|
for (sv = sva + 1; sv < svend; ++sv) { |
1186
|
|
|
|
|
|
if (SvTYPE(sv) != (svtype)SVTYPEMASK) { |
1187
|
|
|
|
|
|
PerlIO_printf(Perl_debug_log, "leaked: sv=0x%p" |
1188
|
|
|
|
|
|
" flags=0x%"UVxf |
1189
|
|
|
|
|
|
" refcnt=%"UVuf pTHX__FORMAT "\n" |
1190
|
|
|
|
|
|
"\tallocated at %s:%d %s %s (parent 0x%"UVxf");" |
1191
|
|
|
|
|
|
"serial %"UVuf"\n", |
1192
|
|
|
|
|
|
(void*)sv, (UV)sv->sv_flags, (UV)sv->sv_refcnt |
1193
|
|
|
|
|
|
pTHX__VALUE, |
1194
|
|
|
|
|
|
sv->sv_debug_file ? sv->sv_debug_file : "(unknown)", |
1195
|
|
|
|
|
|
sv->sv_debug_line, |
1196
|
|
|
|
|
|
sv->sv_debug_inpad ? "for" : "by", |
1197
|
|
|
|
|
|
sv->sv_debug_optype ? |
1198
|
|
|
|
|
|
PL_op_name[sv->sv_debug_optype]: "(none)", |
1199
|
|
|
|
|
|
PTR2UV(sv->sv_debug_parent), |
1200
|
|
|
|
|
|
sv->sv_debug_serial |
1201
|
|
|
|
|
|
); |
1202
|
|
|
|
|
|
#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP |
1203
|
|
|
|
|
|
Perl_dump_sv_child(aTHX_ sv); |
1204
|
|
|
|
|
|
#endif |
1205
|
|
|
|
|
|
} |
1206
|
|
|
|
|
|
} |
1207
|
|
|
|
|
|
} |
1208
|
|
|
|
|
|
} |
1209
|
|
|
|
|
|
#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP |
1210
|
|
|
|
|
|
{ |
1211
|
|
|
|
|
|
int status; |
1212
|
|
|
|
|
|
fd_set rset; |
1213
|
|
|
|
|
|
/* Wait for up to 4 seconds for child to terminate. |
1214
|
|
|
|
|
|
This seems to be the least effort way of timing out on reaping |
1215
|
|
|
|
|
|
its exit status. */ |
1216
|
|
|
|
|
|
struct timeval waitfor = {4, 0}; |
1217
|
|
|
|
|
|
int sock = PL_dumper_fd; |
1218
|
|
|
|
|
|
|
1219
|
|
|
|
|
|
shutdown(sock, 1); |
1220
|
|
|
|
|
|
FD_ZERO(&rset); |
1221
|
|
|
|
|
|
FD_SET(sock, &rset); |
1222
|
|
|
|
|
|
select(sock + 1, &rset, NULL, NULL, &waitfor); |
1223
|
|
|
|
|
|
waitpid(child, &status, WNOHANG); |
1224
|
|
|
|
|
|
close(sock); |
1225
|
|
|
|
|
|
} |
1226
|
|
|
|
|
|
#endif |
1227
|
|
|
|
|
|
#endif |
1228
|
|
|
|
|
|
#ifdef DEBUG_LEAKING_SCALARS_ABORT |
1229
|
|
|
|
|
|
if (PL_sv_count) |
1230
|
|
|
|
|
|
abort(); |
1231
|
|
|
|
|
|
#endif |
1232
|
0
|
|
|
|
|
PL_sv_count = 0; |
1233
|
|
|
|
|
|
|
1234
|
|
|
|
|
|
#if defined(PERLIO_LAYERS) |
1235
|
|
|
|
|
|
/* No more IO - including error messages ! */ |
1236
|
0
|
|
|
|
|
PerlIO_cleanup(aTHX); |
1237
|
|
|
|
|
|
#endif |
1238
|
|
|
|
|
|
|
1239
|
|
|
|
|
|
/* sv_undef needs to stay immortal until after PerlIO_cleanup |
1240
|
|
|
|
|
|
as currently layers use it rather than NULL as a marker |
1241
|
|
|
|
|
|
for no arg - and will try and SvREFCNT_dec it. |
1242
|
|
|
|
|
|
*/ |
1243
|
0
|
|
|
|
|
SvREFCNT(&PL_sv_undef) = 0; |
1244
|
0
|
|
|
|
|
SvREADONLY_off(&PL_sv_undef); |
1245
|
|
|
|
|
|
|
1246
|
0
|
|
|
|
|
Safefree(PL_origfilename); |
1247
|
0
|
|
|
|
|
PL_origfilename = NULL; |
1248
|
0
|
|
|
|
|
Safefree(PL_reg_curpm); |
1249
|
0
|
|
|
|
|
free_tied_hv_pool(); |
1250
|
0
|
|
|
|
|
Safefree(PL_op_mask); |
1251
|
0
|
|
|
|
|
Safefree(PL_psig_name); |
1252
|
0
|
|
|
|
|
PL_psig_name = (SV**)NULL; |
1253
|
0
|
|
|
|
|
PL_psig_ptr = (SV**)NULL; |
1254
|
|
|
|
|
|
{ |
1255
|
|
|
|
|
|
/* We need to NULL PL_psig_pend first, so that |
1256
|
|
|
|
|
|
signal handlers know not to use it */ |
1257
|
0
|
|
|
|
|
int *psig_save = PL_psig_pend; |
1258
|
0
|
|
|
|
|
PL_psig_pend = (int*)NULL; |
1259
|
0
|
|
|
|
|
Safefree(psig_save); |
1260
|
|
|
|
|
|
} |
1261
|
|
|
|
|
|
nuke_stacks(); |
1262
|
0
|
|
|
|
|
TAINTING_set(FALSE); |
1263
|
0
|
|
|
|
|
TAINT_WARN_set(FALSE); |
1264
|
0
|
|
|
|
|
PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */ |
1265
|
0
|
|
|
|
|
PL_debug = 0; |
1266
|
|
|
|
|
|
|
1267
|
|
|
|
|
|
DEBUG_P(debprofdump()); |
1268
|
|
|
|
|
|
|
1269
|
|
|
|
|
|
#ifdef USE_REENTRANT_API |
1270
|
|
|
|
|
|
Perl_reentrant_free(aTHX); |
1271
|
|
|
|
|
|
#endif |
1272
|
|
|
|
|
|
|
1273
|
0
|
|
|
|
|
sv_free_arenas(); |
1274
|
|
|
|
|
|
|
1275
|
0
|
0
|
|
|
|
while (PL_regmatch_slab) { |
1276
|
0
|
|
|
|
|
regmatch_slab *s = PL_regmatch_slab; |
1277
|
0
|
|
|
|
|
PL_regmatch_slab = PL_regmatch_slab->next; |
1278
|
0
|
|
|
|
|
Safefree(s); |
1279
|
|
|
|
|
|
} |
1280
|
|
|
|
|
|
|
1281
|
|
|
|
|
|
/* As the absolutely last thing, free the non-arena SV for mess() */ |
1282
|
|
|
|
|
|
|
1283
|
0
|
0
|
|
|
|
if (PL_mess_sv) { |
1284
|
|
|
|
|
|
/* we know that type == SVt_PVMG */ |
1285
|
|
|
|
|
|
|
1286
|
|
|
|
|
|
/* it could have accumulated taint magic */ |
1287
|
|
|
|
|
|
MAGIC* mg; |
1288
|
|
|
|
|
|
MAGIC* moremagic; |
1289
|
0
|
0
|
|
|
|
for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) { |
1290
|
0
|
|
|
|
|
moremagic = mg->mg_moremagic; |
1291
|
0
|
0
|
|
|
|
if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global |
|
|
0
|
|
|
|
|
1292
|
0
|
0
|
|
|
|
&& mg->mg_len >= 0) |
1293
|
0
|
|
|
|
|
Safefree(mg->mg_ptr); |
1294
|
0
|
|
|
|
|
Safefree(mg); |
1295
|
|
|
|
|
|
} |
1296
|
|
|
|
|
|
|
1297
|
|
|
|
|
|
/* we know that type >= SVt_PV */ |
1298
|
0
|
0
|
|
|
|
SvPV_free(PL_mess_sv); |
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
1299
|
0
|
|
|
|
|
Safefree(SvANY(PL_mess_sv)); |
1300
|
0
|
|
|
|
|
Safefree(PL_mess_sv); |
1301
|
0
|
|
|
|
|
PL_mess_sv = NULL; |
1302
|
|
|
|
|
|
} |
1303
|
2017
|
|
|
|
|
return STATUS_EXIT; |
1304
|
|
|
|
|
|
} |
1305
|
|
|
|
|
|
|
1306
|
|
|
|
|
|
/* |
1307
|
|
|
|
|
|
=for apidoc perl_free |
1308
|
|
|
|
|
|
|
1309
|
|
|
|
|
|
Releases a Perl interpreter. See L. |
1310
|
|
|
|
|
|
|
1311
|
|
|
|
|
|
=cut |
1312
|
|
|
|
|
|
*/ |
1313
|
|
|
|
|
|
|
1314
|
|
|
|
|
|
void |
1315
|
11991
|
|
|
|
|
perl_free(pTHXx) |
1316
|
|
|
|
|
|
{ |
1317
|
|
|
|
|
|
dVAR; |
1318
|
|
|
|
|
|
|
1319
|
|
|
|
|
|
PERL_ARGS_ASSERT_PERL_FREE; |
1320
|
|
|
|
|
|
|
1321
|
11991
|
50
|
|
|
|
if (PL_veto_cleanup) |
1322
|
11991
|
|
|
|
|
return; |
1323
|
|
|
|
|
|
|
1324
|
|
|
|
|
|
#ifdef PERL_TRACK_MEMPOOL |
1325
|
|
|
|
|
|
{ |
1326
|
|
|
|
|
|
/* |
1327
|
|
|
|
|
|
* Don't free thread memory if PERL_DESTRUCT_LEVEL is set to a non-zero |
1328
|
|
|
|
|
|
* value as we're probably hunting memory leaks then |
1329
|
|
|
|
|
|
*/ |
1330
|
|
|
|
|
|
if (PL_perl_destruct_level == 0) { |
1331
|
|
|
|
|
|
const U32 old_debug = PL_debug; |
1332
|
|
|
|
|
|
/* Emulate the PerlHost behaviour of free()ing all memory allocated in this |
1333
|
|
|
|
|
|
thread at thread exit. */ |
1334
|
|
|
|
|
|
if (DEBUG_m_TEST) { |
1335
|
|
|
|
|
|
PerlIO_puts(Perl_debug_log, "Disabling memory debugging as we " |
1336
|
|
|
|
|
|
"free this thread's memory\n"); |
1337
|
|
|
|
|
|
PL_debug &= ~ DEBUG_m_FLAG; |
1338
|
|
|
|
|
|
} |
1339
|
|
|
|
|
|
while(aTHXx->Imemory_debug_header.next != &(aTHXx->Imemory_debug_header)) |
1340
|
|
|
|
|
|
safesysfree(sTHX + (char *)(aTHXx->Imemory_debug_header.next)); |
1341
|
|
|
|
|
|
PL_debug = old_debug; |
1342
|
|
|
|
|
|
} |
1343
|
|
|
|
|
|
} |
1344
|
|
|
|
|
|
#endif |
1345
|
|
|
|
|
|
|
1346
|
|
|
|
|
|
#if defined(WIN32) || defined(NETWARE) |
1347
|
|
|
|
|
|
# if defined(PERL_IMPLICIT_SYS) |
1348
|
|
|
|
|
|
{ |
1349
|
|
|
|
|
|
# ifdef NETWARE |
1350
|
|
|
|
|
|
void *host = nw_internal_host; |
1351
|
|
|
|
|
|
PerlMem_free(aTHXx); |
1352
|
|
|
|
|
|
nw_delete_internal_host(host); |
1353
|
|
|
|
|
|
# else |
1354
|
|
|
|
|
|
void *host = w32_internal_host; |
1355
|
|
|
|
|
|
PerlMem_free(aTHXx); |
1356
|
|
|
|
|
|
win32_delete_internal_host(host); |
1357
|
|
|
|
|
|
# endif |
1358
|
|
|
|
|
|
} |
1359
|
|
|
|
|
|
# else |
1360
|
|
|
|
|
|
PerlMem_free(aTHXx); |
1361
|
|
|
|
|
|
# endif |
1362
|
|
|
|
|
|
#else |
1363
|
11991
|
|
|
|
|
PerlMem_free(aTHXx); |
1364
|
|
|
|
|
|
#endif |
1365
|
|
|
|
|
|
} |
1366
|
|
|
|
|
|
|
1367
|
|
|
|
|
|
#if defined(USE_ITHREADS) |
1368
|
|
|
|
|
|
/* provide destructors to clean up the thread key when libperl is unloaded */ |
1369
|
|
|
|
|
|
#ifndef WIN32 /* handled during DLL_PROCESS_DETACH in win32/perllib.c */ |
1370
|
|
|
|
|
|
|
1371
|
|
|
|
|
|
#if defined(__hpux) && !(defined(__ux_version) && __ux_version <= 1020) && !defined(__GNUC__) |
1372
|
|
|
|
|
|
#pragma fini "perl_fini" |
1373
|
|
|
|
|
|
#elif defined(__sun) && !defined(__GNUC__) |
1374
|
|
|
|
|
|
#pragma fini (perl_fini) |
1375
|
|
|
|
|
|
#endif |
1376
|
|
|
|
|
|
|
1377
|
|
|
|
|
|
static void |
1378
|
|
|
|
|
|
#if defined(__GNUC__) |
1379
|
|
|
|
|
|
__attribute__((destructor)) |
1380
|
|
|
|
|
|
#endif |
1381
|
|
|
|
|
|
perl_fini(void) |
1382
|
|
|
|
|
|
{ |
1383
|
|
|
|
|
|
dVAR; |
1384
|
|
|
|
|
|
if ( |
1385
|
|
|
|
|
|
#ifdef PERL_GLOBAL_STRUCT_PRIVATE |
1386
|
|
|
|
|
|
my_vars && |
1387
|
|
|
|
|
|
#endif |
1388
|
|
|
|
|
|
PL_curinterp && !PL_veto_cleanup) |
1389
|
|
|
|
|
|
FREE_THREAD_KEY; |
1390
|
|
|
|
|
|
} |
1391
|
|
|
|
|
|
|
1392
|
|
|
|
|
|
#endif /* WIN32 */ |
1393
|
|
|
|
|
|
#endif /* THREADS */ |
1394
|
|
|
|
|
|
|
1395
|
|
|
|
|
|
void |
1396
|
0
|
|
|
|
|
Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr) |
1397
|
|
|
|
|
|
{ |
1398
|
|
|
|
|
|
dVAR; |
1399
|
0
|
0
|
|
|
|
Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry); |
1400
|
0
|
|
|
|
|
PL_exitlist[PL_exitlistlen].fn = fn; |
1401
|
0
|
|
|
|
|
PL_exitlist[PL_exitlistlen].ptr = ptr; |
1402
|
0
|
|
|
|
|
++PL_exitlistlen; |
1403
|
0
|
|
|
|
|
} |
1404
|
|
|
|
|
|
|
1405
|
|
|
|
|
|
STATIC void |
1406
|
11937
|
|
|
|
|
S_set_caret_X(pTHX) { |
1407
|
|
|
|
|
|
dVAR; |
1408
|
11937
|
|
|
|
|
GV* tmpgv = gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL, SVt_PV); /* $^X */ |
1409
|
11937
|
50
|
|
|
|
if (tmpgv) { |
1410
|
11937
|
|
|
|
|
SV *const caret_x = GvSV(tmpgv); |
1411
|
|
|
|
|
|
#if defined(OS2) |
1412
|
|
|
|
|
|
sv_setpv(caret_x, os2_execname(aTHX)); |
1413
|
|
|
|
|
|
#else |
1414
|
|
|
|
|
|
# ifdef USE_KERN_PROC_PATHNAME |
1415
|
|
|
|
|
|
size_t size = 0; |
1416
|
|
|
|
|
|
int mib[4]; |
1417
|
|
|
|
|
|
mib[0] = CTL_KERN; |
1418
|
|
|
|
|
|
mib[1] = KERN_PROC; |
1419
|
|
|
|
|
|
mib[2] = KERN_PROC_PATHNAME; |
1420
|
|
|
|
|
|
mib[3] = -1; |
1421
|
|
|
|
|
|
|
1422
|
|
|
|
|
|
if (sysctl(mib, 4, NULL, &size, NULL, 0) == 0 |
1423
|
|
|
|
|
|
&& size > 0 && size < MAXPATHLEN * MAXPATHLEN) { |
1424
|
|
|
|
|
|
sv_grow(caret_x, size); |
1425
|
|
|
|
|
|
|
1426
|
|
|
|
|
|
if (sysctl(mib, 4, SvPVX(caret_x), &size, NULL, 0) == 0 |
1427
|
|
|
|
|
|
&& size > 2) { |
1428
|
|
|
|
|
|
SvPOK_only(caret_x); |
1429
|
|
|
|
|
|
SvCUR_set(caret_x, size - 1); |
1430
|
|
|
|
|
|
SvTAINT(caret_x); |
1431
|
|
|
|
|
|
return; |
1432
|
|
|
|
|
|
} |
1433
|
|
|
|
|
|
} |
1434
|
|
|
|
|
|
# elif defined(USE_NSGETEXECUTABLEPATH) |
1435
|
|
|
|
|
|
char buf[1]; |
1436
|
|
|
|
|
|
uint32_t size = sizeof(buf); |
1437
|
|
|
|
|
|
|
1438
|
|
|
|
|
|
_NSGetExecutablePath(buf, &size); |
1439
|
|
|
|
|
|
if (size < MAXPATHLEN * MAXPATHLEN) { |
1440
|
|
|
|
|
|
sv_grow(caret_x, size); |
1441
|
|
|
|
|
|
if (_NSGetExecutablePath(SvPVX(caret_x), &size) == 0) { |
1442
|
|
|
|
|
|
char *const tidied = realpath(SvPVX(caret_x), NULL); |
1443
|
|
|
|
|
|
if (tidied) { |
1444
|
|
|
|
|
|
sv_setpv(caret_x, tidied); |
1445
|
|
|
|
|
|
free(tidied); |
1446
|
|
|
|
|
|
} else { |
1447
|
|
|
|
|
|
SvPOK_only(caret_x); |
1448
|
|
|
|
|
|
SvCUR_set(caret_x, size); |
1449
|
|
|
|
|
|
} |
1450
|
|
|
|
|
|
return; |
1451
|
|
|
|
|
|
} |
1452
|
|
|
|
|
|
} |
1453
|
|
|
|
|
|
# elif defined(HAS_PROCSELFEXE) |
1454
|
|
|
|
|
|
char buf[MAXPATHLEN]; |
1455
|
11937
|
|
|
|
|
int len = readlink(PROCSELFEXE_PATH, buf, sizeof(buf) - 1); |
1456
|
|
|
|
|
|
|
1457
|
|
|
|
|
|
/* On Playstation2 Linux V1.0 (kernel 2.2.1) readlink(/proc/self/exe) |
1458
|
|
|
|
|
|
includes a spurious NUL which will cause $^X to fail in system |
1459
|
|
|
|
|
|
or backticks (this will prevent extensions from being built and |
1460
|
|
|
|
|
|
many tests from working). readlink is not meant to add a NUL. |
1461
|
|
|
|
|
|
Normal readlink works fine. |
1462
|
|
|
|
|
|
*/ |
1463
|
11937
|
50
|
|
|
|
if (len > 0 && buf[len-1] == '\0') { |
|
|
50
|
|
|
|
|
1464
|
0
|
|
|
|
|
len--; |
1465
|
|
|
|
|
|
} |
1466
|
|
|
|
|
|
|
1467
|
|
|
|
|
|
/* FreeBSD's implementation is acknowledged to be imperfect, sometimes |
1468
|
|
|
|
|
|
returning the text "unknown" from the readlink rather than the path |
1469
|
|
|
|
|
|
to the executable (or returning an error from the readlink). Any |
1470
|
|
|
|
|
|
valid path has a '/' in it somewhere, so use that to validate the |
1471
|
|
|
|
|
|
result. See http://www.freebsd.org/cgi/query-pr.cgi?pr=35703 |
1472
|
|
|
|
|
|
*/ |
1473
|
11937
|
50
|
|
|
|
if (len > 0 && memchr(buf, '/', len)) { |
|
|
50
|
|
|
|
|
1474
|
11937
|
|
|
|
|
sv_setpvn(caret_x, buf, len); |
1475
|
21857
|
|
|
|
|
return; |
1476
|
|
|
|
|
|
} |
1477
|
|
|
|
|
|
# endif |
1478
|
|
|
|
|
|
/* Fallback to this: */ |
1479
|
0
|
|
|
|
|
sv_setpv(caret_x, PL_origargv[0]); |
1480
|
|
|
|
|
|
#endif |
1481
|
|
|
|
|
|
} |
1482
|
|
|
|
|
|
} |
1483
|
|
|
|
|
|
|
1484
|
|
|
|
|
|
/* |
1485
|
|
|
|
|
|
=for apidoc perl_parse |
1486
|
|
|
|
|
|
|
1487
|
|
|
|
|
|
Tells a Perl interpreter to parse a Perl script. See L. |
1488
|
|
|
|
|
|
|
1489
|
|
|
|
|
|
=cut |
1490
|
|
|
|
|
|
*/ |
1491
|
|
|
|
|
|
|
1492
|
|
|
|
|
|
#define SET_CURSTASH(newstash) \ |
1493
|
|
|
|
|
|
if (PL_curstash != newstash) { \ |
1494
|
|
|
|
|
|
SvREFCNT_dec(PL_curstash); \ |
1495
|
|
|
|
|
|
PL_curstash = (HV *)SvREFCNT_inc(newstash); \ |
1496
|
|
|
|
|
|
} |
1497
|
|
|
|
|
|
|
1498
|
|
|
|
|
|
int |
1499
|
11993
|
|
|
|
|
perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env) |
1500
|
|
|
|
|
|
{ |
1501
|
|
|
|
|
|
dVAR; |
1502
|
|
|
|
|
|
I32 oldscope; |
1503
|
|
|
|
|
|
int ret; |
1504
|
|
|
|
|
|
dJMPENV; |
1505
|
|
|
|
|
|
|
1506
|
|
|
|
|
|
PERL_ARGS_ASSERT_PERL_PARSE; |
1507
|
|
|
|
|
|
#ifndef MULTIPLICITY |
1508
|
|
|
|
|
|
PERL_UNUSED_ARG(my_perl); |
1509
|
|
|
|
|
|
#endif |
1510
|
|
|
|
|
|
#if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) || defined(USE_HASH_SEED_DEBUG) |
1511
|
|
|
|
|
|
{ |
1512
|
11993
|
|
|
|
|
const char * const s = PerlEnv_getenv("PERL_HASH_SEED_DEBUG"); |
1513
|
|
|
|
|
|
|
1514
|
12003
|
|
|
|
|
if (s && (atoi(s) == 1)) { |
1515
|
|
|
|
|
|
unsigned char *seed= PERL_HASH_SEED; |
1516
|
|
|
|
|
|
unsigned char *seed_end= PERL_HASH_SEED + PERL_HASH_SEED_BYTES; |
1517
|
10
|
|
|
|
|
PerlIO_printf(Perl_debug_log, "HASH_FUNCTION = %s HASH_SEED = 0x", PERL_HASH_FUNC); |
1518
|
100
|
0
|
|
|
|
while (seed < seed_end) { |
1519
|
80
|
|
|
|
|
PerlIO_printf(Perl_debug_log, "%02x", *seed++); |
1520
|
|
|
|
|
|
} |
1521
|
|
|
|
|
|
#ifdef PERL_HASH_RANDOMIZE_KEYS |
1522
|
20
|
0
|
|
|
|
PerlIO_printf(Perl_debug_log, " PERTURB_KEYS = %d (%s)", |
1523
|
|
|
|
|
|
PL_HASH_RAND_BITS_ENABLED, |
1524
|
18
|
0
|
|
|
|
PL_HASH_RAND_BITS_ENABLED == 0 ? "NO" : PL_HASH_RAND_BITS_ENABLED == 1 ? "RANDOM" : "DETERMINISTIC"); |
1525
|
|
|
|
|
|
#endif |
1526
|
10
|
|
|
|
|
PerlIO_printf(Perl_debug_log, "\n"); |
1527
|
|
|
|
|
|
} |
1528
|
|
|
|
|
|
} |
1529
|
|
|
|
|
|
#endif /* #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) */ |
1530
|
11993
|
|
|
|
|
PL_origargc = argc; |
1531
|
11993
|
|
|
|
|
PL_origargv = argv; |
1532
|
|
|
|
|
|
|
1533
|
11993
|
50
|
|
|
|
if (PL_origalen != 0) { |
1534
|
0
|
|
|
|
|
PL_origalen = 1; /* don't use old PL_origalen if perl_parse() is called again */ |
1535
|
|
|
|
|
|
} |
1536
|
|
|
|
|
|
else { |
1537
|
|
|
|
|
|
/* Set PL_origalen be the sum of the contiguous argv[] |
1538
|
|
|
|
|
|
* elements plus the size of the env in case that it is |
1539
|
|
|
|
|
|
* contiguous with the argv[]. This is used in mg.c:Perl_magic_set() |
1540
|
|
|
|
|
|
* as the maximum modifiable length of $0. In the worst case |
1541
|
|
|
|
|
|
* the area we are able to modify is limited to the size of |
1542
|
|
|
|
|
|
* the original argv[0]. (See below for 'contiguous', though.) |
1543
|
|
|
|
|
|
* --jhi */ |
1544
|
|
|
|
|
|
const char *s = NULL; |
1545
|
|
|
|
|
|
int i; |
1546
|
|
|
|
|
|
const UV mask = |
1547
|
|
|
|
|
|
~(UV)(PTRSIZE == 4 ? 3 : PTRSIZE == 8 ? 7 : PTRSIZE == 16 ? 15 : 0); |
1548
|
|
|
|
|
|
/* Do the mask check only if the args seem like aligned. */ |
1549
|
11993
|
|
|
|
|
const UV aligned = |
1550
|
11993
|
|
|
|
|
(mask < ~(UV)0) && ((PTR2UV(argv[0]) & mask) == PTR2UV(argv[0])); |
1551
|
|
|
|
|
|
|
1552
|
|
|
|
|
|
/* See if all the arguments are contiguous in memory. Note |
1553
|
|
|
|
|
|
* that 'contiguous' is a loose term because some platforms |
1554
|
|
|
|
|
|
* align the argv[] and the envp[]. If the arguments look |
1555
|
|
|
|
|
|
* like non-aligned, assume that they are 'strictly' or |
1556
|
|
|
|
|
|
* 'traditionally' contiguous. If the arguments look like |
1557
|
|
|
|
|
|
* aligned, we just check that they are within aligned |
1558
|
|
|
|
|
|
* PTRSIZE bytes. As long as no system has something bizarre |
1559
|
|
|
|
|
|
* like the argv[] interleaved with some other data, we are |
1560
|
|
|
|
|
|
* fine. (Did I just evoke Murphy's Law?) --jhi */ |
1561
|
11993
|
50
|
|
|
|
if (PL_origargv && PL_origargc >= 1 && (s = PL_origargv[0])) { |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
1562
|
461795
|
100
|
|
|
|
while (*s) s++; |
1563
|
50823
|
100
|
|
|
|
for (i = 1; i < PL_origargc; i++) { |
1564
|
48807
|
50
|
|
|
|
if ((PL_origargv[i] == s + 1 |
1565
|
|
|
|
|
|
#ifdef OS2 |
1566
|
|
|
|
|
|
|| PL_origargv[i] == s + 2 |
1567
|
|
|
|
|
|
#endif |
1568
|
|
|
|
|
|
) |
1569
|
1
|
0
|
|
|
|
|| |
1570
|
0
|
0
|
|
|
|
(aligned && |
1571
|
0
|
0
|
|
|
|
(PL_origargv[i] > s && |
1572
|
0
|
|
|
|
|
PL_origargv[i] <= |
1573
|
0
|
|
|
|
|
INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask))) |
1574
|
|
|
|
|
|
) |
1575
|
|
|
|
|
|
{ |
1576
|
48806
|
|
|
|
|
s = PL_origargv[i]; |
1577
|
226192
|
100
|
|
|
|
while (*s) s++; |
1578
|
|
|
|
|
|
} |
1579
|
|
|
|
|
|
else |
1580
|
|
|
|
|
|
break; |
1581
|
|
|
|
|
|
} |
1582
|
|
|
|
|
|
} |
1583
|
|
|
|
|
|
|
1584
|
|
|
|
|
|
#ifndef PERL_USE_SAFE_PUTENV |
1585
|
|
|
|
|
|
/* Can we grab env area too to be used as the area for $0? */ |
1586
|
11993
|
50
|
|
|
|
if (s && PL_origenviron && !PL_use_safe_putenv) { |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
1587
|
11992
|
50
|
|
|
|
if ((PL_origenviron[0] == s + 1) |
1588
|
0
|
0
|
|
|
|
|| |
1589
|
0
|
0
|
|
|
|
(aligned && |
1590
|
0
|
0
|
|
|
|
(PL_origenviron[0] > s && |
1591
|
0
|
|
|
|
|
PL_origenviron[0] <= |
1592
|
0
|
|
|
|
|
INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask))) |
1593
|
|
|
|
|
|
) |
1594
|
|
|
|
|
|
{ |
1595
|
|
|
|
|
|
#ifndef OS2 /* ENVIRON is read by the kernel too. */ |
1596
|
11992
|
|
|
|
|
s = PL_origenviron[0]; |
1597
|
98146
|
100
|
|
|
|
while (*s) s++; |
1598
|
|
|
|
|
|
#endif |
1599
|
11992
|
|
|
|
|
my_setenv("NoNe SuCh", NULL); |
1600
|
|
|
|
|
|
/* Force copy of environment. */ |
1601
|
857854
|
100
|
|
|
|
for (i = 1; PL_origenviron[i]; i++) { |
1602
|
845862
|
50
|
|
|
|
if (PL_origenviron[i] == s + 1 |
1603
|
0
|
0
|
|
|
|
|| |
1604
|
0
|
0
|
|
|
|
(aligned && |
1605
|
0
|
0
|
|
|
|
(PL_origenviron[i] > s && |
1606
|
0
|
|
|
|
|
PL_origenviron[i] <= |
1607
|
0
|
|
|
|
|
INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask))) |
1608
|
|
|
|
|
|
) |
1609
|
|
|
|
|
|
{ |
1610
|
845862
|
|
|
|
|
s = PL_origenviron[i]; |
1611
|
13644578
|
100
|
|
|
|
while (*s) s++; |
1612
|
|
|
|
|
|
} |
1613
|
|
|
|
|
|
else |
1614
|
|
|
|
|
|
break; |
1615
|
|
|
|
|
|
} |
1616
|
|
|
|
|
|
} |
1617
|
|
|
|
|
|
} |
1618
|
|
|
|
|
|
#endif /* !defined(PERL_USE_SAFE_PUTENV) */ |
1619
|
|
|
|
|
|
|
1620
|
11993
|
50
|
|
|
|
PL_origalen = s ? s - PL_origargv[0] + 1 : 0; |
1621
|
|
|
|
|
|
} |
1622
|
|
|
|
|
|
|
1623
|
11993
|
50
|
|
|
|
if (PL_do_undump) { |
1624
|
|
|
|
|
|
|
1625
|
|
|
|
|
|
/* Come here if running an undumped a.out. */ |
1626
|
|
|
|
|
|
|
1627
|
0
|
|
|
|
|
PL_origfilename = savepv(argv[0]); |
1628
|
0
|
|
|
|
|
PL_do_undump = FALSE; |
1629
|
0
|
|
|
|
|
cxstack_ix = -1; /* start label stack again */ |
1630
|
0
|
|
|
|
|
init_ids(); |
1631
|
|
|
|
|
|
assert (!TAINT_get); |
1632
|
0
|
|
|
|
|
TAINT; |
1633
|
0
|
|
|
|
|
S_set_caret_X(aTHX); |
1634
|
0
|
|
|
|
|
TAINT_NOT; |
1635
|
0
|
|
|
|
|
init_postdump_symbols(argc,argv,env); |
1636
|
0
|
|
|
|
|
return 0; |
1637
|
|
|
|
|
|
} |
1638
|
|
|
|
|
|
|
1639
|
11993
|
50
|
|
|
|
if (PL_main_root) { |
1640
|
0
|
|
|
|
|
op_free(PL_main_root); |
1641
|
0
|
|
|
|
|
PL_main_root = NULL; |
1642
|
|
|
|
|
|
} |
1643
|
11993
|
|
|
|
|
PL_main_start = NULL; |
1644
|
11993
|
|
|
|
|
SvREFCNT_dec(PL_main_cv); |
1645
|
11993
|
|
|
|
|
PL_main_cv = NULL; |
1646
|
|
|
|
|
|
|
1647
|
11993
|
|
|
|
|
time(&PL_basetime); |
1648
|
11993
|
|
|
|
|
oldscope = PL_scopestack_ix; |
1649
|
11993
|
|
|
|
|
PL_dowarn = G_WARN_OFF; |
1650
|
|
|
|
|
|
|
1651
|
11993
|
|
|
|
|
JMPENV_PUSH(ret); |
1652
|
12472
|
|
|
|
|
switch (ret) { |
1653
|
|
|
|
|
|
case 0: |
1654
|
11993
|
|
|
|
|
parse_body(env,xsinit); |
1655
|
11542
|
50
|
|
|
|
if (PL_unitcheckav) { |
1656
|
10
|
|
|
|
|
call_list(oldscope, PL_unitcheckav); |
1657
|
|
|
|
|
|
} |
1658
|
11542
|
50
|
|
|
|
if (PL_checkav) { |
1659
|
2248
|
|
|
|
|
PERL_SET_PHASE(PERL_PHASE_CHECK); |
1660
|
2248
|
|
|
|
|
call_list(oldscope, PL_checkav); |
1661
|
|
|
|
|
|
} |
1662
|
|
|
|
|
|
ret = 0; |
1663
|
|
|
|
|
|
break; |
1664
|
|
|
|
|
|
case 1: |
1665
|
0
|
|
|
|
|
STATUS_ALL_FAILURE; |
1666
|
|
|
|
|
|
/* FALL THROUGH */ |
1667
|
|
|
|
|
|
case 2: |
1668
|
|
|
|
|
|
/* my_exit() was called */ |
1669
|
790
|
0
|
|
|
|
while (PL_scopestack_ix > oldscope) |
1670
|
311
|
|
|
|
|
LEAVE; |
1671
|
479
|
0
|
|
|
|
FREETMPS; |
1672
|
479
|
0
|
|
|
|
SET_CURSTASH(PL_defstash); |
1673
|
479
|
0
|
|
|
|
if (PL_unitcheckav) { |
1674
|
0
|
|
|
|
|
call_list(oldscope, PL_unitcheckav); |
1675
|
|
|
|
|
|
} |
1676
|
479
|
0
|
|
|
|
if (PL_checkav) { |
1677
|
182
|
|
|
|
|
PERL_SET_PHASE(PERL_PHASE_CHECK); |
1678
|
182
|
|
|
|
|
call_list(oldscope, PL_checkav); |
1679
|
|
|
|
|
|
} |
1680
|
475
|
|
|
|
|
ret = STATUS_EXIT; |
1681
|
475
|
|
|
|
|
break; |
1682
|
|
|
|
|
|
case 3: |
1683
|
0
|
0
|
|
|
|
PerlIO_printf(Perl_error_log, "panic: top_env\n"); |
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
1684
|
|
|
|
|
|
ret = 1; |
1685
|
0
|
|
|
|
|
break; |
1686
|
|
|
|
|
|
} |
1687
|
11993
|
|
|
|
|
JMPENV_POP; |
1688
|
11993
|
|
|
|
|
return ret; |
1689
|
|
|
|
|
|
} |
1690
|
|
|
|
|
|
|
1691
|
|
|
|
|
|
/* This needs to stay in perl.c, as perl.c is compiled with different flags for |
1692
|
|
|
|
|
|
miniperl, and we need to see those flags reflected in the values here. */ |
1693
|
|
|
|
|
|
|
1694
|
|
|
|
|
|
/* What this returns is subject to change. Use the public interface in Config. |
1695
|
|
|
|
|
|
*/ |
1696
|
|
|
|
|
|
static void |
1697
|
13
|
|
|
|
|
S_Internals_V(pTHX_ CV *cv) |
1698
|
13
|
0
|
|
|
|
{ |
1699
|
13
|
|
|
|
|
dXSARGS; |
1700
|
|
|
|
|
|
#ifdef LOCAL_PATCH_COUNT |
1701
|
|
|
|
|
|
const int local_patch_count = LOCAL_PATCH_COUNT; |
1702
|
|
|
|
|
|
#else |
1703
|
|
|
|
|
|
const int local_patch_count = 0; |
1704
|
|
|
|
|
|
#endif |
1705
|
|
|
|
|
|
const int entries = 3 + local_patch_count; |
1706
|
|
|
|
|
|
int i; |
1707
|
|
|
|
|
|
static const char non_bincompat_options[] = |
1708
|
|
|
|
|
|
# ifdef DEBUGGING |
1709
|
|
|
|
|
|
" DEBUGGING" |
1710
|
|
|
|
|
|
# endif |
1711
|
|
|
|
|
|
# ifdef NO_MATHOMS |
1712
|
|
|
|
|
|
" NO_MATHOMS" |
1713
|
|
|
|
|
|
# endif |
1714
|
|
|
|
|
|
# ifdef NO_HASH_SEED |
1715
|
|
|
|
|
|
" NO_HASH_SEED" |
1716
|
|
|
|
|
|
# endif |
1717
|
|
|
|
|
|
# ifdef NO_TAINT_SUPPORT |
1718
|
|
|
|
|
|
" NO_TAINT_SUPPORT" |
1719
|
|
|
|
|
|
# endif |
1720
|
|
|
|
|
|
# ifdef PERL_DISABLE_PMC |
1721
|
|
|
|
|
|
" PERL_DISABLE_PMC" |
1722
|
|
|
|
|
|
# endif |
1723
|
|
|
|
|
|
# ifdef PERL_DONT_CREATE_GVSV |
1724
|
|
|
|
|
|
" PERL_DONT_CREATE_GVSV" |
1725
|
|
|
|
|
|
# endif |
1726
|
|
|
|
|
|
# ifdef PERL_EXTERNAL_GLOB |
1727
|
|
|
|
|
|
" PERL_EXTERNAL_GLOB" |
1728
|
|
|
|
|
|
# endif |
1729
|
|
|
|
|
|
# ifdef PERL_HASH_FUNC_SIPHASH |
1730
|
|
|
|
|
|
" PERL_HASH_FUNC_SIPHASH" |
1731
|
|
|
|
|
|
# endif |
1732
|
|
|
|
|
|
# ifdef PERL_HASH_FUNC_SDBM |
1733
|
|
|
|
|
|
" PERL_HASH_FUNC_SDBM" |
1734
|
|
|
|
|
|
# endif |
1735
|
|
|
|
|
|
# ifdef PERL_HASH_FUNC_DJB2 |
1736
|
|
|
|
|
|
" PERL_HASH_FUNC_DJB2" |
1737
|
|
|
|
|
|
# endif |
1738
|
|
|
|
|
|
# ifdef PERL_HASH_FUNC_SUPERFAST |
1739
|
|
|
|
|
|
" PERL_HASH_FUNC_SUPERFAST" |
1740
|
|
|
|
|
|
# endif |
1741
|
|
|
|
|
|
# ifdef PERL_HASH_FUNC_MURMUR3 |
1742
|
|
|
|
|
|
" PERL_HASH_FUNC_MURMUR3" |
1743
|
|
|
|
|
|
# endif |
1744
|
|
|
|
|
|
# ifdef PERL_HASH_FUNC_ONE_AT_A_TIME |
1745
|
|
|
|
|
|
" PERL_HASH_FUNC_ONE_AT_A_TIME" |
1746
|
|
|
|
|
|
# endif |
1747
|
|
|
|
|
|
# ifdef PERL_HASH_FUNC_ONE_AT_A_TIME_HARD |
1748
|
|
|
|
|
|
" PERL_HASH_FUNC_ONE_AT_A_TIME_HARD" |
1749
|
|
|
|
|
|
# endif |
1750
|
|
|
|
|
|
# ifdef PERL_HASH_FUNC_ONE_AT_A_TIME_OLD |
1751
|
|
|
|
|
|
" PERL_HASH_FUNC_ONE_AT_A_TIME_OLD" |
1752
|
|
|
|
|
|
# endif |
1753
|
|
|
|
|
|
# ifdef PERL_IS_MINIPERL |
1754
|
|
|
|
|
|
" PERL_IS_MINIPERL" |
1755
|
|
|
|
|
|
# endif |
1756
|
|
|
|
|
|
# ifdef PERL_MALLOC_WRAP |
1757
|
|
|
|
|
|
" PERL_MALLOC_WRAP" |
1758
|
|
|
|
|
|
# endif |
1759
|
|
|
|
|
|
# ifdef PERL_MEM_LOG |
1760
|
|
|
|
|
|
" PERL_MEM_LOG" |
1761
|
|
|
|
|
|
# endif |
1762
|
|
|
|
|
|
# ifdef PERL_MEM_LOG_NOIMPL |
1763
|
|
|
|
|
|
" PERL_MEM_LOG_NOIMPL" |
1764
|
|
|
|
|
|
# endif |
1765
|
|
|
|
|
|
# ifdef PERL_NEW_COPY_ON_WRITE |
1766
|
|
|
|
|
|
" PERL_NEW_COPY_ON_WRITE" |
1767
|
|
|
|
|
|
# endif |
1768
|
|
|
|
|
|
# ifdef PERL_PERTURB_KEYS_DETERMINISTIC |
1769
|
|
|
|
|
|
" PERL_PERTURB_KEYS_DETERMINISTIC" |
1770
|
|
|
|
|
|
# endif |
1771
|
|
|
|
|
|
# ifdef PERL_PERTURB_KEYS_DISABLED |
1772
|
|
|
|
|
|
" PERL_PERTURB_KEYS_DISABLED" |
1773
|
|
|
|
|
|
# endif |
1774
|
|
|
|
|
|
# ifdef PERL_PERTURB_KEYS_RANDOM |
1775
|
|
|
|
|
|
" PERL_PERTURB_KEYS_RANDOM" |
1776
|
|
|
|
|
|
# endif |
1777
|
|
|
|
|
|
# ifdef PERL_PRESERVE_IVUV |
1778
|
|
|
|
|
|
" PERL_PRESERVE_IVUV" |
1779
|
|
|
|
|
|
# endif |
1780
|
|
|
|
|
|
# ifdef PERL_RELOCATABLE_INCPUSH |
1781
|
|
|
|
|
|
" PERL_RELOCATABLE_INCPUSH" |
1782
|
|
|
|
|
|
# endif |
1783
|
|
|
|
|
|
# ifdef PERL_USE_DEVEL |
1784
|
|
|
|
|
|
" PERL_USE_DEVEL" |
1785
|
|
|
|
|
|
# endif |
1786
|
|
|
|
|
|
# ifdef PERL_USE_SAFE_PUTENV |
1787
|
|
|
|
|
|
" PERL_USE_SAFE_PUTENV" |
1788
|
|
|
|
|
|
# endif |
1789
|
|
|
|
|
|
# ifdef UNLINK_ALL_VERSIONS |
1790
|
|
|
|
|
|
" UNLINK_ALL_VERSIONS" |
1791
|
|
|
|
|
|
# endif |
1792
|
|
|
|
|
|
# ifdef USE_ATTRIBUTES_FOR_PERLIO |
1793
|
|
|
|
|
|
" USE_ATTRIBUTES_FOR_PERLIO" |
1794
|
|
|
|
|
|
# endif |
1795
|
|
|
|
|
|
# ifdef USE_FAST_STDIO |
1796
|
|
|
|
|
|
" USE_FAST_STDIO" |
1797
|
|
|
|
|
|
# endif |
1798
|
|
|
|
|
|
# ifdef USE_HASH_SEED_EXPLICIT |
1799
|
|
|
|
|
|
" USE_HASH_SEED_EXPLICIT" |
1800
|
|
|
|
|
|
# endif |
1801
|
|
|
|
|
|
# ifdef USE_LOCALE |
1802
|
|
|
|
|
|
" USE_LOCALE" |
1803
|
|
|
|
|
|
# endif |
1804
|
|
|
|
|
|
# ifdef USE_LOCALE_CTYPE |
1805
|
|
|
|
|
|
" USE_LOCALE_CTYPE" |
1806
|
|
|
|
|
|
# endif |
1807
|
|
|
|
|
|
# ifdef USE_PERL_ATOF |
1808
|
|
|
|
|
|
" USE_PERL_ATOF" |
1809
|
|
|
|
|
|
# endif |
1810
|
|
|
|
|
|
# ifdef USE_SITECUSTOMIZE |
1811
|
|
|
|
|
|
" USE_SITECUSTOMIZE" |
1812
|
|
|
|
|
|
# endif |
1813
|
|
|
|
|
|
; |
1814
|
|
|
|
|
|
PERL_UNUSED_ARG(cv); |
1815
|
|
|
|
|
|
PERL_UNUSED_ARG(items); |
1816
|
|
|
|
|
|
|
1817
|
13
|
|
|
|
|
EXTEND(SP, entries); |
1818
|
|
|
|
|
|
|
1819
|
13
|
|
|
|
|
PUSHs(sv_2mortal(newSVpv(PL_bincompat_options, 0))); |
1820
|
13
|
|
|
|
|
PUSHs(Perl_newSVpvn_flags(aTHX_ non_bincompat_options, |
1821
|
|
|
|
|
|
sizeof(non_bincompat_options) - 1, SVs_TEMP)); |
1822
|
|
|
|
|
|
|
1823
|
|
|
|
|
|
#ifdef __DATE__ |
1824
|
|
|
|
|
|
# ifdef __TIME__ |
1825
|
13
|
|
|
|
|
PUSHs(Perl_newSVpvn_flags(aTHX_ |
1826
|
|
|
|
|
|
STR_WITH_LEN("Compiled at " __DATE__ " " __TIME__), |
1827
|
|
|
|
|
|
SVs_TEMP)); |
1828
|
|
|
|
|
|
# else |
1829
|
|
|
|
|
|
PUSHs(Perl_newSVpvn_flags(aTHX_ STR_WITH_LEN("Compiled on " __DATE__), |
1830
|
|
|
|
|
|
SVs_TEMP)); |
1831
|
|
|
|
|
|
# endif |
1832
|
|
|
|
|
|
#else |
1833
|
|
|
|
|
|
PUSHs(&PL_sv_undef); |
1834
|
|
|
|
|
|
#endif |
1835
|
|
|
|
|
|
|
1836
|
|
|
|
|
|
for (i = 1; i <= local_patch_count; i++) { |
1837
|
|
|
|
|
|
/* This will be an undef, if PL_localpatches[i] is NULL. */ |
1838
|
|
|
|
|
|
PUSHs(sv_2mortal(newSVpv(PL_localpatches[i], 0))); |
1839
|
|
|
|
|
|
} |
1840
|
|
|
|
|
|
|
1841
|
13
|
|
|
|
|
XSRETURN(entries); |
1842
|
|
|
|
|
|
} |
1843
|
|
|
|
|
|
|
1844
|
|
|
|
|
|
#define INCPUSH_UNSHIFT 0x01 |
1845
|
|
|
|
|
|
#define INCPUSH_ADD_OLD_VERS 0x02 |
1846
|
|
|
|
|
|
#define INCPUSH_ADD_VERSIONED_SUB_DIRS 0x04 |
1847
|
|
|
|
|
|
#define INCPUSH_ADD_ARCHONLY_SUB_DIRS 0x08 |
1848
|
|
|
|
|
|
#define INCPUSH_NOT_BASEDIR 0x10 |
1849
|
|
|
|
|
|
#define INCPUSH_CAN_RELOCATE 0x20 |
1850
|
|
|
|
|
|
#define INCPUSH_ADD_SUB_DIRS \ |
1851
|
|
|
|
|
|
(INCPUSH_ADD_VERSIONED_SUB_DIRS|INCPUSH_ADD_ARCHONLY_SUB_DIRS) |
1852
|
|
|
|
|
|
|
1853
|
|
|
|
|
|
STATIC void * |
1854
|
11993
|
|
|
|
|
S_parse_body(pTHX_ char **env, XSINIT_t xsinit) |
1855
|
|
|
|
|
|
{ |
1856
|
|
|
|
|
|
dVAR; |
1857
|
|
|
|
|
|
PerlIO *rsfp; |
1858
|
11993
|
|
|
|
|
int argc = PL_origargc; |
1859
|
11993
|
|
|
|
|
char **argv = PL_origargv; |
1860
|
|
|
|
|
|
const char *scriptname = NULL; |
1861
|
11993
|
|
|
|
|
VOL bool dosearch = FALSE; |
1862
|
|
|
|
|
|
char c; |
1863
|
|
|
|
|
|
bool doextract = FALSE; |
1864
|
|
|
|
|
|
const char *cddir = NULL; |
1865
|
|
|
|
|
|
#ifdef USE_SITECUSTOMIZE |
1866
|
|
|
|
|
|
bool minus_f = FALSE; |
1867
|
|
|
|
|
|
#endif |
1868
|
|
|
|
|
|
SV *linestr_sv = NULL; |
1869
|
|
|
|
|
|
bool add_read_e_script = FALSE; |
1870
|
|
|
|
|
|
U32 lex_start_flags = 0; |
1871
|
|
|
|
|
|
|
1872
|
11993
|
|
|
|
|
PERL_SET_PHASE(PERL_PHASE_START); |
1873
|
|
|
|
|
|
|
1874
|
11993
|
|
|
|
|
init_main_stash(); |
1875
|
|
|
|
|
|
|
1876
|
|
|
|
|
|
{ |
1877
|
|
|
|
|
|
const char *s; |
1878
|
39029
|
100
|
|
|
|
for (argc--,argv++; argc > 0; argc--,argv++) { |
1879
|
34749
|
100
|
|
|
|
if (argv[0][0] != '-' || !argv[0][1]) |
|
|
50
|
|
|
|
|
1880
|
|
|
|
|
|
break; |
1881
|
28448
|
|
|
|
|
s = argv[0]+1; |
1882
|
|
|
|
|
|
reswitch: |
1883
|
39109
|
|
|
|
|
switch ((c = *s)) { |
1884
|
|
|
|
|
|
case 'C': |
1885
|
|
|
|
|
|
#ifndef PERL_STRICT_CR |
1886
|
|
|
|
|
|
case '\r': |
1887
|
|
|
|
|
|
#endif |
1888
|
|
|
|
|
|
case ' ': |
1889
|
|
|
|
|
|
case '0': |
1890
|
|
|
|
|
|
case 'F': |
1891
|
|
|
|
|
|
case 'a': |
1892
|
|
|
|
|
|
case 'c': |
1893
|
|
|
|
|
|
case 'd': |
1894
|
|
|
|
|
|
case 'D': |
1895
|
|
|
|
|
|
case 'h': |
1896
|
|
|
|
|
|
case 'i': |
1897
|
|
|
|
|
|
case 'l': |
1898
|
|
|
|
|
|
case 'M': |
1899
|
|
|
|
|
|
case 'm': |
1900
|
|
|
|
|
|
case 'n': |
1901
|
|
|
|
|
|
case 'p': |
1902
|
|
|
|
|
|
case 's': |
1903
|
|
|
|
|
|
case 'u': |
1904
|
|
|
|
|
|
case 'U': |
1905
|
|
|
|
|
|
case 'v': |
1906
|
|
|
|
|
|
case 'W': |
1907
|
|
|
|
|
|
case 'X': |
1908
|
|
|
|
|
|
case 'w': |
1909
|
10586
|
50
|
|
|
|
if ((s = moreswitches(s))) |
1910
|
|
|
|
|
|
goto reswitch; |
1911
|
|
|
|
|
|
break; |
1912
|
|
|
|
|
|
|
1913
|
|
|
|
|
|
case 't': |
1914
|
|
|
|
|
|
#if SILENT_NO_TAINT_SUPPORT |
1915
|
|
|
|
|
|
/* silently ignore */ |
1916
|
|
|
|
|
|
#elif NO_TAINT_SUPPORT |
1917
|
|
|
|
|
|
Perl_croak_nocontext("This perl was compiled without taint support. " |
1918
|
|
|
|
|
|
"Cowardly refusing to run with -t or -T flags"); |
1919
|
|
|
|
|
|
#else |
1920
|
|
|
|
|
|
CHECK_MALLOC_TOO_LATE_FOR('t'); |
1921
|
2
|
0
|
|
|
|
if( !TAINTING_get ) { |
1922
|
2
|
|
|
|
|
TAINT_WARN_set(TRUE); |
1923
|
2
|
|
|
|
|
TAINTING_set(TRUE); |
1924
|
|
|
|
|
|
} |
1925
|
|
|
|
|
|
#endif |
1926
|
2
|
|
|
|
|
s++; |
1927
|
2
|
|
|
|
|
goto reswitch; |
1928
|
|
|
|
|
|
case 'T': |
1929
|
|
|
|
|
|
#if SILENT_NO_TAINT_SUPPORT |
1930
|
|
|
|
|
|
/* silently ignore */ |
1931
|
|
|
|
|
|
#elif NO_TAINT_SUPPORT |
1932
|
|
|
|
|
|
Perl_croak_nocontext("This perl was compiled without taint support. " |
1933
|
|
|
|
|
|
"Cowardly refusing to run with -t or -T flags"); |
1934
|
|
|
|
|
|
#else |
1935
|
|
|
|
|
|
CHECK_MALLOC_TOO_LATE_FOR('T'); |
1936
|
84
|
|
|
|
|
TAINTING_set(TRUE); |
1937
|
84
|
|
|
|
|
TAINT_WARN_set(FALSE); |
1938
|
|
|
|
|
|
#endif |
1939
|
84
|
|
|
|
|
s++; |
1940
|
84
|
|
|
|
|
goto reswitch; |
1941
|
|
|
|
|
|
|
1942
|
|
|
|
|
|
case 'E': |
1943
|
5
|
|
|
|
|
PL_minus_E = TRUE; |
1944
|
|
|
|
|
|
/* FALL THROUGH */ |
1945
|
|
|
|
|
|
case 'e': |
1946
|
6218
|
|
|
|
|
forbid_setid('e', FALSE); |
1947
|
6218
|
50
|
|
|
|
if (!PL_e_script) { |
1948
|
5791
|
|
|
|
|
PL_e_script = newSVpvs(""); |
1949
|
|
|
|
|
|
add_read_e_script = TRUE; |
1950
|
|
|
|
|
|
} |
1951
|
6218
|
50
|
|
|
|
if (*++s) |
1952
|
110
|
|
|
|
|
sv_catpv(PL_e_script, s); |
1953
|
6108
|
50
|
|
|
|
else if (argv[1]) { |
1954
|
6108
|
|
|
|
|
sv_catpv(PL_e_script, argv[1]); |
1955
|
6108
|
|
|
|
|
argc--,argv++; |
1956
|
|
|
|
|
|
} |
1957
|
|
|
|
|
|
else |
1958
|
0
|
|
|
|
|
Perl_croak(aTHX_ "No code specified for -%c", c); |
1959
|
6218
|
|
|
|
|
sv_catpvs(PL_e_script, "\n"); |
1960
|
6218
|
|
|
|
|
break; |
1961
|
|
|
|
|
|
|
1962
|
|
|
|
|
|
case 'f': |
1963
|
|
|
|
|
|
#ifdef USE_SITECUSTOMIZE |
1964
|
|
|
|
|
|
minus_f = TRUE; |
1965
|
|
|
|
|
|
#endif |
1966
|
6
|
|
|
|
|
s++; |
1967
|
6
|
|
|
|
|
goto reswitch; |
1968
|
|
|
|
|
|
|
1969
|
|
|
|
|
|
case 'I': /* -I handled both here and in moreswitches() */ |
1970
|
11266
|
|
|
|
|
forbid_setid('I', FALSE); |
1971
|
11266
|
50
|
|
|
|
if (!*++s && (s=argv[1]) != NULL) { |
|
|
0
|
|
|
|
|
1972
|
18
|
|
|
|
|
argc--,argv++; |
1973
|
|
|
|
|
|
} |
1974
|
11266
|
50
|
|
|
|
if (s && *s) { |
|
|
50
|
|
|
|
|
1975
|
11266
|
|
|
|
|
STRLEN len = strlen(s); |
1976
|
11266
|
|
|
|
|
incpush(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_ADD_OLD_VERS); |
1977
|
|
|
|
|
|
} |
1978
|
|
|
|
|
|
else |
1979
|
0
|
|
|
|
|
Perl_croak(aTHX_ "No directory specified for -I"); |
1980
|
11266
|
|
|
|
|
break; |
1981
|
|
|
|
|
|
case 'S': |
1982
|
0
|
|
|
|
|
forbid_setid('S', FALSE); |
1983
|
0
|
|
|
|
|
dosearch = TRUE; |
1984
|
0
|
|
|
|
|
s++; |
1985
|
0
|
|
|
|
|
goto reswitch; |
1986
|
|
|
|
|
|
case 'V': |
1987
|
|
|
|
|
|
{ |
1988
|
|
|
|
|
|
SV *opts_prog; |
1989
|
|
|
|
|
|
|
1990
|
6
|
0
|
|
|
|
if (*++s != ':') { |
1991
|
3
|
|
|
|
|
opts_prog = newSVpvs("use Config; Config::_V()"); |
1992
|
|
|
|
|
|
} |
1993
|
|
|
|
|
|
else { |
1994
|
3
|
|
|
|
|
++s; |
1995
|
3
|
|
|
|
|
opts_prog = Perl_newSVpvf(aTHX_ |
1996
|
|
|
|
|
|
"use Config; Config::config_vars(qw%c%s%c)", |
1997
|
|
|
|
|
|
0, s, 0); |
1998
|
3
|
|
|
|
|
s += strlen(s); |
1999
|
|
|
|
|
|
} |
2000
|
6
|
|
|
|
|
Perl_av_create_and_push(aTHX_ &PL_preambleav, opts_prog); |
2001
|
|
|
|
|
|
/* don't look for script or read stdin */ |
2002
|
|
|
|
|
|
scriptname = BIT_BUCKET; |
2003
|
1231
|
|
|
|
|
goto reswitch; |
2004
|
|
|
|
|
|
} |
2005
|
|
|
|
|
|
case 'x': |
2006
|
|
|
|
|
|
doextract = TRUE; |
2007
|
4
|
|
|
|
|
s++; |
2008
|
4
|
0
|
|
|
|
if (*s) |
2009
|
|
|
|
|
|
cddir = s; |
2010
|
|
|
|
|
|
break; |
2011
|
|
|
|
|
|
case 0: |
2012
|
|
|
|
|
|
break; |
2013
|
|
|
|
|
|
case '-': |
2014
|
1356
|
50
|
|
|
|
if (!*++s || isSPACE(*s)) { |
|
|
0
|
|
|
|
|
2015
|
1356
|
|
|
|
|
argc--,argv++; |
2016
|
1356
|
|
|
|
|
goto switch_end; |
2017
|
|
|
|
|
|
} |
2018
|
|
|
|
|
|
/* catch use of gnu style long options. |
2019
|
|
|
|
|
|
Both of these exit immediately. */ |
2020
|
0
|
0
|
|
|
|
if (strEQ(s, "version")) |
2021
|
0
|
|
|
|
|
minus_v(); |
2022
|
0
|
0
|
|
|
|
if (strEQ(s, "help")) |
2023
|
0
|
|
|
|
|
usage(); |
2024
|
|
|
|
|
|
s--; |
2025
|
|
|
|
|
|
/* FALL THROUGH */ |
2026
|
|
|
|
|
|
default: |
2027
|
33
|
|
|
|
|
Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s); |
2028
|
|
|
|
|
|
} |
2029
|
|
|
|
|
|
} |
2030
|
|
|
|
|
|
} |
2031
|
|
|
|
|
|
|
2032
|
|
|
|
|
|
switch_end: |
2033
|
|
|
|
|
|
|
2034
|
|
|
|
|
|
{ |
2035
|
|
|
|
|
|
char *s; |
2036
|
|
|
|
|
|
|
2037
|
11937
|
50
|
|
|
|
if ( |
2038
|
|
|
|
|
|
#ifndef SECURE_INTERNAL_GETENV |
2039
|
21771
|
50
|
|
|
|
!TAINTING_get && |
2040
|
|
|
|
|
|
#endif |
2041
|
|
|
|
|
|
(s = PerlEnv_getenv("PERL5OPT"))) |
2042
|
|
|
|
|
|
{ |
2043
|
273
|
0
|
|
|
|
while (isSPACE(*s)) |
2044
|
0
|
|
|
|
|
s++; |
2045
|
273
|
0
|
|
|
|
if (*s == '-' && *(s+1) == 'T') { |
|
|
0
|
|
|
|
|
2046
|
|
|
|
|
|
#if SILENT_NO_TAINT_SUPPORT |
2047
|
|
|
|
|
|
/* silently ignore */ |
2048
|
|
|
|
|
|
#elif NO_TAINT_SUPPORT |
2049
|
|
|
|
|
|
Perl_croak_nocontext("This perl was compiled without taint support. " |
2050
|
|
|
|
|
|
"Cowardly refusing to run with -t or -T flags"); |
2051
|
|
|
|
|
|
#else |
2052
|
|
|
|
|
|
CHECK_MALLOC_TOO_LATE_FOR('T'); |
2053
|
0
|
|
|
|
|
TAINTING_set(TRUE); |
2054
|
0
|
|
|
|
|
TAINT_WARN_set(FALSE); |
2055
|
|
|
|
|
|
#endif |
2056
|
|
|
|
|
|
} |
2057
|
|
|
|
|
|
else { |
2058
|
|
|
|
|
|
char *popt_copy = NULL; |
2059
|
295
|
0
|
|
|
|
while (s && *s) { |
|
|
0
|
|
|
|
|
2060
|
|
|
|
|
|
const char *d; |
2061
|
22
|
0
|
|
|
|
while (isSPACE(*s)) |
2062
|
0
|
|
|
|
|
s++; |
2063
|
22
|
0
|
|
|
|
if (*s == '-') { |
2064
|
22
|
|
|
|
|
s++; |
2065
|
22
|
0
|
|
|
|
if (isSPACE(*s)) |
2066
|
0
|
|
|
|
|
continue; |
2067
|
|
|
|
|
|
} |
2068
|
|
|
|
|
|
d = s; |
2069
|
22
|
0
|
|
|
|
if (!*s) |
2070
|
|
|
|
|
|
break; |
2071
|
22
|
0
|
|
|
|
if (!strchr("CDIMUdmtwW", *s)) |
2072
|
0
|
|
|
|
|
Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s); |
2073
|
103
|
0
|
|
|
|
while (++s && *s) { |
|
|
0
|
|
|
|
|
2074
|
89
|
0
|
|
|
|
if (isSPACE(*s)) { |
2075
|
8
|
0
|
|
|
|
if (!popt_copy) { |
2076
|
8
|
|
|
|
|
popt_copy = SvPVX(sv_2mortal(newSVpv(d,0))); |
2077
|
8
|
|
|
|
|
s = popt_copy + (s - d); |
2078
|
|
|
|
|
|
d = popt_copy; |
2079
|
|
|
|
|
|
} |
2080
|
8
|
|
|
|
|
*s++ = '\0'; |
2081
|
8
|
|
|
|
|
break; |
2082
|
|
|
|
|
|
} |
2083
|
|
|
|
|
|
} |
2084
|
22
|
0
|
|
|
|
if (*d == 't') { |
2085
|
|
|
|
|
|
#if SILENT_NO_TAINT_SUPPORT |
2086
|
|
|
|
|
|
/* silently ignore */ |
2087
|
|
|
|
|
|
#elif NO_TAINT_SUPPORT |
2088
|
|
|
|
|
|
Perl_croak_nocontext("This perl was compiled without taint support. " |
2089
|
|
|
|
|
|
"Cowardly refusing to run with -t or -T flags"); |
2090
|
|
|
|
|
|
#else |
2091
|
1
|
0
|
|
|
|
if( !TAINTING_get) { |
2092
|
1
|
|
|
|
|
TAINT_WARN_set(TRUE); |
2093
|
1
|
|
|
|
|
TAINTING_set(TRUE); |
2094
|
|
|
|
|
|
} |
2095
|
|
|
|
|
|
#endif |
2096
|
|
|
|
|
|
} else { |
2097
|
21
|
|
|
|
|
moreswitches(d); |
2098
|
|
|
|
|
|
} |
2099
|
|
|
|
|
|
} |
2100
|
|
|
|
|
|
} |
2101
|
|
|
|
|
|
} |
2102
|
|
|
|
|
|
} |
2103
|
|
|
|
|
|
|
2104
|
|
|
|
|
|
/* Set $^X early so that it can be used for relocatable paths in @INC */ |
2105
|
|
|
|
|
|
/* and for SITELIB_EXP in USE_SITECUSTOMIZE */ |
2106
|
|
|
|
|
|
assert (!TAINT_get); |
2107
|
11937
|
|
|
|
|
TAINT; |
2108
|
11937
|
|
|
|
|
S_set_caret_X(aTHX); |
2109
|
11937
|
|
|
|
|
TAINT_NOT; |
2110
|
|
|
|
|
|
|
2111
|
|
|
|
|
|
#if defined(USE_SITECUSTOMIZE) |
2112
|
11937
|
100
|
|
|
|
if (!minus_f) { |
2113
|
|
|
|
|
|
/* The games with local $! are to avoid setting errno if there is no |
2114
|
|
|
|
|
|
sitecustomize script. "q%c...%c", 0, ..., 0 becomes "q\0...\0", |
2115
|
|
|
|
|
|
ie a q() operator with a NUL byte as a the delimiter. This avoids |
2116
|
|
|
|
|
|
problems with pathnames containing (say) ' */ |
2117
|
|
|
|
|
|
# ifdef PERL_IS_MINIPERL |
2118
|
11930
|
|
|
|
|
AV *const inc = GvAV(PL_incgv); |
2119
|
11936
|
50
|
|
|
|
SV **const inc0 = inc ? av_fetch(inc, 0, FALSE) : NULL; |
2120
|
|
|
|
|
|
|
2121
|
6584
|
100
|
|
|
|
if (inc0) { |
2122
|
|
|
|
|
|
/* if lib/buildcustomize.pl exists, it should not fail. If it does, |
2123
|
|
|
|
|
|
it should be reported immediately as a build failure. */ |
2124
|
7218
|
|
|
|
|
(void)Perl_av_create_and_unshift_one(aTHX_ &PL_preambleav, |
2125
|
|
|
|
|
|
Perl_newSVpvf(aTHX_ |
2126
|
|
|
|
|
|
"BEGIN { do {local $!; -f q%c%"SVf"/buildcustomize.pl%c} and do q%c%"SVf"/buildcustomize.pl%c || die $@ }", |
2127
|
|
|
|
|
|
0, *inc0, 0, |
2128
|
|
|
|
|
|
0, *inc0, 0)); |
2129
|
|
|
|
|
|
} |
2130
|
|
|
|
|
|
# else |
2131
|
|
|
|
|
|
/* SITELIB_EXP is a function call on Win32. */ |
2132
|
|
|
|
|
|
const char *const raw_sitelib = SITELIB_EXP; |
2133
|
|
|
|
|
|
if (raw_sitelib) { |
2134
|
|
|
|
|
|
/* process .../.. if PERL_RELOCATABLE_INC is defined */ |
2135
|
|
|
|
|
|
SV *sitelib_sv = mayberelocate(raw_sitelib, strlen(raw_sitelib), |
2136
|
|
|
|
|
|
INCPUSH_CAN_RELOCATE); |
2137
|
|
|
|
|
|
const char *const sitelib = SvPVX(sitelib_sv); |
2138
|
|
|
|
|
|
(void)Perl_av_create_and_unshift_one(aTHX_ &PL_preambleav, |
2139
|
|
|
|
|
|
Perl_newSVpvf(aTHX_ |
2140
|
|
|
|
|
|
"BEGIN { do {local $!; -f q%c%s/sitecustomize.pl%c} && do q%c%s/sitecustomize.pl%c }", |
2141
|
|
|
|
|
|
0, sitelib, 0, |
2142
|
|
|
|
|
|
0, sitelib, 0)); |
2143
|
|
|
|
|
|
assert (SvREFCNT(sitelib_sv) == 1); |
2144
|
|
|
|
|
|
SvREFCNT_dec(sitelib_sv); |
2145
|
|
|
|
|
|
} |
2146
|
|
|
|
|
|
# endif |
2147
|
|
|
|
|
|
} |
2148
|
|
|
|
|
|
#endif |
2149
|
|
|
|
|
|
|
2150
|
11937
|
50
|
|
|
|
if (!scriptname) |
2151
|
11937
|
|
|
|
|
scriptname = argv[0]; |
2152
|
11937
|
100
|
|
|
|
if (PL_e_script) { |
2153
|
11142
|
|
|
|
|
argc++,argv--; |
2154
|
|
|
|
|
|
scriptname = BIT_BUCKET; /* don't look for script or read stdin */ |
2155
|
|
|
|
|
|
} |
2156
|
816
|
50
|
|
|
|
else if (scriptname == NULL) { |
2157
|
|
|
|
|
|
#ifdef MSDOS |
2158
|
|
|
|
|
|
if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) ) |
2159
|
|
|
|
|
|
moreswitches("h"); |
2160
|
|
|
|
|
|
#endif |
2161
|
|
|
|
|
|
scriptname = "-"; |
2162
|
|
|
|
|
|
} |
2163
|
|
|
|
|
|
|
2164
|
|
|
|
|
|
assert (!TAINT_get); |
2165
|
|
|
|
|
|
init_perllib(); |
2166
|
|
|
|
|
|
|
2167
|
|
|
|
|
|
{ |
2168
|
11936
|
|
|
|
|
bool suidscript = FALSE; |
2169
|
|
|
|
|
|
|
2170
|
11936
|
|
|
|
|
rsfp = open_script(scriptname, dosearch, &suidscript); |
2171
|
11936
|
50
|
|
|
|
if (!rsfp) { |
2172
|
0
|
|
|
|
|
rsfp = PerlIO_stdin(); |
2173
|
|
|
|
|
|
lex_start_flags = LEX_DONT_CLOSE_RSFP; |
2174
|
|
|
|
|
|
} |
2175
|
|
|
|
|
|
|
2176
|
2017
|
|
|
|
|
validate_suid(rsfp); |
2177
|
|
|
|
|
|
|
2178
|
|
|
|
|
|
#ifndef PERL_MICRO |
2179
|
|
|
|
|
|
# if defined(SIGCHLD) || defined(SIGCLD) |
2180
|
|
|
|
|
|
{ |
2181
|
|
|
|
|
|
# ifndef SIGCHLD |
2182
|
|
|
|
|
|
# define SIGCHLD SIGCLD |
2183
|
|
|
|
|
|
# endif |
2184
|
11936
|
|
|
|
|
Sighandler_t sigstate = rsignal_state(SIGCHLD); |
2185
|
2021
|
50
|
|
|
|
if (sigstate == (Sighandler_t) SIG_IGN) { |
2186
|
4
|
|
|
|
|
Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), |
2187
|
|
|
|
|
|
"Can't ignore signal CHLD, forcing to default"); |
2188
|
4
|
|
|
|
|
(void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL); |
2189
|
|
|
|
|
|
} |
2190
|
|
|
|
|
|
} |
2191
|
|
|
|
|
|
# endif |
2192
|
|
|
|
|
|
#endif |
2193
|
|
|
|
|
|
|
2194
|
2021
|
50
|
|
|
|
if (doextract) { |
2195
|
|
|
|
|
|
|
2196
|
|
|
|
|
|
/* This will croak if suidscript is true, as -x cannot be used with |
2197
|
|
|
|
|
|
setuid scripts. */ |
2198
|
2
|
|
|
|
|
forbid_setid('x', suidscript); |
2199
|
|
|
|
|
|
/* Hence you can't get here if suidscript is true */ |
2200
|
|
|
|
|
|
|
2201
|
0
|
|
|
|
|
linestr_sv = newSV_type(SVt_PV); |
2202
|
9917
|
|
|
|
|
lex_start_flags |= LEX_START_COPIED; |
2203
|
9917
|
|
|
|
|
find_beginning(linestr_sv, rsfp); |
2204
|
9917
|
0
|
|
|
|
if (cddir && PerlDir_chdir( (char *)cddir ) < 0) |
|
|
0
|
|
|
|
|
2205
|
9917
|
|
|
|
|
Perl_croak(aTHX_ "Can't chdir to %s",cddir); |
2206
|
|
|
|
|
|
} |
2207
|
|
|
|
|
|
} |
2208
|
|
|
|
|
|
|
2209
|
11934
|
|
|
|
|
PL_main_cv = PL_compcv = MUTABLE_CV(newSV_type(SVt_PVCV)); |
2210
|
11934
|
|
|
|
|
CvUNIQUE_on(PL_compcv); |
2211
|
|
|
|
|
|
|
2212
|
11934
|
|
|
|
|
CvPADLIST(PL_compcv) = pad_new(0); |
2213
|
|
|
|
|
|
|
2214
|
11934
|
|
|
|
|
PL_isarev = newHV(); |
2215
|
|
|
|
|
|
|
2216
|
11934
|
|
|
|
|
boot_core_PerlIO(); |
2217
|
11933
|
|
|
|
|
boot_core_UNIVERSAL(); |
2218
|
11934
|
|
|
|
|
boot_core_mro(); |
2219
|
11934
|
|
|
|
|
newXS("Internals::V", S_Internals_V, __FILE__); |
2220
|
|
|
|
|
|
|
2221
|
11934
|
50
|
|
|
|
if (xsinit) |
2222
|
11934
|
|
|
|
|
(*xsinit)(aTHX); /* in case linked C routines want magical variables */ |
2223
|
|
|
|
|
|
#ifndef PERL_MICRO |
2224
|
|
|
|
|
|
#if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(SYMBIAN) |
2225
|
|
|
|
|
|
init_os_extras(); |
2226
|
|
|
|
|
|
#endif |
2227
|
|
|
|
|
|
#endif |
2228
|
|
|
|
|
|
|
2229
|
|
|
|
|
|
#ifdef USE_SOCKS |
2230
|
|
|
|
|
|
# ifdef HAS_SOCKS5_INIT |
2231
|
|
|
|
|
|
socks5_init(argv[0]); |
2232
|
|
|
|
|
|
# else |
2233
|
|
|
|
|
|
SOCKSinit(argv[0]); |
2234
|
|
|
|
|
|
# endif |
2235
|
|
|
|
|
|
#endif |
2236
|
|
|
|
|
|
|
2237
|
2030
|
|
|
|
|
init_predump_symbols(); |
2238
|
|
|
|
|
|
/* init_postdump_symbols not currently designed to be called */ |
2239
|
|
|
|
|
|
/* more than once (ENV isn't cleared first, for example) */ |
2240
|
|
|
|
|
|
/* But running with -u leaves %ENV & @ARGV undefined! XXX */ |
2241
|
2030
|
50
|
|
|
|
if (!PL_do_undump) |
2242
|
2025
|
|
|
|
|
init_postdump_symbols(argc,argv,env); |
2243
|
|
|
|
|
|
|
2244
|
|
|
|
|
|
/* PL_unicode is turned on by -C, or by $ENV{PERL_UNICODE}, |
2245
|
|
|
|
|
|
* or explicitly in some platforms. |
2246
|
|
|
|
|
|
* locale.c:Perl_init_i18nl10n() if the environment |
2247
|
|
|
|
|
|
* look like the user wants to use UTF-8. */ |
2248
|
|
|
|
|
|
#if defined(__SYMBIAN32__) |
2249
|
|
|
|
|
|
PL_unicode = PERL_UNICODE_STD_FLAG; /* See PERL_SYMBIAN_CONSOLE_UTF8. */ |
2250
|
|
|
|
|
|
#endif |
2251
|
|
|
|
|
|
# ifndef PERL_IS_MINIPERL |
2252
|
|
|
|
|
|
if (PL_unicode) { |
2253
|
|
|
|
|
|
/* Requires init_predump_symbols(). */ |
2254
|
|
|
|
|
|
if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) { |
2255
|
|
|
|
|
|
IO* io; |
2256
|
|
|
|
|
|
PerlIO* fp; |
2257
|
|
|
|
|
|
SV* sv; |
2258
|
|
|
|
|
|
|
2259
|
|
|
|
|
|
/* Turn on UTF-8-ness on STDIN, STDOUT, STDERR |
2260
|
|
|
|
|
|
* and the default open disciplines. */ |
2261
|
|
|
|
|
|
if ((PL_unicode & PERL_UNICODE_STDIN_FLAG) && |
2262
|
|
|
|
|
|
PL_stdingv && (io = GvIO(PL_stdingv)) && |
2263
|
|
|
|
|
|
(fp = IoIFP(io))) |
2264
|
|
|
|
|
|
PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8"); |
2265
|
|
|
|
|
|
if ((PL_unicode & PERL_UNICODE_STDOUT_FLAG) && |
2266
|
|
|
|
|
|
PL_defoutgv && (io = GvIO(PL_defoutgv)) && |
2267
|
|
|
|
|
|
(fp = IoOFP(io))) |
2268
|
|
|
|
|
|
PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8"); |
2269
|
|
|
|
|
|
if ((PL_unicode & PERL_UNICODE_STDERR_FLAG) && |
2270
|
|
|
|
|
|
PL_stderrgv && (io = GvIO(PL_stderrgv)) && |
2271
|
|
|
|
|
|
(fp = IoOFP(io))) |
2272
|
|
|
|
|
|
PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8"); |
2273
|
|
|
|
|
|
if ((PL_unicode & PERL_UNICODE_INOUT_FLAG) && |
2274
|
|
|
|
|
|
(sv = GvSV(gv_fetchpvs("\017PEN", GV_ADD|GV_NOTQUAL, |
2275
|
|
|
|
|
|
SVt_PV)))) { |
2276
|
|
|
|
|
|
U32 in = PL_unicode & PERL_UNICODE_IN_FLAG; |
2277
|
|
|
|
|
|
U32 out = PL_unicode & PERL_UNICODE_OUT_FLAG; |
2278
|
|
|
|
|
|
if (in) { |
2279
|
|
|
|
|
|
if (out) |
2280
|
|
|
|
|
|
sv_setpvs(sv, ":utf8\0:utf8"); |
2281
|
|
|
|
|
|
else |
2282
|
|
|
|
|
|
sv_setpvs(sv, ":utf8\0"); |
2283
|
|
|
|
|
|
} |
2284
|
|
|
|
|
|
else if (out) |
2285
|
|
|
|
|
|
sv_setpvs(sv, "\0:utf8"); |
2286
|
|
|
|
|
|
SvSETMAGIC(sv); |
2287
|
|
|
|
|
|
} |
2288
|
|
|
|
|
|
} |
2289
|
|
|
|
|
|
} |
2290
|
|
|
|
|
|
#endif |
2291
|
|
|
|
|
|
|
2292
|
|
|
|
|
|
{ |
2293
|
|
|
|
|
|
const char *s; |
2294
|
2021
|
50
|
|
|
|
if ((s = PerlEnv_getenv("PERL_SIGNALS"))) { |
2295
|
4
|
0
|
|
|
|
if (strEQ(s, "unsafe")) |
2296
|
13
|
|
|
|
|
PL_signals |= PERL_SIGNALS_UNSAFE_FLAG; |
2297
|
8
|
0
|
|
|
|
else if (strEQ(s, "safe")) |
2298
|
4
|
|
|
|
|
PL_signals &= ~PERL_SIGNALS_UNSAFE_FLAG; |
2299
|
|
|
|
|
|
else |
2300
|
4
|
|
|
|
|
Perl_croak(aTHX_ "PERL_SIGNALS illegal: \"%s\"", s); |
2301
|
|
|
|
|
|
} |
2302
|
|
|
|
|
|
} |
2303
|
|
|
|
|
|
|
2304
|
|
|
|
|
|
#ifdef PERL_MAD |
2305
|
|
|
|
|
|
{ |
2306
|
|
|
|
|
|
const char *s; |
2307
|
|
|
|
|
|
if (!TAINTING_get && |
2308
|
|
|
|
|
|
(s = PerlEnv_getenv("PERL_XMLDUMP"))) { |
2309
|
|
|
|
|
|
PL_madskills = 1; |
2310
|
|
|
|
|
|
PL_minus_c = 1; |
2311
|
|
|
|
|
|
if (!s || !s[0]) |
2312
|
|
|
|
|
|
PL_xmlfp = PerlIO_stdout(); |
2313
|
|
|
|
|
|
else { |
2314
|
|
|
|
|
|
PL_xmlfp = PerlIO_open(s, "w"); |
2315
|
|
|
|
|
|
if (!PL_xmlfp) |
2316
|
|
|
|
|
|
Perl_croak(aTHX_ "Can't open %s", s); |
2317
|
|
|
|
|
|
} |
2318
|
|
|
|
|
|
my_setenv("PERL_XMLDUMP", NULL); /* hide from subprocs */ |
2319
|
|
|
|
|
|
} |
2320
|
|
|
|
|
|
} |
2321
|
|
|
|
|
|
|
2322
|
|
|
|
|
|
{ |
2323
|
|
|
|
|
|
const char *s; |
2324
|
|
|
|
|
|
if ((s = PerlEnv_getenv("PERL_MADSKILLS"))) { |
2325
|
|
|
|
|
|
PL_madskills = atoi(s); |
2326
|
|
|
|
|
|
my_setenv("PERL_MADSKILLS", NULL); /* hide from subprocs */ |
2327
|
|
|
|
|
|
} |
2328
|
|
|
|
|
|
} |
2329
|
|
|
|
|
|
#endif |
2330
|
|
|
|
|
|
|
2331
|
2030
|
|
|
|
|
lex_start(linestr_sv, rsfp, lex_start_flags); |
2332
|
2027
|
|
|
|
|
SvREFCNT_dec(linestr_sv); |
2333
|
|
|
|
|
|
|
2334
|
2022
|
|
|
|
|
PL_subname = newSVpvs("main"); |
2335
|
|
|
|
|
|
|
2336
|
2022
|
100
|
|
|
|
if (add_read_e_script) |
2337
|
1240
|
|
|
|
|
filter_add(read_e_script, NULL); |
2338
|
|
|
|
|
|
|
2339
|
|
|
|
|
|
/* now parse the script */ |
2340
|
|
|
|
|
|
|
2341
|
2021
|
|
|
|
|
SETERRNO(0,SS_NORMAL); |
2342
|
2021
|
50
|
|
|
|
if (yyparse(GRAMPROG) || PL_parser->error_count) { |
|
|
50
|
|
|
|
|
2343
|
4
|
0
|
|
|
|
if (PL_minus_c) |
2344
|
4
|
|
|
|
|
Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename); |
2345
|
|
|
|
|
|
else { |
2346
|
3
|
|
|
|
|
Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n", |
2347
|
|
|
|
|
|
PL_origfilename); |
2348
|
|
|
|
|
|
} |
2349
|
|
|
|
|
|
} |
2350
|
2017
|
|
|
|
|
CopLINE_set(PL_curcop, 0); |
2351
|
2020
|
50
|
|
|
|
SET_CURSTASH(PL_defstash); |
2352
|
2018
|
100
|
|
|
|
if (PL_e_script) { |
2353
|
1224
|
|
|
|
|
SvREFCNT_dec(PL_e_script); |
2354
|
1227
|
|
|
|
|
PL_e_script = NULL; |
2355
|
|
|
|
|
|
} |
2356
|
|
|
|
|
|
|
2357
|
11934
|
50
|
|
|
|
if (PL_do_undump) |
2358
|
0
|
|
|
|
|
my_unexec(); |
2359
|
|
|
|
|
|
|
2360
|
2017
|
100
|
|
|
|
if (isWARN_ONCE) { |
2361
|
1860
|
|
|
|
|
SAVECOPFILE(PL_curcop); |
2362
|
1860
|
|
|
|
|
SAVECOPLINE(PL_curcop); |
2363
|
1860
|
|
|
|
|
gv_check(PL_defstash); |
2364
|
|
|
|
|
|
} |
2365
|
|
|
|
|
|
|
2366
|
11934
|
|
|
|
|
LEAVE; |
2367
|
11934
|
50
|
|
|
|
FREETMPS; |
2368
|
|
|
|
|
|
|
2369
|
|
|
|
|
|
#ifdef MYMALLOC |
2370
|
|
|
|
|
|
{ |
2371
|
|
|
|
|
|
const char *s; |
2372
|
|
|
|
|
|
if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2) |
2373
|
|
|
|
|
|
dump_mstats("after compilation:"); |
2374
|
|
|
|
|
|
} |
2375
|
|
|
|
|
|
#endif |
2376
|
|
|
|
|
|
|
2377
|
11934
|
|
|
|
|
ENTER; |
2378
|
11934
|
|
|
|
|
PL_restartjmpenv = NULL; |
2379
|
6584
|
|
|
|
|
PL_restartop = 0; |
2380
|
11934
|
|
|
|
|
return NULL; |
2381
|
|
|
|
|
|
} |
2382
|
|
|
|
|
|
|
2383
|
|
|
|
|
|
/* |
2384
|
|
|
|
|
|
=for apidoc perl_run |
2385
|
|
|
|
|
|
|
2386
|
|
|
|
|
|
Tells a Perl interpreter to run. See L. |
2387
|
|
|
|
|
|
|
2388
|
|
|
|
|
|
=cut |
2389
|
|
|
|
|
|
*/ |
2390
|
|
|
|
|
|
|
2391
|
|
|
|
|
|
int |
2392
|
11934
|
|
|
|
|
perl_run(pTHXx) |
2393
|
|
|
|
|
|
{ |
2394
|
|
|
|
|
|
dVAR; |
2395
|
|
|
|
|
|
I32 oldscope; |
2396
|
|
|
|
|
|
int ret = 0; |
2397
|
|
|
|
|
|
dJMPENV; |
2398
|
|
|
|
|
|
|
2399
|
|
|
|
|
|
PERL_ARGS_ASSERT_PERL_RUN; |
2400
|
|
|
|
|
|
#ifndef MULTIPLICITY |
2401
|
|
|
|
|
|
PERL_UNUSED_ARG(my_perl); |
2402
|
|
|
|
|
|
#endif |
2403
|
|
|
|
|
|
|
2404
|
2110
|
|
|
|
|
oldscope = PL_scopestack_ix; |
2405
|
|
|
|
|
|
#ifdef VMS |
2406
|
|
|
|
|
|
VMSISH_HUSHED = 0; |
2407
|
|
|
|
|
|
#endif |
2408
|
|
|
|
|
|
|
2409
|
2018
|
|
|
|
|
JMPENV_PUSH(ret); |
2410
|
5192
|
|
|
|
|
switch (ret) { |
2411
|
|
|
|
|
|
case 1: |
2412
|
9525
|
|
|
|
|
cxstack_ix = -1; /* start context stack again */ |
2413
|
9525
|
|
|
|
|
goto redo_body; |
2414
|
|
|
|
|
|
case 0: /* normal completion */ |
2415
|
|
|
|
|
|
redo_body: |
2416
|
12608
|
|
|
|
|
run_body(oldscope); |
2417
|
|
|
|
|
|
/* FALL THROUGH */ |
2418
|
|
|
|
|
|
case 2: /* my_exit() */ |
2419
|
6599
|
100
|
|
|
|
while (PL_scopestack_ix > oldscope) |
2420
|
4582
|
|
|
|
|
LEAVE; |
2421
|
11542
|
100
|
|
|
|
FREETMPS; |
2422
|
2017
|
50
|
|
|
|
SET_CURSTASH(PL_defstash); |
2423
|
11542
|
50
|
|
|
|
if (!(PL_exit_flags & PERL_EXIT_DESTRUCT_END) && |
|
|
0
|
|
|
|
|
2424
|
6895
|
0
|
|
|
|
PL_endav && !PL_minus_c) { |
2425
|
6895
|
|
|
|
|
PERL_SET_PHASE(PERL_PHASE_END); |
2426
|
6895
|
|
|
|
|
call_list(oldscope, PL_endav); |
2427
|
|
|
|
|
|
} |
2428
|
|
|
|
|
|
#ifdef MYMALLOC |
2429
|
|
|
|
|
|
if (PerlEnv_getenv("PERL_DEBUG_MSTATS")) |
2430
|
|
|
|
|
|
dump_mstats("after execution: "); |
2431
|
|
|
|
|
|
#endif |
2432
|
11542
|
|
|
|
|
ret = STATUS_EXIT; |
2433
|
11542
|
|
|
|
|
break; |
2434
|
|
|
|
|
|
case 3: |
2435
|
10591
|
50
|
|
|
|
if (PL_restartop) { |
2436
|
10591
|
0
|
|
|
|
POPSTACK_TO(PL_mainstack); |
|
|
50
|
|
|
|
|
2437
|
|
|
|
|
|
goto redo_body; |
2438
|
|
|
|
|
|
} |
2439
|
9525
|
0
|
|
|
|
PerlIO_printf(Perl_error_log, "panic: restartop in perl_run\n"); |
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
2440
|
9525
|
0
|
|
|
|
FREETMPS; |
2441
|
|
|
|
|
|
ret = 1; |
2442
|
|
|
|
|
|
break; |
2443
|
|
|
|
|
|
} |
2444
|
|
|
|
|
|
|
2445
|
11624
|
|
|
|
|
JMPENV_POP; |
2446
|
11624
|
|
|
|
|
return ret; |
2447
|
|
|
|
|
|
} |
2448
|
|
|
|
|
|
|
2449
|
|
|
|
|
|
STATIC void |
2450
|
12690
|
|
|
|
|
S_run_body(pTHX_ I32 oldscope) |
2451
|
|
|
|
|
|
{ |
2452
|
|
|
|
|
|
dVAR; |
2453
|
|
|
|
|
|
DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support (0x%x).\n", |
2454
|
|
|
|
|
|
PL_sawampersand ? "Enabling" : "Omitting", |
2455
|
|
|
|
|
|
(unsigned int)(PL_sawampersand))); |
2456
|
|
|
|
|
|
|
2457
|
134225
|
100
|
|
|
|
if (!PL_restartop) { |
2458
|
|
|
|
|
|
#ifdef PERL_MAD |
2459
|
|
|
|
|
|
if (PL_xmlfp) { |
2460
|
|
|
|
|
|
xmldump_all(); |
2461
|
|
|
|
|
|
exit(0); /* less likely to core dump than my_exit(0) */ |
2462
|
|
|
|
|
|
} |
2463
|
|
|
|
|
|
#endif |
2464
|
|
|
|
|
|
#ifdef DEBUGGING |
2465
|
|
|
|
|
|
if (DEBUG_x_TEST || DEBUG_B_TEST) |
2466
|
|
|
|
|
|
dump_all_perl(!DEBUG_B_TEST); |
2467
|
|
|
|
|
|
if (!DEBUG_q_TEST) |
2468
|
|
|
|
|
|
PERL_DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n")); |
2469
|
|
|
|
|
|
#endif |
2470
|
|
|
|
|
|
|
2471
|
2017
|
50
|
|
|
|
if (PL_minus_c) { |
2472
|
0
|
0
|
|
|
|
PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename); |
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
2473
|
121535
|
|
|
|
|
my_exit(0); |
2474
|
|
|
|
|
|
} |
2475
|
13996
|
50
|
|
|
|
if (PERLDB_SINGLE && PL_DBsingle) |
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
2476
|
2372
|
|
|
|
|
sv_setiv(PL_DBsingle, 1); |
2477
|
11624
|
50
|
|
|
|
if (PL_initav) { |
2478
|
9607
|
|
|
|
|
PERL_SET_PHASE(PERL_PHASE_INIT); |
2479
|
9607
|
|
|
|
|
call_list(oldscope, PL_initav); |
2480
|
|
|
|
|
|
} |
2481
|
|
|
|
|
|
#ifdef PERL_DEBUG_READONLY_OPS |
2482
|
|
|
|
|
|
if (PL_main_root && PL_main_root->op_slabbed) |
2483
|
|
|
|
|
|
Slab_to_ro(OpSLAB(PL_main_root)); |
2484
|
|
|
|
|
|
#endif |
2485
|
|
|
|
|
|
} |
2486
|
|
|
|
|
|
|
2487
|
|
|
|
|
|
/* do it */ |
2488
|
|
|
|
|
|
|
2489
|
3083
|
|
|
|
|
PERL_SET_PHASE(PERL_PHASE_RUN); |
2490
|
|
|
|
|
|
|
2491
|
3083
|
100
|
|
|
|
if (PL_restartop) { |
2492
|
1066
|
|
|
|
|
PL_restartjmpenv = NULL; |
2493
|
10673
|
|
|
|
|
PL_op = PL_restartop; |
2494
|
10673
|
|
|
|
|
PL_restartop = 0; |
2495
|
112994
|
|
|
|
|
CALLRUNOPS(aTHX); |
2496
|
|
|
|
|
|
} |
2497
|
2017
|
50
|
|
|
|
else if (PL_main_start) { |
2498
|
4034
|
|
|
|
|
CvDEPTH(PL_main_cv) = 1; |
2499
|
2017
|
|
|
|
|
PL_op = PL_main_start; |
2500
|
11624
|
|
|
|
|
CALLRUNOPS(aTHX); |
2501
|
|
|
|
|
|
} |
2502
|
11558
|
|
|
|
|
my_exit(0); |
2503
|
|
|
|
|
|
assert(0); /* NOTREACHED */ |
2504
|
|
|
|
|
|
} |
2505
|
|
|
|
|
|
|
2506
|
|
|
|
|
|
/* |
2507
|
|
|
|
|
|
=head1 SV Manipulation Functions |
2508
|
|
|
|
|
|
|
2509
|
|
|
|
|
|
=for apidoc p||get_sv |
2510
|
|
|
|
|
|
|
2511
|
|
|
|
|
|
Returns the SV of the specified Perl scalar. C are passed to |
2512
|
|
|
|
|
|
C. If C is set and the |
2513
|
|
|
|
|
|
Perl variable does not exist then it will be created. If C is zero |
2514
|
|
|
|
|
|
and the variable does not exist then NULL is returned. |
2515
|
|
|
|
|
|
|
2516
|
|
|
|
|
|
=cut |
2517
|
|
|
|
|
|
*/ |
2518
|
|
|
|
|
|
|
2519
|
|
|
|
|
|
SV* |
2520
|
174444
|
|
|
|
|
Perl_get_sv(pTHX_ const char *name, I32 flags) |
2521
|
|
|
|
|
|
{ |
2522
|
|
|
|
|
|
GV *gv; |
2523
|
|
|
|
|
|
|
2524
|
|
|
|
|
|
PERL_ARGS_ASSERT_GET_SV; |
2525
|
|
|
|
|
|
|
2526
|
174444
|
|
|
|
|
gv = gv_fetchpv(name, flags, SVt_PV); |
2527
|
62516
|
50
|
|
|
|
if (gv) |
2528
|
52994
|
|
|
|
|
return GvSV(gv); |
2529
|
|
|
|
|
|
return NULL; |
2530
|
|
|
|
|
|
} |
2531
|
|
|
|
|
|
|
2532
|
|
|
|
|
|
/* |
2533
|
|
|
|
|
|
=head1 Array Manipulation Functions |
2534
|
|
|
|
|
|
|
2535
|
|
|
|
|
|
=for apidoc p||get_av |
2536
|
|
|
|
|
|
|
2537
|
|
|
|
|
|
Returns the AV of the specified Perl global or package array with the given |
2538
|
|
|
|
|
|
name (so it won't work on lexical variables). C are passed |
2539
|
|
|
|
|
|
to C. If C is set and the |
2540
|
|
|
|
|
|
Perl variable does not exist then it will be created. If C is zero |
2541
|
|
|
|
|
|
and the variable does not exist then NULL is returned. |
2542
|
|
|
|
|
|
|
2543
|
|
|
|
|
|
Perl equivalent: C<@{"$name"}>. |
2544
|
|
|
|
|
|
|
2545
|
|
|
|
|
|
=cut |
2546
|
|
|
|
|
|
*/ |
2547
|
|
|
|
|
|
|
2548
|
|
|
|
|
|
AV* |
2549
|
85
|
|
|
|
|
Perl_get_av(pTHX_ const char *name, I32 flags) |
2550
|
|
|
|
|
|
{ |
2551
|
9522
|
|
|
|
|
GV* const gv = gv_fetchpv(name, flags, SVt_PVAV); |
2552
|
|
|
|
|
|
|
2553
|
|
|
|
|
|
PERL_ARGS_ASSERT_GET_AV; |
2554
|
|
|
|
|
|
|
2555
|
109
|
0
|
|
|
|
if (flags) |
2556
|
9522
|
0
|
|
|
|
return GvAVn(gv); |
2557
|
2252
|
0
|
|
|
|
if (gv) |
2558
|
2252
|
|
|
|
|
return GvAV(gv); |
2559
|
|
|
|
|
|
return NULL; |
2560
|
|
|
|
|
|
} |
2561
|
|
|
|
|
|
|
2562
|
|
|
|
|
|
/* |
2563
|
|
|
|
|
|
=head1 Hash Manipulation Functions |
2564
|
|
|
|
|
|
|
2565
|
|
|
|
|
|
=for apidoc p||get_hv |
2566
|
|
|
|
|
|
|
2567
|
|
|
|
|
|
Returns the HV of the specified Perl hash. C are passed to |
2568
|
|
|
|
|
|
C. If C is set and the |
2569
|
|
|
|
|
|
Perl variable does not exist then it will be created. If C is zero |
2570
|
|
|
|
|
|
and the variable does not exist then NULL is returned. |
2571
|
|
|
|
|
|
|
2572
|
|
|
|
|
|
=cut |
2573
|
|
|
|
|
|
*/ |
2574
|
|
|
|
|
|
|
2575
|
|
|
|
|
|
HV* |
2576
|
133215
|
|
|
|
|
Perl_get_hv(pTHX_ const char *name, I32 flags) |
2577
|
|
|
|
|
|
{ |
2578
|
133215
|
|
|
|
|
GV* const gv = gv_fetchpv(name, flags, SVt_PVHV); |
2579
|
|
|
|
|
|
|
2580
|
|
|
|
|
|
PERL_ARGS_ASSERT_GET_HV; |
2581
|
|
|
|
|
|
|
2582
|
123694
|
100
|
|
|
|
if (flags) |
2583
|
113945
|
50
|
|
|
|
return GvHVn(gv); |
2584
|
121677
|
50
|
|
|
|
if (gv) |
2585
|
123694
|
|
|
|
|
return GvHV(gv); |
2586
|
|
|
|
|
|
return NULL; |
2587
|
|
|
|
|
|
} |
2588
|
|
|
|
|
|
|
2589
|
|
|
|
|
|
/* |
2590
|
|
|
|
|
|
=head1 CV Manipulation Functions |
2591
|
|
|
|
|
|
|
2592
|
|
|
|
|
|
=for apidoc p||get_cvn_flags |
2593
|
|
|
|
|
|
|
2594
|
|
|
|
|
|
Returns the CV of the specified Perl subroutine. C are passed to |
2595
|
|
|
|
|
|
C. If C is set and the Perl subroutine does not |
2596
|
|
|
|
|
|
exist then it will be declared (which has the same effect as saying |
2597
|
|
|
|
|
|
C). If C is not set and the subroutine does not exist |
2598
|
|
|
|
|
|
then NULL is returned. |
2599
|
|
|
|
|
|
|
2600
|
|
|
|
|
|
=for apidoc p||get_cv |
2601
|
|
|
|
|
|
|
2602
|
|
|
|
|
|
Uses C to get the length of C, then calls C. |
2603
|
|
|
|
|
|
|
2604
|
|
|
|
|
|
=cut |
2605
|
|
|
|
|
|
*/ |
2606
|
|
|
|
|
|
|
2607
|
|
|
|
|
|
CV* |
2608
|
11609
|
|
|
|
|
Perl_get_cvn_flags(pTHX_ const char *name, STRLEN len, I32 flags) |
2609
|
|
|
|
|
|
{ |
2610
|
20788
|
|
|
|
|
GV* const gv = gv_fetchpvn_flags(name, len, flags, SVt_PVCV); |
2611
|
|
|
|
|
|
|
2612
|
|
|
|
|
|
PERL_ARGS_ASSERT_GET_CVN_FLAGS; |
2613
|
|
|
|
|
|
|
2614
|
|
|
|
|
|
/* XXX this is probably not what they think they're getting. |
2615
|
|
|
|
|
|
* It has the same effect as "sub name;", i.e. just a forward |
2616
|
|
|
|
|
|
* declaration! */ |
2617
|
11438
|
50
|
|
|
|
if ((flags & ~GV_NOADD_MASK) && !GvCVu(gv)) { |
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
2618
|
9350
|
|
|
|
|
return newSTUB(gv,0); |
2619
|
|
|
|
|
|
} |
2620
|
10993
|
100
|
|
|
|
if (gv) |
2621
|
105453076
|
50
|
|
|
|
return GvCVu(gv); |
2622
|
|
|
|
|
|
return NULL; |
2623
|
|
|
|
|
|
} |
2624
|
|
|
|
|
|
|
2625
|
|
|
|
|
|
/* Nothing in core calls this now, but we can't replace it with a macro and |
2626
|
|
|
|
|
|
move it to mathoms.c as a macro would evaluate name twice. */ |
2627
|
|
|
|
|
|
CV* |
2628
|
105450988
|
|
|
|
|
Perl_get_cv(pTHX_ const char *name, I32 flags) |
2629
|
|
|
|
|
|
{ |
2630
|
|
|
|
|
|
PERL_ARGS_ASSERT_GET_CV; |
2631
|
|
|
|
|
|
|
2632
|
105450988
|
|
|
|
|
return get_cvn_flags(name, strlen(name), flags); |
2633
|
|
|
|
|
|
} |
2634
|
|
|
|
|
|
|
2635
|
|
|
|
|
|
/* Be sure to refetch the stack pointer after calling these routines. */ |
2636
|
|
|
|
|
|
|
2637
|
|
|
|
|
|
/* |
2638
|
|
|
|
|
|
|
2639
|
|
|
|
|
|
=head1 Callback Functions |
2640
|
|
|
|
|
|
|
2641
|
|
|
|
|
|
=for apidoc p||call_argv |
2642
|
|
|
|
|
|
|
2643
|
|
|
|
|
|
Performs a callback to the specified named and package-scoped Perl subroutine |
2644
|
|
|
|
|
|
with C (a NULL-terminated array of strings) as arguments. See L. |
2645
|
|
|
|
|
|
|
2646
|
|
|
|
|
|
Approximate Perl equivalent: C<&{"$sub_name"}(@$argv)>. |
2647
|
|
|
|
|
|
|
2648
|
|
|
|
|
|
=cut |
2649
|
|
|
|
|
|
*/ |
2650
|
|
|
|
|
|
|
2651
|
|
|
|
|
|
I32 |
2652
|
105212231
|
|
|
|
|
Perl_call_argv(pTHX_ const char *sub_name, I32 flags, char **argv) |
2653
|
|
|
|
|
|
|
2654
|
|
|
|
|
|
/* See G_* flags in cop.h */ |
2655
|
|
|
|
|
|
/* null terminated arg list */ |
2656
|
|
|
|
|
|
{ |
2657
|
|
|
|
|
|
dVAR; |
2658
|
2645
|
|
|
|
|
dSP; |
2659
|
|
|
|
|
|
|
2660
|
|
|
|
|
|
PERL_ARGS_ASSERT_CALL_ARGV; |
2661
|
|
|
|
|
|
|
2662
|
2645
|
0
|
|
|
|
PUSHMARK(SP); |
2663
|
2645
|
0
|
|
|
|
if (argv) { |
2664
|
2643
|
0
|
|
|
|
while (*argv) { |
2665
|
2
|
0
|
|
|
|
mXPUSHs(newSVpv(*argv,0)); |
2666
|
1
|
|
|
|
|
argv++; |
2667
|
|
|
|
|
|
} |
2668
|
2525264
|
|
|
|
|
PUTBACK; |
2669
|
|
|
|
|
|
} |
2670
|
2525264
|
|
|
|
|
return call_pv(sub_name, flags); |
2671
|
|
|
|
|
|
} |
2672
|
|
|
|
|
|
|
2673
|
|
|
|
|
|
/* |
2674
|
|
|
|
|
|
=for apidoc p||call_pv |
2675
|
|
|
|
|
|
|
2676
|
|
|
|
|
|
Performs a callback to the specified Perl sub. See L. |
2677
|
|
|
|
|
|
|
2678
|
|
|
|
|
|
=cut |
2679
|
|
|
|
|
|
*/ |
2680
|
|
|
|
|
|
|
2681
|
|
|
|
|
|
I32 |
2682
|
2525264
|
|
|
|
|
Perl_call_pv(pTHX_ const char *sub_name, I32 flags) |
2683
|
|
|
|
|
|
/* name of the subroutine */ |
2684
|
|
|
|
|
|
/* See G_* flags in cop.h */ |
2685
|
|
|
|
|
|
{ |
2686
|
|
|
|
|
|
PERL_ARGS_ASSERT_CALL_PV; |
2687
|
|
|
|
|
|
|
2688
|
23695
|
|
|
|
|
return call_sv(MUTABLE_SV(get_cv(sub_name, GV_ADD)), flags); |
2689
|
|
|
|
|
|
} |
2690
|
|
|
|
|
|
|
2691
|
|
|
|
|
|
/* |
2692
|
|
|
|
|
|
=for apidoc p||call_method |
2693
|
|
|
|
|
|
|
2694
|
|
|
|
|
|
Performs a callback to the specified Perl method. The blessed object must |
2695
|
|
|
|
|
|
be on the stack. See L. |
2696
|
|
|
|
|
|
|
2697
|
|
|
|
|
|
=cut |
2698
|
|
|
|
|
|
*/ |
2699
|
|
|
|
|
|
|
2700
|
|
|
|
|
|
I32 |
2701
|
2501569
|
|
|
|
|
Perl_call_method(pTHX_ const char *methname, I32 flags) |
2702
|
|
|
|
|
|
/* name of the subroutine */ |
2703
|
|
|
|
|
|
/* See G_* flags in cop.h */ |
2704
|
|
|
|
|
|
{ |
2705
|
|
|
|
|
|
STRLEN len; |
2706
|
|
|
|
|
|
SV* sv; |
2707
|
|
|
|
|
|
PERL_ARGS_ASSERT_CALL_METHOD; |
2708
|
|
|
|
|
|
|
2709
|
2501418
|
|
|
|
|
len = strlen(methname); |
2710
|
728719
|
|
|
|
|
sv = flags & G_METHOD_NAMED |
2711
|
728719
|
|
|
|
|
? sv_2mortal(newSVpvn_share(methname, len,0)) |
2712
|
728719
|
0
|
|
|
|
: newSVpvn_flags(methname, len, SVs_TEMP); |
2713
|
|
|
|
|
|
|
2714
|
5
|
|
|
|
|
return call_sv(sv, flags | G_METHOD); |
2715
|
|
|
|
|
|
} |
2716
|
|
|
|
|
|
|
2717
|
|
|
|
|
|
/* May be called with any of a CV, a GV, or an SV containing the name. */ |
2718
|
|
|
|
|
|
/* |
2719
|
|
|
|
|
|
=for apidoc p||call_sv |
2720
|
|
|
|
|
|
|
2721
|
|
|
|
|
|
Performs a callback to the Perl sub whose name is in the SV. See |
2722
|
|
|
|
|
|
L. |
2723
|
|
|
|
|
|
|
2724
|
|
|
|
|
|
=cut |
2725
|
|
|
|
|
|
*/ |
2726
|
|
|
|
|
|
|
2727
|
|
|
|
|
|
I32 |
2728
|
2537274
|
|
|
|
|
Perl_call_sv(pTHX_ SV *sv, VOL I32 flags) |
2729
|
|
|
|
|
|
/* See G_* flags in cop.h */ |
2730
|
2533394
|
50
|
|
|
|
{ |
2731
|
2467792
|
|
|
|
|
dVAR; dSP; |
2732
|
|
|
|
|
|
LOGOP myop; /* fake syntax tree node */ |
2733
|
|
|
|
|
|
UNOP method_unop; |
2734
|
|
|
|
|
|
SVOP method_svop; |
2735
|
|
|
|
|
|
I32 oldmark; |
2736
|
2467792
|
|
|
|
|
VOL I32 retval = 0; |
2737
|
|
|
|
|
|
I32 oldscope; |
2738
|
1808566
|
|
|
|
|
bool oldcatch = CATCH_GET; |
2739
|
|
|
|
|
|
int ret; |
2740
|
1808566
|
|
|
|
|
OP* const oldop = PL_op; |
2741
|
|
|
|
|
|
dJMPENV; |
2742
|
|
|
|
|
|
|
2743
|
|
|
|
|
|
PERL_ARGS_ASSERT_CALL_SV; |
2744
|
|
|
|
|
|
|
2745
|
1808566
|
100
|
|
|
|
if (flags & G_DISCARD) { |
2746
|
563779
|
|
|
|
|
ENTER; |
2747
|
563788
|
|
|
|
|
SAVETMPS; |
2748
|
|
|
|
|
|
} |
2749
|
1808569
|
100
|
|
|
|
if (!(flags & G_WANT)) { |
2750
|
|
|
|
|
|
/* Backwards compatibility - as G_SCALAR was 0, it could be omitted. |
2751
|
|
|
|
|
|
*/ |
2752
|
161
|
|
|
|
|
flags |= G_SCALAR; |
2753
|
|
|
|
|
|
} |
2754
|
|
|
|
|
|
|
2755
|
|
|
|
|
|
Zero(&myop, 1, LOGOP); |
2756
|
1808566
|
50
|
|
|
|
if (!(flags & G_NOARGS)) |
2757
|
1808566
|
|
|
|
|
myop.op_flags |= OPf_STACKED; |
2758
|
2367730
|
|
|
|
|
myop.op_flags |= OP_GIMME_REVERSE(flags); |
2759
|
2367730
|
|
|
|
|
SAVEOP(); |
2760
|
2139373
|
|
|
|
|
PL_op = (OP*)&myop; |
2761
|
|
|
|
|
|
|
2762
|
330813
|
|
|
|
|
EXTEND(PL_stack_sp, 1); |
2763
|
2139373
|
100
|
|
|
|
if (!(flags & G_METHOD_NAMED)) |
2764
|
565729
|
|
|
|
|
*++PL_stack_sp = sv; |
2765
|
2139373
|
|
|
|
|
oldmark = TOPMARK; |
2766
|
2139373
|
|
|
|
|
oldscope = PL_scopestack_ix; |
2767
|
|
|
|
|
|
|
2768
|
6711561
|
50
|
|
|
|
if (PERLDB_SUB && PL_curstash != PL_debstash |
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
2769
|
|
|
|
|
|
/* Handle first BEGIN of -d. */ |
2770
|
4903001
|
0
|
|
|
|
&& (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub))) |
|
|
0
|
|
|
|
|
2771
|
|
|
|
|
|
/* Try harder, since this may have been a sighandler, thus |
2772
|
|
|
|
|
|
* curstash may be meaningless. */ |
2773
|
4903001
|
0
|
|
|
|
&& (SvTYPE(sv) != SVt_PVCV || CvSTASH((const CV *)sv) != PL_debstash) |
|
|
0
|
|
|
|
|
2774
|
4903001
|
0
|
|
|
|
&& !(flags & G_NODEBUG)) |
2775
|
4903001
|
|
|
|
|
myop.op_private |= OPpENTERSUB_DB; |
2776
|
|
|
|
|
|
|
2777
|
6711561
|
100
|
|
|
|
if (flags & (G_METHOD|G_METHOD_NAMED)) { |
2778
|
6145832
|
50
|
|
|
|
if ( flags & G_METHOD_NAMED ) { |
2779
|
|
|
|
|
|
Zero(&method_svop, 1, SVOP); |
2780
|
4049157
|
|
|
|
|
method_svop.op_next = (OP*)&myop; |
2781
|
4049157
|
|
|
|
|
method_svop.op_ppaddr = PL_ppaddr[OP_METHOD_NAMED]; |
2782
|
6145832
|
|
|
|
|
method_svop.op_type = OP_METHOD_NAMED; |
2783
|
1299969
|
|
|
|
|
method_svop.op_sv = sv; |
2784
|
6145832
|
|
|
|
|
PL_op = (OP*)&method_svop; |
2785
|
|
|
|
|
|
} else { |
2786
|
|
|
|
|
|
Zero(&method_unop, 1, UNOP); |
2787
|
4902978
|
|
|
|
|
method_unop.op_next = (OP*)&myop; |
2788
|
4903001
|
|
|
|
|
method_unop.op_ppaddr = PL_ppaddr[OP_METHOD]; |
2789
|
4903001
|
|
|
|
|
method_unop.op_type = OP_METHOD; |
2790
|
4903001
|
|
|
|
|
PL_op = (OP*)&method_unop; |
2791
|
|
|
|
|
|
} |
2792
|
6145836
|
|
|
|
|
myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB]; |
2793
|
6145832
|
|
|
|
|
myop.op_type = OP_ENTERSUB; |
2794
|
|
|
|
|
|
|
2795
|
|
|
|
|
|
} |
2796
|
|
|
|
|
|
|
2797
|
5641799
|
100
|
|
|
|
if (!(flags & G_EVAL)) { |
2798
|
6147941
|
|
|
|
|
CATCH_SET(TRUE); |
2799
|
6147941
|
100
|
|
|
|
CALL_BODY_SUB((OP*)&myop); |
|
|
50
|
|
|
|
|
2800
|
6147939
|
|
|
|
|
retval = PL_stack_sp - (PL_stack_base + oldmark); |
2801
|
1249465
|
|
|
|
|
CATCH_SET(oldcatch); |
2802
|
|
|
|
|
|
} |
2803
|
|
|
|
|
|
else { |
2804
|
564887
|
|
|
|
|
myop.op_other = (OP*)&myop; |
2805
|
564214
|
|
|
|
|
PL_markstack_ptr--; |
2806
|
564214
|
|
|
|
|
create_eval_scope(flags|G_FAKINGEVAL); |
2807
|
5466621
|
|
|
|
|
PL_markstack_ptr++; |
2808
|
|
|
|
|
|
|
2809
|
1964837
|
|
|
|
|
JMPENV_PUSH(ret); |
2810
|
|
|
|
|
|
|
2811
|
1638402
|
|
|
|
|
switch (ret) { |
2812
|
|
|
|
|
|
case 0: |
2813
|
|
|
|
|
|
redo_body: |
2814
|
1637976
|
100
|
|
|
|
CALL_BODY_SUB((OP*)&myop); |
|
|
50
|
|
|
|
|
2815
|
1632956
|
|
|
|
|
retval = PL_stack_sp - (PL_stack_base + oldmark); |
2816
|
1632956
|
100
|
|
|
|
if (!(flags & G_KEEPERR)) { |
2817
|
1231651
|
50
|
|
|
|
CLEAR_ERRSV(); |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
2818
|
|
|
|
|
|
} |
2819
|
|
|
|
|
|
break; |
2820
|
|
|
|
|
|
case 1: |
2821
|
331455
|
|
|
|
|
STATUS_ALL_FAILURE; |
2822
|
|
|
|
|
|
/* FALL THROUGH */ |
2823
|
|
|
|
|
|
case 2: |
2824
|
|
|
|
|
|
/* my_exit() was called */ |
2825
|
331455
|
0
|
|
|
|
SET_CURSTASH(PL_defstash); |
2826
|
331455
|
0
|
|
|
|
FREETMPS; |
2827
|
331455
|
|
|
|
|
JMPENV_POP; |
2828
|
1401217
|
|
|
|
|
my_exit_jump(); |
2829
|
|
|
|
|
|
assert(0); /* NOTREACHED */ |
2830
|
|
|
|
|
|
case 3: |
2831
|
1406237
|
100
|
|
|
|
if (PL_restartop) { |
2832
|
4907595
|
|
|
|
|
PL_restartjmpenv = NULL; |
2833
|
2161341
|
|
|
|
|
PL_op = PL_restartop; |
2834
|
2161341
|
|
|
|
|
PL_restartop = 0; |
2835
|
2160872
|
|
|
|
|
goto redo_body; |
2836
|
|
|
|
|
|
} |
2837
|
2156704
|
|
|
|
|
PL_stack_sp = PL_stack_base + oldmark; |
2838
|
2746680
|
50
|
|
|
|
if ((flags & G_WANT) == G_ARRAY) |
2839
|
2746254
|
|
|
|
|
retval = 0; |
2840
|
|
|
|
|
|
else { |
2841
|
2746680
|
|
|
|
|
retval = 1; |
2842
|
2746680
|
|
|
|
|
*++PL_stack_sp = &PL_sv_undef; |
2843
|
|
|
|
|
|
} |
2844
|
|
|
|
|
|
break; |
2845
|
|
|
|
|
|
} |
2846
|
|
|
|
|
|
|
2847
|
3309874
|
100
|
|
|
|
if (PL_scopestack_ix > oldscope) |
2848
|
3348754
|
|
|
|
|
delete_eval_scope(); |
2849
|
3336508
|
|
|
|
|
JMPENV_POP; |
2850
|
|
|
|
|
|
} |
2851
|
|
|
|
|
|
|
2852
|
4542140
|
100
|
|
|
|
if (flags & G_DISCARD) { |
2853
|
3297354
|
|
|
|
|
PL_stack_sp = PL_stack_base + oldmark; |
2854
|
2849342
|
|
|
|
|
retval = 0; |
2855
|
563772
|
100
|
|
|
|
FREETMPS; |
2856
|
563902
|
|
|
|
|
LEAVE; |
2857
|
|
|
|
|
|
} |
2858
|
1808688
|
|
|
|
|
PL_op = oldop; |
2859
|
1808688
|
|
|
|
|
return retval; |
2860
|
|
|
|
|
|
} |
2861
|
|
|
|
|
|
|
2862
|
|
|
|
|
|
/* Eval a string. The G_EVAL flag is always assumed. */ |
2863
|
|
|
|
|
|
|
2864
|
|
|
|
|
|
/* |
2865
|
|
|
|
|
|
=for apidoc p||eval_sv |
2866
|
|
|
|
|
|
|
2867
|
|
|
|
|
|
Tells Perl to C the string in the SV. It supports the same flags |
2868
|
|
|
|
|
|
as C, with the obvious exception of G_EVAL. See L. |
2869
|
|
|
|
|
|
|
2870
|
|
|
|
|
|
=cut |
2871
|
|
|
|
|
|
*/ |
2872
|
|
|
|
|
|
|
2873
|
|
|
|
|
|
I32 |
2874
|
130
|
|
|
|
|
Perl_eval_sv(pTHX_ SV *sv, I32 flags) |
2875
|
|
|
|
|
|
|
2876
|
|
|
|
|
|
/* See G_* flags in cop.h */ |
2877
|
39176
|
0
|
|
|
|
{ |
2878
|
|
|
|
|
|
dVAR; |
2879
|
26634
|
|
|
|
|
dSP; |
2880
|
|
|
|
|
|
UNOP myop; /* fake syntax tree node */ |
2881
|
26634
|
|
|
|
|
VOL I32 oldmark = SP - PL_stack_base; |
2882
|
26634
|
|
|
|
|
VOL I32 retval = 0; |
2883
|
|
|
|
|
|
int ret; |
2884
|
26634
|
|
|
|
|
OP* const oldop = PL_op; |
2885
|
|
|
|
|
|
dJMPENV; |
2886
|
|
|
|
|
|
|
2887
|
|
|
|
|
|
PERL_ARGS_ASSERT_EVAL_SV; |
2888
|
|
|
|
|
|
|
2889
|
12542
|
0
|
|
|
|
if (flags & G_DISCARD) { |
2890
|
12542
|
|
|
|
|
ENTER; |
2891
|
38
|
|
|
|
|
SAVETMPS; |
2892
|
|
|
|
|
|
} |
2893
|
|
|
|
|
|
|
2894
|
12504
|
|
|
|
|
SAVEOP(); |
2895
|
12504
|
|
|
|
|
PL_op = (OP*)&myop; |
2896
|
|
|
|
|
|
Zero(&myop, 1, UNOP); |
2897
|
2746124
|
|
|
|
|
EXTEND(PL_stack_sp, 1); |
2898
|
2733582
|
|
|
|
|
*++PL_stack_sp = sv; |
2899
|
|
|
|
|
|
|
2900
|
2746124
|
0
|
|
|
|
if (!(flags & G_NOARGS)) |
2901
|
4902402
|
|
|
|
|
myop.op_flags = OPf_STACKED; |
2902
|
2805967
|
|
|
|
|
myop.op_type = OP_ENTEREVAL; |
2903
|
2805967
|
|
|
|
|
myop.op_flags |= OP_GIMME_REVERSE(flags); |
2904
|
2805967
|
0
|
|
|
|
if (flags & G_KEEPERR) |
2905
|
2805967
|
|
|
|
|
myop.op_flags |= OPf_SPECIAL; |
2906
|
|
|
|
|
|
|
2907
|
4902402
|
0
|
|
|
|
if (flags & G_RE_REPARSING) |
2908
|
4902402
|
|
|
|
|
myop.op_private = (OPpEVAL_COPHH | OPpEVAL_RE_REPARSING); |
2909
|
|
|
|
|
|
|
2910
|
|
|
|
|
|
/* fail now; otherwise we could fail after the JMPENV_PUSH but |
2911
|
|
|
|
|
|
* before a PUSHEVAL, which corrupts the stack after a croak */ |
2912
|
915
|
0
|
|
|
|
TAINT_PROPER("eval_sv()"); |
2913
|
|
|
|
|
|
|
2914
|
915
|
|
|
|
|
JMPENV_PUSH(ret); |
2915
|
915
|
|
|
|
|
switch (ret) { |
2916
|
|
|
|
|
|
case 0: |
2917
|
|
|
|
|
|
redo_body: |
2918
|
915
|
0
|
|
|
|
if (PL_op == (OP*)(&myop)) { |
2919
|
915
|
|
|
|
|
PL_op = PL_ppaddr[OP_ENTEREVAL](aTHX); |
2920
|
915
|
0
|
|
|
|
if (!PL_op) |
2921
|
|
|
|
|
|
goto fail; /* failed in compilation */ |
2922
|
|
|
|
|
|
} |
2923
|
915
|
|
|
|
|
CALLRUNOPS(aTHX); |
2924
|
22
|
|
|
|
|
retval = PL_stack_sp - (PL_stack_base + oldmark); |
2925
|
22
|
0
|
|
|
|
if (!(flags & G_KEEPERR)) { |
2926
|
915
|
0
|
|
|
|
CLEAR_ERRSV(); |
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
2927
|
|
|
|
|
|
} |
2928
|
|
|
|
|
|
break; |
2929
|
|
|
|
|
|
case 1: |
2930
|
915
|
|
|
|
|
STATUS_ALL_FAILURE; |
2931
|
|
|
|
|
|
/* FALL THROUGH */ |
2932
|
|
|
|
|
|
case 2: |
2933
|
|
|
|
|
|
/* my_exit() was called */ |
2934
|
915
|
0
|
|
|
|
SET_CURSTASH(PL_defstash); |
2935
|
915
|
0
|
|
|
|
FREETMPS; |
2936
|
915
|
|
|
|
|
JMPENV_POP; |
2937
|
907
|
|
|
|
|
my_exit_jump(); |
2938
|
|
|
|
|
|
assert(0); /* NOTREACHED */ |
2939
|
|
|
|
|
|
case 3: |
2940
|
915
|
0
|
|
|
|
if (PL_restartop) { |
2941
|
915
|
|
|
|
|
PL_restartjmpenv = NULL; |
2942
|
915
|
|
|
|
|
PL_op = PL_restartop; |
2943
|
12
|
|
|
|
|
PL_restartop = 0; |
2944
|
915
|
|
|
|
|
goto redo_body; |
2945
|
|
|
|
|
|
} |
2946
|
|
|
|
|
|
fail: |
2947
|
44
|
|
|
|
|
PL_stack_sp = PL_stack_base + oldmark; |
2948
|
915
|
0
|
|
|
|
if ((flags & G_WANT) == G_ARRAY) |
2949
|
914
|
|
|
|
|
retval = 0; |
2950
|
|
|
|
|
|
else { |
2951
|
956
|
|
|
|
|
retval = 1; |
2952
|
920
|
|
|
|
|
*++PL_stack_sp = &PL_sv_undef; |
2953
|
|
|
|
|
|
} |
2954
|
|
|
|
|
|
break; |
2955
|
|
|
|
|
|
} |
2956
|
|
|
|
|
|
|
2957
|
914
|
|
|
|
|
JMPENV_POP; |
2958
|
910
|
0
|
|
|
|
if (flags & G_DISCARD) { |
2959
|
912
|
|
|
|
|
PL_stack_sp = PL_stack_base + oldmark; |
2960
|
874
|
|
|
|
|
retval = 0; |
2961
|
874
|
0
|
|
|
|
FREETMPS; |
2962
|
873
|
|
|
|
|
LEAVE; |
2963
|
|
|
|
|
|
} |
2964
|
0
|
|
|
|
|
PL_op = oldop; |
2965
|
0
|
|
|
|
|
return retval; |
2966
|
|
|
|
|
|
} |
2967
|
|
|
|
|
|
|
2968
|
|
|
|
|
|
/* |
2969
|
|
|
|
|
|
=for apidoc p||eval_pv |
2970
|
|
|
|
|
|
|
2971
|
|
|
|
|
|
Tells Perl to C the given string and return an SV* result. |
2972
|
|
|
|
|
|
|
2973
|
|
|
|
|
|
=cut |
2974
|
|
|
|
|
|
*/ |
2975
|
|
|
|
|
|
|
2976
|
|
|
|
|
|
SV* |
2977
|
0
|
|
|
|
|
Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error) |
2978
|
|
|
|
|
|
{ |
2979
|
|
|
|
|
|
dVAR; |
2980
|
0
|
|
|
|
|
SV* sv = newSVpv(p, 0); |
2981
|
|
|
|
|
|
|
2982
|
|
|
|
|
|
PERL_ARGS_ASSERT_EVAL_PV; |
2983
|
|
|
|
|
|
|
2984
|
0
|
|
|
|
|
eval_sv(sv, G_SCALAR); |
2985
|
42
|
|
|
|
|
SvREFCNT_dec(sv); |
2986
|
|
|
|
|
|
|
2987
|
|
|
|
|
|
{ |
2988
|
6
|
|
|
|
|
dSP; |
2989
|
6
|
|
|
|
|
sv = POPs; |
2990
|
6
|
|
|
|
|
PUTBACK; |
2991
|
|
|
|
|
|
} |
2992
|
|
|
|
|
|
|
2993
|
|
|
|
|
|
/* just check empty string or undef? */ |
2994
|
6
|
0
|
|
|
|
if (croak_on_error) { |
2995
|
40
|
0
|
|
|
|
SV * const errsv = ERRSV; |
2996
|
40
|
0
|
|
|
|
if(SvTRUE_NN(errsv)) |
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
2997
|
|
|
|
|
|
/* replace with croak_sv? */ |
2998
|
12
|
0
|
|
|
|
Perl_croak_nocontext("%s", SvPV_nolen_const(errsv)); |
2999
|
|
|
|
|
|
} |
3000
|
|
|
|
|
|
|
3001
|
28
|
|
|
|
|
return sv; |
3002
|
|
|
|
|
|
} |
3003
|
|
|
|
|
|
|
3004
|
|
|
|
|
|
/* Require a module. */ |
3005
|
|
|
|
|
|
|
3006
|
|
|
|
|
|
/* |
3007
|
|
|
|
|
|
=head1 Embedding Functions |
3008
|
|
|
|
|
|
|
3009
|
|
|
|
|
|
=for apidoc p||require_pv |
3010
|
|
|
|
|
|
|
3011
|
|
|
|
|
|
Tells Perl to C the file named by the string argument. It is |
3012
|
|
|
|
|
|
analogous to the Perl code C. It's even |
3013
|
|
|
|
|
|
implemented that way; consider using load_module instead. |
3014
|
|
|
|
|
|
|
3015
|
|
|
|
|
|
=cut */ |
3016
|
|
|
|
|
|
|
3017
|
|
|
|
|
|
void |
3018
|
28
|
|
|
|
|
Perl_require_pv(pTHX_ const char *pv) |
3019
|
|
|
|
|
|
{ |
3020
|
|
|
|
|
|
dVAR; |
3021
|
914
|
|
|
|
|
dSP; |
3022
|
|
|
|
|
|
SV* sv; |
3023
|
|
|
|
|
|
|
3024
|
|
|
|
|
|
PERL_ARGS_ASSERT_REQUIRE_PV; |
3025
|
|
|
|
|
|
|
3026
|
914
|
0
|
|
|
|
PUSHSTACKi(PERLSI_REQUIRE); |
3027
|
22
|
|
|
|
|
PUTBACK; |
3028
|
22
|
|
|
|
|
sv = Perl_newSVpvf(aTHX_ "require q%c%s%c", 0, pv, 0); |
3029
|
22
|
|
|
|
|
eval_sv(sv_2mortal(sv), G_DISCARD); |
3030
|
|
|
|
|
|
SPAGAIN; |
3031
|
22
|
0
|
|
|
|
POPSTACK; |
3032
|
914
|
|
|
|
|
} |
3033
|
|
|
|
|
|
|
3034
|
|
|
|
|
|
STATIC void |
3035
|
914
|
|
|
|
|
S_usage(pTHX) /* XXX move this out into a module ? */ |
3036
|
|
|
|
|
|
{ |
3037
|
|
|
|
|
|
/* This message really ought to be max 23 lines. |
3038
|
|
|
|
|
|
* Removed -h because the user already knows that option. Others? */ |
3039
|
|
|
|
|
|
|
3040
|
|
|
|
|
|
/* Grouped as 6 lines per C string literal, to keep under the ANSI C 89 |
3041
|
|
|
|
|
|
minimum of 509 character string literals. */ |
3042
|
|
|
|
|
|
static const char * const usage_msg[] = { |
3043
|
|
|
|
|
|
" -0[octal] specify record separator (\\0, if no argument)\n" |
3044
|
|
|
|
|
|
" -a autosplit mode with -n or -p (splits $_ into @F)\n" |
3045
|
|
|
|
|
|
" -C[number/list] enables the listed Unicode features\n" |
3046
|
|
|
|
|
|
" -c check syntax only (runs BEGIN and CHECK blocks)\n" |
3047
|
|
|
|
|
|
" -d[:debugger] run program under debugger\n" |
3048
|
|
|
|
|
|
" -D[number/list] set debugging flags (argument is a bit mask or alphabets)\n", |
3049
|
|
|
|
|
|
" -e program one line of program (several -e's allowed, omit programfile)\n" |
3050
|
|
|
|
|
|
" -E program like -e, but enables all optional features\n" |
3051
|
|
|
|
|
|
" -f don't do $sitelib/sitecustomize.pl at startup\n" |
3052
|
|
|
|
|
|
" -F/pattern/ split() pattern for -a switch (//'s are optional)\n" |
3053
|
|
|
|
|
|
" -i[extension] edit <> files in place (makes backup if extension supplied)\n" |
3054
|
|
|
|
|
|
" -Idirectory specify @INC/#include directory (several -I's allowed)\n", |
3055
|
|
|
|
|
|
" -l[octal] enable line ending processing, specifies line terminator\n" |
3056
|
|
|
|
|
|
" -[mM][-]module execute \"use/no module...\" before executing program\n" |
3057
|
|
|
|
|
|
" -n assume \"while (<>) { ... }\" loop around program\n" |
3058
|
|
|
|
|
|
" -p assume loop like -n but print line also, like sed\n" |
3059
|
|
|
|
|
|
" -s enable rudimentary parsing for switches after programfile\n" |
3060
|
|
|
|
|
|
" -S look for programfile using PATH environment variable\n", |
3061
|
|
|
|
|
|
" -t enable tainting warnings\n" |
3062
|
|
|
|
|
|
" -T enable tainting checks\n" |
3063
|
|
|
|
|
|
" -u dump core after parsing program\n" |
3064
|
|
|
|
|
|
" -U allow unsafe operations\n" |
3065
|
|
|
|
|
|
" -v print version, patchlevel and license\n" |
3066
|
|
|
|
|
|
" -V[:variable] print configuration summary (or a single Config.pm variable)\n", |
3067
|
|
|
|
|
|
" -w enable many useful warnings\n" |
3068
|
|
|
|
|
|
" -W enable all warnings\n" |
3069
|
|
|
|
|
|
" -x[directory] ignore text before #!perl line (optionally cd to directory)\n" |
3070
|
|
|
|
|
|
" -X disable all warnings\n" |
3071
|
|
|
|
|
|
" \n" |
3072
|
|
|
|
|
|
"Run 'perldoc perl' for more help with Perl.\n\n", |
3073
|
|
|
|
|
|
NULL |
3074
|
|
|
|
|
|
}; |
3075
|
|
|
|
|
|
const char * const *p = usage_msg; |
3076
|
798
|
|
|
|
|
PerlIO *out = PerlIO_stdout(); |
3077
|
|
|
|
|
|
|
3078
|
798
|
|
|
|
|
PerlIO_printf(out, |
3079
|
|
|
|
|
|
"\nUsage: %s [switches] [--] [programfile] [arguments]\n", |
3080
|
|
|
|
|
|
PL_origargv[0]); |
3081
|
798
|
0
|
|
|
|
while (*p) |
3082
|
798
|
|
|
|
|
PerlIO_puts(out, *p++); |
3083
|
798
|
|
|
|
|
my_exit(0); |
3084
|
|
|
|
|
|
} |
3085
|
|
|
|
|
|
|
3086
|
|
|
|
|
|
/* convert a string of -D options (or digits) into an int. |
3087
|
|
|
|
|
|
* sets *s to point to the char after the options */ |
3088
|
|
|
|
|
|
|
3089
|
|
|
|
|
|
#ifdef DEBUGGING |
3090
|
|
|
|
|
|
int |
3091
|
|
|
|
|
|
Perl_get_debug_opts(pTHX_ const char **s, bool givehelp) |
3092
|
|
|
|
|
|
{ |
3093
|
|
|
|
|
|
static const char * const usage_msgd[] = { |
3094
|
|
|
|
|
|
" Debugging flag values: (see also -d)\n" |
3095
|
|
|
|
|
|
" p Tokenizing and parsing (with v, displays parse stack)\n" |
3096
|
|
|
|
|
|
" s Stack snapshots (with v, displays all stacks)\n" |
3097
|
|
|
|
|
|
" l Context (loop) stack processing\n" |
3098
|
|
|
|
|
|
" t Trace execution\n" |
3099
|
|
|
|
|
|
" o Method and overloading resolution\n", |
3100
|
|
|
|
|
|
" c String/numeric conversions\n" |
3101
|
|
|
|
|
|
" P Print profiling info, source file input state\n" |
3102
|
|
|
|
|
|
" m Memory and SV allocation\n" |
3103
|
|
|
|
|
|
" f Format processing\n" |
3104
|
|
|
|
|
|
" r Regular expression parsing and execution\n" |
3105
|
|
|
|
|
|
" x Syntax tree dump\n", |
3106
|
|
|
|
|
|
" u Tainting checks\n" |
3107
|
|
|
|
|
|
" H Hash dump -- usurps values()\n" |
3108
|
|
|
|
|
|
" X Scratchpad allocation\n" |
3109
|
|
|
|
|
|
" D Cleaning up\n" |
3110
|
|
|
|
|
|
" S Op slab allocation\n" |
3111
|
|
|
|
|
|
" T Tokenising\n" |
3112
|
|
|
|
|
|
" R Include reference counts of dumped variables (eg when using -Ds)\n", |
3113
|
|
|
|
|
|
" J Do not s,t,P-debug (Jump over) opcodes within package DB\n" |
3114
|
|
|
|
|
|
" v Verbose: use in conjunction with other flags\n" |
3115
|
|
|
|
|
|
" C Copy On Write\n" |
3116
|
|
|
|
|
|
" A Consistency checks on internal structures\n" |
3117
|
|
|
|
|
|
" q quiet - currently only suppresses the 'EXECUTING' message\n" |
3118
|
|
|
|
|
|
" M trace smart match resolution\n" |
3119
|
|
|
|
|
|
" B dump suBroutine definitions, including special Blocks like BEGIN\n", |
3120
|
|
|
|
|
|
NULL |
3121
|
|
|
|
|
|
}; |
3122
|
|
|
|
|
|
int i = 0; |
3123
|
|
|
|
|
|
|
3124
|
|
|
|
|
|
PERL_ARGS_ASSERT_GET_DEBUG_OPTS; |
3125
|
|
|
|
|
|
|
3126
|
|
|
|
|
|
if (isALPHA(**s)) { |
3127
|
|
|
|
|
|
/* if adding extra options, remember to update DEBUG_MASK */ |
3128
|
|
|
|
|
|
static const char debopts[] = "psltocPmfrxuUHXDSTRJvCAqMB"; |
3129
|
|
|
|
|
|
|
3130
|
|
|
|
|
|
for (; isWORDCHAR(**s); (*s)++) { |
3131
|
|
|
|
|
|
const char * const d = strchr(debopts,**s); |
3132
|
|
|
|
|
|
if (d) |
3133
|
|
|
|
|
|
i |= 1 << (d - debopts); |
3134
|
|
|
|
|
|
else if (ckWARN_d(WARN_DEBUGGING)) |
3135
|
|
|
|
|
|
Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), |
3136
|
|
|
|
|
|
"invalid option -D%c, use -D'' to see choices\n", **s); |
3137
|
|
|
|
|
|
} |
3138
|
|
|
|
|
|
} |
3139
|
|
|
|
|
|
else if (isDIGIT(**s)) { |
3140
|
|
|
|
|
|
i = atoi(*s); |
3141
|
|
|
|
|
|
for (; isWORDCHAR(**s); (*s)++) ; |
3142
|
|
|
|
|
|
} |
3143
|
|
|
|
|
|
else if (givehelp) { |
3144
|
|
|
|
|
|
const char *const *p = usage_msgd; |
3145
|
|
|
|
|
|
while (*p) PerlIO_puts(PerlIO_stdout(), *p++); |
3146
|
|
|
|
|
|
} |
3147
|
|
|
|
|
|
# ifdef EBCDIC |
3148
|
|
|
|
|
|
if ((i & DEBUG_p_FLAG) && ckWARN_d(WARN_DEBUGGING)) |
3149
|
|
|
|
|
|
Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), |
3150
|
|
|
|
|
|
"-Dp not implemented on this platform\n"); |
3151
|
|
|
|
|
|
# endif |
3152
|
|
|
|
|
|
return i; |
3153
|
|
|
|
|
|
} |
3154
|
|
|
|
|
|
#endif |
3155
|
|
|
|
|
|
|
3156
|
|
|
|
|
|
/* This routine handles any switches that can be given during run */ |
3157
|
|
|
|
|
|
|
3158
|
|
|
|
|
|
const char * |
3159
|
2046
|
|
|
|
|
Perl_moreswitches(pTHX_ const char *s) |
3160
|
|
|
|
|
|
{ |
3161
|
|
|
|
|
|
dVAR; |
3162
|
|
|
|
|
|
UV rschar; |
3163
|
2046
|
|
|
|
|
const char option = *s; /* used to remember option in -m/-M code */ |
3164
|
|
|
|
|
|
|
3165
|
|
|
|
|
|
PERL_ARGS_ASSERT_MORESWITCHES; |
3166
|
|
|
|
|
|
|
3167
|
2046
|
|
|
|
|
switch (*s) { |
3168
|
|
|
|
|
|
case '0': |
3169
|
|
|
|
|
|
{ |
3170
|
5
|
|
|
|
|
I32 flags = 0; |
3171
|
|
|
|
|
|
STRLEN numlen; |
3172
|
|
|
|
|
|
|
3173
|
5
|
|
|
|
|
SvREFCNT_dec(PL_rs); |
3174
|
4
|
0
|
|
|
|
if (s[1] == 'x' && s[2]) { |
|
|
0
|
|
|
|
|
3175
|
794
|
|
|
|
|
const char *e = s+=2; |
3176
|
|
|
|
|
|
U8 *tmps; |
3177
|
|
|
|
|
|
|
3178
|
10
|
0
|
|
|
|
while (*e) |
3179
|
10
|
|
|
|
|
e++; |
3180
|
10
|
|
|
|
|
numlen = e - s; |
3181
|
10
|
|
|
|
|
flags = PERL_SCAN_SILENT_ILLDIGIT; |
3182
|
10
|
|
|
|
|
rschar = (U32)grok_hex(s, &numlen, &flags, NULL); |
3183
|
10
|
0
|
|
|
|
if (s + numlen < e) { |
3184
|
|
|
|
|
|
rschar = 0; /* Grandfather -0xFOO as -0 -xFOO. */ |
3185
|
10
|
|
|
|
|
numlen = 0; |
3186
|
10
|
|
|
|
|
s--; |
3187
|
|
|
|
|
|
} |
3188
|
1
|
|
|
|
|
PL_rs = newSVpvs(""); |
3189
|
1
|
0
|
|
|
|
SvGROW(PL_rs, (STRLEN)(UNISKIP(rschar) + 1)); |
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
3190
|
1
|
|
|
|
|
tmps = (U8*)SvPVX(PL_rs); |
3191
|
7
|
|
|
|
|
uvchr_to_utf8(tmps, rschar); |
3192
|
5
|
0
|
|
|
|
SvCUR_set(PL_rs, UNISKIP(rschar)); |
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
3193
|
1
|
|
|
|
|
SvUTF8_on(PL_rs); |
3194
|
|
|
|
|
|
} |
3195
|
|
|
|
|
|
else { |
3196
|
11205
|
|
|
|
|
numlen = 4; |
3197
|
11205
|
|
|
|
|
rschar = (U32)grok_oct(s, &numlen, &flags, NULL); |
3198
|
11205
|
0
|
|
|
|
if (rschar & ~((U8)~0)) |
3199
|
9
|
|
|
|
|
PL_rs = &PL_sv_undef; |
3200
|
9
|
0
|
|
|
|
else if (!rschar && numlen >= 2) |
|
|
0
|
|
|
|
|
3201
|
9
|
|
|
|
|
PL_rs = newSVpvs(""); |
3202
|
|
|
|
|
|
else { |
3203
|
0
|
|
|
|
|
char ch = (char)rschar; |
3204
|
0
|
|
|
|
|
PL_rs = newSVpvn(&ch, 1); |
3205
|
|
|
|
|
|
} |
3206
|
|
|
|
|
|
} |
3207
|
0
|
|
|
|
|
sv_setsv(get_sv("/", GV_ADD), PL_rs); |
3208
|
0
|
|
|
|
|
return s + numlen; |
3209
|
|
|
|
|
|
} |
3210
|
|
|
|
|
|
case 'C': |
3211
|
0
|
|
|
|
|
s++; |
3212
|
0
|
|
|
|
|
PL_unicode = parse_unicode_opts( (const char **)&s ); |
3213
|
0
|
0
|
|
|
|
if (PL_unicode & PERL_UNICODE_UTF8CACHEASSERT_FLAG) |
3214
|
0
|
|
|
|
|
PL_utf8cache = -1; |
3215
|
0
|
|
|
|
|
return s; |
3216
|
|
|
|
|
|
case 'F': |
3217
|
0
|
|
|
|
|
PL_minus_a = TRUE; |
3218
|
0
|
|
|
|
|
PL_minus_F = TRUE; |
3219
|
0
|
|
|
|
|
PL_minus_n = TRUE; |
3220
|
0
|
|
|
|
|
PL_splitstr = ++s; |
3221
|
0
|
0
|
|
|
|
while (*s && !isSPACE(*s)) ++s; |
|
|
0
|
|
|
|
|
3222
|
0
|
|
|
|
|
PL_splitstr = savepvn(PL_splitstr, s - PL_splitstr); |
3223
|
9
|
|
|
|
|
return s; |
3224
|
|
|
|
|
|
case 'a': |
3225
|
9
|
|
|
|
|
PL_minus_a = TRUE; |
3226
|
9
|
|
|
|
|
PL_minus_n = TRUE; |
3227
|
1
|
|
|
|
|
s++; |
3228
|
8
|
|
|
|
|
return s; |
3229
|
|
|
|
|
|
case 'c': |
3230
|
1
|
|
|
|
|
PL_minus_c = TRUE; |
3231
|
7
|
|
|
|
|
s++; |
3232
|
7
|
|
|
|
|
return s; |
3233
|
|
|
|
|
|
case 'd': |
3234
|
9
|
|
|
|
|
forbid_setid('d', FALSE); |
3235
|
9
|
|
|
|
|
s++; |
3236
|
|
|
|
|
|
|
3237
|
|
|
|
|
|
/* -dt indicates to the debugger that threads will be used */ |
3238
|
18
|
0
|
|
|
|
if (*s == 't' && !isWORDCHAR(s[1])) { |
|
|
0
|
|
|
|
|
3239
|
18
|
|
|
|
|
++s; |
3240
|
18
|
|
|
|
|
my_setenv("PERL5DB_THREADED", "1"); |
3241
|
|
|
|
|
|
} |
3242
|
|
|
|
|
|
|
3243
|
|
|
|
|
|
/* The following permits -d:Mod to accepts arguments following an = |
3244
|
|
|
|
|
|
in the fashion that -MSome::Mod does. */ |
3245
|
0
|
0
|
|
|
|
if (*s == ':' || *s == '=') { |
3246
|
|
|
|
|
|
const char *start; |
3247
|
|
|
|
|
|
const char *end; |
3248
|
|
|
|
|
|
SV *sv; |
3249
|
|
|
|
|
|
|
3250
|
18
|
0
|
|
|
|
if (*++s == '-') { |
3251
|
4
|
|
|
|
|
++s; |
3252
|
4
|
|
|
|
|
sv = newSVpvs("no Devel::"); |
3253
|
|
|
|
|
|
} else { |
3254
|
4
|
|
|
|
|
sv = newSVpvs("use Devel::"); |
3255
|
|
|
|
|
|
} |
3256
|
|
|
|
|
|
|
3257
|
4
|
|
|
|
|
start = s; |
3258
|
4
|
|
|
|
|
end = s + strlen(s); |
3259
|
|
|
|
|
|
|
3260
|
|
|
|
|
|
/* We now allow -d:Module=Foo,Bar and -d:-Module */ |
3261
|
4
|
0
|
|
|
|
while(isWORDCHAR(*s) || *s==':') ++s; |
|
|
0
|
|
|
|
|
3262
|
4
|
0
|
|
|
|
if (*s != '=') |
3263
|
7
|
|
|
|
|
sv_catpvn(sv, start, end - start); |
3264
|
|
|
|
|
|
else { |
3265
|
7
|
|
|
|
|
sv_catpvn(sv, start, s-start); |
3266
|
|
|
|
|
|
/* Don't use NUL as q// delimiter here, this string goes in the |
3267
|
|
|
|
|
|
* environment. */ |
3268
|
7
|
|
|
|
|
Perl_sv_catpvf(aTHX_ sv, " split(/,/,q{%s});", ++s); |
3269
|
|
|
|
|
|
} |
3270
|
7
|
|
|
|
|
s = end; |
3271
|
29
|
0
|
|
|
|
my_setenv("PERL5DB", SvPV_nolen_const(sv)); |
3272
|
29
|
|
|
|
|
SvREFCNT_dec(sv); |
3273
|
|
|
|
|
|
} |
3274
|
29
|
0
|
|
|
|
if (!PL_perldb) { |
3275
|
108
|
|
|
|
|
PL_perldb = PERLDB_ALL; |
3276
|
108
|
|
|
|
|
init_debugger(); |
3277
|
|
|
|
|
|
} |
3278
|
108
|
|
|
|
|
return s; |
3279
|
|
|
|
|
|
case 'D': |
3280
|
|
|
|
|
|
{ |
3281
|
|
|
|
|
|
#ifdef DEBUGGING |
3282
|
|
|
|
|
|
forbid_setid('D', FALSE); |
3283
|
|
|
|
|
|
s++; |
3284
|
|
|
|
|
|
PL_debug = get_debug_opts( (const char **)&s, 1) | DEBUG_TOP_FLAG; |
3285
|
|
|
|
|
|
#else /* !DEBUGGING */ |
3286
|
1
|
0
|
|
|
|
if (ckWARN_d(WARN_DEBUGGING)) |
3287
|
1
|
|
|
|
|
Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), |
3288
|
|
|
|
|
|
"Recompile perl with -DDEBUGGING to use -D switch (did you mean -d ?)\n"); |
3289
|
108
|
0
|
|
|
|
for (s++; isWORDCHAR(*s); s++) ; |
3290
|
|
|
|
|
|
#endif |
3291
|
10
|
|
|
|
|
return s; |
3292
|
|
|
|
|
|
} |
3293
|
|
|
|
|
|
case 'h': |
3294
|
1
|
|
|
|
|
usage(); |
3295
|
|
|
|
|
|
case 'i': |
3296
|
1
|
|
|
|
|
Safefree(PL_inplace); |
3297
|
|
|
|
|
|
#if defined(__CYGWIN__) /* do backup extension automagically */ |
3298
|
|
|
|
|
|
if (*(s+1) == '\0') { |
3299
|
|
|
|
|
|
PL_inplace = savepvs(".bak"); |
3300
|
|
|
|
|
|
return s+1; |
3301
|
|
|
|
|
|
} |
3302
|
|
|
|
|
|
#endif /* __CYGWIN__ */ |
3303
|
|
|
|
|
|
{ |
3304
|
9
|
|
|
|
|
const char * const start = ++s; |
3305
|
10
|
0
|
|
|
|
while (*s && !isSPACE(*s)) |
|
|
0
|
|
|
|
|
3306
|
10
|
|
|
|
|
++s; |
3307
|
|
|
|
|
|
|
3308
|
10
|
|
|
|
|
PL_inplace = savepvn(start, s - start); |
3309
|
|
|
|
|
|
} |
3310
|
10
|
0
|
|
|
|
if (*s) { |
3311
|
8
|
|
|
|
|
++s; |
3312
|
2
|
0
|
|
|
|
if (*s == '-') /* Additional switches on #! line. */ |
3313
|
2
|
|
|
|
|
s++; |
3314
|
|
|
|
|
|
} |
3315
|
10
|
|
|
|
|
return s; |
3316
|
|
|
|
|
|
case 'I': /* -I handled both here and in parse_body() */ |
3317
|
10
|
|
|
|
|
forbid_setid('I', FALSE); |
3318
|
10
|
|
|
|
|
++s; |
3319
|
108
|
0
|
|
|
|
while (*s && isSPACE(*s)) |
|
|
0
|
|
|
|
|
3320
|
107
|
|
|
|
|
++s; |
3321
|
107
|
0
|
|
|
|
if (*s) { |
3322
|
|
|
|
|
|
const char *e, *p; |
3323
|
108
|
|
|
|
|
p = s; |
3324
|
|
|
|
|
|
/* ignore trailing spaces (possibly followed by other switches) */ |
3325
|
|
|
|
|
|
do { |
3326
|
2
|
0
|
|
|
|
for (e = p; *e && !isSPACE(*e); e++) ; |
|
|
0
|
|
|
|
|
3327
|
|
|
|
|
|
p = e; |
3328
|
2
|
0
|
|
|
|
while (isSPACE(*p)) |
3329
|
2
|
|
|
|
|
p++; |
3330
|
2
|
0
|
|
|
|
} while (*p && *p != '-'); |
3331
|
1
|
|
|
|
|
incpush(s, e-s, |
3332
|
|
|
|
|
|
INCPUSH_ADD_SUB_DIRS|INCPUSH_ADD_OLD_VERS|INCPUSH_UNSHIFT); |
3333
|
4
|
|
|
|
|
s = p; |
3334
|
4
|
0
|
|
|
|
if (*s == '-') |
3335
|
22
|
|
|
|
|
s++; |
3336
|
|
|
|
|
|
} |
3337
|
|
|
|
|
|
else |
3338
|
14
|
|
|
|
|
Perl_croak(aTHX_ "No directory specified for -I"); |
3339
|
4
|
|
|
|
|
return s; |
3340
|
|
|
|
|
|
case 'l': |
3341
|
154
|
|
|
|
|
PL_minus_l = TRUE; |
3342
|
151
|
|
|
|
|
s++; |
3343
|
151
|
50
|
|
|
|
if (PL_ors_sv) { |
3344
|
0
|
|
|
|
|
SvREFCNT_dec(PL_ors_sv); |
3345
|
4
|
|
|
|
|
PL_ors_sv = NULL; |
3346
|
|
|
|
|
|
} |
3347
|
165
|
50
|
|
|
|
if (isDIGIT(*s)) { |
3348
|
15
|
|
|
|
|
I32 flags = 0; |
3349
|
|
|
|
|
|
STRLEN numlen; |
3350
|
30
|
|
|
|
|
PL_ors_sv = newSVpvs("\n"); |
3351
|
0
|
0
|
|
|
|
numlen = 3 + (*s == '0'); |
3352
|
15
|
|
|
|
|
*SvPVX(PL_ors_sv) = (char)grok_oct(s, &numlen, &flags, NULL); |
3353
|
15
|
|
|
|
|
s += numlen; |
3354
|
|
|
|
|
|
} |
3355
|
|
|
|
|
|
else { |
3356
|
165
|
50
|
|
|
|
if (RsPARA(PL_rs)) { |
|
|
50
|
|
|
|
|
3357
|
28
|
|
|
|
|
PL_ors_sv = newSVpvs("\n\n"); |
3358
|
|
|
|
|
|
} |
3359
|
|
|
|
|
|
else { |
3360
|
163
|
|
|
|
|
PL_ors_sv = newSVsv(PL_rs); |
3361
|
|
|
|
|
|
} |
3362
|
|
|
|
|
|
} |
3363
|
165
|
|
|
|
|
return s; |
3364
|
|
|
|
|
|
case 'M': |
3365
|
1088
|
|
|
|
|
forbid_setid('M', FALSE); /* XXX ? */ |
3366
|
|
|
|
|
|
/* FALL THROUGH */ |
3367
|
|
|
|
|
|
case 'm': |
3368
|
1088
|
|
|
|
|
forbid_setid('m', FALSE); /* XXX ? */ |
3369
|
1088
|
50
|
|
|
|
if (*++s) { |
3370
|
|
|
|
|
|
const char *start; |
3371
|
|
|
|
|
|
const char *end; |
3372
|
|
|
|
|
|
SV *sv; |
3373
|
|
|
|
|
|
const char *use = "use "; |
3374
|
|
|
|
|
|
bool colon = FALSE; |
3375
|
|
|
|
|
|
/* -M-foo == 'no foo' */ |
3376
|
|
|
|
|
|
/* Leading space on " no " is deliberate, to make both |
3377
|
|
|
|
|
|
possibilities the same length. */ |
3378
|
1075
|
50
|
|
|
|
if (*s == '-') { use = " no "; ++s; } |
3379
|
1073
|
|
|
|
|
sv = newSVpvn(use,4); |
3380
|
1088
|
|
|
|
|
start = s; |
3381
|
|
|
|
|
|
/* We allow -M'Module qw(Foo Bar)' */ |
3382
|
18858
|
100
|
|
|
|
while(isWORDCHAR(*s) || *s==':') { |
|
|
100
|
|
|
|
|
3383
|
17785
|
100
|
|
|
|
if( *s++ == ':' ) { |
3384
|
1530
|
50
|
|
|
|
if( *s == ':' ) |
3385
|
17327
|
|
|
|
|
s++; |
3386
|
|
|
|
|
|
else |
3387
|
|
|
|
|
|
colon = TRUE; |
3388
|
|
|
|
|
|
} |
3389
|
|
|
|
|
|
} |
3390
|
1073
|
50
|
|
|
|
if (s == start) |
3391
|
458
|
|
|
|
|
Perl_croak(aTHX_ "Module name required with -%c option", |
3392
|
|
|
|
|
|
option); |
3393
|
1074
|
50
|
|
|
|
if (colon) |
3394
|
1
|
|
|
|
|
Perl_croak(aTHX_ "Invalid module name %.*s with -%c option: " |
3395
|
|
|
|
|
|
"contains single ':'", |
3396
|
1
|
|
|
|
|
(int)(s - start), start, option); |
3397
|
1074
|
|
|
|
|
end = s + strlen(s); |
3398
|
1074
|
50
|
|
|
|
if (*s != '=') { |
3399
|
1530
|
|
|
|
|
sv_catpvn(sv, start, end - start); |
3400
|
1073
|
50
|
|
|
|
if (option == 'm') { |
3401
|
457
|
0
|
|
|
|
if (*s != '\0') |
3402
|
458
|
|
|
|
|
Perl_croak(aTHX_ "Can't use '%c' after -mname", *s); |
3403
|
7741
|
|
|
|
|
sv_catpvs( sv, " ()"); |
3404
|
|
|
|
|
|
} |
3405
|
|
|
|
|
|
} else { |
3406
|
7746
|
|
|
|
|
sv_catpvn(sv, start, s-start); |
3407
|
|
|
|
|
|
/* Use NUL as q''-delimiter. */ |
3408
|
7746
|
|
|
|
|
sv_catpvs(sv, " split(/,/,q\0"); |
3409
|
7746
|
|
|
|
|
++s; |
3410
|
7746
|
|
|
|
|
sv_catpvn(sv, s, end - s); |
3411
|
7746
|
|
|
|
|
sv_catpvs(sv, "\0)"); |
3412
|
|
|
|
|
|
} |
3413
|
94227
|
|
|
|
|
s = end; |
3414
|
78735
|
|
|
|
|
Perl_av_create_and_push(aTHX_ &PL_preambleav, sv); |
3415
|
|
|
|
|
|
} |
3416
|
|
|
|
|
|
else |
3417
|
5065
|
|
|
|
|
Perl_croak(aTHX_ "Missing argument to -%c", option); |
3418
|
6133
|
|
|
|
|
return s; |
3419
|
|
|
|
|
|
case 'n': |
3420
|
7746
|
|
|
|
|
PL_minus_n = TRUE; |
3421
|
2
|
|
|
|
|
s++; |
3422
|
7744
|
|
|
|
|
return s; |
3423
|
|
|
|
|
|
case 'p': |
3424
|
6
|
|
|
|
|
PL_minus_p = TRUE; |
3425
|
3
|
|
|
|
|
s++; |
3426
|
7741
|
|
|
|
|
return s; |
3427
|
|
|
|
|
|
case 's': |
3428
|
7741
|
|
|
|
|
forbid_setid('s', FALSE); |
3429
|
3095
|
|
|
|
|
PL_doswitches = TRUE; |
3430
|
3095
|
|
|
|
|
s++; |
3431
|
1
|
|
|
|
|
return s; |
3432
|
|
|
|
|
|
case 't': |
3433
|
|
|
|
|
|
case 'T': |
3434
|
|
|
|
|
|
#if SILENT_NO_TAINT_SUPPORT |
3435
|
|
|
|
|
|
/* silently ignore */ |
3436
|
|
|
|
|
|
#elif NO_TAINT_SUPPORT |
3437
|
|
|
|
|
|
Perl_croak_nocontext("This perl was compiled without taint support. " |
3438
|
|
|
|
|
|
"Cowardly refusing to run with -t or -T flags"); |
3439
|
|
|
|
|
|
#else |
3440
|
0
|
0
|
|
|
|
if (!TAINTING_get) |
3441
|
1
|
|
|
|
|
TOO_LATE_FOR(*s); |
3442
|
|
|
|
|
|
#endif |
3443
|
4646
|
|
|
|
|
s++; |
3444
|
4646
|
|
|
|
|
return s; |
3445
|
|
|
|
|
|
case 'u': |
3446
|
4646
|
|
|
|
|
PL_do_undump = TRUE; |
3447
|
4646
|
|
|
|
|
s++; |
3448
|
4646
|
|
|
|
|
return s; |
3449
|
|
|
|
|
|
case 'U': |
3450
|
7741
|
|
|
|
|
PL_unsafe = TRUE; |
3451
|
7741
|
|
|
|
|
s++; |
3452
|
0
|
|
|
|
|
return s; |
3453
|
|
|
|
|
|
case 'v': |
3454
|
7741
|
|
|
|
|
minus_v(); |
3455
|
|
|
|
|
|
case 'w': |
3456
|
56
|
50
|
|
|
|
if (! (PL_dowarn & G_WARN_ALL_MASK)) { |
3457
|
56
|
|
|
|
|
PL_dowarn |= G_WARN_ON; |
3458
|
|
|
|
|
|
} |
3459
|
56
|
|
|
|
|
s++; |
3460
|
26
|
|
|
|
|
return s; |
3461
|
|
|
|
|
|
case 'W': |
3462
|
13
|
|
|
|
|
PL_dowarn = G_WARN_ALL_ON|G_WARN_ON; |
3463
|
13
|
0
|
|
|
|
if (!specialWARN(PL_compiling.cop_warnings)) |
|
|
0
|
|
|
|
|
3464
|
4
|
|
|
|
|
PerlMemShared_free(PL_compiling.cop_warnings); |
3465
|
4
|
|
|
|
|
PL_compiling.cop_warnings = pWARN_ALL ; |
3466
|
4
|
|
|
|
|
s++; |
3467
|
4
|
|
|
|
|
return s; |
3468
|
|
|
|
|
|
case 'X': |
3469
|
18
|
|
|
|
|
PL_dowarn = G_WARN_ALL_OFF; |
3470
|
0
|
0
|
|
|
|
if (!specialWARN(PL_compiling.cop_warnings)) |
|
|
0
|
|
|
|
|
3471
|
18
|
|
|
|
|
PerlMemShared_free(PL_compiling.cop_warnings); |
3472
|
18
|
|
|
|
|
PL_compiling.cop_warnings = pWARN_NONE ; |
3473
|
0
|
|
|
|
|
s++; |
3474
|
0
|
|
|
|
|
return s; |
3475
|
|
|
|
|
|
case '*': |
3476
|
|
|
|
|
|
case ' ': |
3477
|
0
|
0
|
|
|
|
while( *s == ' ' ) |
3478
|
1
|
|
|
|
|
++s; |
3479
|
1
|
0
|
|
|
|
if (s[0] == '-') /* Additional switches on #! line. */ |
3480
|
1
|
|
|
|
|
return s+1; |
3481
|
|
|
|
|
|
break; |
3482
|
|
|
|
|
|
case '-': |
3483
|
|
|
|
|
|
case 0: |
3484
|
|
|
|
|
|
#if defined(WIN32) || !defined(PERL_STRICT_CR) |
3485
|
|
|
|
|
|
case '\r': |
3486
|
|
|
|
|
|
#endif |
3487
|
|
|
|
|
|
case '\n': |
3488
|
|
|
|
|
|
case '\t': |
3489
|
|
|
|
|
|
break; |
3490
|
|
|
|
|
|
#ifdef ALTERNATE_SHEBANG |
3491
|
|
|
|
|
|
case 'S': /* OS/2 needs -S on "extproc" line. */ |
3492
|
|
|
|
|
|
break; |
3493
|
|
|
|
|
|
#endif |
3494
|
|
|
|
|
|
case 'e': case 'f': case 'x': case 'E': |
3495
|
|
|
|
|
|
#ifndef ALTERNATE_SHEBANG |
3496
|
|
|
|
|
|
case 'S': |
3497
|
|
|
|
|
|
#endif |
3498
|
|
|
|
|
|
case 'V': |
3499
|
17
|
|
|
|
|
Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s); |
3500
|
|
|
|
|
|
default: |
3501
|
2954
|
|
|
|
|
Perl_croak(aTHX_ |
3502
|
|
|
|
|
|
"Unrecognized switch: -%.1s (-h will show valid options)",s |
3503
|
|
|
|
|
|
); |
3504
|
|
|
|
|
|
} |
3505
|
|
|
|
|
|
return NULL; |
3506
|
|
|
|
|
|
} |
3507
|
|
|
|
|
|
|
3508
|
|
|
|
|
|
|
3509
|
|
|
|
|
|
STATIC void |
3510
|
1704
|
|
|
|
|
S_minus_v(pTHX) |
3511
|
|
|
|
|
|
{ |
3512
|
|
|
|
|
|
PerlIO * PIO_stdout; |
3513
|
1706
|
0
|
|
|
|
if (!sv_derived_from(PL_patchlevel, "version")) |
3514
|
1706
|
|
|
|
|
upg_version(PL_patchlevel, TRUE); |
3515
|
|
|
|
|
|
{ |
3516
|
24
|
|
|
|
|
SV* level= vstringify(PL_patchlevel); |
3517
|
|
|
|
|
|
#ifdef PERL_PATCHNUM |
3518
|
|
|
|
|
|
# ifdef PERL_GIT_UNCOMMITTED_CHANGES |
3519
|
|
|
|
|
|
SV *num = newSVpvs(PERL_PATCHNUM "*"); |
3520
|
|
|
|
|
|
# else |
3521
|
24
|
|
|
|
|
SV *num = newSVpvs(PERL_PATCHNUM); |
3522
|
|
|
|
|
|
# endif |
3523
|
|
|
|
|
|
{ |
3524
|
|
|
|
|
|
STRLEN level_len, num_len; |
3525
|
|
|
|
|
|
char * level_str, * num_str; |
3526
|
0
|
0
|
|
|
|
num_str = SvPV(num, num_len); |
3527
|
24
|
0
|
|
|
|
level_str = SvPV(level, level_len); |
3528
|
24
|
0
|
|
|
|
if (num_len>=level_len && strnEQ(num_str,level_str,level_len)) { |
|
|
0
|
|
|
|
|
3529
|
24
|
|
|
|
|
SvREFCNT_dec(level); |
3530
|
59
|
|
|
|
|
level= num; |
3531
|
|
|
|
|
|
} else { |
3532
|
59
|
|
|
|
|
Perl_sv_catpvf(aTHX_ level, " (%"SVf")", num); |
3533
|
0
|
|
|
|
|
SvREFCNT_dec(num); |
3534
|
|
|
|
|
|
} |
3535
|
|
|
|
|
|
} |
3536
|
|
|
|
|
|
#endif |
3537
|
59
|
|
|
|
|
PIO_stdout = PerlIO_stdout(); |
3538
|
59
|
|
|
|
|
PerlIO_printf(PIO_stdout, |
3539
|
|
|
|
|
|
"\nThis is perl " STRINGIFY(PERL_REVISION) |
3540
|
|
|
|
|
|
", version " STRINGIFY(PERL_VERSION) |
3541
|
|
|
|
|
|
", subversion " STRINGIFY(PERL_SUBVERSION) |
3542
|
|
|
|
|
|
" (%"SVf") built for " ARCHNAME, level |
3543
|
|
|
|
|
|
); |
3544
|
59
|
|
|
|
|
SvREFCNT_dec(level); |
3545
|
|
|
|
|
|
} |
3546
|
|
|
|
|
|
#if defined(LOCAL_PATCH_COUNT) |
3547
|
|
|
|
|
|
if (LOCAL_PATCH_COUNT > 0) |
3548
|
|
|
|
|
|
PerlIO_printf(PIO_stdout, |
3549
|
|
|
|
|
|
"\n(with %d registered patch%s, " |
3550
|
|
|
|
|
|
"see perl -V for more detail)", |
3551
|
|
|
|
|
|
LOCAL_PATCH_COUNT, |
3552
|
|
|
|
|
|
(LOCAL_PATCH_COUNT!=1) ? "es" : ""); |
3553
|
|
|
|
|
|
#endif |
3554
|
|
|
|
|
|
|
3555
|
777
|
|
|
|
|
PerlIO_printf(PIO_stdout, |
3556
|
|
|
|
|
|
"\n\nCopyright 1987-2013, Larry Wall\n"); |
3557
|
|
|
|
|
|
#ifdef MSDOS |
3558
|
|
|
|
|
|
PerlIO_printf(PIO_stdout, |
3559
|
|
|
|
|
|
"\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n"); |
3560
|
|
|
|
|
|
#endif |
3561
|
|
|
|
|
|
#ifdef DJGPP |
3562
|
|
|
|
|
|
PerlIO_printf(PIO_stdout, |
3563
|
|
|
|
|
|
"djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n" |
3564
|
|
|
|
|
|
"djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n"); |
3565
|
|
|
|
|
|
#endif |
3566
|
|
|
|
|
|
#ifdef OS2 |
3567
|
|
|
|
|
|
PerlIO_printf(PIO_stdout, |
3568
|
|
|
|
|
|
"\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n" |
3569
|
|
|
|
|
|
"Version 5 port Copyright (c) 1994-2002, Andreas Kaiser, Ilya Zakharevich\n"); |
3570
|
|
|
|
|
|
#endif |
3571
|
|
|
|
|
|
#ifdef OEMVS |
3572
|
|
|
|
|
|
PerlIO_printf(PIO_stdout, |
3573
|
|
|
|
|
|
"MVS (OS390) port by Mortice Kern Systems, 1997-1999\n"); |
3574
|
|
|
|
|
|
#endif |
3575
|
|
|
|
|
|
#ifdef __VOS__ |
3576
|
|
|
|
|
|
PerlIO_printf(PIO_stdout, |
3577
|
|
|
|
|
|
"Stratus OpenVOS port by Paul.Green@stratus.com, 1997-2013\n"); |
3578
|
|
|
|
|
|
#endif |
3579
|
|
|
|
|
|
#ifdef POSIX_BC |
3580
|
|
|
|
|
|
PerlIO_printf(PIO_stdout, |
3581
|
|
|
|
|
|
"BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n"); |
3582
|
|
|
|
|
|
#endif |
3583
|
|
|
|
|
|
#ifdef UNDER_CE |
3584
|
|
|
|
|
|
PerlIO_printf(PIO_stdout, |
3585
|
|
|
|
|
|
"WINCE port by Rainer Keuchel, 2001-2002\n" |
3586
|
|
|
|
|
|
"Built on " __DATE__ " " __TIME__ "\n\n"); |
3587
|
|
|
|
|
|
wce_hitreturn(); |
3588
|
|
|
|
|
|
#endif |
3589
|
|
|
|
|
|
#ifdef __SYMBIAN32__ |
3590
|
|
|
|
|
|
PerlIO_printf(PIO_stdout, |
3591
|
|
|
|
|
|
"Symbian port by Nokia, 2004-2005\n"); |
3592
|
|
|
|
|
|
#endif |
3593
|
|
|
|
|
|
#ifdef BINARY_BUILD_NOTICE |
3594
|
|
|
|
|
|
BINARY_BUILD_NOTICE; |
3595
|
|
|
|
|
|
#endif |
3596
|
750
|
|
|
|
|
PerlIO_printf(PIO_stdout, |
3597
|
|
|
|
|
|
"\n\ |
3598
|
|
|
|
|
|
Perl may be copied only under the terms of either the Artistic License or the\n\ |
3599
|
|
|
|
|
|
GNU General Public License, which may be found in the Perl 5 source kit.\n\n\ |
3600
|
|
|
|
|
|
Complete documentation for Perl, including FAQ lists, should be found on\n\ |
3601
|
|
|
|
|
|
this system using \"man perl\" or \"perldoc perl\". If you have access to the\n\ |
3602
|
|
|
|
|
|
Internet, point your browser at http://www.perl.org/, the Perl Home Page.\n\n"); |
3603
|
27
|
|
|
|
|
my_exit(0); |
3604
|
|
|
|
|
|
} |
3605
|
|
|
|
|
|
|
3606
|
|
|
|
|
|
/* compliments of Tom Christiansen */ |
3607
|
|
|
|
|
|
|
3608
|
|
|
|
|
|
/* unexec() can be found in the Gnu emacs distribution */ |
3609
|
|
|
|
|
|
/* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */ |
3610
|
|
|
|
|
|
|
3611
|
|
|
|
|
|
#ifdef VMS |
3612
|
|
|
|
|
|
#include |
3613
|
|
|
|
|
|
#endif |
3614
|
|
|
|
|
|
|
3615
|
|
|
|
|
|
void |
3616
|
5
|
|
|
|
|
Perl_my_unexec(pTHX) |
3617
|
|
|
|
|
|
{ |
3618
|
|
|
|
|
|
PERL_UNUSED_CONTEXT; |
3619
|
|
|
|
|
|
#ifdef UNEXEC |
3620
|
|
|
|
|
|
SV * prog = newSVpv(BIN_EXP, 0); |
3621
|
|
|
|
|
|
SV * file = newSVpv(PL_origfilename, 0); |
3622
|
|
|
|
|
|
int status = 1; |
3623
|
|
|
|
|
|
extern int etext; |
3624
|
|
|
|
|
|
|
3625
|
|
|
|
|
|
sv_catpvs(prog, "/perl"); |
3626
|
|
|
|
|
|
sv_catpvs(file, ".perldump"); |
3627
|
|
|
|
|
|
|
3628
|
|
|
|
|
|
unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0); |
3629
|
|
|
|
|
|
/* unexec prints msg to stderr in case of failure */ |
3630
|
|
|
|
|
|
PerlProc_exit(status); |
3631
|
|
|
|
|
|
#else |
3632
|
|
|
|
|
|
# ifdef VMS |
3633
|
|
|
|
|
|
lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */ |
3634
|
|
|
|
|
|
# elif defined(WIN32) || defined(__CYGWIN__) |
3635
|
|
|
|
|
|
Perl_croak(aTHX_ "dump is not supported"); |
3636
|
|
|
|
|
|
# else |
3637
|
6
|
|
|
|
|
ABORT(); /* for use with undump */ |
3638
|
|
|
|
|
|
# endif |
3639
|
|
|
|
|
|
#endif |
3640
|
33
|
|
|
|
|
} |
3641
|
|
|
|
|
|
|
3642
|
|
|
|
|
|
/* initialize curinterp */ |
3643
|
|
|
|
|
|
STATIC void |
3644
|
17
|
|
|
|
|
S_init_interp(pTHX) |
3645
|
|
|
|
|
|
{ |
3646
|
|
|
|
|
|
dVAR; |
3647
|
|
|
|
|
|
#ifdef MULTIPLICITY |
3648
|
|
|
|
|
|
# define PERLVAR(prefix,var,type) |
3649
|
|
|
|
|
|
# define PERLVARA(prefix,var,n,type) |
3650
|
|
|
|
|
|
# if defined(PERL_IMPLICIT_CONTEXT) |
3651
|
|
|
|
|
|
# define PERLVARI(prefix,var,type,init) aTHX->prefix##var = init; |
3652
|
|
|
|
|
|
# define PERLVARIC(prefix,var,type,init) aTHX->prefix##var = init; |
3653
|
|
|
|
|
|
# else |
3654
|
|
|
|
|
|
# define PERLVARI(prefix,var,type,init) PERL_GET_INTERP->var = init; |
3655
|
|
|
|
|
|
# define PERLVARIC(prefix,var,type,init) PERL_GET_INTERP->var = init; |
3656
|
|
|
|
|
|
# endif |
3657
|
|
|
|
|
|
# include "intrpvar.h" |
3658
|
|
|
|
|
|
# undef PERLVAR |
3659
|
|
|
|
|
|
# undef PERLVARA |
3660
|
|
|
|
|
|
# undef PERLVARI |
3661
|
|
|
|
|
|
# undef PERLVARIC |
3662
|
|
|
|
|
|
#else |
3663
|
|
|
|
|
|
# define PERLVAR(prefix,var,type) |
3664
|
|
|
|
|
|
# define PERLVARA(prefix,var,n,type) |
3665
|
|
|
|
|
|
# define PERLVARI(prefix,var,type,init) PL_##var = init; |
3666
|
|
|
|
|
|
# define PERLVARIC(prefix,var,type,init) PL_##var = init; |
3667
|
|
|
|
|
|
# include "intrpvar.h" |
3668
|
|
|
|
|
|
# undef PERLVAR |
3669
|
|
|
|
|
|
# undef PERLVARA |
3670
|
|
|
|
|
|
# undef PERLVARI |
3671
|
|
|
|
|
|
# undef PERLVARIC |
3672
|
|
|
|
|
|
#endif |
3673
|
|
|
|
|
|
|
3674
|
17
|
|
|
|
|
} |
3675
|
|
|
|
|
|
|
3676
|
|
|
|
|
|
STATIC void |
3677
|
2034
|
|
|
|
|
S_init_main_stash(pTHX) |
3678
|
|
|
|
|
|
{ |
3679
|
|
|
|
|
|
dVAR; |
3680
|
|
|
|
|
|
GV *gv; |
3681
|
|
|
|
|
|
|
3682
|
2034
|
|
|
|
|
PL_curstash = PL_defstash = (HV *)SvREFCNT_inc_simple_NN(newHV()); |
3683
|
|
|
|
|
|
/* We know that the string "main" will be in the global shared string |
3684
|
|
|
|
|
|
table, so it's a small saving to use it rather than allocate another |
3685
|
|
|
|
|
|
8 bytes. */ |
3686
|
2034
|
|
|
|
|
PL_curstname = newSVpvs_share("main"); |
3687
|
2034
|
|
|
|
|
gv = gv_fetchpvs("main::", GV_ADD|GV_NOTQUAL, SVt_PVHV); |
3688
|
|
|
|
|
|
/* If we hadn't caused another reference to "main" to be in the shared |
3689
|
|
|
|
|
|
string table above, then it would be worth reordering these two, |
3690
|
|
|
|
|
|
because otherwise all we do is delete "main" from it as a consequence |
3691
|
|
|
|
|
|
of the SvREFCNT_dec, only to add it again with hv_name_set */ |
3692
|
2034
|
|
|
|
|
SvREFCNT_dec(GvHV(gv)); |
3693
|
2034
|
|
|
|
|
hv_name_set(PL_defstash, "main", 4, 0); |
3694
|
4034
|
|
|
|
|
GvHV(gv) = MUTABLE_HV(SvREFCNT_inc_simple(PL_defstash)); |
3695
|
2017
|
|
|
|
|
SvREADONLY_on(gv); |
3696
|
2034
|
|
|
|
|
PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpvs("INC", GV_ADD|GV_NOTQUAL, |
3697
|
|
|
|
|
|
SVt_PVAV))); |
3698
|
2034
|
50
|
|
|
|
SvREFCNT_inc_simple_void(PL_incgv); /* Don't allow it to be freed */ |
3699
|
2034
|
|
|
|
|
GvMULTI_on(PL_incgv); |
3700
|
2034
|
|
|
|
|
PL_hintgv = gv_fetchpvs("\010", GV_ADD|GV_NOTQUAL, SVt_PV); /* ^H */ |
3701
|
2034
|
|
|
|
|
GvMULTI_on(PL_hintgv); |
3702
|
2034
|
|
|
|
|
PL_defgv = gv_fetchpvs("_", GV_ADD|GV_NOTQUAL, SVt_PVAV); |
3703
|
2034
|
50
|
|
|
|
SvREFCNT_inc_simple_void(PL_defgv); |
3704
|
2034
|
|
|
|
|
PL_errgv = gv_HVadd(gv_fetchpvs("@", GV_ADD|GV_NOTQUAL, SVt_PV)); |
3705
|
2017
|
50
|
|
|
|
SvREFCNT_inc_simple_void(PL_errgv); |
3706
|
2017
|
|
|
|
|
GvMULTI_on(PL_errgv); |
3707
|
2017
|
|
|
|
|
PL_replgv = gv_fetchpvs("\022", GV_ADD|GV_NOTQUAL, SVt_PV); /* ^R */ |
3708
|
2017
|
|
|
|
|
GvMULTI_on(PL_replgv); |
3709
|
2017
|
|
|
|
|
(void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */ |
3710
|
|
|
|
|
|
#ifdef PERL_DONT_CREATE_GVSV |
3711
|
11993
|
|
|
|
|
gv_SVadd(PL_errgv); |
3712
|
|
|
|
|
|
#endif |
3713
|
11993
|
50
|
|
|
|
sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */ |
3714
|
11993
|
50
|
|
|
|
CLEAR_ERRSV(); |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
3715
|
11993
|
50
|
|
|
|
SET_CURSTASH(PL_defstash); |
3716
|
11993
|
|
|
|
|
CopSTASH_set(&PL_compiling, PL_defstash); |
3717
|
11993
|
|
|
|
|
PL_debstash = GvHV(gv_fetchpvs("DB::", GV_ADDMULTI, SVt_PVHV)); |
3718
|
21969
|
|
|
|
|
PL_globalstash = GvHV(gv_fetchpvs("CORE::GLOBAL::", GV_ADDMULTI, |
3719
|
|
|
|
|
|
SVt_PVHV)); |
3720
|
|
|
|
|
|
/* We must init $/ before switches are processed. */ |
3721
|
11993
|
|
|
|
|
sv_setpvs(get_sv("/", GV_ADD), "\n"); |
3722
|
11993
|
|
|
|
|
} |
3723
|
|
|
|
|
|
|
3724
|
|
|
|
|
|
STATIC PerlIO * |
3725
|
11993
|
|
|
|
|
S_open_script(pTHX_ const char *scriptname, bool dosearch, bool *suidscript) |
3726
|
|
|
|
|
|
{ |
3727
|
|
|
|
|
|
int fdscript = -1; |
3728
|
|
|
|
|
|
PerlIO *rsfp = NULL; |
3729
|
|
|
|
|
|
dVAR; |
3730
|
|
|
|
|
|
Stat_t tmpstatbuf; |
3731
|
|
|
|
|
|
|
3732
|
|
|
|
|
|
PERL_ARGS_ASSERT_OPEN_SCRIPT; |
3733
|
|
|
|
|
|
|
3734
|
11993
|
100
|
|
|
|
if (PL_e_script) { |
3735
|
11199
|
|
|
|
|
PL_origfilename = savepvs("-e"); |
3736
|
|
|
|
|
|
} |
3737
|
|
|
|
|
|
else { |
3738
|
|
|
|
|
|
/* if find_script() returns, it returns a malloc()-ed value */ |
3739
|
10770
|
|
|
|
|
scriptname = PL_origfilename = find_script(scriptname, dosearch, NULL, 1); |
3740
|
|
|
|
|
|
|
3741
|
10770
|
50
|
|
|
|
if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) { |
|
|
0
|
|
|
|
|
3742
|
9976
|
|
|
|
|
const char *s = scriptname + 8; |
3743
|
|
|
|
|
|
fdscript = atoi(s); |
3744
|
9976
|
0
|
|
|
|
while (isDIGIT(*s)) |
3745
|
9976
|
|
|
|
|
s++; |
3746
|
9976
|
0
|
|
|
|
if (*s) { |
3747
|
|
|
|
|
|
/* PSz 18 Feb 04 |
3748
|
|
|
|
|
|
* Tell apart "normal" usage of fdscript, e.g. |
3749
|
|
|
|
|
|
* with bash on FreeBSD: |
3750
|
|
|
|
|
|
* perl <( echo '#!perl -DA'; echo 'print "$0\n"') |
3751
|
|
|
|
|
|
* from usage in suidperl. |
3752
|
|
|
|
|
|
* Does any "normal" usage leave garbage after the number??? |
3753
|
|
|
|
|
|
* Is it a mistake to use a similar /dev/fd/ construct for |
3754
|
|
|
|
|
|
* suidperl? |
3755
|
|
|
|
|
|
*/ |
3756
|
9976
|
|
|
|
|
*suidscript = TRUE; |
3757
|
|
|
|
|
|
/* PSz 20 Feb 04 |
3758
|
|
|
|
|
|
* Be supersafe and do some sanity-checks. |
3759
|
|
|
|
|
|
* Still, can we be sure we got the right thing? |
3760
|
|
|
|
|
|
*/ |
3761
|
9976
|
0
|
|
|
|
if (*s != '/') { |
3762
|
9976
|
|
|
|
|
Perl_croak(aTHX_ "Wrong syntax (suid) fd script name \"%s\"\n", s); |
3763
|
|
|
|
|
|
} |
3764
|
9976
|
0
|
|
|
|
if (! *(s+1)) { |
3765
|
9976
|
|
|
|
|
Perl_croak(aTHX_ "Missing (suid) fd script name\n"); |
3766
|
|
|
|
|
|
} |
3767
|
9976
|
|
|
|
|
scriptname = savepv(s + 1); |
3768
|
9976
|
|
|
|
|
Safefree(PL_origfilename); |
3769
|
9976
|
|
|
|
|
PL_origfilename = (char *)scriptname; |
3770
|
|
|
|
|
|
} |
3771
|
|
|
|
|
|
} |
3772
|
|
|
|
|
|
} |
3773
|
|
|
|
|
|
|
3774
|
11993
|
|
|
|
|
CopFILE_free(PL_curcop); |
3775
|
11993
|
|
|
|
|
CopFILE_set(PL_curcop, PL_origfilename); |
3776
|
11993
|
100
|
|
|
|
if (*PL_origfilename == '-' && PL_origfilename[1] == '\0') |
|
|
50
|
|
|
|
|
3777
|
|
|
|
|
|
scriptname = (char *)""; |
3778
|
11993
|
50
|
|
|
|
if (fdscript >= 0) { |
3779
|
9920
|
|
|
|
|
rsfp = PerlIO_fdopen(fdscript,PERL_SCRIPT_MODE); |
3780
|
|
|
|
|
|
} |
3781
|
11937
|
50
|
|
|
|
else if (!*scriptname) { |
3782
|
4568
|
|
|
|
|
forbid_setid(0, *suidscript); |
3783
|
7369
|
|
|
|
|
return NULL; |
3784
|
|
|
|
|
|
} |
3785
|
|
|
|
|
|
else { |
3786
|
|
|
|
|
|
#ifdef FAKE_BIT_BUCKET |
3787
|
|
|
|
|
|
/* This hack allows one not to have /dev/null (or BIT_BUCKET as it |
3788
|
|
|
|
|
|
* is called) and still have the "-e" work. (Believe it or not, |
3789
|
|
|
|
|
|
* a /dev/null is required for the "-e" to work because source |
3790
|
|
|
|
|
|
* filter magic is used to implement it. ) This is *not* a general |
3791
|
|
|
|
|
|
* replacement for a /dev/null. What we do here is create a temp |
3792
|
|
|
|
|
|
* file (an empty file), open up that as the script, and then |
3793
|
|
|
|
|
|
* immediately close and unlink it. Close enough for jazz. */ |
3794
|
|
|
|
|
|
#define FAKE_BIT_BUCKET_PREFIX "/tmp/perlnull-" |
3795
|
|
|
|
|
|
#define FAKE_BIT_BUCKET_SUFFIX "XXXXXXXX" |
3796
|
|
|
|
|
|
#define FAKE_BIT_BUCKET_TEMPLATE FAKE_BIT_BUCKET_PREFIX FAKE_BIT_BUCKET_SUFFIX |
3797
|
|
|
|
|
|
char tmpname[sizeof(FAKE_BIT_BUCKET_TEMPLATE)] = { |
3798
|
|
|
|
|
|
FAKE_BIT_BUCKET_TEMPLATE |
3799
|
|
|
|
|
|
}; |
3800
|
|
|
|
|
|
const char * const err = "Failed to create a fake bit bucket"; |
3801
|
|
|
|
|
|
if (strEQ(scriptname, BIT_BUCKET)) { |
3802
|
|
|
|
|
|
#ifdef HAS_MKSTEMP /* Hopefully mkstemp() is safe here. */ |
3803
|
|
|
|
|
|
int tmpfd = mkstemp(tmpname); |
3804
|
|
|
|
|
|
if (tmpfd > -1) { |
3805
|
|
|
|
|
|
scriptname = tmpname; |
3806
|
|
|
|
|
|
close(tmpfd); |
3807
|
|
|
|
|
|
} else |
3808
|
|
|
|
|
|
Perl_croak(aTHX_ err); |
3809
|
|
|
|
|
|
#else |
3810
|
|
|
|
|
|
# ifdef HAS_MKTEMP |
3811
|
|
|
|
|
|
scriptname = mktemp(tmpname); |
3812
|
|
|
|
|
|
if (!scriptname) |
3813
|
|
|
|
|
|
Perl_croak(aTHX_ err); |
3814
|
|
|
|
|
|
# endif |
3815
|
|
|
|
|
|
#endif |
3816
|
|
|
|
|
|
} |
3817
|
|
|
|
|
|
#endif |
3818
|
7369
|
|
|
|
|
rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE); |
3819
|
|
|
|
|
|
#ifdef FAKE_BIT_BUCKET |
3820
|
|
|
|
|
|
if (memEQ(scriptname, FAKE_BIT_BUCKET_PREFIX, |
3821
|
|
|
|
|
|
sizeof(FAKE_BIT_BUCKET_PREFIX) - 1) |
3822
|
|
|
|
|
|
&& strlen(scriptname) == sizeof(tmpname) - 1) { |
3823
|
|
|
|
|
|
unlink(scriptname); |
3824
|
|
|
|
|
|
} |
3825
|
|
|
|
|
|
scriptname = BIT_BUCKET; |
3826
|
|
|
|
|
|
#endif |
3827
|
|
|
|
|
|
} |
3828
|
2017
|
50
|
|
|
|
if (!rsfp) { |
3829
|
|
|
|
|
|
/* PSz 16 Sep 03 Keep neat error message */ |
3830
|
0
|
0
|
|
|
|
if (PL_e_script) |
3831
|
0
|
|
|
|
|
Perl_croak(aTHX_ "Can't open "BIT_BUCKET": %s\n", Strerror(errno)); |
3832
|
|
|
|
|
|
else |
3833
|
0
|
0
|
|
|
|
Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n", |
3834
|
0
|
|
|
|
|
CopFILE(PL_curcop), Strerror(errno)); |
3835
|
|
|
|
|
|
} |
3836
|
|
|
|
|
|
#if defined(HAS_FCNTL) && defined(F_SETFD) |
3837
|
|
|
|
|
|
/* ensure close-on-exec */ |
3838
|
2017
|
|
|
|
|
fcntl(PerlIO_fileno(rsfp), F_SETFD, 1); |
3839
|
|
|
|
|
|
#endif |
3840
|
|
|
|
|
|
|
3841
|
4034
|
50
|
|
|
|
if (PerlLIO_fstat(PerlIO_fileno(rsfp), &tmpstatbuf) >= 0 |
3842
|
2017
|
50
|
|
|
|
&& S_ISDIR(tmpstatbuf.st_mode)) |
3843
|
0
|
0
|
|
|
|
Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n", |
3844
|
0
|
|
|
|
|
CopFILE(PL_curcop), |
3845
|
|
|
|
|
|
Strerror(EISDIR)); |
3846
|
|
|
|
|
|
|
3847
|
|
|
|
|
|
return rsfp; |
3848
|
|
|
|
|
|
} |
3849
|
|
|
|
|
|
|
3850
|
|
|
|
|
|
/* Mention |
3851
|
|
|
|
|
|
* I_SYSSTATVFS HAS_FSTATVFS |
3852
|
|
|
|
|
|
* I_SYSMOUNT |
3853
|
|
|
|
|
|
* I_STATFS HAS_FSTATFS HAS_GETFSSTAT |
3854
|
|
|
|
|
|
* I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT |
3855
|
|
|
|
|
|
* here so that metaconfig picks them up. */ |
3856
|
|
|
|
|
|
|
3857
|
|
|
|
|
|
|
3858
|
|
|
|
|
|
#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW |
3859
|
|
|
|
|
|
/* Don't even need this function. */ |
3860
|
|
|
|
|
|
#else |
3861
|
|
|
|
|
|
STATIC void |
3862
|
2017
|
|
|
|
|
S_validate_suid(pTHX_ PerlIO *rsfp) |
3863
|
|
|
|
|
|
{ |
3864
|
2017
|
|
|
|
|
const Uid_t my_uid = PerlProc_getuid(); |
3865
|
11937
|
|
|
|
|
const Uid_t my_euid = PerlProc_geteuid(); |
3866
|
21857
|
|
|
|
|
const Gid_t my_gid = PerlProc_getgid(); |
3867
|
11937
|
|
|
|
|
const Gid_t my_egid = PerlProc_getegid(); |
3868
|
|
|
|
|
|
|
3869
|
|
|
|
|
|
PERL_ARGS_ASSERT_VALIDATE_SUID; |
3870
|
|
|
|
|
|
|
3871
|
11937
|
50
|
|
|
|
if (my_euid != my_uid || my_egid != my_gid) { /* (suidperl doesn't exist, in fact) */ |
3872
|
|
|
|
|
|
dVAR; |
3873
|
|
|
|
|
|
|
3874
|
0
|
|
|
|
|
PerlLIO_fstat(PerlIO_fileno(rsfp),&PL_statbuf); /* may be either wrapped or real suid */ |
3875
|
9920
|
0
|
|
|
|
if ((my_euid != my_uid && my_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID) |
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
3876
|
22
|
0
|
|
|
|
|| |
3877
|
22
|
0
|
|
|
|
(my_egid != my_gid && my_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID) |
|
|
0
|
|
|
|
|
3878
|
|
|
|
|
|
) |
3879
|
9898
|
0
|
|
|
|
if (!PL_do_undump) |
3880
|
9898
|
|
|
|
|
Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\ |
3881
|
|
|
|
|
|
FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); |
3882
|
|
|
|
|
|
/* not set-id, must be wrapped */ |
3883
|
|
|
|
|
|
} |
3884
|
2017
|
|
|
|
|
} |
3885
|
|
|
|
|
|
#endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */ |
3886
|
|
|
|
|
|
|
3887
|
|
|
|
|
|
STATIC void |
3888
|
0
|
|
|
|
|
S_find_beginning(pTHX_ SV* linestr_sv, PerlIO *rsfp) |
3889
|
|
|
|
|
|
{ |
3890
|
|
|
|
|
|
dVAR; |
3891
|
|
|
|
|
|
const char *s; |
3892
|
|
|
|
|
|
const char *s2; |
3893
|
|
|
|
|
|
|
3894
|
|
|
|
|
|
PERL_ARGS_ASSERT_FIND_BEGINNING; |
3895
|
|
|
|
|
|
|
3896
|
|
|
|
|
|
/* skip forward in input to the real script? */ |
3897
|
|
|
|
|
|
|
3898
|
|
|
|
|
|
do { |
3899
|
0
|
0
|
|
|
|
if ((s = sv_gets(linestr_sv, rsfp, 0)) == NULL) |
3900
|
0
|
|
|
|
|
Perl_croak(aTHX_ "No Perl script found in input\n"); |
3901
|
|
|
|
|
|
s2 = s; |
3902
|
9898
|
0
|
|
|
|
} while (!(*s == '#' && s[1] == '!' && ((s = instr(s,"perl")) || (s = instr(s2,"PERL"))))); |
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
3903
|
19796
|
|
|
|
|
PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */ |
3904
|
9898
|
0
|
|
|
|
while (*s && !(isSPACE (*s) || *s == '#')) s++; |
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
3905
|
|
|
|
|
|
s2 = s; |
3906
|
3
|
0
|
|
|
|
while (*s == ' ' || *s == '\t') s++; |
3907
|
2
|
0
|
|
|
|
if (*s++ == '-') { |
3908
|
9919
|
0
|
|
|
|
while (isDIGIT(s2[-1]) || s2[-1] == '-' || s2[-1] == '.' |
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
3909
|
9919
|
0
|
|
|
|
|| s2[-1] == '_') s2--; |
3910
|
9919
|
0
|
|
|
|
if (strnEQ(s2-4,"perl",4)) |
3911
|
9919
|
0
|
|
|
|
while ((s = moreswitches(s))) |
3912
|
|
|
|
|
|
; |
3913
|
|
|
|
|
|
} |
3914
|
9919
|
|
|
|
|
} |
3915
|
|
|
|
|
|
|
3916
|
|
|
|
|
|
|
3917
|
|
|
|
|
|
STATIC void |
3918
|
11936
|
|
|
|
|
S_init_ids(pTHX) |
3919
|
|
|
|
|
|
{ |
3920
|
|
|
|
|
|
/* no need to do anything here any more if we don't |
3921
|
|
|
|
|
|
* do tainting. */ |
3922
|
|
|
|
|
|
#if !NO_TAINT_SUPPORT |
3923
|
|
|
|
|
|
dVAR; |
3924
|
2017
|
|
|
|
|
const Uid_t my_uid = PerlProc_getuid(); |
3925
|
2017
|
|
|
|
|
const Uid_t my_euid = PerlProc_geteuid(); |
3926
|
2017
|
|
|
|
|
const Gid_t my_gid = PerlProc_getgid(); |
3927
|
2017
|
|
|
|
|
const Gid_t my_egid = PerlProc_getegid(); |
3928
|
|
|
|
|
|
|
3929
|
|
|
|
|
|
/* Should not happen: */ |
3930
|
|
|
|
|
|
CHECK_MALLOC_TAINT(my_uid && (my_euid != my_uid || my_egid != my_gid)); |
3931
|
2017
|
50
|
|
|
|
TAINTING_set( TAINTING_get | (my_uid && (my_euid != my_uid || my_egid != my_gid)) ); |
|
|
50
|
|
|
|
|
3932
|
|
|
|
|
|
#endif |
3933
|
|
|
|
|
|
/* BUG */ |
3934
|
|
|
|
|
|
/* PSz 27 Feb 04 |
3935
|
|
|
|
|
|
* Should go by suidscript, not uid!=euid: why disallow |
3936
|
|
|
|
|
|
* system("ls") in scripts run from setuid things? |
3937
|
|
|
|
|
|
* Or, is this run before we check arguments and set suidscript? |
3938
|
|
|
|
|
|
* What about SETUID_SCRIPTS_ARE_SECURE_NOW: could we use fdscript then? |
3939
|
|
|
|
|
|
* (We never have suidscript, can we be sure to have fdscript?) |
3940
|
|
|
|
|
|
* Or must then go by UID checks? See comments in forbid_setid also. |
3941
|
|
|
|
|
|
*/ |
3942
|
2017
|
|
|
|
|
} |
3943
|
|
|
|
|
|
|
3944
|
|
|
|
|
|
/* This is used very early in the lifetime of the program, |
3945
|
|
|
|
|
|
* before even the options are parsed, so PL_tainting has |
3946
|
|
|
|
|
|
* not been initialized properly. */ |
3947
|
|
|
|
|
|
bool |
3948
|
9919
|
|
|
|
|
Perl_doing_taint(int argc, char *argv[], char *envp[]) |
3949
|
|
|
|
|
|
{ |
3950
|
|
|
|
|
|
#ifndef PERL_IMPLICIT_SYS |
3951
|
|
|
|
|
|
/* If we have PERL_IMPLICIT_SYS we can't call getuid() et alia |
3952
|
|
|
|
|
|
* before we have an interpreter-- and the whole point of this |
3953
|
|
|
|
|
|
* function is to be called at such an early stage. If you are on |
3954
|
|
|
|
|
|
* a system with PERL_IMPLICIT_SYS but you do have a concept of |
3955
|
|
|
|
|
|
* "tainted because running with altered effective ids', you'll |
3956
|
|
|
|
|
|
* have to add your own checks somewhere in here. The two most |
3957
|
|
|
|
|
|
* known samples of 'implicitness' are Win32 and NetWare, neither |
3958
|
|
|
|
|
|
* of which has much of concept of 'uids'. */ |
3959
|
4
|
|
|
|
|
Uid_t uid = PerlProc_getuid(); |
3960
|
41
|
|
|
|
|
Uid_t euid = PerlProc_geteuid(); |
3961
|
2
|
|
|
|
|
Gid_t gid = PerlProc_getgid(); |
3962
|
39
|
|
|
|
|
Gid_t egid = PerlProc_getegid(); |
3963
|
|
|
|
|
|
(void)envp; |
3964
|
|
|
|
|
|
|
3965
|
|
|
|
|
|
#ifdef VMS |
3966
|
|
|
|
|
|
uid |= gid << 16; |
3967
|
|
|
|
|
|
euid |= egid << 16; |
3968
|
|
|
|
|
|
#endif |
3969
|
2
|
0
|
|
|
|
if (uid && (euid != uid || egid != gid)) |
|
|
0
|
|
|
|
|
3970
|
|
|
|
|
|
return 1; |
3971
|
|
|
|
|
|
#endif /* !PERL_IMPLICIT_SYS */ |
3972
|
|
|
|
|
|
/* This is a really primitive check; environment gets ignored only |
3973
|
|
|
|
|
|
* if -T are the first chars together; otherwise one gets |
3974
|
|
|
|
|
|
* "Too late" message. */ |
3975
|
2
|
0
|
|
|
|
if ( argc > 1 && argv[1][0] == '-' |
|
|
0
|
|
|
|
|
3976
|
2
|
0
|
|
|
|
&& (argv[1][1] == 't' || argv[1][1] == 'T') ) |
3977
|
|
|
|
|
|
return 1; |
3978
|
2
|
|
|
|
|
return 0; |
3979
|
|
|
|
|
|
} |
3980
|
|
|
|
|
|
|
3981
|
|
|
|
|
|
/* Passing the flag as a single char rather than a string is a slight space |
3982
|
|
|
|
|
|
optimisation. The only message that isn't /^-.$/ is |
3983
|
|
|
|
|
|
"program input from stdin", which is substituted in place of '\0', which |
3984
|
|
|
|
|
|
could never be a command line flag. */ |
3985
|
|
|
|
|
|
STATIC void |
3986
|
6398
|
|
|
|
|
S_forbid_setid(pTHX_ const char flag, const bool suidscript) /* g */ |
3987
|
|
|
|
|
|
{ |
3988
|
|
|
|
|
|
dVAR; |
3989
|
6398
|
|
|
|
|
char string[3] = "-x"; |
3990
|
|
|
|
|
|
const char *message = "program input from stdin"; |
3991
|
|
|
|
|
|
|
3992
|
6398
|
50
|
|
|
|
if (flag) { |
3993
|
6400
|
|
|
|
|
string[1] = flag; |
3994
|
|
|
|
|
|
message = string; |
3995
|
|
|
|
|
|
} |
3996
|
|
|
|
|
|
|
3997
|
|
|
|
|
|
#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW |
3998
|
|
|
|
|
|
if (PerlProc_getuid() != PerlProc_geteuid()) |
3999
|
|
|
|
|
|
Perl_croak(aTHX_ "No %s allowed while running setuid", message); |
4000
|
|
|
|
|
|
if (PerlProc_getgid() != PerlProc_getegid()) |
4001
|
|
|
|
|
|
Perl_croak(aTHX_ "No %s allowed while running setgid", message); |
4002
|
|
|
|
|
|
#endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */ |
4003
|
6398
|
50
|
|
|
|
if (suidscript) |
4004
|
9976
|
|
|
|
|
Perl_croak(aTHX_ "No %s allowed with (suid) fdscript", message); |
4005
|
16372
|
|
|
|
|
} |
4006
|
|
|
|
|
|
|
4007
|
|
|
|
|
|
void |
4008
|
11165
|
|
|
|
|
Perl_init_dbargs(pTHX) |
4009
|
|
|
|
|
|
{ |
4010
|
11165
|
|
|
|
|
AV *const args = PL_dbargs = GvAV(gv_AVadd((gv_fetchpvs("DB::args", |
4011
|
|
|
|
|
|
GV_ADDMULTI, |
4012
|
|
|
|
|
|
SVt_PVAV)))); |
4013
|
|
|
|
|
|
|
4014
|
11165
|
50
|
|
|
|
if (AvREAL(args)) { |
4015
|
|
|
|
|
|
/* Someone has already created it. |
4016
|
|
|
|
|
|
It might have entries, and if we just turn off AvREAL(), they will |
4017
|
|
|
|
|
|
"leak" until global destruction. */ |
4018
|
11165
|
|
|
|
|
av_clear(args); |
4019
|
11165
|
50
|
|
|
|
if (SvTIED_mg((const SV *)args, PERL_MAGIC_tied)) |
|
|
0
|
|
|
|
|
4020
|
0
|
|
|
|
|
Perl_croak(aTHX_ "Cannot set tied @DB::args"); |
4021
|
|
|
|
|
|
} |
4022
|
1189
|
|
|
|
|
AvREIFY_only(PL_dbargs); |
4023
|
1189
|
|
|
|
|
} |
4024
|
|
|
|
|
|
|
4025
|
|
|
|
|
|
void |
4026
|
0
|
|
|
|
|
Perl_init_debugger(pTHX) |
4027
|
|
|
|
|
|
{ |
4028
|
|
|
|
|
|
dVAR; |
4029
|
0
|
|
|
|
|
HV * const ostash = PL_curstash; |
4030
|
|
|
|
|
|
|
4031
|
0
|
|
|
|
|
PL_curstash = (HV *)SvREFCNT_inc_simple(PL_debstash); |
4032
|
|
|
|
|
|
|
4033
|
0
|
|
|
|
|
Perl_init_dbargs(aTHX); |
4034
|
0
|
|
|
|
|
PL_DBgv = gv_fetchpvs("DB::DB", GV_ADDMULTI, SVt_PVGV); |
4035
|
0
|
|
|
|
|
PL_DBline = gv_fetchpvs("DB::dbline", GV_ADDMULTI, SVt_PVAV); |
4036
|
28874
|
|
|
|
|
PL_DBsub = gv_HVadd(gv_fetchpvs("DB::sub", GV_ADDMULTI, SVt_PVHV)); |
4037
|
28874
|
|
|
|
|
PL_DBsingle = GvSV((gv_fetchpvs("DB::single", GV_ADDMULTI, SVt_PV))); |
4038
|
28874
|
0
|
|
|
|
if (!SvIOK(PL_DBsingle)) |
4039
|
28852
|
|
|
|
|
sv_setiv(PL_DBsingle, 0); |
4040
|
28874
|
|
|
|
|
PL_DBtrace = GvSV((gv_fetchpvs("DB::trace", GV_ADDMULTI, SVt_PV))); |
4041
|
0
|
0
|
|
|
|
if (!SvIOK(PL_DBtrace)) |
4042
|
28874
|
|
|
|
|
sv_setiv(PL_DBtrace, 0); |
4043
|
44929
|
|
|
|
|
PL_DBsignal = GvSV((gv_fetchpvs("DB::signal", GV_ADDMULTI, SVt_PV))); |
4044
|
44929
|
0
|
|
|
|
if (!SvIOK(PL_DBsignal)) |
4045
|
44929
|
|
|
|
|
sv_setiv(PL_DBsignal, 0); |
4046
|
42568
|
|
|
|
|
SvREFCNT_dec(PL_curstash); |
4047
|
42568
|
|
|
|
|
PL_curstash = ostash; |
4048
|
1
|
|
|
|
|
} |
4049
|
|
|
|
|
|
|
4050
|
|
|
|
|
|
#ifndef STRESS_REALLOC |
4051
|
|
|
|
|
|
#define REASONABLE(size) (size) |
4052
|
|
|
|
|
|
#else |
4053
|
|
|
|
|
|
#define REASONABLE(size) (1) /* unreasonable */ |
4054
|
|
|
|
|
|
#endif |
4055
|
|
|
|
|
|
|
4056
|
|
|
|
|
|
void |
4057
|
46945
|
|
|
|
|
Perl_init_stacks(pTHX) |
4058
|
|
|
|
|
|
{ |
4059
|
|
|
|
|
|
dVAR; |
4060
|
|
|
|
|
|
/* start with 128-item stack and 8K cxstack */ |
4061
|
46945
|
|
|
|
|
PL_curstackinfo = new_stackinfo(REASONABLE(128), |
4062
|
|
|
|
|
|
REASONABLE(8192/sizeof(PERL_CONTEXT) - 1)); |
4063
|
4463
|
|
|
|
|
PL_curstackinfo->si_type = PERLSI_MAIN; |
4064
|
4463
|
|
|
|
|
PL_curstack = PL_curstackinfo->si_stack; |
4065
|
6909
|
|
|
|
|
PL_mainstack = PL_curstack; /* remember in case we switch stacks */ |
4066
|
|
|
|
|
|
|
4067
|
4463
|
|
|
|
|
PL_stack_base = AvARRAY(PL_curstack); |
4068
|
4463
|
|
|
|
|
PL_stack_sp = PL_stack_base; |
4069
|
4463
|
|
|
|
|
PL_stack_max = PL_stack_base + AvMAX(PL_curstack); |
4070
|
|
|
|
|
|
|
4071
|
4463
|
|
|
|
|
Newx(PL_tmps_stack,REASONABLE(128),SV*); |
4072
|
4463
|
|
|
|
|
PL_tmps_floor = -1; |
4073
|
4463
|
|
|
|
|
PL_tmps_ix = -1; |
4074
|
4462
|
|
|
|
|
PL_tmps_max = REASONABLE(128); |
4075
|
|
|
|
|
|
|
4076
|
4463
|
|
|
|
|
Newx(PL_markstack,REASONABLE(32),I32); |
4077
|
4463
|
|
|
|
|
PL_markstack_ptr = PL_markstack; |
4078
|
4462
|
|
|
|
|
PL_markstack_max = PL_markstack + REASONABLE(32); |
4079
|
|
|
|
|
|
|
4080
|
|
|
|
|
|
SET_MARK_OFFSET; |
4081
|
|
|
|
|
|
|
4082
|
4463
|
|
|
|
|
Newx(PL_scopestack,REASONABLE(32),I32); |
4083
|
|
|
|
|
|
#ifdef DEBUGGING |
4084
|
|
|
|
|
|
Newx(PL_scopestack_name,REASONABLE(32),const char*); |
4085
|
|
|
|
|
|
#endif |
4086
|
4463
|
|
|
|
|
PL_scopestack_ix = 0; |
4087
|
4462
|
|
|
|
|
PL_scopestack_max = REASONABLE(32); |
4088
|
|
|
|
|
|
|
4089
|
4463
|
|
|
|
|
Newx(PL_savestack,REASONABLE(128),ANY); |
4090
|
4463
|
|
|
|
|
PL_savestack_ix = 0; |
4091
|
4463
|
|
|
|
|
PL_savestack_max = REASONABLE(128); |
4092
|
11993
|
|
|
|
|
} |
4093
|
|
|
|
|
|
|
4094
|
|
|
|
|
|
#undef REASONABLE |
4095
|
|
|
|
|
|
|
4096
|
|
|
|
|
|
STATIC void |
4097
|
|
|
|
|
|
S_nuke_stacks(pTHX) |
4098
|
|
|
|
|
|
{ |
4099
|
|
|
|
|
|
dVAR; |
4100
|
9976
|
0
|
|
|
|
while (PL_curstackinfo->si_next) |
4101
|
9976
|
|
|
|
|
PL_curstackinfo = PL_curstackinfo->si_next; |
4102
|
9976
|
0
|
|
|
|
while (PL_curstackinfo) { |
4103
|
9976
|
|
|
|
|
PERL_SI *p = PL_curstackinfo->si_prev; |
4104
|
|
|
|
|
|
/* curstackinfo->si_stack got nuked by sv_free_arenas() */ |
4105
|
9976
|
|
|
|
|
Safefree(PL_curstackinfo->si_cxstack); |
4106
|
9976
|
|
|
|
|
Safefree(PL_curstackinfo); |
4107
|
9976
|
|
|
|
|
PL_curstackinfo = p; |
4108
|
|
|
|
|
|
} |
4109
|
9976
|
|
|
|
|
Safefree(PL_tmps_stack); |
4110
|
9976
|
|
|
|
|
Safefree(PL_markstack); |
4111
|
9976
|
|
|
|
|
Safefree(PL_scopestack); |
4112
|
|
|
|
|
|
#ifdef DEBUGGING |
4113
|
|
|
|
|
|
Safefree(PL_scopestack_name); |
4114
|
|
|
|
|
|
#endif |
4115
|
9976
|
|
|
|
|
Safefree(PL_savestack); |
4116
|
|
|
|
|
|
} |
4117
|
|
|
|
|
|
|
4118
|
|
|
|
|
|
void |
4119
|
11993
|
|
|
|
|
Perl_populate_isa(pTHX_ const char *name, STRLEN len, ...) |
4120
|
|
|
|
|
|
{ |
4121
|
11993
|
|
|
|
|
GV *const gv = gv_fetchpvn(name, len, GV_ADD | GV_ADDMULTI, SVt_PVAV); |
4122
|
11993
|
50
|
|
|
|
AV *const isa = GvAVn(gv); |
4123
|
|
|
|
|
|
va_list args; |
4124
|
|
|
|
|
|
|
4125
|
|
|
|
|
|
PERL_ARGS_ASSERT_POPULATE_ISA; |
4126
|
|
|
|
|
|
|
4127
|
11993
|
50
|
|
|
|
if(AvFILLp(isa) != -1) |
4128
|
11993
|
|
|
|
|
return; |
4129
|
|
|
|
|
|
|
4130
|
|
|
|
|
|
/* NOTE: No support for tied ISA */ |
4131
|
|
|
|
|
|
|
4132
|
11993
|
|
|
|
|
va_start(args, len); |
4133
|
|
|
|
|
|
do { |
4134
|
18044
|
100
|
|
|
|
const char *const parent = va_arg(args, const char*); |
4135
|
|
|
|
|
|
size_t parent_len; |
4136
|
|
|
|
|
|
|
4137
|
18044
|
100
|
|
|
|
if (!parent) |
4138
|
|
|
|
|
|
break; |
4139
|
16027
|
100
|
|
|
|
parent_len = va_arg(args, size_t); |
4140
|
|
|
|
|
|
|
4141
|
|
|
|
|
|
/* Arguments are supplied with a trailing :: */ |
4142
|
|
|
|
|
|
assert(parent_len > 2); |
4143
|
|
|
|
|
|
assert(parent[parent_len - 1] == ':'); |
4144
|
|
|
|
|
|
assert(parent[parent_len - 2] == ':'); |
4145
|
16027
|
|
|
|
|
av_push(isa, newSVpvn(parent, parent_len - 2)); |
4146
|
6051
|
|
|
|
|
(void) gv_fetchpvn(parent, parent_len, GV_ADD, SVt_PVGV); |
4147
|
6051
|
|
|
|
|
} while (1); |
4148
|
2017
|
|
|
|
|
va_end(args); |
4149
|
|
|
|
|
|
} |
4150
|
|
|
|
|
|
|
4151
|
|
|
|
|
|
|
4152
|
|
|
|
|
|
STATIC void |
4153
|
2017
|
|
|
|
|
S_init_predump_symbols(pTHX) |
4154
|
|
|
|
|
|
{ |
4155
|
|
|
|
|
|
dVAR; |
4156
|
|
|
|
|
|
GV *tmpgv; |
4157
|
|
|
|
|
|
IO *io; |
4158
|
|
|
|
|
|
|
4159
|
2017
|
|
|
|
|
sv_setpvs(get_sv("\"", GV_ADD), " "); |
4160
|
2017
|
|
|
|
|
PL_ofsgv = (GV*)SvREFCNT_inc(gv_fetchpvs(",", GV_ADD|GV_NOTQUAL, SVt_PV)); |
4161
|
|
|
|
|
|
|
4162
|
|
|
|
|
|
|
4163
|
|
|
|
|
|
/* Historically, PVIOs were blessed into IO::Handle, unless |
4164
|
|
|
|
|
|
FileHandle was loaded, in which case they were blessed into |
4165
|
|
|
|
|
|
that. Action at a distance. |
4166
|
|
|
|
|
|
However, if we simply bless into IO::Handle, we break code |
4167
|
|
|
|
|
|
that assumes that PVIOs will have (among others) a seek |
4168
|
|
|
|
|
|
method. IO::File inherits from IO::Handle and IO::Seekable, |
4169
|
|
|
|
|
|
and provides the needed methods. But if we simply bless into |
4170
|
|
|
|
|
|
it, then we break code that assumed that by loading |
4171
|
|
|
|
|
|
IO::Handle, *it* would work. |
4172
|
|
|
|
|
|
So a compromise is to set up the correct @IO::File::ISA, |
4173
|
|
|
|
|
|
so that code that does C |
4174
|
|
|
|
|
|
*/ |
4175
|
|
|
|
|
|
|
4176
|
2017
|
|
|
|
|
Perl_populate_isa(aTHX_ STR_WITH_LEN("IO::File::ISA"), |
4177
|
|
|
|
|
|
STR_WITH_LEN("IO::Handle::"), |
4178
|
|
|
|
|
|
STR_WITH_LEN("IO::Seekable::"), |
4179
|
|
|
|
|
|
STR_WITH_LEN("Exporter::"), |
4180
|
|
|
|
|
|
NULL); |
4181
|
|
|
|
|
|
|
4182
|
2017
|
|
|
|
|
PL_stdingv = gv_fetchpvs("STDIN", GV_ADD|GV_NOTQUAL, SVt_PVIO); |
4183
|
2017
|
|
|
|
|
GvMULTI_on(PL_stdingv); |
4184
|
2017
|
|
|
|
|
io = GvIOp(PL_stdingv); |
4185
|
2017
|
|
|
|
|
IoTYPE(io) = IoTYPE_RDONLY; |
4186
|
11992
|
|
|
|
|
IoIFP(io) = PerlIO_stdin(); |
4187
|
11992
|
|
|
|
|
tmpgv = gv_fetchpvs("stdin", GV_ADD|GV_NOTQUAL, SVt_PV); |
4188
|
11992
|
|
|
|
|
GvMULTI_on(tmpgv); |
4189
|
14009
|
|
|
|
|
GvIOp(tmpgv) = MUTABLE_IO(SvREFCNT_inc_simple(io)); |
4190
|
|
|
|
|
|
|
4191
|
11992
|
|
|
|
|
tmpgv = gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO); |
4192
|
11963
|
|
|
|
|
GvMULTI_on(tmpgv); |
4193
|
41859
|
|
|
|
|
io = GvIOp(tmpgv); |
4194
|
41859
|
|
|
|
|
IoTYPE(io) = IoTYPE_WRONLY; |
4195
|
31913
|
|
|
|
|
IoOFP(io) = IoIFP(io) = PerlIO_stdout(); |
4196
|
31913
|
|
|
|
|
setdefout(tmpgv); |
4197
|
31913
|
|
|
|
|
tmpgv = gv_fetchpvs("stdout", GV_ADD|GV_NOTQUAL, SVt_PV); |
4198
|
31913
|
|
|
|
|
GvMULTI_on(tmpgv); |
4199
|
13980
|
|
|
|
|
GvIOp(tmpgv) = MUTABLE_IO(SvREFCNT_inc_simple(io)); |
4200
|
|
|
|
|
|
|
4201
|
11934
|
|
|
|
|
PL_stderrgv = gv_fetchpvs("STDERR", GV_ADD|GV_NOTQUAL, SVt_PVIO); |
4202
|
11934
|
|
|
|
|
GvMULTI_on(PL_stderrgv); |
4203
|
21851
|
|
|
|
|
io = GvIOp(PL_stderrgv); |
4204
|
11934
|
|
|
|
|
IoTYPE(io) = IoTYPE_WRONLY; |
4205
|
11934
|
|
|
|
|
IoOFP(io) = IoIFP(io) = PerlIO_stderr(); |
4206
|
11934
|
|
|
|
|
tmpgv = gv_fetchpvs("stderr", GV_ADD|GV_NOTQUAL, SVt_PV); |
4207
|
11934
|
|
|
|
|
GvMULTI_on(tmpgv); |
4208
|
13951
|
|
|
|
|
GvIOp(tmpgv) = MUTABLE_IO(SvREFCNT_inc_simple(io)); |
4209
|
|
|
|
|
|
|
4210
|
11934
|
|
|
|
|
PL_statname = newSVpvs(""); /* last filename we did stat on */ |
4211
|
11934
|
|
|
|
|
} |
4212
|
|
|
|
|
|
|
4213
|
|
|
|
|
|
void |
4214
|
11934
|
|
|
|
|
Perl_init_argv_symbols(pTHX_ int argc, char **argv) |
4215
|
|
|
|
|
|
{ |
4216
|
|
|
|
|
|
dVAR; |
4217
|
|
|
|
|
|
|
4218
|
|
|
|
|
|
PERL_ARGS_ASSERT_INIT_ARGV_SYMBOLS; |
4219
|
|
|
|
|
|
|
4220
|
21851
|
|
|
|
|
argc--,argv++; /* skip name of script */ |
4221
|
11934
|
50
|
|
|
|
if (PL_doswitches) { |
4222
|
9917
|
0
|
|
|
|
for (; argc > 0 && **argv == '-'; argc--,argv++) { |
|
|
0
|
|
|
|
|
4223
|
|
|
|
|
|
char *s; |
4224
|
9917
|
0
|
|
|
|
if (!argv[0][1]) |
4225
|
|
|
|
|
|
break; |
4226
|
9917
|
0
|
|
|
|
if (argv[0][1] == '-' && !argv[0][2]) { |
|
|
0
|
|
|
|
|
4227
|
9917
|
|
|
|
|
argc--,argv++; |
4228
|
9917
|
|
|
|
|
break; |
4229
|
|
|
|
|
|
} |
4230
|
9917
|
0
|
|
|
|
if ((s = strchr(argv[0], '='))) { |
4231
|
9917
|
|
|
|
|
const char *const start_name = argv[0] + 1; |
4232
|
19834
|
|
|
|
|
sv_setpv(GvSV(gv_fetchpvn_flags(start_name, s - start_name, |
4233
|
|
|
|
|
|
TRUE, SVt_PV)), s + 1); |
4234
|
|
|
|
|
|
} |
4235
|
|
|
|
|
|
else |
4236
|
9917
|
|
|
|
|
sv_setiv(GvSV(gv_fetchpv(argv[0]+1, GV_ADD, SVt_PV)),1); |
4237
|
|
|
|
|
|
} |
4238
|
|
|
|
|
|
} |
4239
|
11934
|
50
|
|
|
|
if ((PL_argvgv = gv_fetchpvs("ARGV", GV_ADD|GV_NOTQUAL, SVt_PVAV))) { |
4240
|
11934
|
|
|
|
|
GvMULTI_on(PL_argvgv); |
4241
|
11934
|
|
|
|
|
(void)gv_AVadd(PL_argvgv); |
4242
|
11934
|
50
|
|
|
|
av_clear(GvAVn(PL_argvgv)); |
4243
|
16966
|
100
|
|
|
|
for (; argc > 0; argc--,argv++) { |
4244
|
14949
|
|
|
|
|
SV * const sv = newSVpv(argv[0],0); |
4245
|
24866
|
50
|
|
|
|
av_push(GvAVn(PL_argvgv),sv); |
4246
|
14949
|
50
|
|
|
|
if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) { |
|
|
0
|
|
|
|
|
4247
|
14949
|
50
|
|
|
|
if (PL_unicode & PERL_UNICODE_ARGV_FLAG) |
4248
|
9920
|
|
|
|
|
SvUTF8_on(sv); |
4249
|
|
|
|
|
|
} |
4250
|
14952
|
50
|
|
|
|
if (PL_unicode & PERL_UNICODE_WIDESYSCALLS_FLAG) /* Sarathy? */ |
4251
|
9920
|
|
|
|
|
(void)sv_utf8_decode(sv); |
4252
|
|
|
|
|
|
} |
4253
|
|
|
|
|
|
} |
4254
|
|
|
|
|
|
|
4255
|
2022
|
50
|
|
|
|
if (PL_inplace && (!PL_argvgv || AvFILL(GvAV(PL_argvgv)) == -1)) |
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
4256
|
5
|
|
|
|
|
Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE), |
4257
|
|
|
|
|
|
"-i used with no filenames on the command line, " |
4258
|
|
|
|
|
|
"reading from STDIN"); |
4259
|
2022
|
|
|
|
|
} |
4260
|
|
|
|
|
|
|
4261
|
|
|
|
|
|
STATIC void |
4262
|
2017
|
|
|
|
|
S_init_postdump_symbols(pTHX_ int argc, char **argv, char **env) |
4263
|
|
|
|
|
|
{ |
4264
|
|
|
|
|
|
dVAR; |
4265
|
|
|
|
|
|
GV* tmpgv; |
4266
|
|
|
|
|
|
|
4267
|
|
|
|
|
|
PERL_ARGS_ASSERT_INIT_POSTDUMP_SYMBOLS; |
4268
|
|
|
|
|
|
|
4269
|
2017
|
|
|
|
|
PL_toptarget = newSV_type(SVt_PVIV); |
4270
|
2022
|
|
|
|
|
sv_setpvs(PL_toptarget, ""); |
4271
|
2020
|
|
|
|
|
PL_bodytarget = newSV_type(SVt_PVIV); |
4272
|
2020
|
|
|
|
|
sv_setpvs(PL_bodytarget, ""); |
4273
|
2019
|
|
|
|
|
PL_formtarget = PL_bodytarget; |
4274
|
|
|
|
|
|
|
4275
|
11937
|
|
|
|
|
TAINT; |
4276
|
|
|
|
|
|
|
4277
|
11937
|
|
|
|
|
init_argv_symbols(argc,argv); |
4278
|
|
|
|
|
|
|
4279
|
11937
|
50
|
|
|
|
if ((tmpgv = gv_fetchpvs("0", GV_ADD|GV_NOTQUAL, SVt_PV))) { |
4280
|
11937
|
|
|
|
|
sv_setpv(GvSV(tmpgv),PL_origfilename); |
4281
|
|
|
|
|
|
} |
4282
|
14924
|
50
|
|
|
|
if ((PL_envgv = gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV))) { |
4283
|
|
|
|
|
|
HV *hv; |
4284
|
|
|
|
|
|
bool env_is_not_environ; |
4285
|
5004
|
|
|
|
|
GvMULTI_on(PL_envgv); |
4286
|
5004
|
50
|
|
|
|
hv = GvHVn(PL_envgv); |
4287
|
5004
|
|
|
|
|
hv_magic(hv, NULL, PERL_MAGIC_env); |
4288
|
|
|
|
|
|
#ifndef PERL_MICRO |
4289
|
|
|
|
|
|
#ifdef USE_ENVIRON_ARRAY |
4290
|
|
|
|
|
|
/* Note that if the supplied env parameter is actually a copy |
4291
|
|
|
|
|
|
of the global environ then it may now point to free'd memory |
4292
|
|
|
|
|
|
if the environment has been modified since. To avoid this |
4293
|
|
|
|
|
|
problem we treat env==NULL as meaning 'use the default' |
4294
|
|
|
|
|
|
*/ |
4295
|
5004
|
50
|
|
|
|
if (!env) |
4296
|
2018
|
|
|
|
|
env = environ; |
4297
|
5004
|
|
|
|
|
env_is_not_environ = env != environ; |
4298
|
2017
|
50
|
|
|
|
if (env_is_not_environ |
4299
|
|
|
|
|
|
# ifdef USE_ITHREADS |
4300
|
|
|
|
|
|
&& PL_curinterp == aTHX |
4301
|
|
|
|
|
|
# endif |
4302
|
|
|
|
|
|
) |
4303
|
|
|
|
|
|
{ |
4304
|
9920
|
|
|
|
|
environ[0] = NULL; |
4305
|
|
|
|
|
|
} |
4306
|
2018
|
50
|
|
|
|
if (env) { |
4307
|
|
|
|
|
|
char *s, *old_var; |
4308
|
|
|
|
|
|
SV *sv; |
4309
|
157592
|
100
|
|
|
|
for (; *env; env++) { |
4310
|
155572
|
|
|
|
|
old_var = *env; |
4311
|
|
|
|
|
|
|
4312
|
155572
|
50
|
|
|
|
if (!(s = strchr(old_var,'=')) || s == old_var) |
|
|
50
|
|
|
|
|
4313
|
9917
|
|
|
|
|
continue; |
4314
|
|
|
|
|
|
|
4315
|
|
|
|
|
|
#if defined(MSDOS) && !defined(DJGPP) |
4316
|
|
|
|
|
|
*s = '\0'; |
4317
|
|
|
|
|
|
(void)strupr(old_var); |
4318
|
|
|
|
|
|
*s = '='; |
4319
|
|
|
|
|
|
#endif |
4320
|
155572
|
|
|
|
|
sv = newSVpv(s+1, 0); |
4321
|
155572
|
|
|
|
|
(void)hv_store(hv, old_var, s - old_var, sv, 0); |
4322
|
155572
|
50
|
|
|
|
if (env_is_not_environ) |
4323
|
9917
|
|
|
|
|
mg_set(sv); |
4324
|
|
|
|
|
|
} |
4325
|
|
|
|
|
|
} |
4326
|
|
|
|
|
|
#endif /* USE_ENVIRON_ARRAY */ |
4327
|
|
|
|
|
|
#endif /* !PERL_MICRO */ |
4328
|
|
|
|
|
|
} |
4329
|
11934
|
|
|
|
|
TAINT_NOT; |
4330
|
|
|
|
|
|
|
4331
|
|
|
|
|
|
/* touch @F array to prevent spurious warnings 20020415 MJD */ |
4332
|
11934
|
50
|
|
|
|
if (PL_minus_a) { |
4333
|
9917
|
|
|
|
|
(void) get_av("main::F", GV_ADD | GV_ADDMULTI); |
4334
|
|
|
|
|
|
} |
4335
|
11934
|
|
|
|
|
} |
4336
|
|
|
|
|
|
|
4337
|
|
|
|
|
|
STATIC void |
4338
|
|
|
|
|
|
S_init_perllib(pTHX) |
4339
|
|
|
|
|
|
{ |
4340
|
|
|
|
|
|
dVAR; |
4341
|
|
|
|
|
|
#ifndef VMS |
4342
|
|
|
|
|
|
const char *perl5lib = NULL; |
4343
|
|
|
|
|
|
#endif |
4344
|
|
|
|
|
|
const char *s; |
4345
|
|
|
|
|
|
#if defined(WIN32) && !defined(PERL_IS_MINIPERL) |
4346
|
|
|
|
|
|
STRLEN len; |
4347
|
|
|
|
|
|
#endif |
4348
|
|
|
|
|
|
|
4349
|
11934
|
50
|
|
|
|
if (!TAINTING_get) { |
4350
|
|
|
|
|
|
#ifndef VMS |
4351
|
11934
|
|
|
|
|
perl5lib = PerlEnv_getenv("PERL5LIB"); |
4352
|
|
|
|
|
|
/* |
4353
|
|
|
|
|
|
* It isn't possible to delete an environment variable with |
4354
|
|
|
|
|
|
* PERL_USE_SAFE_PUTENV set unless unsetenv() is also available, so in that |
4355
|
|
|
|
|
|
* case we treat PERL5LIB as undefined if it has a zero-length value. |
4356
|
|
|
|
|
|
*/ |
4357
|
|
|
|
|
|
#if defined(PERL_USE_SAFE_PUTENV) && ! defined(HAS_UNSETENV) |
4358
|
|
|
|
|
|
if (perl5lib && *perl5lib != '\0') |
4359
|
|
|
|
|
|
#else |
4360
|
11934
|
50
|
|
|
|
if (perl5lib) |
4361
|
|
|
|
|
|
#endif |
4362
|
9917
|
|
|
|
|
incpush_use_sep(perl5lib, 0, INCPUSH_ADD_SUB_DIRS); |
4363
|
|
|
|
|
|
else { |
4364
|
11933
|
|
|
|
|
s = PerlEnv_getenv("PERLLIB"); |
4365
|
11934
|
50
|
|
|
|
if (s) |
4366
|
9917
|
|
|
|
|
incpush_use_sep(s, 0, 0); |
4367
|
|
|
|
|
|
} |
4368
|
|
|
|
|
|
#else /* VMS */ |
4369
|
|
|
|
|
|
/* Treat PERL5?LIB as a possible search list logical name -- the |
4370
|
|
|
|
|
|
* "natural" VMS idiom for a Unix path string. We allow each |
4371
|
|
|
|
|
|
* element to be a set of |-separated directories for compatibility. |
4372
|
|
|
|
|
|
*/ |
4373
|
|
|
|
|
|
char buf[256]; |
4374
|
|
|
|
|
|
int idx = 0; |
4375
|
|
|
|
|
|
if (my_trnlnm("PERL5LIB",buf,0)) |
4376
|
|
|
|
|
|
do { |
4377
|
|
|
|
|
|
incpush_use_sep(buf, 0, INCPUSH_ADD_SUB_DIRS); |
4378
|
|
|
|
|
|
} while (my_trnlnm("PERL5LIB",buf,++idx)); |
4379
|
|
|
|
|
|
else { |
4380
|
|
|
|
|
|
while (my_trnlnm("PERLLIB",buf,idx++)) |
4381
|
|
|
|
|
|
incpush_use_sep(buf, 0, 0); |
4382
|
|
|
|
|
|
} |
4383
|
|
|
|
|
|
#endif /* VMS */ |
4384
|
|
|
|
|
|
} |
4385
|
|
|
|
|
|
|
4386
|
|
|
|
|
|
#ifndef PERL_IS_MINIPERL |
4387
|
|
|
|
|
|
/* miniperl gets just -I..., the split of $ENV{PERL5LIB}, and "." in @INC |
4388
|
|
|
|
|
|
(and not the architecture specific directories from $ENV{PERL5LIB}) */ |
4389
|
|
|
|
|
|
|
4390
|
|
|
|
|
|
/* Use the ~-expanded versions of APPLLIB (undocumented), |
4391
|
|
|
|
|
|
SITEARCH, SITELIB, VENDORARCH, VENDORLIB, ARCHLIB and PRIVLIB |
4392
|
|
|
|
|
|
*/ |
4393
|
|
|
|
|
|
#ifdef APPLLIB_EXP |
4394
|
|
|
|
|
|
S_incpush_use_sep(aTHX_ STR_WITH_LEN(APPLLIB_EXP), |
4395
|
|
|
|
|
|
INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE); |
4396
|
|
|
|
|
|
#endif |
4397
|
|
|
|
|
|
|
4398
|
|
|
|
|
|
#ifdef SITEARCH_EXP |
4399
|
|
|
|
|
|
/* sitearch is always relative to sitelib on Windows for |
4400
|
|
|
|
|
|
* DLL-based path intuition to work correctly */ |
4401
|
|
|
|
|
|
# if !defined(WIN32) |
4402
|
|
|
|
|
|
S_incpush_use_sep(aTHX_ STR_WITH_LEN(SITEARCH_EXP), |
4403
|
|
|
|
|
|
INCPUSH_CAN_RELOCATE); |
4404
|
|
|
|
|
|
# endif |
4405
|
|
|
|
|
|
#endif |
4406
|
|
|
|
|
|
|
4407
|
|
|
|
|
|
#ifdef SITELIB_EXP |
4408
|
|
|
|
|
|
# if defined(WIN32) |
4409
|
|
|
|
|
|
/* this picks up sitearch as well */ |
4410
|
|
|
|
|
|
s = win32_get_sitelib(PERL_FS_VERSION, &len); |
4411
|
|
|
|
|
|
if (s) |
4412
|
|
|
|
|
|
incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE); |
4413
|
|
|
|
|
|
# else |
4414
|
|
|
|
|
|
S_incpush_use_sep(aTHX_ STR_WITH_LEN(SITELIB_EXP), INCPUSH_CAN_RELOCATE); |
4415
|
|
|
|
|
|
# endif |
4416
|
|
|
|
|
|
#endif |
4417
|
|
|
|
|
|
|
4418
|
|
|
|
|
|
#ifdef PERL_VENDORARCH_EXP |
4419
|
|
|
|
|
|
/* vendorarch is always relative to vendorlib on Windows for |
4420
|
|
|
|
|
|
* DLL-based path intuition to work correctly */ |
4421
|
|
|
|
|
|
# if !defined(WIN32) |
4422
|
|
|
|
|
|
S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_VENDORARCH_EXP), |
4423
|
|
|
|
|
|
INCPUSH_CAN_RELOCATE); |
4424
|
|
|
|
|
|
# endif |
4425
|
|
|
|
|
|
#endif |
4426
|
|
|
|
|
|
|
4427
|
|
|
|
|
|
#ifdef PERL_VENDORLIB_EXP |
4428
|
|
|
|
|
|
# if defined(WIN32) |
4429
|
|
|
|
|
|
/* this picks up vendorarch as well */ |
4430
|
|
|
|
|
|
s = win32_get_vendorlib(PERL_FS_VERSION, &len); |
4431
|
|
|
|
|
|
if (s) |
4432
|
|
|
|
|
|
incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE); |
4433
|
|
|
|
|
|
# else |
4434
|
|
|
|
|
|
S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_VENDORLIB_EXP), |
4435
|
|
|
|
|
|
INCPUSH_CAN_RELOCATE); |
4436
|
|
|
|
|
|
# endif |
4437
|
|
|
|
|
|
#endif |
4438
|
|
|
|
|
|
|
4439
|
|
|
|
|
|
#ifdef ARCHLIB_EXP |
4440
|
|
|
|
|
|
S_incpush_use_sep(aTHX_ STR_WITH_LEN(ARCHLIB_EXP), INCPUSH_CAN_RELOCATE); |
4441
|
|
|
|
|
|
#endif |
4442
|
|
|
|
|
|
|
4443
|
|
|
|
|
|
#ifndef PRIVLIB_EXP |
4444
|
|
|
|
|
|
# define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl" |
4445
|
|
|
|
|
|
#endif |
4446
|
|
|
|
|
|
|
4447
|
|
|
|
|
|
#if defined(WIN32) |
4448
|
|
|
|
|
|
s = win32_get_privlib(PERL_FS_VERSION, &len); |
4449
|
|
|
|
|
|
if (s) |
4450
|
|
|
|
|
|
incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE); |
4451
|
|
|
|
|
|
#else |
4452
|
|
|
|
|
|
# ifdef NETWARE |
4453
|
|
|
|
|
|
S_incpush_use_sep(aTHX_ PRIVLIB_EXP, 0, INCPUSH_CAN_RELOCATE); |
4454
|
|
|
|
|
|
# else |
4455
|
|
|
|
|
|
S_incpush_use_sep(aTHX_ STR_WITH_LEN(PRIVLIB_EXP), INCPUSH_CAN_RELOCATE); |
4456
|
|
|
|
|
|
# endif |
4457
|
|
|
|
|
|
#endif |
4458
|
|
|
|
|
|
|
4459
|
|
|
|
|
|
#ifdef PERL_OTHERLIBDIRS |
4460
|
|
|
|
|
|
S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_OTHERLIBDIRS), |
4461
|
|
|
|
|
|
INCPUSH_ADD_VERSIONED_SUB_DIRS|INCPUSH_NOT_BASEDIR |
4462
|
|
|
|
|
|
|INCPUSH_CAN_RELOCATE); |
4463
|
|
|
|
|
|
#endif |
4464
|
|
|
|
|
|
|
4465
|
|
|
|
|
|
if (!TAINTING_get) { |
4466
|
|
|
|
|
|
#ifndef VMS |
4467
|
|
|
|
|
|
/* |
4468
|
|
|
|
|
|
* It isn't possible to delete an environment variable with |
4469
|
|
|
|
|
|
* PERL_USE_SAFE_PUTENV set unless unsetenv() is also available, so in that |
4470
|
|
|
|
|
|
* case we treat PERL5LIB as undefined if it has a zero-length value. |
4471
|
|
|
|
|
|
*/ |
4472
|
|
|
|
|
|
#if defined(PERL_USE_SAFE_PUTENV) && ! defined(HAS_UNSETENV) |
4473
|
|
|
|
|
|
if (perl5lib && *perl5lib != '\0') |
4474
|
|
|
|
|
|
#else |
4475
|
|
|
|
|
|
if (perl5lib) |
4476
|
|
|
|
|
|
#endif |
4477
|
|
|
|
|
|
incpush_use_sep(perl5lib, 0, |
4478
|
|
|
|
|
|
INCPUSH_ADD_OLD_VERS|INCPUSH_NOT_BASEDIR); |
4479
|
|
|
|
|
|
#else /* VMS */ |
4480
|
|
|
|
|
|
/* Treat PERL5?LIB as a possible search list logical name -- the |
4481
|
|
|
|
|
|
* "natural" VMS idiom for a Unix path string. We allow each |
4482
|
|
|
|
|
|
* element to be a set of |-separated directories for compatibility. |
4483
|
|
|
|
|
|
*/ |
4484
|
|
|
|
|
|
char buf[256]; |
4485
|
|
|
|
|
|
int idx = 0; |
4486
|
|
|
|
|
|
if (my_trnlnm("PERL5LIB",buf,0)) |
4487
|
|
|
|
|
|
do { |
4488
|
|
|
|
|
|
incpush_use_sep(buf, 0, |
4489
|
|
|
|
|
|
INCPUSH_ADD_OLD_VERS|INCPUSH_NOT_BASEDIR); |
4490
|
|
|
|
|
|
} while (my_trnlnm("PERL5LIB",buf,++idx)); |
4491
|
|
|
|
|
|
#endif /* VMS */ |
4492
|
|
|
|
|
|
} |
4493
|
|
|
|
|
|
|
4494
|
|
|
|
|
|
/* Use the ~-expanded versions of APPLLIB (undocumented), |
4495
|
|
|
|
|
|
SITELIB and VENDORLIB for older versions |
4496
|
|
|
|
|
|
*/ |
4497
|
|
|
|
|
|
#ifdef APPLLIB_EXP |
4498
|
|
|
|
|
|
S_incpush_use_sep(aTHX_ STR_WITH_LEN(APPLLIB_EXP), INCPUSH_ADD_OLD_VERS |
4499
|
|
|
|
|
|
|INCPUSH_NOT_BASEDIR|INCPUSH_CAN_RELOCATE); |
4500
|
|
|
|
|
|
#endif |
4501
|
|
|
|
|
|
|
4502
|
|
|
|
|
|
#if defined(SITELIB_STEM) && defined(PERL_INC_VERSION_LIST) |
4503
|
|
|
|
|
|
/* Search for version-specific dirs below here */ |
4504
|
|
|
|
|
|
S_incpush_use_sep(aTHX_ STR_WITH_LEN(SITELIB_STEM), |
4505
|
|
|
|
|
|
INCPUSH_ADD_OLD_VERS|INCPUSH_CAN_RELOCATE); |
4506
|
|
|
|
|
|
#endif |
4507
|
|
|
|
|
|
|
4508
|
|
|
|
|
|
|
4509
|
|
|
|
|
|
#if defined(PERL_VENDORLIB_STEM) && defined(PERL_INC_VERSION_LIST) |
4510
|
|
|
|
|
|
/* Search for version-specific dirs below here */ |
4511
|
|
|
|
|
|
S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_VENDORLIB_STEM), |
4512
|
|
|
|
|
|
INCPUSH_ADD_OLD_VERS|INCPUSH_CAN_RELOCATE); |
4513
|
|
|
|
|
|
#endif |
4514
|
|
|
|
|
|
|
4515
|
|
|
|
|
|
#ifdef PERL_OTHERLIBDIRS |
4516
|
|
|
|
|
|
S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_OTHERLIBDIRS), |
4517
|
|
|
|
|
|
INCPUSH_ADD_OLD_VERS|INCPUSH_ADD_ARCHONLY_SUB_DIRS |
4518
|
|
|
|
|
|
|INCPUSH_CAN_RELOCATE); |
4519
|
|
|
|
|
|
#endif |
4520
|
|
|
|
|
|
#endif /* !PERL_IS_MINIPERL */ |
4521
|
|
|
|
|
|
|
4522
|
2017
|
50
|
|
|
|
if (!TAINTING_get) |
4523
|
11934
|
|
|
|
|
S_incpush(aTHX_ STR_WITH_LEN("."), 0); |
4524
|
|
|
|
|
|
} |
4525
|
|
|
|
|
|
|
4526
|
|
|
|
|
|
#if defined(DOSISH) || defined(__SYMBIAN32__) |
4527
|
|
|
|
|
|
# define PERLLIB_SEP ';' |
4528
|
|
|
|
|
|
#else |
4529
|
|
|
|
|
|
# if defined(VMS) |
4530
|
|
|
|
|
|
# define PERLLIB_SEP '|' |
4531
|
|
|
|
|
|
# else |
4532
|
|
|
|
|
|
# define PERLLIB_SEP ':' |
4533
|
|
|
|
|
|
# endif |
4534
|
|
|
|
|
|
#endif |
4535
|
|
|
|
|
|
#ifndef PERLLIB_MANGLE |
4536
|
|
|
|
|
|
# define PERLLIB_MANGLE(s,n) (s) |
4537
|
|
|
|
|
|
#endif |
4538
|
|
|
|
|
|
|
4539
|
|
|
|
|
|
#ifndef PERL_IS_MINIPERL |
4540
|
|
|
|
|
|
/* Push a directory onto @INC if it exists. |
4541
|
|
|
|
|
|
Generate a new SV if we do this, to save needing to copy the SV we push |
4542
|
|
|
|
|
|
onto @INC */ |
4543
|
|
|
|
|
|
STATIC SV * |
4544
|
|
|
|
|
|
S_incpush_if_exists(pTHX_ AV *const av, SV *dir, SV *const stem) |
4545
|
|
|
|
|
|
{ |
4546
|
|
|
|
|
|
dVAR; |
4547
|
|
|
|
|
|
Stat_t tmpstatbuf; |
4548
|
|
|
|
|
|
|
4549
|
|
|
|
|
|
PERL_ARGS_ASSERT_INCPUSH_IF_EXISTS; |
4550
|
|
|
|
|
|
|
4551
|
|
|
|
|
|
if (PerlLIO_stat(SvPVX_const(dir), &tmpstatbuf) >= 0 && |
4552
|
|
|
|
|
|
S_ISDIR(tmpstatbuf.st_mode)) { |
4553
|
|
|
|
|
|
av_push(av, dir); |
4554
|
|
|
|
|
|
dir = newSVsv(stem); |
4555
|
|
|
|
|
|
} else { |
4556
|
|
|
|
|
|
/* Truncate dir back to stem. */ |
4557
|
|
|
|
|
|
SvCUR_set(dir, SvCUR(stem)); |
4558
|
|
|
|
|
|
} |
4559
|
|
|
|
|
|
return dir; |
4560
|
|
|
|
|
|
} |
4561
|
|
|
|
|
|
#endif |
4562
|
|
|
|
|
|
|
4563
|
|
|
|
|
|
STATIC SV * |
4564
|
712944
|
|
|
|
|
S_mayberelocate(pTHX_ const char *const dir, STRLEN len, U32 flags) |
4565
|
|
|
|
|
|
{ |
4566
|
712944
|
|
|
|
|
const U8 canrelocate = (U8)flags & INCPUSH_CAN_RELOCATE; |
4567
|
|
|
|
|
|
SV *libdir; |
4568
|
|
|
|
|
|
|
4569
|
|
|
|
|
|
PERL_ARGS_ASSERT_MAYBERELOCATE; |
4570
|
|
|
|
|
|
assert(len > 0); |
4571
|
|
|
|
|
|
|
4572
|
|
|
|
|
|
/* I am not convinced that this is valid when PERLLIB_MANGLE is |
4573
|
|
|
|
|
|
defined to so something (in os2/os2.c), but the code has been |
4574
|
|
|
|
|
|
this way, ignoring any possible changed of length, since |
4575
|
|
|
|
|
|
760ac839baf413929cd31cc32ffd6dba6b781a81 (5.003_02) so I'll leave |
4576
|
|
|
|
|
|
it be. */ |
4577
|
712944
|
|
|
|
|
libdir = newSVpvn(PERLLIB_MANGLE(dir, len), len); |
4578
|
|
|
|
|
|
|
4579
|
|
|
|
|
|
#ifdef VMS |
4580
|
|
|
|
|
|
{ |
4581
|
|
|
|
|
|
char *unix; |
4582
|
|
|
|
|
|
|
4583
|
|
|
|
|
|
if ((unix = tounixspec_ts(SvPV(libdir,len),NULL)) != NULL) { |
4584
|
|
|
|
|
|
len = strlen(unix); |
4585
|
|
|
|
|
|
while (unix[len-1] == '/') len--; /* Cosmetic */ |
4586
|
|
|
|
|
|
sv_usepvn(libdir,unix,len); |
4587
|
|
|
|
|
|
} |
4588
|
|
|
|
|
|
else |
4589
|
|
|
|
|
|
PerlIO_printf(Perl_error_log, |
4590
|
|
|
|
|
|
"Failed to unixify @INC element \"%s\"\n", |
4591
|
|
|
|
|
|
SvPV_nolen_const(libdir)); |
4592
|
|
|
|
|
|
} |
4593
|
|
|
|
|
|
#endif |
4594
|
|
|
|
|
|
|
4595
|
|
|
|
|
|
/* Do the if() outside the #ifdef to avoid warnings about an unused |
4596
|
|
|
|
|
|
parameter. */ |
4597
|
5044
|
50
|
|
|
|
if (canrelocate) { |
4598
|
|
|
|
|
|
#ifdef PERL_RELOCATABLE_INC |
4599
|
|
|
|
|
|
/* |
4600
|
|
|
|
|
|
* Relocatable include entries are marked with a leading .../ |
4601
|
|
|
|
|
|
* |
4602
|
|
|
|
|
|
* The algorithm is |
4603
|
|
|
|
|
|
* 0: Remove that leading ".../" |
4604
|
|
|
|
|
|
* 1: Remove trailing executable name (anything after the last '/') |
4605
|
|
|
|
|
|
* from the perl path to give a perl prefix |
4606
|
|
|
|
|
|
* Then |
4607
|
|
|
|
|
|
* While the @INC element starts "../" and the prefix ends with a real |
4608
|
|
|
|
|
|
* directory (ie not . or ..) chop that real directory off the prefix |
4609
|
|
|
|
|
|
* and the leading "../" from the @INC element. ie a logical "../" |
4610
|
|
|
|
|
|
* cleanup |
4611
|
|
|
|
|
|
* Finally concatenate the prefix and the remainder of the @INC element |
4612
|
|
|
|
|
|
* The intent is that /usr/local/bin/perl and .../../lib/perl5 |
4613
|
|
|
|
|
|
* generates /usr/local/lib/perl5 |
4614
|
|
|
|
|
|
*/ |
4615
|
707900
|
|
|
|
|
const char *libpath = SvPVX(libdir); |
4616
|
707900
|
|
|
|
|
STRLEN libpath_len = SvCUR(libdir); |
4617
|
707900
|
0
|
|
|
|
if (libpath_len >= 4 && memEQ (libpath, ".../", 4)) { |
|
|
0
|
|
|
|
|
4618
|
|
|
|
|
|
/* Game on! */ |
4619
|
0
|
|
|
|
|
SV * const caret_X = get_sv("\030", 0); |
4620
|
|
|
|
|
|
/* Going to use the SV just as a scratch buffer holding a C |
4621
|
|
|
|
|
|
string: */ |
4622
|
|
|
|
|
|
SV *prefix_sv; |
4623
|
|
|
|
|
|
char *prefix; |
4624
|
|
|
|
|
|
char *lastslash; |
4625
|
|
|
|
|
|
|
4626
|
|
|
|
|
|
/* $^X is *the* source of taint if tainting is on, hence |
4627
|
|
|
|
|
|
SvPOK() won't be true. */ |
4628
|
|
|
|
|
|
assert(caret_X); |
4629
|
|
|
|
|
|
assert(SvPOKp(caret_X)); |
4630
|
9917
|
|
|
|
|
prefix_sv = newSVpvn_flags(SvPVX(caret_X), SvCUR(caret_X), |
4631
|
|
|
|
|
|
SvUTF8(caret_X)); |
4632
|
|
|
|
|
|
/* Firstly take off the leading .../ |
4633
|
|
|
|
|
|
If all else fail we'll do the paths relative to the current |
4634
|
|
|
|
|
|
directory. */ |
4635
|
9917
|
|
|
|
|
sv_chop(libdir, libpath + 4); |
4636
|
|
|
|
|
|
/* Don't use SvPV as we're intentionally bypassing taining, |
4637
|
|
|
|
|
|
mortal copies that the mg_get of tainting creates, and |
4638
|
|
|
|
|
|
corruption that seems to come via the save stack. |
4639
|
|
|
|
|
|
I guess that the save stack isn't correctly set up yet. */ |
4640
|
6
|
|
|
|
|
libpath = SvPVX(libdir); |
4641
|
9917
|
|
|
|
|
libpath_len = SvCUR(libdir); |
4642
|
|
|
|
|
|
|
4643
|
|
|
|
|
|
/* This would work more efficiently with memrchr, but as it's |
4644
|
|
|
|
|
|
only a GNU extension we'd need to probe for it and |
4645
|
|
|
|
|
|
implement our own. Not hard, but maybe not worth it? */ |
4646
|
|
|
|
|
|
|
4647
|
9920
|
|
|
|
|
prefix = SvPVX(prefix_sv); |
4648
|
9920
|
|
|
|
|
lastslash = strrchr(prefix, '/'); |
4649
|
|
|
|
|
|
|
4650
|
|
|
|
|
|
/* First time in with the *lastslash = '\0' we just wipe off |
4651
|
|
|
|
|
|
the trailing /perl from (say) /usr/foo/bin/perl |
4652
|
|
|
|
|
|
*/ |
4653
|
9833
|
0
|
|
|
|
if (lastslash) { |
4654
|
|
|
|
|
|
SV *tempsv; |
4655
|
9833
|
0
|
|
|
|
while ((*lastslash = '\0'), /* Do that, come what may. */ |
|
|
0
|
|
|
|
|
4656
|
3671
|
0
|
|
|
|
(libpath_len >= 3 && memEQ(libpath, "../", 3) |
4657
|
6162
|
0
|
|
|
|
&& (lastslash = strrchr(prefix, '/')))) { |
4658
|
6162
|
0
|
|
|
|
if (lastslash[1] == '\0' |
4659
|
2
|
0
|
|
|
|
|| (lastslash[1] == '.' |
4660
|
9920
|
0
|
|
|
|
&& (lastslash[2] == '/' /* ends "/." */ |
4661
|
9920
|
0
|
|
|
|
|| (lastslash[2] == '/' |
4662
|
9920
|
0
|
|
|
|
&& lastslash[3] == '/' /* or "/.." */ |
4663
|
|
|
|
|
|
)))) { |
4664
|
|
|
|
|
|
/* Prefix ends "/" or "/." or "/..", any of which |
4665
|
|
|
|
|
|
are fishy, so don't do any more logical cleanup. |
4666
|
|
|
|
|
|
*/ |
4667
|
|
|
|
|
|
break; |
4668
|
|
|
|
|
|
} |
4669
|
|
|
|
|
|
/* Remove leading "../" from path */ |
4670
|
9920
|
|
|
|
|
libpath += 3; |
4671
|
9920
|
|
|
|
|
libpath_len -= 3; |
4672
|
|
|
|
|
|
/* Next iteration round the loop removes the last |
4673
|
|
|
|
|
|
directory name from prefix by writing a '\0' in |
4674
|
|
|
|
|
|
the while clause. */ |
4675
|
|
|
|
|
|
} |
4676
|
|
|
|
|
|
/* prefix has been terminated with a '\0' to the correct |
4677
|
|
|
|
|
|
length. libpath points somewhere into the libdir SV. |
4678
|
|
|
|
|
|
We need to join the 2 with '/' and drop the result into |
4679
|
|
|
|
|
|
libdir. */ |
4680
|
9920
|
|
|
|
|
tempsv = Perl_newSVpvf(aTHX_ "%s/%s", prefix, libpath); |
4681
|
9920
|
|
|
|
|
SvREFCNT_dec(libdir); |
4682
|
|
|
|
|
|
/* And this is the new libdir. */ |
4683
|
|
|
|
|
|
libdir = tempsv; |
4684
|
9833
|
|
|
|
|
if (TAINTING_get && |
4685
|
3671
|
0
|
|
|
|
(PerlProc_getuid() != PerlProc_geteuid() || |
4686
|
9920
|
|
|
|
|
PerlProc_getgid() != PerlProc_getegid())) { |
4687
|
|
|
|
|
|
/* Need to taint relocated paths if running set ID */ |
4688
|
9833
|
0
|
|
|
|
SvTAINTED_on(libdir); |
4689
|
|
|
|
|
|
} |
4690
|
|
|
|
|
|
} |
4691
|
9920
|
|
|
|
|
SvREFCNT_dec(prefix_sv); |
4692
|
|
|
|
|
|
} |
4693
|
|
|
|
|
|
#endif |
4694
|
|
|
|
|
|
} |
4695
|
57913
|
|
|
|
|
return libdir; |
4696
|
|
|
|
|
|
} |
4697
|
|
|
|
|
|
|
4698
|
|
|
|
|
|
STATIC void |
4699
|
130175
|
|
|
|
|
S_incpush(pTHX_ const char *const dir, STRLEN len, U32 flags) |
4700
|
|
|
|
|
|
{ |
4701
|
|
|
|
|
|
dVAR; |
4702
|
|
|
|
|
|
#ifndef PERL_IS_MINIPERL |
4703
|
|
|
|
|
|
const U8 using_sub_dirs |
4704
|
|
|
|
|
|
= (U8)flags & (INCPUSH_ADD_VERSIONED_SUB_DIRS |
4705
|
|
|
|
|
|
|INCPUSH_ADD_ARCHONLY_SUB_DIRS|INCPUSH_ADD_OLD_VERS); |
4706
|
|
|
|
|
|
const U8 add_versioned_sub_dirs |
4707
|
|
|
|
|
|
= (U8)flags & INCPUSH_ADD_VERSIONED_SUB_DIRS; |
4708
|
|
|
|
|
|
const U8 add_archonly_sub_dirs |
4709
|
|
|
|
|
|
= (U8)flags & INCPUSH_ADD_ARCHONLY_SUB_DIRS; |
4710
|
|
|
|
|
|
#ifdef PERL_INC_VERSION_LIST |
4711
|
|
|
|
|
|
const U8 addoldvers = (U8)flags & INCPUSH_ADD_OLD_VERS; |
4712
|
|
|
|
|
|
#endif |
4713
|
|
|
|
|
|
#endif |
4714
|
24437
|
|
|
|
|
const U8 unshift = (U8)flags & INCPUSH_UNSHIFT; |
4715
|
24437
|
|
|
|
|
const U8 push_basedir = (flags & INCPUSH_NOT_BASEDIR) ? 0 : 1; |
4716
|
24437
|
50
|
|
|
|
AV *const inc = GvAVn(PL_incgv); |
4717
|
|
|
|
|
|
|
4718
|
|
|
|
|
|
PERL_ARGS_ASSERT_INCPUSH; |
4719
|
|
|
|
|
|
assert(len > 0); |
4720
|
|
|
|
|
|
|
4721
|
|
|
|
|
|
/* Could remove this vestigial extra block, if we don't mind a lot of |
4722
|
|
|
|
|
|
re-indenting diff noise. */ |
4723
|
|
|
|
|
|
{ |
4724
|
38520
|
|
|
|
|
SV *const libdir = mayberelocate(dir, len, flags); |
4725
|
|
|
|
|
|
/* Change 20189146be79a0596543441fa369c6bf7f85103f, to fix RT#6665, |
4726
|
|
|
|
|
|
arranged to unshift #! line -I onto the front of @INC. However, |
4727
|
|
|
|
|
|
-I can add version and architecture specific libraries, and they |
4728
|
|
|
|
|
|
need to go first. The old code assumed that it was always |
4729
|
|
|
|
|
|
pushing. Hence to make it work, need to push the architecture |
4730
|
|
|
|
|
|
(etc) libraries onto a temporary array, then "unshift" that onto |
4731
|
|
|
|
|
|
the front of @INC. */ |
4732
|
|
|
|
|
|
#ifndef PERL_IS_MINIPERL |
4733
|
|
|
|
|
|
AV *const av = (using_sub_dirs) ? (unshift ? newAV() : inc) : NULL; |
4734
|
|
|
|
|
|
|
4735
|
|
|
|
|
|
/* |
4736
|
|
|
|
|
|
* BEFORE pushing libdir onto @INC we may first push version- and |
4737
|
|
|
|
|
|
* archname-specific sub-directories. |
4738
|
|
|
|
|
|
*/ |
4739
|
|
|
|
|
|
if (using_sub_dirs) { |
4740
|
|
|
|
|
|
SV *subdir = newSVsv(libdir); |
4741
|
|
|
|
|
|
#ifdef PERL_INC_VERSION_LIST |
4742
|
|
|
|
|
|
/* Configure terminates PERL_INC_VERSION_LIST with a NULL */ |
4743
|
|
|
|
|
|
const char * const incverlist[] = { PERL_INC_VERSION_LIST }; |
4744
|
|
|
|
|
|
const char * const *incver; |
4745
|
|
|
|
|
|
#endif |
4746
|
|
|
|
|
|
|
4747
|
|
|
|
|
|
if (add_versioned_sub_dirs) { |
4748
|
|
|
|
|
|
/* .../version/archname if -d .../version/archname */ |
4749
|
|
|
|
|
|
sv_catpvs(subdir, "/" PERL_FS_VERSION "/" ARCHNAME); |
4750
|
|
|
|
|
|
subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir); |
4751
|
|
|
|
|
|
|
4752
|
|
|
|
|
|
/* .../version if -d .../version */ |
4753
|
|
|
|
|
|
sv_catpvs(subdir, "/" PERL_FS_VERSION); |
4754
|
|
|
|
|
|
subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir); |
4755
|
|
|
|
|
|
} |
4756
|
|
|
|
|
|
|
4757
|
|
|
|
|
|
#ifdef PERL_INC_VERSION_LIST |
4758
|
|
|
|
|
|
if (addoldvers) { |
4759
|
|
|
|
|
|
for (incver = incverlist; *incver; incver++) { |
4760
|
|
|
|
|
|
/* .../xxx if -d .../xxx */ |
4761
|
|
|
|
|
|
Perl_sv_catpvf(aTHX_ subdir, "/%s", *incver); |
4762
|
|
|
|
|
|
subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir); |
4763
|
|
|
|
|
|
} |
4764
|
|
|
|
|
|
} |
4765
|
|
|
|
|
|
#endif |
4766
|
|
|
|
|
|
|
4767
|
|
|
|
|
|
if (add_archonly_sub_dirs) { |
4768
|
|
|
|
|
|
/* .../archname if -d .../archname */ |
4769
|
|
|
|
|
|
sv_catpvs(subdir, "/" ARCHNAME); |
4770
|
|
|
|
|
|
subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir); |
4771
|
|
|
|
|
|
|
4772
|
|
|
|
|
|
} |
4773
|
|
|
|
|
|
|
4774
|
|
|
|
|
|
assert (SvREFCNT(subdir) == 1); |
4775
|
|
|
|
|
|
SvREFCNT_dec(subdir); |
4776
|
|
|
|
|
|
} |
4777
|
|
|
|
|
|
#endif /* !PERL_IS_MINIPERL */ |
4778
|
|
|
|
|
|
/* finally add this lib directory at the end of @INC */ |
4779
|
57913
|
50
|
|
|
|
if (unshift) { |
4780
|
|
|
|
|
|
#ifdef PERL_IS_MINIPERL |
4781
|
|
|
|
|
|
const Size_t extra = 0; |
4782
|
|
|
|
|
|
#else |
4783
|
|
|
|
|
|
Size_t extra = av_len(av) + 1; |
4784
|
|
|
|
|
|
#endif |
4785
|
96349
|
|
|
|
|
av_unshift(inc, extra + push_basedir); |
4786
|
96349
|
0
|
|
|
|
if (push_basedir) |
4787
|
96349
|
|
|
|
|
av_store(inc, extra, libdir); |
4788
|
|
|
|
|
|
#ifndef PERL_IS_MINIPERL |
4789
|
|
|
|
|
|
while (extra--) { |
4790
|
|
|
|
|
|
/* av owns a reference, av_store() expects to be donated a |
4791
|
|
|
|
|
|
reference, and av expects to be sane when it's cleared. |
4792
|
|
|
|
|
|
If I wanted to be naughty and wrong, I could peek inside the |
4793
|
|
|
|
|
|
implementation of av_clear(), realise that it uses |
4794
|
|
|
|
|
|
SvREFCNT_dec() too, so av's array could be a run of NULLs, |
4795
|
|
|
|
|
|
and so directly steal from it (with a memcpy() to inc, and |
4796
|
|
|
|
|
|
then memset() to NULL them out. But people copy code from the |
4797
|
|
|
|
|
|
core expecting it to be best practise, so let's use the API. |
4798
|
|
|
|
|
|
Although studious readers will note that I'm not checking any |
4799
|
|
|
|
|
|
return codes. */ |
4800
|
|
|
|
|
|
av_store(inc, extra, SvREFCNT_inc(*av_fetch(av, extra, FALSE))); |
4801
|
|
|
|
|
|
} |
4802
|
|
|
|
|
|
SvREFCNT_dec(av); |
4803
|
|
|
|
|
|
#endif |
4804
|
|
|
|
|
|
} |
4805
|
101393
|
50
|
|
|
|
else if (push_basedir) { |
4806
|
64564
|
|
|
|
|
av_push(inc, libdir); |
4807
|
|
|
|
|
|
} |
4808
|
|
|
|
|
|
|
4809
|
64564
|
50
|
|
|
|
if (!push_basedir) { |
4810
|
|
|
|
|
|
assert (SvREFCNT(libdir) == 1); |
4811
|
59520
|
|
|
|
|
SvREFCNT_dec(libdir); |
4812
|
|
|
|
|
|
} |
4813
|
|
|
|
|
|
} |
4814
|
5044
|
|
|
|
|
} |
4815
|
|
|
|
|
|
|
4816
|
|
|
|
|
|
STATIC void |
4817
|
0
|
|
|
|
|
S_incpush_use_sep(pTHX_ const char *p, STRLEN len, U32 flags) |
4818
|
|
|
|
|
|
{ |
4819
|
|
|
|
|
|
const char *s; |
4820
|
|
|
|
|
|
const char *end; |
4821
|
|
|
|
|
|
/* This logic has been broken out from S_incpush(). It may be possible to |
4822
|
|
|
|
|
|
simplify it. */ |
4823
|
|
|
|
|
|
|
4824
|
|
|
|
|
|
PERL_ARGS_ASSERT_INCPUSH_USE_SEP; |
4825
|
|
|
|
|
|
|
4826
|
|
|
|
|
|
/* perl compiled with -DPERL_RELOCATABLE_INCPUSH will ignore the len |
4827
|
|
|
|
|
|
* argument to incpush_use_sep. This allows creation of relocatable |
4828
|
|
|
|
|
|
* Perl distributions that patch the binary at install time. Those |
4829
|
|
|
|
|
|
* distributions will have to provide their own relocation tools; this |
4830
|
|
|
|
|
|
* is not a feature otherwise supported by core Perl. |
4831
|
|
|
|
|
|
*/ |
4832
|
|
|
|
|
|
#ifndef PERL_RELOCATABLE_INCPUSH |
4833
|
0
|
0
|
|
|
|
if (!len) |
4834
|
|
|
|
|
|
#endif |
4835
|
0
|
|
|
|
|
len = strlen(p); |
4836
|
|
|
|
|
|
|
4837
|
0
|
|
|
|
|
end = p + len; |
4838
|
|
|
|
|
|
|
4839
|
|
|
|
|
|
/* Break at all separators */ |
4840
|
0
|
0
|
|
|
|
while ((s = (const char*)memchr(p, PERLLIB_SEP, end - p))) { |
4841
|
0
|
0
|
|
|
|
if (s == p) { |
4842
|
|
|
|
|
|
/* skip any consecutive separators */ |
4843
|
|
|
|
|
|
|
4844
|
|
|
|
|
|
/* Uncomment the next line for PATH semantics */ |
4845
|
|
|
|
|
|
/* But you'll need to write tests */ |
4846
|
|
|
|
|
|
/* av_push(GvAVn(PL_incgv), newSVpvs(".")); */ |
4847
|
|
|
|
|
|
} else { |
4848
|
0
|
|
|
|
|
incpush(p, (STRLEN)(s - p), flags); |
4849
|
|
|
|
|
|
} |
4850
|
0
|
|
|
|
|
p = s + 1; |
4851
|
|
|
|
|
|
} |
4852
|
0
|
0
|
|
|
|
if (p != end) |
4853
|
0
|
|
|
|
|
incpush(p, (STRLEN)(end - p), flags); |
4854
|
|
|
|
|
|
|
4855
|
0
|
|
|
|
|
} |
4856
|
|
|
|
|
|
|
4857
|
|
|
|
|
|
void |
4858
|
211071
|
|
|
|
|
Perl_call_list(pTHX_ I32 oldscope, AV *paramList) |
4859
|
|
|
|
|
|
{ |
4860
|
|
|
|
|
|
dVAR; |
4861
|
|
|
|
|
|
SV *atsv; |
4862
|
211071
|
50
|
|
|
|
volatile const line_t oldline = PL_curcop ? CopLINE(PL_curcop) : 0; |
4863
|
|
|
|
|
|
CV *cv; |
4864
|
|
|
|
|
|
STRLEN len; |
4865
|
|
|
|
|
|
int ret; |
4866
|
|
|
|
|
|
dJMPENV; |
4867
|
|
|
|
|
|
|
4868
|
|
|
|
|
|
PERL_ARGS_ASSERT_CALL_LIST; |
4869
|
|
|
|
|
|
|
4870
|
372960
|
100
|
|
|
|
while (av_len(paramList) >= 0) { |
4871
|
162315
|
|
|
|
|
cv = MUTABLE_CV(av_shift(paramList)); |
4872
|
162315
|
50
|
|
|
|
if (PL_savebegin) { |
4873
|
0
|
0
|
|
|
|
if (paramList == PL_beginav) { |
4874
|
|
|
|
|
|
/* save PL_beginav for compiler */ |
4875
|
0
|
|
|
|
|
Perl_av_create_and_push(aTHX_ &PL_beginav_save, MUTABLE_SV(cv)); |
4876
|
|
|
|
|
|
} |
4877
|
0
|
0
|
|
|
|
else if (paramList == PL_checkav) { |
4878
|
|
|
|
|
|
/* save PL_checkav for compiler */ |
4879
|
0
|
|
|
|
|
Perl_av_create_and_push(aTHX_ &PL_checkav_save, MUTABLE_SV(cv)); |
4880
|
|
|
|
|
|
} |
4881
|
0
|
0
|
|
|
|
else if (paramList == PL_unitcheckav) { |
4882
|
|
|
|
|
|
/* save PL_unitcheckav for compiler */ |
4883
|
0
|
|
|
|
|
Perl_av_create_and_push(aTHX_ &PL_unitcheckav_save, MUTABLE_SV(cv)); |
4884
|
|
|
|
|
|
} |
4885
|
|
|
|
|
|
} else { |
4886
|
|
|
|
|
|
if (!PL_madskills) |
4887
|
162315
|
|
|
|
|
SAVEFREESV(cv); |
4888
|
|
|
|
|
|
} |
4889
|
162315
|
|
|
|
|
JMPENV_PUSH(ret); |
4890
|
258664
|
|
|
|
|
switch (ret) { |
4891
|
|
|
|
|
|
case 0: |
4892
|
|
|
|
|
|
#ifdef PERL_MAD |
4893
|
|
|
|
|
|
if (PL_madskills) |
4894
|
|
|
|
|
|
PL_madskills |= 16384; |
4895
|
|
|
|
|
|
#endif |
4896
|
258664
|
50
|
|
|
|
CALL_LIST_BODY(cv); |
4897
|
|
|
|
|
|
#ifdef PERL_MAD |
4898
|
|
|
|
|
|
if (PL_madskills) |
4899
|
|
|
|
|
|
PL_madskills &= ~16384; |
4900
|
|
|
|
|
|
#endif |
4901
|
258664
|
50
|
|
|
|
atsv = ERRSV; |
4902
|
258664
|
50
|
|
|
|
(void)SvPV_const(atsv, len); |
4903
|
258664
|
100
|
|
|
|
if (len) { |
4904
|
96775
|
|
|
|
|
PL_curcop = &PL_compiling; |
4905
|
96775
|
|
|
|
|
CopLINE_set(PL_curcop, oldline); |
4906
|
96775
|
50
|
|
|
|
if (paramList == PL_beginav) |
4907
|
96775
|
|
|
|
|
sv_catpvs(atsv, "BEGIN failed--compilation aborted"); |
4908
|
|
|
|
|
|
else |
4909
|
96349
|
0
|
|
|
|
Perl_sv_catpvf(aTHX_ atsv, |
4910
|
|
|
|
|
|
"%s failed--call queue aborted", |
4911
|
|
|
|
|
|
paramList == PL_checkav ? "CHECK" |
4912
|
96349
|
|
|
|
|
: paramList == PL_initav ? "INIT" |
4913
|
96349
|
0
|
|
|
|
: paramList == PL_unitcheckav ? "UNITCHECK" |
4914
|
96349
|
0
|
|
|
|
: "END"); |
4915
|
97201
|
100
|
|
|
|
while (PL_scopestack_ix > oldscope) |
4916
|
27418
|
|
|
|
|
LEAVE; |
4917
|
27418
|
|
|
|
|
JMPENV_POP; |
4918
|
18049
|
|
|
|
|
Perl_croak(aTHX_ "%"SVf"", SVfARG(atsv)); |
4919
|
|
|
|
|
|
} |
4920
|
|
|
|
|
|
break; |
4921
|
|
|
|
|
|
case 1: |
4922
|
17623
|
|
|
|
|
STATUS_ALL_FAILURE; |
4923
|
|
|
|
|
|
/* FALL THROUGH */ |
4924
|
|
|
|
|
|
case 2: |
4925
|
|
|
|
|
|
/* my_exit() was called */ |
4926
|
17623
|
0
|
|
|
|
while (PL_scopestack_ix > oldscope) |
4927
|
17623
|
|
|
|
|
LEAVE; |
4928
|
26992
|
0
|
|
|
|
FREETMPS; |
4929
|
17623
|
0
|
|
|
|
SET_CURSTASH(PL_defstash); |
4930
|
17623
|
|
|
|
|
PL_curcop = &PL_compiling; |
4931
|
26992
|
|
|
|
|
CopLINE_set(PL_curcop, oldline); |
4932
|
96349
|
|
|
|
|
JMPENV_POP; |
4933
|
15
|
|
|
|
|
my_exit_jump(); |
4934
|
|
|
|
|
|
assert(0); /* NOTREACHED */ |
4935
|
|
|
|
|
|
case 3: |
4936
|
15
|
0
|
|
|
|
if (PL_restartop) { |
4937
|
15
|
|
|
|
|
PL_curcop = &PL_compiling; |
4938
|
15
|
|
|
|
|
CopLINE_set(PL_curcop, oldline); |
4939
|
15
|
0
|
|
|
|
JMPENV_JUMP(3); |
4940
|
|
|
|
|
|
} |
4941
|
0
|
0
|
|
|
|
PerlIO_printf(Perl_error_log, "panic: restartop in call_list\n"); |
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
4942
|
15
|
0
|
|
|
|
FREETMPS; |
4943
|
|
|
|
|
|
break; |
4944
|
|
|
|
|
|
} |
4945
|
258223
|
|
|
|
|
JMPENV_POP; |
4946
|
|
|
|
|
|
} |
4947
|
297610
|
|
|
|
|
} |
4948
|
|
|
|
|
|
|
4949
|
|
|
|
|
|
void |
4950
|
98366
|
|
|
|
|
Perl_my_exit(pTHX_ U32 status) |
4951
|
|
|
|
|
|
{ |
4952
|
|
|
|
|
|
dVAR; |
4953
|
11386
|
50
|
|
|
|
if (PL_exit_flags & PERL_EXIT_ABORT) { |
4954
|
96349
|
|
|
|
|
abort(); |
4955
|
|
|
|
|
|
} |
4956
|
68881
|
50
|
|
|
|
if (PL_exit_flags & PERL_EXIT_WARN) { |
4957
|
66864
|
|
|
|
|
PL_exit_flags |= PERL_EXIT_ABORT; /* Protect against reentrant calls */ |
4958
|
7344
|
|
|
|
|
Perl_warn(aTHX_ "Unexpected exit %u", status); |
4959
|
66864
|
|
|
|
|
PL_exit_flags &= ~PERL_EXIT_ABORT; |
4960
|
|
|
|
|
|
} |
4961
|
147731
|
|
|
|
|
switch (status) { |
4962
|
|
|
|
|
|
case 0: |
4963
|
14003
|
|
|
|
|
STATUS_ALL_SUCCESS; |
4964
|
13975
|
|
|
|
|
break; |
4965
|
|
|
|
|
|
case 1: |
4966
|
11986
|
|
|
|
|
STATUS_ALL_FAILURE; |
4967
|
66864
|
|
|
|
|
break; |
4968
|
|
|
|
|
|
default: |
4969
|
66304
|
0
|
|
|
|
STATUS_EXIT_SET(status); |
4970
|
|
|
|
|
|
break; |
4971
|
|
|
|
|
|
} |
4972
|
68881
|
|
|
|
|
my_exit_jump(); |
4973
|
|
|
|
|
|
} |
4974
|
|
|
|
|
|
|
4975
|
|
|
|
|
|
void |
4976
|
4387168
|
|
|
|
|
Perl_my_failure_exit(pTHX) |
4977
|
|
|
|
|
|
{ |
4978
|
|
|
|
|
|
dVAR; |
4979
|
|
|
|
|
|
#ifdef VMS |
4980
|
|
|
|
|
|
/* We have been called to fall on our sword. The desired exit code |
4981
|
|
|
|
|
|
* should be already set in STATUS_UNIX, but could be shifted over |
4982
|
|
|
|
|
|
* by 8 bits. STATUS_UNIX_EXIT_SET will handle the cases where a |
4983
|
|
|
|
|
|
* that code is set. |
4984
|
|
|
|
|
|
* |
4985
|
|
|
|
|
|
* If an error code has not been set, then force the issue. |
4986
|
|
|
|
|
|
*/ |
4987
|
|
|
|
|
|
if (MY_POSIX_EXIT) { |
4988
|
|
|
|
|
|
|
4989
|
|
|
|
|
|
/* According to the die_exit.t tests, if errno is non-zero */ |
4990
|
|
|
|
|
|
/* It should be used for the error status. */ |
4991
|
|
|
|
|
|
|
4992
|
|
|
|
|
|
if (errno == EVMSERR) { |
4993
|
|
|
|
|
|
STATUS_NATIVE = vaxc$errno; |
4994
|
|
|
|
|
|
} else { |
4995
|
|
|
|
|
|
|
4996
|
|
|
|
|
|
/* According to die_exit.t tests, if the child_exit code is */ |
4997
|
|
|
|
|
|
/* also zero, then we need to exit with a code of 255 */ |
4998
|
|
|
|
|
|
if ((errno != 0) && (errno < 256)) |
4999
|
|
|
|
|
|
STATUS_UNIX_EXIT_SET(errno); |
5000
|
|
|
|
|
|
else if (STATUS_UNIX < 255) { |
5001
|
|
|
|
|
|
STATUS_UNIX_EXIT_SET(255); |
5002
|
|
|
|
|
|
} |
5003
|
|
|
|
|
|
|
5004
|
|
|
|
|
|
} |
5005
|
|
|
|
|
|
|
5006
|
|
|
|
|
|
/* The exit code could have been set by $? or vmsish which |
5007
|
|
|
|
|
|
* means that it may not have fatal set. So convert |
5008
|
|
|
|
|
|
* success/warning codes to fatal with out changing |
5009
|
|
|
|
|
|
* the POSIX status code. The severity makes VMS native |
5010
|
|
|
|
|
|
* status handling work, while UNIX mode programs use the |
5011
|
|
|
|
|
|
* the POSIX exit codes. |
5012
|
|
|
|
|
|
*/ |
5013
|
|
|
|
|
|
if ((STATUS_NATIVE & (STS$K_SEVERE|STS$K_ERROR)) == 0) { |
5014
|
|
|
|
|
|
STATUS_NATIVE &= STS$M_COND_ID; |
5015
|
|
|
|
|
|
STATUS_NATIVE |= STS$K_ERROR | STS$M_INHIB_MSG; |
5016
|
|
|
|
|
|
} |
5017
|
|
|
|
|
|
} |
5018
|
|
|
|
|
|
else { |
5019
|
|
|
|
|
|
/* Traditionally Perl on VMS always expects a Fatal Error. */ |
5020
|
|
|
|
|
|
if (vaxc$errno & 1) { |
5021
|
|
|
|
|
|
|
5022
|
|
|
|
|
|
/* So force success status to failure */ |
5023
|
|
|
|
|
|
if (STATUS_NATIVE & 1) |
5024
|
|
|
|
|
|
STATUS_ALL_FAILURE; |
5025
|
|
|
|
|
|
} |
5026
|
|
|
|
|
|
else { |
5027
|
|
|
|
|
|
if (!vaxc$errno) { |
5028
|
|
|
|
|
|
STATUS_UNIX = EINTR; /* In case something cares */ |
5029
|
|
|
|
|
|
STATUS_ALL_FAILURE; |
5030
|
|
|
|
|
|
} |
5031
|
|
|
|
|
|
else { |
5032
|
|
|
|
|
|
int severity; |
5033
|
|
|
|
|
|
STATUS_NATIVE = vaxc$errno; /* Should already be this */ |
5034
|
|
|
|
|
|
|
5035
|
|
|
|
|
|
/* Encode the severity code */ |
5036
|
|
|
|
|
|
severity = STATUS_NATIVE & STS$M_SEVERITY; |
5037
|
|
|
|
|
|
STATUS_UNIX = (severity ? severity : 1) << 8; |
5038
|
|
|
|
|
|
|
5039
|
|
|
|
|
|
/* Perl expects this to be a fatal error */ |
5040
|
|
|
|
|
|
if (severity != STS$K_SEVERE) |
5041
|
|
|
|
|
|
STATUS_ALL_FAILURE; |
5042
|
|
|
|
|
|
} |
5043
|
|
|
|
|
|
} |
5044
|
|
|
|
|
|
} |
5045
|
|
|
|
|
|
|
5046
|
|
|
|
|
|
#else |
5047
|
|
|
|
|
|
int exitstatus; |
5048
|
4387168
|
0
|
|
|
|
if (errno & 255) |
5049
|
11057000
|
0
|
|
|
|
STATUS_UNIX_SET(errno); |
5050
|
|
|
|
|
|
else { |
5051
|
2295169
|
|
|
|
|
exitstatus = STATUS_UNIX >> 8; |
5052
|
2295169
|
0
|
|
|
|
if (exitstatus & 255) |
5053
|
1374942
|
0
|
|
|
|
STATUS_UNIX_SET(exitstatus); |
5054
|
|
|
|
|
|
else |
5055
|
1353213
|
0
|
|
|
|
STATUS_UNIX_SET(255); |
5056
|
|
|
|
|
|
} |
5057
|
|
|
|
|
|
#endif |
5058
|
21729
|
0
|
|
|
|
if (PL_exit_flags & PERL_EXIT_ABORT) { |
5059
|
4859
|
|
|
|
|
abort(); |
5060
|
|
|
|
|
|
} |
5061
|
16870
|
0
|
|
|
|
if (PL_exit_flags & PERL_EXIT_WARN) { |
5062
|
175
|
|
|
|
|
PL_exit_flags |= PERL_EXIT_ABORT; /* Protect against reentrant calls */ |
5063
|
920227
|
|
|
|
|
Perl_warn(aTHX_ "Unexpected exit failure %u", PL_statusvalue); |
5064
|
2295169
|
|
|
|
|
PL_exit_flags &= ~PERL_EXIT_ABORT; |
5065
|
|
|
|
|
|
} |
5066
|
2295295
|
|
|
|
|
my_exit_jump(); |
5067
|
|
|
|
|
|
} |
5068
|
|
|
|
|
|
|
5069
|
|
|
|
|
|
STATIC void |
5070
|
2297186
|
|
|
|
|
S_my_exit_jump(pTHX) |
5071
|
|
|
|
|
|
{ |
5072
|
|
|
|
|
|
dVAR; |
5073
|
|
|
|
|
|
|
5074
|
2297060
|
50
|
|
|
|
if (PL_e_script) { |
5075
|
2295043
|
|
|
|
|
SvREFCNT_dec(PL_e_script); |
5076
|
2297060
|
|
|
|
|
PL_e_script = NULL; |
5077
|
|
|
|
|
|
} |
5078
|
|
|
|
|
|
|
5079
|
14396
|
0
|
|
|
|
POPSTACK_TO(PL_mainstack); |
|
|
50
|
|
|
|
|
5080
|
14396
|
|
|
|
|
dounwind(-1); |
5081
|
14396
|
100
|
|
|
|
LEAVE_SCOPE(0); |
5082
|
|
|
|
|
|
|
5083
|
14368
|
50
|
|
|
|
JMPENV_JUMP(2); |
5084
|
|
|
|
|
|
} |
5085
|
|
|
|
|
|
|
5086
|
|
|
|
|
|
static I32 |
5087
|
2502
|
|
|
|
|
read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen) |
5088
|
|
|
|
|
|
{ |
5089
|
|
|
|
|
|
dVAR; |
5090
|
2474
|
|
|
|
|
const char * const p = SvPVX_const(PL_e_script); |
5091
|
2446
|
|
|
|
|
const char *nl = strchr(p, '\n'); |
5092
|
|
|
|
|
|
|
5093
|
|
|
|
|
|
PERL_UNUSED_ARG(idx); |
5094
|
|
|
|
|
|
PERL_UNUSED_ARG(maxlen); |
5095
|
|
|
|
|
|
|
5096
|
2446
|
100
|
|
|
|
nl = (nl) ? nl+1 : SvEND(PL_e_script); |
5097
|
27176
|
100
|
|
|
|
if (nl-p == 0) { |
5098
|
13574
|
|
|
|
|
filter_del(read_e_script); |
5099
|
13602
|
|
|
|
|
return 0; |
5100
|
|
|
|
|
|
} |
5101
|
13602
|
|
|
|
|
sv_catpvn(buf_sv, p, nl-p); |
5102
|
1223
|
|
|
|
|
sv_chop(PL_e_script, nl); |
5103
|
3539
|
|
|
|
|
return 1; |
5104
|
2984
|
|
|
|
|
} |
5105
|
|
|
|
|
|
|
5106
|
|
|
|
|
|
/* |
5107
|
|
|
|
|
|
* Local variables: |
5108
|
|
|
|
|
|
* c-indentation-style: bsd |
5109
|
|
|
|
|
|
* c-basic-offset: 4 |
5110
|
|
|
|
|
|
* indent-tabs-mode: nil |
5111
|
|
|
|
|
|
* End: |
5112
|
|
|
|
|
|
* |
5113
|
|
|
|
|
|
* ex: set ts=8 sts=4 sw=4 et: |
5114
|
|
|
|
|
|
*/ |