line |
stmt |
bran |
cond |
sub |
time |
code |
1
|
|
|
|
|
|
/* util.c |
2
|
|
|
|
|
|
* |
3
|
|
|
|
|
|
* Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, |
4
|
|
|
|
|
|
* 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others |
5
|
|
|
|
|
|
* |
6
|
|
|
|
|
|
* You may distribute under the terms of either the GNU General Public |
7
|
|
|
|
|
|
* License or the Artistic License, as specified in the README file. |
8
|
|
|
|
|
|
* |
9
|
|
|
|
|
|
*/ |
10
|
|
|
|
|
|
|
11
|
|
|
|
|
|
/* |
12
|
|
|
|
|
|
* 'Very useful, no doubt, that was to Saruman; yet it seems that he was |
13
|
|
|
|
|
|
* not content.' --Gandalf to Pippin |
14
|
|
|
|
|
|
* |
15
|
|
|
|
|
|
* [p.598 of _The Lord of the Rings_, III/xi: "The PalantÃr"] |
16
|
|
|
|
|
|
*/ |
17
|
|
|
|
|
|
|
18
|
|
|
|
|
|
/* This file contains assorted utility routines. |
19
|
|
|
|
|
|
* Which is a polite way of saying any stuff that people couldn't think of |
20
|
|
|
|
|
|
* a better place for. Amongst other things, it includes the warning and |
21
|
|
|
|
|
|
* dieing stuff, plus wrappers for malloc code. |
22
|
|
|
|
|
|
*/ |
23
|
|
|
|
|
|
|
24
|
720628194
|
|
|
|
|
#include "EXTERN.h" |
25
|
|
|
|
|
|
#define PERL_IN_UTIL_C |
26
|
|
|
|
|
|
#include "perl.h" |
27
|
|
|
|
|
|
#include "reentr.h" |
28
|
|
|
|
|
|
|
29
|
720628194
|
0
|
|
|
|
#ifdef USE_PERLIO |
30
|
|
|
|
|
|
#include "perliol.h" /* For PerlIOUnix_refcnt */ |
31
|
|
|
|
|
|
#endif |
32
|
|
|
|
|
|
|
33
|
|
|
|
|
|
#ifndef PERL_MICRO |
34
|
|
|
|
|
|
#include |
35
|
720628194
|
0
|
|
|
|
#ifndef SIG_ERR |
36
|
|
|
|
|
|
# define SIG_ERR ((Sighandler_t) -1) |
37
|
|
|
|
|
|
#endif |
38
|
0
|
|
|
|
|
#endif |
39
|
0
|
|
|
|
|
|
40
|
|
|
|
|
|
#ifdef __Lynx__ |
41
|
|
|
|
|
|
/* Missing protos on LynxOS */ |
42
|
|
|
|
|
|
int putenv(char *); |
43
|
|
|
|
|
|
#endif |
44
|
|
|
|
|
|
|
45
|
|
|
|
|
|
#ifdef HAS_SELECT |
46
|
|
|
|
|
|
# ifdef I_SYS_SELECT |
47
|
|
|
|
|
|
# include |
48
|
128868813
|
|
|
|
|
# endif |
49
|
|
|
|
|
|
#endif |
50
|
|
|
|
|
|
|
51
|
|
|
|
|
|
#define FLUSH |
52
|
|
|
|
|
|
|
53
|
128868813
|
0
|
|
|
|
#if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC) |
54
|
|
|
|
|
|
# define FD_CLOEXEC 1 /* NeXT needs this */ |
55
|
|
|
|
|
|
#endif |
56
|
|
|
|
|
|
|
57
|
|
|
|
|
|
/* NOTE: Do not call the next three routines directly. Use the macros |
58
|
|
|
|
|
|
* in handy.h, so that we can easily redefine everything to do tracking of |
59
|
|
|
|
|
|
* allocated hunks back to the original New to track down any memory leaks. |
60
|
0
|
0
|
|
|
|
* XXX This advice seems to be widely ignored :-( --AD August 1996. |
61
|
|
|
|
|
|
*/ |
62
|
|
|
|
|
|
|
63
|
0
|
|
|
|
|
#if defined (DEBUGGING) || defined(PERL_IMPLICIT_SYS) || defined (PERL_TRACK_MEMPOOL) |
64
|
128868813
|
|
|
|
|
# define ALWAYS_NEED_THX |
65
|
|
|
|
|
|
#endif |
66
|
|
|
|
|
|
|
67
|
|
|
|
|
|
/* paranoid version of system's malloc() */ |
68
|
|
|
|
|
|
|
69
|
|
|
|
|
|
Malloc_t |
70
|
|
|
|
|
|
Perl_safesysmalloc(MEM_SIZE size) |
71
|
|
|
|
|
|
{ |
72
|
|
|
|
|
|
#ifdef ALWAYS_NEED_THX |
73
|
2632172
|
|
|
|
|
dTHX; |
74
|
|
|
|
|
|
#endif |
75
|
|
|
|
|
|
Malloc_t ptr; |
76
|
|
|
|
|
|
#ifdef HAS_64K_LIMIT |
77
|
|
|
|
|
|
if (size > 0xffff) { |
78
|
|
|
|
|
|
PerlIO_printf(Perl_error_log, |
79
|
126236641
|
|
|
|
|
"Allocation too large: %lx\n", size) FLUSH; |
80
|
126236641
|
|
|
|
|
my_exit(1); |
81
|
|
|
|
|
|
} |
82
|
|
|
|
|
|
#endif /* HAS_64K_LIMIT */ |
83
|
|
|
|
|
|
#ifdef PERL_TRACK_MEMPOOL |
84
|
|
|
|
|
|
size += sTHX; |
85
|
0
|
|
|
|
|
#endif |
86
|
|
|
|
|
|
#ifdef DEBUGGING |
87
|
0
|
0
|
|
|
|
if ((SSize_t)size < 0) |
88
|
879720991
|
0
|
|
|
|
Perl_croak_nocontext("panic: malloc, size=%"UVuf, (UV) size); |
89
|
879720991
|
0
|
|
|
|
#endif |
90
|
725861983
|
|
|
|
|
ptr = (Malloc_t)PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */ |
91
|
879720991
|
0
|
|
|
|
PERL_ALLOC_CHECK(ptr); |
92
|
159188279
|
|
|
|
|
if (ptr != NULL) { |
93
|
|
|
|
|
|
#ifdef PERL_TRACK_MEMPOOL |
94
|
159188279
|
0
|
|
|
|
struct perl_memory_debug_header *const header |
95
|
|
|
|
|
|
= (struct perl_memory_debug_header *)ptr; |
96
|
159188279
|
|
|
|
|
#endif |
97
|
|
|
|
|
|
|
98
|
159188279
|
|
|
|
|
#ifdef PERL_POISON |
99
|
0
|
|
|
|
|
PoisonNew(((char *)ptr), size, char); |
100
|
|
|
|
|
|
#endif |
101
|
|
|
|
|
|
|
102
|
|
|
|
|
|
#ifdef PERL_TRACK_MEMPOOL |
103
|
|
|
|
|
|
header->interpreter = aTHX; |
104
|
159188279
|
|
|
|
|
/* Link us into the list. */ |
105
|
|
|
|
|
|
header->prev = &PL_memory_debug_header; |
106
|
0
|
0
|
|
|
|
header->next = PL_memory_debug_header.next; |
107
|
0
|
0
|
|
|
|
PL_memory_debug_header.next = header; |
108
|
0
|
|
|
|
|
header->next->prev = header; |
109
|
0
|
0
|
|
|
|
# ifdef PERL_POISON |
110
|
0
|
|
|
|
|
header->size = size; |
111
|
0
|
0
|
|
|
|
# endif |
112
|
|
|
|
|
|
ptr = (Malloc_t)((char*)ptr+sTHX); |
113
|
0
|
|
|
|
|
#endif |
114
|
|
|
|
|
|
DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size)); |
115
|
0
|
|
|
|
|
return ptr; |
116
|
0
|
|
|
|
|
} |
117
|
|
|
|
|
|
else { |
118
|
|
|
|
|
|
#ifndef ALWAYS_NEED_THX |
119
|
|
|
|
|
|
dTHX; |
120
|
|
|
|
|
|
#endif |
121
|
|
|
|
|
|
if (PL_nomemok) |
122
|
0
|
|
|
|
|
return NULL; |
123
|
|
|
|
|
|
else { |
124
|
|
|
|
|
|
croak_no_mem(); |
125
|
|
|
|
|
|
} |
126
|
|
|
|
|
|
} |
127
|
0
|
0
|
|
|
|
/*NOTREACHED*/ |
128
|
186772
|
0
|
|
|
|
} |
129
|
1109928
|
0
|
|
|
|
|
130
|
|
|
|
|
|
/* paranoid version of system's realloc() */ |
131
|
1109925
|
0
|
|
|
|
|
132
|
|
|
|
|
|
Malloc_t |
133
|
|
|
|
|
|
Perl_safesysrealloc(Malloc_t where,MEM_SIZE size) |
134
|
0
|
0
|
|
|
|
{ |
135
|
|
|
|
|
|
#ifdef ALWAYS_NEED_THX |
136
|
|
|
|
|
|
dTHX; |
137
|
|
|
|
|
|
#endif |
138
|
|
|
|
|
|
Malloc_t ptr; |
139
|
|
|
|
|
|
#if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) && !defined(PERL_MICRO) |
140
|
|
|
|
|
|
Malloc_t PerlMem_realloc(); |
141
|
|
|
|
|
|
#endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */ |
142
|
|
|
|
|
|
|
143
|
0
|
|
|
|
|
#ifdef HAS_64K_LIMIT |
144
|
|
|
|
|
|
if (size > 0xffff) { |
145
|
0
|
|
|
|
|
PerlIO_printf(Perl_error_log, |
146
|
|
|
|
|
|
"Reallocation too large: %lx\n", size) FLUSH; |
147
|
|
|
|
|
|
my_exit(1); |
148
|
0
|
|
|
|
|
} |
149
|
|
|
|
|
|
#endif /* HAS_64K_LIMIT */ |
150
|
|
|
|
|
|
if (!size) { |
151
|
|
|
|
|
|
safesysfree(where); |
152
|
|
|
|
|
|
return NULL; |
153
|
|
|
|
|
|
} |
154
|
0
|
|
|
|
|
|
155
|
|
|
|
|
|
if (!where) |
156
|
1109925
|
0
|
|
|
|
return safesysmalloc(size); |
157
|
923156
|
0
|
|
|
|
#ifdef PERL_TRACK_MEMPOOL |
158
|
923156
|
|
|
|
|
where = (Malloc_t)((char*)where-sTHX); |
159
|
|
|
|
|
|
size += sTHX; |
160
|
186772
|
|
|
|
|
{ |
161
|
186772
|
|
|
|
|
struct perl_memory_debug_header *const header |
162
|
|
|
|
|
|
= (struct perl_memory_debug_header *)where; |
163
|
186772
|
|
|
|
|
|
164
|
|
|
|
|
|
if (header->interpreter != aTHX) { |
165
|
|
|
|
|
|
Perl_croak_nocontext("panic: realloc from wrong pool, %p!=%p", |
166
|
186772
|
|
|
|
|
header->interpreter, aTHX); |
167
|
|
|
|
|
|
} |
168
|
|
|
|
|
|
assert(header->next->prev == header); |
169
|
|
|
|
|
|
assert(header->prev->next == header); |
170
|
|
|
|
|
|
# ifdef PERL_POISON |
171
|
4363
|
|
|
|
|
if (header->size > size) { |
172
|
4363
|
|
|
|
|
const MEM_SIZE freed_up = header->size - size; |
173
|
4363
|
|
|
|
|
char *start_of_freed = ((char *)where) + size; |
174
|
|
|
|
|
|
PoisonFree(start_of_freed, freed_up, char); |
175
|
|
|
|
|
|
} |
176
|
|
|
|
|
|
header->size = size; |
177
|
44937
|
|
|
|
|
# endif |
178
|
|
|
|
|
|
} |
179
|
|
|
|
|
|
#endif |
180
|
|
|
|
|
|
#ifdef DEBUGGING |
181
|
|
|
|
|
|
if ((SSize_t)size < 0) |
182
|
|
|
|
|
|
Perl_croak_nocontext("panic: realloc, size=%"UVuf, (UV)size); |
183
|
|
|
|
|
|
#endif |
184
|
44937
|
|
|
|
|
ptr = (Malloc_t)PerlMem_realloc(where,size); |
185
|
|
|
|
|
|
PERL_ALLOC_CHECK(ptr); |
186
|
|
|
|
|
|
|
187
|
|
|
|
|
|
/* MUST do this fixup first, before doing ANYTHING else, as anything else |
188
|
|
|
|
|
|
might allocate memory/free/move memory, and until we do the fixup, it |
189
|
44937
|
|
|
|
|
may well be chasing (and writing to) free memory. */ |
190
|
44937
|
|
|
|
|
#ifdef PERL_TRACK_MEMPOOL |
191
|
2144121520
|
|
|
|
|
if (ptr != NULL) { |
192
|
|
|
|
|
|
struct perl_memory_debug_header *const header |
193
|
|
|
|
|
|
= (struct perl_memory_debug_header *)ptr; |
194
|
|
|
|
|
|
|
195
|
2144077497
|
|
|
|
|
# ifdef PERL_POISON |
196
|
|
|
|
|
|
if (header->size < size) { |
197
|
|
|
|
|
|
const MEM_SIZE fresh = size - header->size; |
198
|
|
|
|
|
|
char *start_of_fresh = ((char *)ptr) + size; |
199
|
|
|
|
|
|
PoisonNew(start_of_fresh, fresh, char); |
200
|
|
|
|
|
|
} |
201
|
|
|
|
|
|
# endif |
202
|
|
|
|
|
|
|
203
|
|
|
|
|
|
header->next->prev = header; |
204
|
|
|
|
|
|
header->prev->next = header; |
205
|
|
|
|
|
|
|
206
|
|
|
|
|
|
ptr = (Malloc_t)((char*)ptr+sTHX); |
207
|
|
|
|
|
|
} |
208
|
|
|
|
|
|
#endif |
209
|
|
|
|
|
|
|
210
|
|
|
|
|
|
/* In particular, must do that fixup above before logging anything via |
211
|
|
|
|
|
|
*printf(), as it can reallocate memory, which can cause SEGVs. */ |
212
|
|
|
|
|
|
|
213
|
|
|
|
|
|
DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++)); |
214
|
|
|
|
|
|
DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size)); |
215
|
|
|
|
|
|
|
216
|
|
|
|
|
|
|
217
|
|
|
|
|
|
if (ptr != NULL) { |
218
|
|
|
|
|
|
return ptr; |
219
|
|
|
|
|
|
} |
220
|
|
|
|
|
|
else { |
221
|
|
|
|
|
|
#ifndef ALWAYS_NEED_THX |
222
|
|
|
|
|
|
dTHX; |
223
|
|
|
|
|
|
#endif |
224
|
|
|
|
|
|
if (PL_nomemok) |
225
|
|
|
|
|
|
return NULL; |
226
|
|
|
|
|
|
else { |
227
|
|
|
|
|
|
croak_no_mem(); |
228
|
|
|
|
|
|
} |
229
|
|
|
|
|
|
} |
230
|
|
|
|
|
|
/*NOTREACHED*/ |
231
|
|
|
|
|
|
} |
232
|
|
|
|
|
|
|
233
|
|
|
|
|
|
/* safe version of system's free() */ |
234
|
|
|
|
|
|
|
235
|
|
|
|
|
|
Free_t |
236
|
|
|
|
|
|
Perl_safesysfree(Malloc_t where) |
237
|
|
|
|
|
|
{ |
238
|
|
|
|
|
|
#ifdef ALWAYS_NEED_THX |
239
|
|
|
|
|
|
dTHX; |
240
|
|
|
|
|
|
#else |
241
|
|
|
|
|
|
dVAR; |
242
|
|
|
|
|
|
#endif |
243
|
|
|
|
|
|
DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) free\n",PTR2UV(where),(long)PL_an++)); |
244
|
|
|
|
|
|
if (where) { |
245
|
|
|
|
|
|
#ifdef PERL_TRACK_MEMPOOL |
246
|
|
|
|
|
|
where = (Malloc_t)((char*)where-sTHX); |
247
|
|
|
|
|
|
{ |
248
|
|
|
|
|
|
struct perl_memory_debug_header *const header |
249
|
|
|
|
|
|
= (struct perl_memory_debug_header *)where; |
250
|
|
|
|
|
|
|
251
|
|
|
|
|
|
if (header->interpreter != aTHX) { |
252
|
|
|
|
|
|
Perl_croak_nocontext("panic: free from wrong pool, %p!=%p", |
253
|
|
|
|
|
|
header->interpreter, aTHX); |
254
|
|
|
|
|
|
} |
255
|
|
|
|
|
|
if (!header->prev) { |
256
|
|
|
|
|
|
Perl_croak_nocontext("panic: duplicate free"); |
257
|
|
|
|
|
|
} |
258
|
|
|
|
|
|
if (!(header->next)) |
259
|
|
|
|
|
|
Perl_croak_nocontext("panic: bad free, header->next==NULL"); |
260
|
|
|
|
|
|
if (header->next->prev != header || header->prev->next != header) { |
261
|
|
|
|
|
|
Perl_croak_nocontext("panic: bad free, ->next->prev=%p, " |
262
|
|
|
|
|
|
"header=%p, ->prev->next=%p", |
263
|
|
|
|
|
|
header->next->prev, header, |
264
|
|
|
|
|
|
header->prev->next); |
265
|
|
|
|
|
|
} |
266
|
|
|
|
|
|
/* Unlink us from the chain. */ |
267
|
|
|
|
|
|
header->next->prev = header->prev; |
268
|
|
|
|
|
|
header->prev->next = header->next; |
269
|
|
|
|
|
|
# ifdef PERL_POISON |
270
|
|
|
|
|
|
PoisonNew(where, header->size, char); |
271
|
|
|
|
|
|
# endif |
272
|
|
|
|
|
|
/* Trigger the duplicate free warning. */ |
273
|
|
|
|
|
|
header->next = NULL; |
274
|
|
|
|
|
|
} |
275
|
|
|
|
|
|
#endif |
276
|
|
|
|
|
|
PerlMem_free(where); |
277
|
|
|
|
|
|
} |
278
|
|
|
|
|
|
} |
279
|
|
|
|
|
|
|
280
|
|
|
|
|
|
/* safe version of system's calloc() */ |
281
|
|
|
|
|
|
|
282
|
|
|
|
|
|
Malloc_t |
283
|
|
|
|
|
|
Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size) |
284
|
|
|
|
|
|
{ |
285
|
|
|
|
|
|
#ifdef ALWAYS_NEED_THX |
286
|
|
|
|
|
|
dTHX; |
287
|
|
|
|
|
|
#endif |
288
|
|
|
|
|
|
Malloc_t ptr; |
289
|
|
|
|
|
|
#if defined(PERL_TRACK_MEMPOOL) || defined(HAS_64K_LIMIT) || defined(DEBUGGING) |
290
|
|
|
|
|
|
MEM_SIZE total_size = 0; |
291
|
|
|
|
|
|
#endif |
292
|
|
|
|
|
|
|
293
|
|
|
|
|
|
/* Even though calloc() for zero bytes is strange, be robust. */ |
294
|
|
|
|
|
|
if (size && (count <= MEM_SIZE_MAX / size)) { |
295
|
|
|
|
|
|
#if defined(PERL_TRACK_MEMPOOL) || defined(HAS_64K_LIMIT) || defined(DEBUGGING) |
296
|
|
|
|
|
|
total_size = size * count; |
297
|
|
|
|
|
|
#endif |
298
|
|
|
|
|
|
} |
299
|
|
|
|
|
|
else |
300
|
|
|
|
|
|
croak_memory_wrap(); |
301
|
|
|
|
|
|
#ifdef PERL_TRACK_MEMPOOL |
302
|
|
|
|
|
|
if (sTHX <= MEM_SIZE_MAX - (MEM_SIZE)total_size) |
303
|
|
|
|
|
|
total_size += sTHX; |
304
|
|
|
|
|
|
else |
305
|
|
|
|
|
|
croak_memory_wrap(); |
306
|
|
|
|
|
|
#endif |
307
|
|
|
|
|
|
#ifdef HAS_64K_LIMIT |
308
|
|
|
|
|
|
if (total_size > 0xffff) { |
309
|
|
|
|
|
|
PerlIO_printf(Perl_error_log, |
310
|
|
|
|
|
|
"Allocation too large: %lx\n", total_size) FLUSH; |
311
|
|
|
|
|
|
my_exit(1); |
312
|
|
|
|
|
|
} |
313
|
|
|
|
|
|
#endif /* HAS_64K_LIMIT */ |
314
|
|
|
|
|
|
#ifdef DEBUGGING |
315
|
|
|
|
|
|
if ((SSize_t)size < 0 || (SSize_t)count < 0) |
316
|
|
|
|
|
|
Perl_croak_nocontext("panic: calloc, size=%"UVuf", count=%"UVuf, |
317
|
|
|
|
|
|
(UV)size, (UV)count); |
318
|
|
|
|
|
|
#endif |
319
|
|
|
|
|
|
#ifdef PERL_TRACK_MEMPOOL |
320
|
|
|
|
|
|
/* Have to use malloc() because we've added some space for our tracking |
321
|
|
|
|
|
|
header. */ |
322
|
|
|
|
|
|
/* malloc(0) is non-portable. */ |
323
|
|
|
|
|
|
ptr = (Malloc_t)PerlMem_malloc(total_size ? total_size : 1); |
324
|
|
|
|
|
|
#else |
325
|
|
|
|
|
|
/* Use calloc() because it might save a memset() if the memory is fresh |
326
|
|
|
|
|
|
and clean from the OS. */ |
327
|
|
|
|
|
|
if (count && size) |
328
|
|
|
|
|
|
ptr = (Malloc_t)PerlMem_calloc(count, size); |
329
|
|
|
|
|
|
else /* calloc(0) is non-portable. */ |
330
|
|
|
|
|
|
ptr = (Malloc_t)PerlMem_calloc(count ? count : 1, size ? size : 1); |
331
|
|
|
|
|
|
#endif |
332
|
|
|
|
|
|
PERL_ALLOC_CHECK(ptr); |
333
|
|
|
|
|
|
DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) calloc %ld x %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)count,(long)total_size)); |
334
|
|
|
|
|
|
if (ptr != NULL) { |
335
|
|
|
|
|
|
#ifdef PERL_TRACK_MEMPOOL |
336
|
|
|
|
|
|
{ |
337
|
|
|
|
|
|
struct perl_memory_debug_header *const header |
338
|
|
|
|
|
|
= (struct perl_memory_debug_header *)ptr; |
339
|
|
|
|
|
|
|
340
|
|
|
|
|
|
memset((void*)ptr, 0, total_size); |
341
|
|
|
|
|
|
header->interpreter = aTHX; |
342
|
|
|
|
|
|
/* Link us into the list. */ |
343
|
|
|
|
|
|
header->prev = &PL_memory_debug_header; |
344
|
|
|
|
|
|
header->next = PL_memory_debug_header.next; |
345
|
|
|
|
|
|
PL_memory_debug_header.next = header; |
346
|
|
|
|
|
|
header->next->prev = header; |
347
|
|
|
|
|
|
# ifdef PERL_POISON |
348
|
|
|
|
|
|
header->size = total_size; |
349
|
|
|
|
|
|
# endif |
350
|
|
|
|
|
|
ptr = (Malloc_t)((char*)ptr+sTHX); |
351
|
|
|
|
|
|
} |
352
|
|
|
|
|
|
#endif |
353
|
|
|
|
|
|
return ptr; |
354
|
|
|
|
|
|
} |
355
|
|
|
|
|
|
else { |
356
|
|
|
|
|
|
#ifndef ALWAYS_NEED_THX |
357
|
|
|
|
|
|
dTHX; |
358
|
|
|
|
|
|
#endif |
359
|
|
|
|
|
|
if (PL_nomemok) |
360
|
|
|
|
|
|
return NULL; |
361
|
|
|
|
|
|
croak_no_mem(); |
362
|
|
|
|
|
|
} |
363
|
|
|
|
|
|
} |
364
|
|
|
|
|
|
|
365
|
|
|
|
|
|
/* These must be defined when not using Perl's malloc for binary |
366
|
|
|
|
|
|
* compatibility */ |
367
|
|
|
|
|
|
|
368
|
|
|
|
|
|
#ifndef MYMALLOC |
369
|
|
|
|
|
|
|
370
|
|
|
|
|
|
Malloc_t Perl_malloc (MEM_SIZE nbytes) |
371
|
|
|
|
|
|
{ |
372
|
|
|
|
|
|
dTHXs; |
373
|
|
|
|
|
|
return (Malloc_t)PerlMem_malloc(nbytes); |
374
|
|
|
|
|
|
} |
375
|
|
|
|
|
|
|
376
|
|
|
|
|
|
Malloc_t Perl_calloc (MEM_SIZE elements, MEM_SIZE size) |
377
|
|
|
|
|
|
{ |
378
|
|
|
|
|
|
dTHXs; |
379
|
|
|
|
|
|
return (Malloc_t)PerlMem_calloc(elements, size); |
380
|
|
|
|
|
|
} |
381
|
|
|
|
|
|
|
382
|
|
|
|
|
|
Malloc_t Perl_realloc (Malloc_t where, MEM_SIZE nbytes) |
383
|
|
|
|
|
|
{ |
384
|
|
|
|
|
|
dTHXs; |
385
|
|
|
|
|
|
return (Malloc_t)PerlMem_realloc(where, nbytes); |
386
|
|
|
|
|
|
} |
387
|
|
|
|
|
|
|
388
|
|
|
|
|
|
Free_t Perl_mfree (Malloc_t where) |
389
|
|
|
|
|
|
{ |
390
|
|
|
|
|
|
dTHXs; |
391
|
|
|
|
|
|
PerlMem_free(where); |
392
|
|
|
|
|
|
} |
393
|
|
|
|
|
|
|
394
|
|
|
|
|
|
#endif |
395
|
|
|
|
|
|
|
396
|
|
|
|
|
|
/* copy a string up to some (non-backslashed) delimiter, if any */ |
397
|
|
|
|
|
|
|
398
|
|
|
|
|
|
char * |
399
|
|
|
|
|
|
Perl_delimcpy(char *to, const char *toend, const char *from, const char *fromend, int delim, I32 *retlen) |
400
|
|
|
|
|
|
{ |
401
|
|
|
|
|
|
I32 tolen; |
402
|
|
|
|
|
|
|
403
|
|
|
|
|
|
PERL_ARGS_ASSERT_DELIMCPY; |
404
|
|
|
|
|
|
|
405
|
|
|
|
|
|
for (tolen = 0; from < fromend; from++, tolen++) { |
406
|
|
|
|
|
|
if (*from == '\\') { |
407
|
|
|
|
|
|
if (from[1] != delim) { |
408
|
|
|
|
|
|
if (to < toend) |
409
|
|
|
|
|
|
*to++ = *from; |
410
|
|
|
|
|
|
tolen++; |
411
|
|
|
|
|
|
} |
412
|
|
|
|
|
|
from++; |
413
|
|
|
|
|
|
} |
414
|
|
|
|
|
|
else if (*from == delim) |
415
|
|
|
|
|
|
break; |
416
|
|
|
|
|
|
if (to < toend) |
417
|
|
|
|
|
|
*to++ = *from; |
418
|
|
|
|
|
|
} |
419
|
|
|
|
|
|
if (to < toend) |
420
|
|
|
|
|
|
*to = '\0'; |
421
|
|
|
|
|
|
*retlen = tolen; |
422
|
|
|
|
|
|
return (char *)from; |
423
|
|
|
|
|
|
} |
424
|
|
|
|
|
|
|
425
|
|
|
|
|
|
/* return ptr to little string in big string, NULL if not found */ |
426
|
|
|
|
|
|
/* This routine was donated by Corey Satten. */ |
427
|
|
|
|
|
|
|
428
|
|
|
|
|
|
char * |
429
|
|
|
|
|
|
Perl_instr(const char *big, const char *little) |
430
|
|
|
|
|
|
{ |
431
|
|
|
|
|
|
|
432
|
|
|
|
|
|
PERL_ARGS_ASSERT_INSTR; |
433
|
|
|
|
|
|
|
434
|
|
|
|
|
|
/* libc prior to 4.6.27 did not work properly on a NULL 'little' */ |
435
|
|
|
|
|
|
if (!little) |
436
|
|
|
|
|
|
return (char*)big; |
437
|
|
|
|
|
|
return strstr((char*)big, (char*)little); |
438
|
|
|
|
|
|
} |
439
|
|
|
|
|
|
|
440
|
|
|
|
|
|
/* same as instr but allow embedded nulls. The end pointers point to 1 beyond |
441
|
|
|
|
|
|
* the final character desired to be checked */ |
442
|
|
|
|
|
|
|
443
|
|
|
|
|
|
char * |
444
|
|
|
|
|
|
Perl_ninstr(const char *big, const char *bigend, const char *little, const char *lend) |
445
|
|
|
|
|
|
{ |
446
|
|
|
|
|
|
PERL_ARGS_ASSERT_NINSTR; |
447
|
|
|
|
|
|
if (little >= lend) |
448
|
|
|
|
|
|
return (char*)big; |
449
|
|
|
|
|
|
{ |
450
|
|
|
|
|
|
const char first = *little; |
451
|
|
|
|
|
|
const char *s, *x; |
452
|
|
|
|
|
|
bigend -= lend - little++; |
453
|
|
|
|
|
|
OUTER: |
454
|
|
|
|
|
|
while (big <= bigend) { |
455
|
|
|
|
|
|
if (*big++ == first) { |
456
|
|
|
|
|
|
for (x=big,s=little; s < lend; x++,s++) { |
457
|
|
|
|
|
|
if (*s != *x) |
458
|
|
|
|
|
|
goto OUTER; |
459
|
|
|
|
|
|
} |
460
|
|
|
|
|
|
return (char*)(big-1); |
461
|
|
|
|
|
|
} |
462
|
|
|
|
|
|
} |
463
|
|
|
|
|
|
} |
464
|
|
|
|
|
|
return NULL; |
465
|
|
|
|
|
|
} |
466
|
|
|
|
|
|
|
467
|
|
|
|
|
|
/* reverse of the above--find last substring */ |
468
|
|
|
|
|
|
|
469
|
|
|
|
|
|
char * |
470
|
|
|
|
|
|
Perl_rninstr(const char *big, const char *bigend, const char *little, const char *lend) |
471
|
|
|
|
|
|
{ |
472
|
|
|
|
|
|
const char *bigbeg; |
473
|
|
|
|
|
|
const I32 first = *little; |
474
|
|
|
|
|
|
const char * const littleend = lend; |
475
|
|
|
|
|
|
|
476
|
|
|
|
|
|
PERL_ARGS_ASSERT_RNINSTR; |
477
|
|
|
|
|
|
|
478
|
|
|
|
|
|
if (little >= littleend) |
479
|
|
|
|
|
|
return (char*)bigend; |
480
|
|
|
|
|
|
bigbeg = big; |
481
|
|
|
|
|
|
big = bigend - (littleend - little++); |
482
|
|
|
|
|
|
while (big >= bigbeg) { |
483
|
|
|
|
|
|
const char *s, *x; |
484
|
|
|
|
|
|
if (*big-- != first) |
485
|
|
|
|
|
|
continue; |
486
|
|
|
|
|
|
for (x=big+2,s=little; s < littleend; /**/ ) { |
487
|
|
|
|
|
|
if (*s != *x) |
488
|
|
|
|
|
|
break; |
489
|
|
|
|
|
|
else { |
490
|
|
|
|
|
|
x++; |
491
|
|
|
|
|
|
s++; |
492
|
|
|
|
|
|
} |
493
|
|
|
|
|
|
} |
494
|
|
|
|
|
|
if (s >= littleend) |
495
|
|
|
|
|
|
return (char*)(big+1); |
496
|
|
|
|
|
|
} |
497
|
|
|
|
|
|
return NULL; |
498
|
|
|
|
|
|
} |
499
|
|
|
|
|
|
|
500
|
|
|
|
|
|
/* As a space optimization, we do not compile tables for strings of length |
501
|
|
|
|
|
|
0 and 1, and for strings of length 2 unless FBMcf_TAIL. These are |
502
|
|
|
|
|
|
special-cased in fbm_instr(). |
503
|
|
|
|
|
|
|
504
|
|
|
|
|
|
If FBMcf_TAIL, the table is created as if the string has a trailing \n. */ |
505
|
|
|
|
|
|
|
506
|
|
|
|
|
|
/* |
507
|
|
|
|
|
|
=head1 Miscellaneous Functions |
508
|
|
|
|
|
|
|
509
|
|
|
|
|
|
=for apidoc fbm_compile |
510
|
|
|
|
|
|
|
511
|
|
|
|
|
|
Analyses the string in order to make fast searches on it using fbm_instr() |
512
|
|
|
|
|
|
-- the Boyer-Moore algorithm. |
513
|
|
|
|
|
|
|
514
|
|
|
|
|
|
=cut |
515
|
|
|
|
|
|
*/ |
516
|
|
|
|
|
|
|
517
|
|
|
|
|
|
void |
518
|
|
|
|
|
|
Perl_fbm_compile(pTHX_ SV *sv, U32 flags) |
519
|
|
|
|
|
|
{ |
520
|
|
|
|
|
|
dVAR; |
521
|
|
|
|
|
|
const U8 *s; |
522
|
|
|
|
|
|
STRLEN i; |
523
|
|
|
|
|
|
STRLEN len; |
524
|
|
|
|
|
|
U32 frequency = 256; |
525
|
|
|
|
|
|
MAGIC *mg; |
526
|
|
|
|
|
|
PERL_DEB( STRLEN rarest = 0 ); |
527
|
|
|
|
|
|
|
528
|
|
|
|
|
|
PERL_ARGS_ASSERT_FBM_COMPILE; |
529
|
|
|
|
|
|
|
530
|
|
|
|
|
|
if (isGV_with_GP(sv) || SvROK(sv)) |
531
|
|
|
|
|
|
return; |
532
|
|
|
|
|
|
|
533
|
|
|
|
|
|
if (SvVALID(sv)) |
534
|
|
|
|
|
|
return; |
535
|
|
|
|
|
|
|
536
|
|
|
|
|
|
if (flags & FBMcf_TAIL) { |
537
|
|
|
|
|
|
MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL; |
538
|
|
|
|
|
|
sv_catpvs(sv, "\n"); /* Taken into account in fbm_instr() */ |
539
|
|
|
|
|
|
if (mg && mg->mg_len >= 0) |
540
|
|
|
|
|
|
mg->mg_len++; |
541
|
|
|
|
|
|
} |
542
|
|
|
|
|
|
if (!SvPOK(sv) || SvNIOKp(sv)) |
543
|
|
|
|
|
|
s = (U8*)SvPV_force_mutable(sv, len); |
544
|
|
|
|
|
|
else s = (U8 *)SvPV_mutable(sv, len); |
545
|
|
|
|
|
|
if (len == 0) /* TAIL might be on a zero-length string. */ |
546
|
|
|
|
|
|
return; |
547
|
|
|
|
|
|
SvUPGRADE(sv, SVt_PVMG); |
548
|
|
|
|
|
|
SvIOK_off(sv); |
549
|
|
|
|
|
|
SvNOK_off(sv); |
550
|
|
|
|
|
|
SvVALID_on(sv); |
551
|
|
|
|
|
|
|
552
|
|
|
|
|
|
/* "deep magic", the comment used to add. The use of MAGIC itself isn't |
553
|
|
|
|
|
|
really. MAGIC was originally added in 79072805bf63abe5 (perl 5.0 alpha 2) |
554
|
|
|
|
|
|
to call SvVALID_off() if the scalar was assigned to. |
555
|
|
|
|
|
|
|
556
|
|
|
|
|
|
The comment itself (and "deeper magic" below) date back to |
557
|
|
|
|
|
|
378cc40b38293ffc (perl 2.0). "deep magic" was an annotation on |
558
|
|
|
|
|
|
str->str_pok |= 2; |
559
|
|
|
|
|
|
where the magic (presumably) was that the scalar had a BM table hidden |
560
|
|
|
|
|
|
inside itself. |
561
|
|
|
|
|
|
|
562
|
|
|
|
|
|
As MAGIC is always present on BMs [in Perl 5 :-)], we can use it to store |
563
|
|
|
|
|
|
the table instead of the previous (somewhat hacky) approach of co-opting |
564
|
|
|
|
|
|
the string buffer and storing it after the string. */ |
565
|
|
|
|
|
|
|
566
|
|
|
|
|
|
assert(!mg_find(sv, PERL_MAGIC_bm)); |
567
|
|
|
|
|
|
mg = sv_magicext(sv, NULL, PERL_MAGIC_bm, &PL_vtbl_bm, NULL, 0); |
568
|
|
|
|
|
|
assert(mg); |
569
|
|
|
|
|
|
|
570
|
|
|
|
|
|
if (len > 2) { |
571
|
|
|
|
|
|
/* Shorter strings are special-cased in Perl_fbm_instr(), and don't use |
572
|
|
|
|
|
|
the BM table. */ |
573
|
|
|
|
|
|
const U8 mlen = (len>255) ? 255 : (U8)len; |
574
|
|
|
|
|
|
const unsigned char *const sb = s + len - mlen; /* first char (maybe) */ |
575
|
|
|
|
|
|
U8 *table; |
576
|
|
|
|
|
|
|
577
|
|
|
|
|
|
Newx(table, 256, U8); |
578
|
|
|
|
|
|
memset((void*)table, mlen, 256); |
579
|
|
|
|
|
|
mg->mg_ptr = (char *)table; |
580
|
|
|
|
|
|
mg->mg_len = 256; |
581
|
|
|
|
|
|
|
582
|
|
|
|
|
|
s += len - 1; /* last char */ |
583
|
|
|
|
|
|
i = 0; |
584
|
|
|
|
|
|
while (s >= sb) { |
585
|
|
|
|
|
|
if (table[*s] == mlen) |
586
|
|
|
|
|
|
table[*s] = (U8)i; |
587
|
|
|
|
|
|
s--, i++; |
588
|
|
|
|
|
|
} |
589
|
|
|
|
|
|
} |
590
|
|
|
|
|
|
|
591
|
|
|
|
|
|
s = (const unsigned char*)(SvPVX_const(sv)); /* deeper magic */ |
592
|
|
|
|
|
|
for (i = 0; i < len; i++) { |
593
|
|
|
|
|
|
if (PL_freq[s[i]] < frequency) { |
594
|
|
|
|
|
|
PERL_DEB( rarest = i ); |
595
|
|
|
|
|
|
frequency = PL_freq[s[i]]; |
596
|
|
|
|
|
|
} |
597
|
|
|
|
|
|
} |
598
|
|
|
|
|
|
BmUSEFUL(sv) = 100; /* Initial value */ |
599
|
|
|
|
|
|
if (flags & FBMcf_TAIL) |
600
|
|
|
|
|
|
SvTAIL_on(sv); |
601
|
|
|
|
|
|
DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %"UVuf"\n", |
602
|
|
|
|
|
|
s[rarest], (UV)rarest)); |
603
|
|
|
|
|
|
} |
604
|
|
|
|
|
|
|
605
|
|
|
|
|
|
/* If SvTAIL(littlestr), it has a fake '\n' at end. */ |
606
|
|
|
|
|
|
/* If SvTAIL is actually due to \Z or \z, this gives false positives |
607
|
|
|
|
|
|
if multiline */ |
608
|
|
|
|
|
|
|
609
|
|
|
|
|
|
/* |
610
|
|
|
|
|
|
=for apidoc fbm_instr |
611
|
|
|
|
|
|
|
612
|
|
|
|
|
|
Returns the location of the SV in the string delimited by C and |
613
|
|
|
|
|
|
C. It returns C if the string can't be found. The C |
614
|
|
|
|
|
|
does not have to be fbm_compiled, but the search will not be as fast |
615
|
|
|
|
|
|
then. |
616
|
|
|
|
|
|
|
617
|
|
|
|
|
|
=cut |
618
|
|
|
|
|
|
*/ |
619
|
|
|
|
|
|
|
620
|
|
|
|
|
|
char * |
621
|
|
|
|
|
|
Perl_fbm_instr(pTHX_ unsigned char *big, unsigned char *bigend, SV *littlestr, U32 flags) |
622
|
|
|
|
|
|
{ |
623
|
|
|
|
|
|
unsigned char *s; |
624
|
|
|
|
|
|
STRLEN l; |
625
|
|
|
|
|
|
const unsigned char *little = (const unsigned char *)SvPV_const(littlestr,l); |
626
|
|
|
|
|
|
STRLEN littlelen = l; |
627
|
|
|
|
|
|
const I32 multiline = flags & FBMrf_MULTILINE; |
628
|
|
|
|
|
|
|
629
|
|
|
|
|
|
PERL_ARGS_ASSERT_FBM_INSTR; |
630
|
|
|
|
|
|
|
631
|
|
|
|
|
|
if ((STRLEN)(bigend - big) < littlelen) { |
632
|
|
|
|
|
|
if ( SvTAIL(littlestr) |
633
|
|
|
|
|
|
&& ((STRLEN)(bigend - big) == littlelen - 1) |
634
|
|
|
|
|
|
&& (littlelen == 1 |
635
|
|
|
|
|
|
|| (*big == *little && |
636
|
|
|
|
|
|
memEQ((char *)big, (char *)little, littlelen - 1)))) |
637
|
|
|
|
|
|
return (char*)big; |
638
|
|
|
|
|
|
return NULL; |
639
|
|
|
|
|
|
} |
640
|
|
|
|
|
|
|
641
|
|
|
|
|
|
switch (littlelen) { /* Special cases for 0, 1 and 2 */ |
642
|
|
|
|
|
|
case 0: |
643
|
|
|
|
|
|
return (char*)big; /* Cannot be SvTAIL! */ |
644
|
|
|
|
|
|
case 1: |
645
|
|
|
|
|
|
if (SvTAIL(littlestr) && !multiline) { /* Anchor only! */ |
646
|
|
|
|
|
|
/* Know that bigend != big. */ |
647
|
|
|
|
|
|
if (bigend[-1] == '\n') |
648
|
|
|
|
|
|
return (char *)(bigend - 1); |
649
|
|
|
|
|
|
return (char *) bigend; |
650
|
|
|
|
|
|
} |
651
|
|
|
|
|
|
s = big; |
652
|
|
|
|
|
|
while (s < bigend) { |
653
|
|
|
|
|
|
if (*s == *little) |
654
|
|
|
|
|
|
return (char *)s; |
655
|
|
|
|
|
|
s++; |
656
|
|
|
|
|
|
} |
657
|
|
|
|
|
|
if (SvTAIL(littlestr)) |
658
|
|
|
|
|
|
return (char *) bigend; |
659
|
|
|
|
|
|
return NULL; |
660
|
|
|
|
|
|
case 2: |
661
|
|
|
|
|
|
if (SvTAIL(littlestr) && !multiline) { |
662
|
|
|
|
|
|
if (bigend[-1] == '\n' && bigend[-2] == *little) |
663
|
|
|
|
|
|
return (char*)bigend - 2; |
664
|
|
|
|
|
|
if (bigend[-1] == *little) |
665
|
|
|
|
|
|
return (char*)bigend - 1; |
666
|
|
|
|
|
|
return NULL; |
667
|
|
|
|
|
|
} |
668
|
|
|
|
|
|
{ |
669
|
|
|
|
|
|
/* This should be better than FBM if c1 == c2, and almost |
670
|
|
|
|
|
|
as good otherwise: maybe better since we do less indirection. |
671
|
|
|
|
|
|
And we save a lot of memory by caching no table. */ |
672
|
|
|
|
|
|
const unsigned char c1 = little[0]; |
673
|
|
|
|
|
|
const unsigned char c2 = little[1]; |
674
|
|
|
|
|
|
|
675
|
|
|
|
|
|
s = big + 1; |
676
|
|
|
|
|
|
bigend--; |
677
|
|
|
|
|
|
if (c1 != c2) { |
678
|
|
|
|
|
|
while (s <= bigend) { |
679
|
|
|
|
|
|
if (s[0] == c2) { |
680
|
|
|
|
|
|
if (s[-1] == c1) |
681
|
|
|
|
|
|
return (char*)s - 1; |
682
|
|
|
|
|
|
s += 2; |
683
|
|
|
|
|
|
continue; |
684
|
|
|
|
|
|
} |
685
|
|
|
|
|
|
next_chars: |
686
|
|
|
|
|
|
if (s[0] == c1) { |
687
|
|
|
|
|
|
if (s == bigend) |
688
|
|
|
|
|
|
goto check_1char_anchor; |
689
|
|
|
|
|
|
if (s[1] == c2) |
690
|
|
|
|
|
|
return (char*)s; |
691
|
|
|
|
|
|
else { |
692
|
|
|
|
|
|
s++; |
693
|
|
|
|
|
|
goto next_chars; |
694
|
|
|
|
|
|
} |
695
|
|
|
|
|
|
} |
696
|
|
|
|
|
|
else |
697
|
|
|
|
|
|
s += 2; |
698
|
|
|
|
|
|
} |
699
|
|
|
|
|
|
goto check_1char_anchor; |
700
|
|
|
|
|
|
} |
701
|
|
|
|
|
|
/* Now c1 == c2 */ |
702
|
|
|
|
|
|
while (s <= bigend) { |
703
|
|
|
|
|
|
if (s[0] == c1) { |
704
|
|
|
|
|
|
if (s[-1] == c1) |
705
|
|
|
|
|
|
return (char*)s - 1; |
706
|
|
|
|
|
|
if (s == bigend) |
707
|
|
|
|
|
|
goto check_1char_anchor; |
708
|
|
|
|
|
|
if (s[1] == c1) |
709
|
|
|
|
|
|
return (char*)s; |
710
|
|
|
|
|
|
s += 3; |
711
|
|
|
|
|
|
} |
712
|
|
|
|
|
|
else |
713
|
|
|
|
|
|
s += 2; |
714
|
|
|
|
|
|
} |
715
|
|
|
|
|
|
} |
716
|
|
|
|
|
|
check_1char_anchor: /* One char and anchor! */ |
717
|
|
|
|
|
|
if (SvTAIL(littlestr) && (*bigend == *little)) |
718
|
|
|
|
|
|
return (char *)bigend; /* bigend is already decremented. */ |
719
|
|
|
|
|
|
return NULL; |
720
|
|
|
|
|
|
default: |
721
|
|
|
|
|
|
break; /* Only lengths 0 1 and 2 have special-case code. */ |
722
|
|
|
|
|
|
} |
723
|
|
|
|
|
|
|
724
|
|
|
|
|
|
if (SvTAIL(littlestr) && !multiline) { /* tail anchored? */ |
725
|
|
|
|
|
|
s = bigend - littlelen; |
726
|
|
|
|
|
|
if (s >= big && bigend[-1] == '\n' && *s == *little |
727
|
|
|
|
|
|
/* Automatically of length > 2 */ |
728
|
|
|
|
|
|
&& memEQ((char*)s + 1, (char*)little + 1, littlelen - 2)) |
729
|
|
|
|
|
|
{ |
730
|
|
|
|
|
|
return (char*)s; /* how sweet it is */ |
731
|
|
|
|
|
|
} |
732
|
|
|
|
|
|
if (s[1] == *little |
733
|
|
|
|
|
|
&& memEQ((char*)s + 2, (char*)little + 1, littlelen - 2)) |
734
|
|
|
|
|
|
{ |
735
|
|
|
|
|
|
return (char*)s + 1; /* how sweet it is */ |
736
|
|
|
|
|
|
} |
737
|
|
|
|
|
|
return NULL; |
738
|
|
|
|
|
|
} |
739
|
|
|
|
|
|
if (!SvVALID(littlestr)) { |
740
|
|
|
|
|
|
char * const b = ninstr((char*)big,(char*)bigend, |
741
|
|
|
|
|
|
(char*)little, (char*)little + littlelen); |
742
|
|
|
|
|
|
|
743
|
|
|
|
|
|
if (!b && SvTAIL(littlestr)) { /* Automatically multiline! */ |
744
|
|
|
|
|
|
/* Chop \n from littlestr: */ |
745
|
|
|
|
|
|
s = bigend - littlelen + 1; |
746
|
|
|
|
|
|
if (*s == *little |
747
|
|
|
|
|
|
&& memEQ((char*)s + 1, (char*)little + 1, littlelen - 2)) |
748
|
|
|
|
|
|
{ |
749
|
|
|
|
|
|
return (char*)s; |
750
|
|
|
|
|
|
} |
751
|
|
|
|
|
|
return NULL; |
752
|
|
|
|
|
|
} |
753
|
|
|
|
|
|
return b; |
754
|
|
|
|
|
|
} |
755
|
|
|
|
|
|
|
756
|
|
|
|
|
|
/* Do actual FBM. */ |
757
|
|
|
|
|
|
if (littlelen > (STRLEN)(bigend - big)) |
758
|
|
|
|
|
|
return NULL; |
759
|
|
|
|
|
|
|
760
|
|
|
|
|
|
{ |
761
|
|
|
|
|
|
const MAGIC *const mg = mg_find(littlestr, PERL_MAGIC_bm); |
762
|
|
|
|
|
|
const unsigned char * const table = (const unsigned char *) mg->mg_ptr; |
763
|
|
|
|
|
|
const unsigned char *oldlittle; |
764
|
|
|
|
|
|
|
765
|
|
|
|
|
|
--littlelen; /* Last char found by table lookup */ |
766
|
|
|
|
|
|
|
767
|
|
|
|
|
|
s = big + littlelen; |
768
|
|
|
|
|
|
little += littlelen; /* last char */ |
769
|
|
|
|
|
|
oldlittle = little; |
770
|
|
|
|
|
|
if (s < bigend) { |
771
|
|
|
|
|
|
I32 tmp; |
772
|
|
|
|
|
|
|
773
|
|
|
|
|
|
top2: |
774
|
|
|
|
|
|
if ((tmp = table[*s])) { |
775
|
|
|
|
|
|
if ((s += tmp) < bigend) |
776
|
|
|
|
|
|
goto top2; |
777
|
|
|
|
|
|
goto check_end; |
778
|
|
|
|
|
|
} |
779
|
|
|
|
|
|
else { /* less expensive than calling strncmp() */ |
780
|
|
|
|
|
|
unsigned char * const olds = s; |
781
|
|
|
|
|
|
|
782
|
|
|
|
|
|
tmp = littlelen; |
783
|
|
|
|
|
|
|
784
|
|
|
|
|
|
while (tmp--) { |
785
|
|
|
|
|
|
if (*--s == *--little) |
786
|
|
|
|
|
|
continue; |
787
|
|
|
|
|
|
s = olds + 1; /* here we pay the price for failure */ |
788
|
|
|
|
|
|
little = oldlittle; |
789
|
|
|
|
|
|
if (s < bigend) /* fake up continue to outer loop */ |
790
|
|
|
|
|
|
goto top2; |
791
|
|
|
|
|
|
goto check_end; |
792
|
|
|
|
|
|
} |
793
|
|
|
|
|
|
return (char *)s; |
794
|
|
|
|
|
|
} |
795
|
|
|
|
|
|
} |
796
|
|
|
|
|
|
check_end: |
797
|
|
|
|
|
|
if ( s == bigend |
798
|
|
|
|
|
|
&& SvTAIL(littlestr) |
799
|
|
|
|
|
|
&& memEQ((char *)(bigend - littlelen), |
800
|
|
|
|
|
|
(char *)(oldlittle - littlelen), littlelen) ) |
801
|
|
|
|
|
|
return (char*)bigend - littlelen; |
802
|
|
|
|
|
|
return NULL; |
803
|
|
|
|
|
|
} |
804
|
|
|
|
|
|
} |
805
|
|
|
|
|
|
|
806
|
|
|
|
|
|
char * |
807
|
|
|
|
|
|
Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last) |
808
|
|
|
|
|
|
{ |
809
|
|
|
|
|
|
dVAR; |
810
|
|
|
|
|
|
PERL_ARGS_ASSERT_SCREAMINSTR; |
811
|
|
|
|
|
|
PERL_UNUSED_ARG(bigstr); |
812
|
|
|
|
|
|
PERL_UNUSED_ARG(littlestr); |
813
|
|
|
|
|
|
PERL_UNUSED_ARG(start_shift); |
814
|
|
|
|
|
|
PERL_UNUSED_ARG(end_shift); |
815
|
|
|
|
|
|
PERL_UNUSED_ARG(old_posp); |
816
|
|
|
|
|
|
PERL_UNUSED_ARG(last); |
817
|
|
|
|
|
|
|
818
|
|
|
|
|
|
/* This function must only ever be called on a scalar with study magic, |
819
|
|
|
|
|
|
but those do not happen any more. */ |
820
|
|
|
|
|
|
Perl_croak(aTHX_ "panic: screaminstr"); |
821
|
|
|
|
|
|
return NULL; |
822
|
|
|
|
|
|
} |
823
|
|
|
|
|
|
|
824
|
|
|
|
|
|
/* |
825
|
|
|
|
|
|
=for apidoc foldEQ |
826
|
|
|
|
|
|
|
827
|
|
|
|
|
|
Returns true if the leading len bytes of the strings s1 and s2 are the same |
828
|
|
|
|
|
|
case-insensitively; false otherwise. Uppercase and lowercase ASCII range bytes |
829
|
|
|
|
|
|
match themselves and their opposite case counterparts. Non-cased and non-ASCII |
830
|
|
|
|
|
|
range bytes match only themselves. |
831
|
|
|
|
|
|
|
832
|
|
|
|
|
|
=cut |
833
|
|
|
|
|
|
*/ |
834
|
|
|
|
|
|
|
835
|
|
|
|
|
|
|
836
|
|
|
|
|
|
I32 |
837
|
|
|
|
|
|
Perl_foldEQ(const char *s1, const char *s2, I32 len) |
838
|
|
|
|
|
|
{ |
839
|
|
|
|
|
|
const U8 *a = (const U8 *)s1; |
840
|
|
|
|
|
|
const U8 *b = (const U8 *)s2; |
841
|
|
|
|
|
|
|
842
|
|
|
|
|
|
PERL_ARGS_ASSERT_FOLDEQ; |
843
|
|
|
|
|
|
|
844
|
|
|
|
|
|
assert(len >= 0); |
845
|
|
|
|
|
|
|
846
|
|
|
|
|
|
while (len--) { |
847
|
|
|
|
|
|
if (*a != *b && *a != PL_fold[*b]) |
848
|
|
|
|
|
|
return 0; |
849
|
|
|
|
|
|
a++,b++; |
850
|
|
|
|
|
|
} |
851
|
|
|
|
|
|
return 1; |
852
|
|
|
|
|
|
} |
853
|
|
|
|
|
|
I32 |
854
|
|
|
|
|
|
Perl_foldEQ_latin1(const char *s1, const char *s2, I32 len) |
855
|
|
|
|
|
|
{ |
856
|
|
|
|
|
|
/* Compare non-utf8 using Unicode (Latin1) semantics. Does not work on |
857
|
|
|
|
|
|
* MICRO_SIGN, LATIN_SMALL_LETTER_SHARP_S, nor |
858
|
|
|
|
|
|
* LATIN_SMALL_LETTER_Y_WITH_DIAERESIS, and does not check for these. Nor |
859
|
|
|
|
|
|
* does it check that the strings each have at least 'len' characters */ |
860
|
|
|
|
|
|
|
861
|
|
|
|
|
|
const U8 *a = (const U8 *)s1; |
862
|
|
|
|
|
|
const U8 *b = (const U8 *)s2; |
863
|
|
|
|
|
|
|
864
|
|
|
|
|
|
PERL_ARGS_ASSERT_FOLDEQ_LATIN1; |
865
|
|
|
|
|
|
|
866
|
|
|
|
|
|
assert(len >= 0); |
867
|
|
|
|
|
|
|
868
|
|
|
|
|
|
while (len--) { |
869
|
|
|
|
|
|
if (*a != *b && *a != PL_fold_latin1[*b]) { |
870
|
|
|
|
|
|
return 0; |
871
|
|
|
|
|
|
} |
872
|
|
|
|
|
|
a++, b++; |
873
|
|
|
|
|
|
} |
874
|
|
|
|
|
|
return 1; |
875
|
|
|
|
|
|
} |
876
|
|
|
|
|
|
|
877
|
|
|
|
|
|
/* |
878
|
|
|
|
|
|
=for apidoc foldEQ_locale |
879
|
|
|
|
|
|
|
880
|
|
|
|
|
|
Returns true if the leading len bytes of the strings s1 and s2 are the same |
881
|
|
|
|
|
|
case-insensitively in the current locale; false otherwise. |
882
|
|
|
|
|
|
|
883
|
|
|
|
|
|
=cut |
884
|
|
|
|
|
|
*/ |
885
|
|
|
|
|
|
|
886
|
|
|
|
|
|
I32 |
887
|
|
|
|
|
|
Perl_foldEQ_locale(const char *s1, const char *s2, I32 len) |
888
|
|
|
|
|
|
{ |
889
|
|
|
|
|
|
dVAR; |
890
|
|
|
|
|
|
const U8 *a = (const U8 *)s1; |
891
|
|
|
|
|
|
const U8 *b = (const U8 *)s2; |
892
|
|
|
|
|
|
|
893
|
|
|
|
|
|
PERL_ARGS_ASSERT_FOLDEQ_LOCALE; |
894
|
|
|
|
|
|
|
895
|
|
|
|
|
|
assert(len >= 0); |
896
|
|
|
|
|
|
|
897
|
|
|
|
|
|
while (len--) { |
898
|
|
|
|
|
|
if (*a != *b && *a != PL_fold_locale[*b]) |
899
|
|
|
|
|
|
return 0; |
900
|
|
|
|
|
|
a++,b++; |
901
|
|
|
|
|
|
} |
902
|
|
|
|
|
|
return 1; |
903
|
|
|
|
|
|
} |
904
|
|
|
|
|
|
|
905
|
|
|
|
|
|
/* copy a string to a safe spot */ |
906
|
|
|
|
|
|
|
907
|
|
|
|
|
|
/* |
908
|
|
|
|
|
|
=head1 Memory Management |
909
|
|
|
|
|
|
|
910
|
|
|
|
|
|
=for apidoc savepv |
911
|
|
|
|
|
|
|
912
|
|
|
|
|
|
Perl's version of C. Returns a pointer to a newly allocated |
913
|
|
|
|
|
|
string which is a duplicate of C. The size of the string is |
914
|
|
|
|
|
|
determined by C. The memory allocated for the new string can |
915
|
|
|
|
|
|
be freed with the C function. |
916
|
|
|
|
|
|
|
917
|
|
|
|
|
|
=cut |
918
|
|
|
|
|
|
*/ |
919
|
|
|
|
|
|
|
920
|
|
|
|
|
|
char * |
921
|
|
|
|
|
|
Perl_savepv(pTHX_ const char *pv) |
922
|
|
|
|
|
|
{ |
923
|
|
|
|
|
|
PERL_UNUSED_CONTEXT; |
924
|
|
|
|
|
|
if (!pv) |
925
|
|
|
|
|
|
return NULL; |
926
|
|
|
|
|
|
else { |
927
|
|
|
|
|
|
char *newaddr; |
928
|
|
|
|
|
|
const STRLEN pvlen = strlen(pv)+1; |
929
|
|
|
|
|
|
Newx(newaddr, pvlen, char); |
930
|
|
|
|
|
|
return (char*)memcpy(newaddr, pv, pvlen); |
931
|
|
|
|
|
|
} |
932
|
|
|
|
|
|
} |
933
|
|
|
|
|
|
|
934
|
|
|
|
|
|
/* same thing but with a known length */ |
935
|
|
|
|
|
|
|
936
|
|
|
|
|
|
/* |
937
|
|
|
|
|
|
=for apidoc savepvn |
938
|
|
|
|
|
|
|
939
|
|
|
|
|
|
Perl's version of what C would be if it existed. Returns a |
940
|
|
|
|
|
|
pointer to a newly allocated string which is a duplicate of the first |
941
|
|
|
|
|
|
C bytes from C, plus a trailing NUL byte. The memory allocated for |
942
|
|
|
|
|
|
the new string can be freed with the C function. |
943
|
|
|
|
|
|
|
944
|
|
|
|
|
|
=cut |
945
|
|
|
|
|
|
*/ |
946
|
|
|
|
|
|
|
947
|
|
|
|
|
|
char * |
948
|
|
|
|
|
|
Perl_savepvn(pTHX_ const char *pv, I32 len) |
949
|
|
|
|
|
|
{ |
950
|
|
|
|
|
|
char *newaddr; |
951
|
|
|
|
|
|
PERL_UNUSED_CONTEXT; |
952
|
|
|
|
|
|
|
953
|
|
|
|
|
|
assert(len >= 0); |
954
|
|
|
|
|
|
|
955
|
|
|
|
|
|
Newx(newaddr,len+1,char); |
956
|
|
|
|
|
|
/* Give a meaning to NULL pointer mainly for the use in sv_magic() */ |
957
|
|
|
|
|
|
if (pv) { |
958
|
|
|
|
|
|
/* might not be null terminated */ |
959
|
|
|
|
|
|
newaddr[len] = '\0'; |
960
|
|
|
|
|
|
return (char *) CopyD(pv,newaddr,len,char); |
961
|
|
|
|
|
|
} |
962
|
|
|
|
|
|
else { |
963
|
|
|
|
|
|
return (char *) ZeroD(newaddr,len+1,char); |
964
|
|
|
|
|
|
} |
965
|
|
|
|
|
|
} |
966
|
|
|
|
|
|
|
967
|
|
|
|
|
|
/* |
968
|
|
|
|
|
|
=for apidoc savesharedpv |
969
|
|
|
|
|
|
|
970
|
|
|
|
|
|
A version of C which allocates the duplicate string in memory |
971
|
|
|
|
|
|
which is shared between threads. |
972
|
|
|
|
|
|
|
973
|
|
|
|
|
|
=cut |
974
|
|
|
|
|
|
*/ |
975
|
|
|
|
|
|
char * |
976
|
|
|
|
|
|
Perl_savesharedpv(pTHX_ const char *pv) |
977
|
|
|
|
|
|
{ |
978
|
|
|
|
|
|
char *newaddr; |
979
|
|
|
|
|
|
STRLEN pvlen; |
980
|
|
|
|
|
|
if (!pv) |
981
|
|
|
|
|
|
return NULL; |
982
|
|
|
|
|
|
|
983
|
|
|
|
|
|
pvlen = strlen(pv)+1; |
984
|
|
|
|
|
|
newaddr = (char*)PerlMemShared_malloc(pvlen); |
985
|
|
|
|
|
|
if (!newaddr) { |
986
|
|
|
|
|
|
croak_no_mem(); |
987
|
|
|
|
|
|
} |
988
|
|
|
|
|
|
return (char*)memcpy(newaddr, pv, pvlen); |
989
|
|
|
|
|
|
} |
990
|
|
|
|
|
|
|
991
|
|
|
|
|
|
/* |
992
|
|
|
|
|
|
=for apidoc savesharedpvn |
993
|
|
|
|
|
|
|
994
|
|
|
|
|
|
A version of C which allocates the duplicate string in memory |
995
|
|
|
|
|
|
which is shared between threads. (With the specific difference that a NULL |
996
|
|
|
|
|
|
pointer is not acceptable) |
997
|
|
|
|
|
|
|
998
|
|
|
|
|
|
=cut |
999
|
|
|
|
|
|
*/ |
1000
|
|
|
|
|
|
char * |
1001
|
|
|
|
|
|
Perl_savesharedpvn(pTHX_ const char *const pv, const STRLEN len) |
1002
|
|
|
|
|
|
{ |
1003
|
|
|
|
|
|
char *const newaddr = (char*)PerlMemShared_malloc(len + 1); |
1004
|
|
|
|
|
|
|
1005
|
|
|
|
|
|
/* PERL_ARGS_ASSERT_SAVESHAREDPVN; */ |
1006
|
|
|
|
|
|
|
1007
|
|
|
|
|
|
if (!newaddr) { |
1008
|
|
|
|
|
|
croak_no_mem(); |
1009
|
|
|
|
|
|
} |
1010
|
|
|
|
|
|
newaddr[len] = '\0'; |
1011
|
|
|
|
|
|
return (char*)memcpy(newaddr, pv, len); |
1012
|
|
|
|
|
|
} |
1013
|
|
|
|
|
|
|
1014
|
|
|
|
|
|
/* |
1015
|
|
|
|
|
|
=for apidoc savesvpv |
1016
|
|
|
|
|
|
|
1017
|
|
|
|
|
|
A version of C/C which gets the string to duplicate from |
1018
|
|
|
|
|
|
the passed in SV using C |
1019
|
|
|
|
|
|
|
1020
|
|
|
|
|
|
=cut |
1021
|
|
|
|
|
|
*/ |
1022
|
|
|
|
|
|
|
1023
|
|
|
|
|
|
char * |
1024
|
|
|
|
|
|
Perl_savesvpv(pTHX_ SV *sv) |
1025
|
|
|
|
|
|
{ |
1026
|
|
|
|
|
|
STRLEN len; |
1027
|
|
|
|
|
|
const char * const pv = SvPV_const(sv, len); |
1028
|
|
|
|
|
|
char *newaddr; |
1029
|
|
|
|
|
|
|
1030
|
|
|
|
|
|
PERL_ARGS_ASSERT_SAVESVPV; |
1031
|
|
|
|
|
|
|
1032
|
|
|
|
|
|
++len; |
1033
|
|
|
|
|
|
Newx(newaddr,len,char); |
1034
|
|
|
|
|
|
return (char *) CopyD(pv,newaddr,len,char); |
1035
|
|
|
|
|
|
} |
1036
|
|
|
|
|
|
|
1037
|
|
|
|
|
|
/* |
1038
|
|
|
|
|
|
=for apidoc savesharedsvpv |
1039
|
|
|
|
|
|
|
1040
|
|
|
|
|
|
A version of C which allocates the duplicate string in |
1041
|
|
|
|
|
|
memory which is shared between threads. |
1042
|
|
|
|
|
|
|
1043
|
|
|
|
|
|
=cut |
1044
|
|
|
|
|
|
*/ |
1045
|
|
|
|
|
|
|
1046
|
|
|
|
|
|
char * |
1047
|
|
|
|
|
|
Perl_savesharedsvpv(pTHX_ SV *sv) |
1048
|
|
|
|
|
|
{ |
1049
|
|
|
|
|
|
STRLEN len; |
1050
|
|
|
|
|
|
const char * const pv = SvPV_const(sv, len); |
1051
|
|
|
|
|
|
|
1052
|
|
|
|
|
|
PERL_ARGS_ASSERT_SAVESHAREDSVPV; |
1053
|
|
|
|
|
|
|
1054
|
|
|
|
|
|
return savesharedpvn(pv, len); |
1055
|
|
|
|
|
|
} |
1056
|
|
|
|
|
|
|
1057
|
|
|
|
|
|
/* the SV for Perl_form() and mess() is not kept in an arena */ |
1058
|
|
|
|
|
|
|
1059
|
|
|
|
|
|
STATIC SV * |
1060
|
|
|
|
|
|
S_mess_alloc(pTHX) |
1061
|
|
|
|
|
|
{ |
1062
|
|
|
|
|
|
dVAR; |
1063
|
|
|
|
|
|
SV *sv; |
1064
|
|
|
|
|
|
XPVMG *any; |
1065
|
|
|
|
|
|
|
1066
|
|
|
|
|
|
if (PL_phase != PERL_PHASE_DESTRUCT) |
1067
|
|
|
|
|
|
return newSVpvs_flags("", SVs_TEMP); |
1068
|
|
|
|
|
|
|
1069
|
|
|
|
|
|
if (PL_mess_sv) |
1070
|
|
|
|
|
|
return PL_mess_sv; |
1071
|
|
|
|
|
|
|
1072
|
|
|
|
|
|
/* Create as PVMG now, to avoid any upgrading later */ |
1073
|
|
|
|
|
|
Newx(sv, 1, SV); |
1074
|
|
|
|
|
|
Newxz(any, 1, XPVMG); |
1075
|
|
|
|
|
|
SvFLAGS(sv) = SVt_PVMG; |
1076
|
|
|
|
|
|
SvANY(sv) = (void*)any; |
1077
|
|
|
|
|
|
SvPV_set(sv, NULL); |
1078
|
|
|
|
|
|
SvREFCNT(sv) = 1 << 30; /* practically infinite */ |
1079
|
|
|
|
|
|
PL_mess_sv = sv; |
1080
|
|
|
|
|
|
return sv; |
1081
|
|
|
|
|
|
} |
1082
|
|
|
|
|
|
|
1083
|
|
|
|
|
|
#if defined(PERL_IMPLICIT_CONTEXT) |
1084
|
|
|
|
|
|
char * |
1085
|
|
|
|
|
|
Perl_form_nocontext(const char* pat, ...) |
1086
|
|
|
|
|
|
{ |
1087
|
|
|
|
|
|
dTHX; |
1088
|
|
|
|
|
|
char *retval; |
1089
|
|
|
|
|
|
va_list args; |
1090
|
|
|
|
|
|
PERL_ARGS_ASSERT_FORM_NOCONTEXT; |
1091
|
|
|
|
|
|
va_start(args, pat); |
1092
|
|
|
|
|
|
retval = vform(pat, &args); |
1093
|
|
|
|
|
|
va_end(args); |
1094
|
|
|
|
|
|
return retval; |
1095
|
|
|
|
|
|
} |
1096
|
|
|
|
|
|
#endif /* PERL_IMPLICIT_CONTEXT */ |
1097
|
|
|
|
|
|
|
1098
|
|
|
|
|
|
/* |
1099
|
|
|
|
|
|
=head1 Miscellaneous Functions |
1100
|
|
|
|
|
|
=for apidoc form |
1101
|
|
|
|
|
|
|
1102
|
|
|
|
|
|
Takes a sprintf-style format pattern and conventional |
1103
|
|
|
|
|
|
(non-SV) arguments and returns the formatted string. |
1104
|
|
|
|
|
|
|
1105
|
|
|
|
|
|
(char *) Perl_form(pTHX_ const char* pat, ...) |
1106
|
|
|
|
|
|
|
1107
|
|
|
|
|
|
can be used any place a string (char *) is required: |
1108
|
|
|
|
|
|
|
1109
|
|
|
|
|
|
char * s = Perl_form("%d.%d",major,minor); |
1110
|
|
|
|
|
|
|
1111
|
|
|
|
|
|
Uses a single private buffer so if you want to format several strings you |
1112
|
|
|
|
|
|
must explicitly copy the earlier strings away (and free the copies when you |
1113
|
|
|
|
|
|
are done). |
1114
|
|
|
|
|
|
|
1115
|
|
|
|
|
|
=cut |
1116
|
|
|
|
|
|
*/ |
1117
|
|
|
|
|
|
|
1118
|
|
|
|
|
|
char * |
1119
|
|
|
|
|
|
Perl_form(pTHX_ const char* pat, ...) |
1120
|
|
|
|
|
|
{ |
1121
|
|
|
|
|
|
char *retval; |
1122
|
|
|
|
|
|
va_list args; |
1123
|
|
|
|
|
|
PERL_ARGS_ASSERT_FORM; |
1124
|
|
|
|
|
|
va_start(args, pat); |
1125
|
|
|
|
|
|
retval = vform(pat, &args); |
1126
|
|
|
|
|
|
va_end(args); |
1127
|
|
|
|
|
|
return retval; |
1128
|
|
|
|
|
|
} |
1129
|
|
|
|
|
|
|
1130
|
|
|
|
|
|
char * |
1131
|
|
|
|
|
|
Perl_vform(pTHX_ const char *pat, va_list *args) |
1132
|
|
|
|
|
|
{ |
1133
|
|
|
|
|
|
SV * const sv = mess_alloc(); |
1134
|
|
|
|
|
|
PERL_ARGS_ASSERT_VFORM; |
1135
|
|
|
|
|
|
sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL); |
1136
|
|
|
|
|
|
return SvPVX(sv); |
1137
|
|
|
|
|
|
} |
1138
|
|
|
|
|
|
|
1139
|
|
|
|
|
|
/* |
1140
|
|
|
|
|
|
=for apidoc Am|SV *|mess|const char *pat|... |
1141
|
|
|
|
|
|
|
1142
|
|
|
|
|
|
Take a sprintf-style format pattern and argument list. These are used to |
1143
|
|
|
|
|
|
generate a string message. If the message does not end with a newline, |
1144
|
|
|
|
|
|
then it will be extended with some indication of the current location |
1145
|
|
|
|
|
|
in the code, as described for L. |
1146
|
|
|
|
|
|
|
1147
|
|
|
|
|
|
Normally, the resulting message is returned in a new mortal SV. |
1148
|
|
|
|
|
|
During global destruction a single SV may be shared between uses of |
1149
|
|
|
|
|
|
this function. |
1150
|
|
|
|
|
|
|
1151
|
|
|
|
|
|
=cut |
1152
|
|
|
|
|
|
*/ |
1153
|
|
|
|
|
|
|
1154
|
|
|
|
|
|
#if defined(PERL_IMPLICIT_CONTEXT) |
1155
|
|
|
|
|
|
SV * |
1156
|
|
|
|
|
|
Perl_mess_nocontext(const char *pat, ...) |
1157
|
|
|
|
|
|
{ |
1158
|
|
|
|
|
|
dTHX; |
1159
|
|
|
|
|
|
SV *retval; |
1160
|
|
|
|
|
|
va_list args; |
1161
|
|
|
|
|
|
PERL_ARGS_ASSERT_MESS_NOCONTEXT; |
1162
|
|
|
|
|
|
va_start(args, pat); |
1163
|
|
|
|
|
|
retval = vmess(pat, &args); |
1164
|
|
|
|
|
|
va_end(args); |
1165
|
|
|
|
|
|
return retval; |
1166
|
|
|
|
|
|
} |
1167
|
|
|
|
|
|
#endif /* PERL_IMPLICIT_CONTEXT */ |
1168
|
|
|
|
|
|
|
1169
|
|
|
|
|
|
SV * |
1170
|
|
|
|
|
|
Perl_mess(pTHX_ const char *pat, ...) |
1171
|
|
|
|
|
|
{ |
1172
|
|
|
|
|
|
SV *retval; |
1173
|
|
|
|
|
|
va_list args; |
1174
|
|
|
|
|
|
PERL_ARGS_ASSERT_MESS; |
1175
|
|
|
|
|
|
va_start(args, pat); |
1176
|
|
|
|
|
|
retval = vmess(pat, &args); |
1177
|
|
|
|
|
|
va_end(args); |
1178
|
|
|
|
|
|
return retval; |
1179
|
|
|
|
|
|
} |
1180
|
|
|
|
|
|
|
1181
|
|
|
|
|
|
const COP* |
1182
|
|
|
|
|
|
Perl_closest_cop(pTHX_ const COP *cop, const OP *o, const OP *curop, |
1183
|
|
|
|
|
|
bool opnext) |
1184
|
|
|
|
|
|
{ |
1185
|
|
|
|
|
|
dVAR; |
1186
|
|
|
|
|
|
/* Look for curop starting from o. cop is the last COP we've seen. */ |
1187
|
|
|
|
|
|
/* opnext means that curop is actually the ->op_next of the op we are |
1188
|
|
|
|
|
|
seeking. */ |
1189
|
|
|
|
|
|
|
1190
|
|
|
|
|
|
PERL_ARGS_ASSERT_CLOSEST_COP; |
1191
|
|
|
|
|
|
|
1192
|
|
|
|
|
|
if (!o || !curop || ( |
1193
|
|
|
|
|
|
opnext ? o->op_next == curop && o->op_type != OP_SCOPE : o == curop |
1194
|
|
|
|
|
|
)) |
1195
|
|
|
|
|
|
return cop; |
1196
|
|
|
|
|
|
|
1197
|
|
|
|
|
|
if (o->op_flags & OPf_KIDS) { |
1198
|
|
|
|
|
|
const OP *kid; |
1199
|
|
|
|
|
|
for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) { |
1200
|
|
|
|
|
|
const COP *new_cop; |
1201
|
|
|
|
|
|
|
1202
|
|
|
|
|
|
/* If the OP_NEXTSTATE has been optimised away we can still use it |
1203
|
|
|
|
|
|
* the get the file and line number. */ |
1204
|
|
|
|
|
|
|
1205
|
|
|
|
|
|
if (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE) |
1206
|
|
|
|
|
|
cop = (const COP *)kid; |
1207
|
|
|
|
|
|
|
1208
|
|
|
|
|
|
/* Keep searching, and return when we've found something. */ |
1209
|
|
|
|
|
|
|
1210
|
|
|
|
|
|
new_cop = closest_cop(cop, kid, curop, opnext); |
1211
|
|
|
|
|
|
if (new_cop) |
1212
|
|
|
|
|
|
return new_cop; |
1213
|
|
|
|
|
|
} |
1214
|
|
|
|
|
|
} |
1215
|
|
|
|
|
|
|
1216
|
|
|
|
|
|
/* Nothing found. */ |
1217
|
|
|
|
|
|
|
1218
|
|
|
|
|
|
return NULL; |
1219
|
|
|
|
|
|
} |
1220
|
|
|
|
|
|
|
1221
|
|
|
|
|
|
/* |
1222
|
|
|
|
|
|
=for apidoc Am|SV *|mess_sv|SV *basemsg|bool consume |
1223
|
|
|
|
|
|
|
1224
|
|
|
|
|
|
Expands a message, intended for the user, to include an indication of |
1225
|
|
|
|
|
|
the current location in the code, if the message does not already appear |
1226
|
|
|
|
|
|
to be complete. |
1227
|
|
|
|
|
|
|
1228
|
|
|
|
|
|
C is the initial message or object. If it is a reference, it |
1229
|
|
|
|
|
|
will be used as-is and will be the result of this function. Otherwise it |
1230
|
|
|
|
|
|
is used as a string, and if it already ends with a newline, it is taken |
1231
|
|
|
|
|
|
to be complete, and the result of this function will be the same string. |
1232
|
|
|
|
|
|
If the message does not end with a newline, then a segment such as C
|
1233
|
|
|
|
|
|
foo.pl line 37> will be appended, and possibly other clauses indicating |
1234
|
|
|
|
|
|
the current state of execution. The resulting message will end with a |
1235
|
|
|
|
|
|
dot and a newline. |
1236
|
|
|
|
|
|
|
1237
|
|
|
|
|
|
Normally, the resulting message is returned in a new mortal SV. |
1238
|
|
|
|
|
|
During global destruction a single SV may be shared between uses of this |
1239
|
|
|
|
|
|
function. If C is true, then the function is permitted (but not |
1240
|
|
|
|
|
|
required) to modify and return C instead of allocating a new SV. |
1241
|
|
|
|
|
|
|
1242
|
|
|
|
|
|
=cut |
1243
|
|
|
|
|
|
*/ |
1244
|
|
|
|
|
|
|
1245
|
|
|
|
|
|
SV * |
1246
|
|
|
|
|
|
Perl_mess_sv(pTHX_ SV *basemsg, bool consume) |
1247
|
|
|
|
|
|
{ |
1248
|
|
|
|
|
|
dVAR; |
1249
|
|
|
|
|
|
SV *sv; |
1250
|
|
|
|
|
|
|
1251
|
|
|
|
|
|
PERL_ARGS_ASSERT_MESS_SV; |
1252
|
|
|
|
|
|
|
1253
|
|
|
|
|
|
if (SvROK(basemsg)) { |
1254
|
|
|
|
|
|
if (consume) { |
1255
|
|
|
|
|
|
sv = basemsg; |
1256
|
|
|
|
|
|
} |
1257
|
|
|
|
|
|
else { |
1258
|
|
|
|
|
|
sv = mess_alloc(); |
1259
|
|
|
|
|
|
sv_setsv(sv, basemsg); |
1260
|
|
|
|
|
|
} |
1261
|
|
|
|
|
|
return sv; |
1262
|
|
|
|
|
|
} |
1263
|
|
|
|
|
|
|
1264
|
|
|
|
|
|
if (SvPOK(basemsg) && consume) { |
1265
|
|
|
|
|
|
sv = basemsg; |
1266
|
|
|
|
|
|
} |
1267
|
|
|
|
|
|
else { |
1268
|
|
|
|
|
|
sv = mess_alloc(); |
1269
|
|
|
|
|
|
sv_copypv(sv, basemsg); |
1270
|
|
|
|
|
|
} |
1271
|
|
|
|
|
|
|
1272
|
|
|
|
|
|
if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') { |
1273
|
|
|
|
|
|
/* |
1274
|
|
|
|
|
|
* Try and find the file and line for PL_op. This will usually be |
1275
|
|
|
|
|
|
* PL_curcop, but it might be a cop that has been optimised away. We |
1276
|
|
|
|
|
|
* can try to find such a cop by searching through the optree starting |
1277
|
|
|
|
|
|
* from the sibling of PL_curcop. |
1278
|
|
|
|
|
|
*/ |
1279
|
|
|
|
|
|
|
1280
|
|
|
|
|
|
const COP *cop = |
1281
|
|
|
|
|
|
closest_cop(PL_curcop, PL_curcop->op_sibling, PL_op, FALSE); |
1282
|
|
|
|
|
|
if (!cop) |
1283
|
|
|
|
|
|
cop = PL_curcop; |
1284
|
|
|
|
|
|
|
1285
|
|
|
|
|
|
if (CopLINE(cop)) |
1286
|
|
|
|
|
|
Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf, |
1287
|
|
|
|
|
|
OutCopFILE(cop), (IV)CopLINE(cop)); |
1288
|
|
|
|
|
|
/* Seems that GvIO() can be untrustworthy during global destruction. */ |
1289
|
|
|
|
|
|
if (GvIO(PL_last_in_gv) && (SvTYPE(GvIOp(PL_last_in_gv)) == SVt_PVIO) |
1290
|
|
|
|
|
|
&& IoLINES(GvIOp(PL_last_in_gv))) |
1291
|
|
|
|
|
|
{ |
1292
|
|
|
|
|
|
STRLEN l; |
1293
|
|
|
|
|
|
const bool line_mode = (RsSIMPLE(PL_rs) && |
1294
|
|
|
|
|
|
*SvPV_const(PL_rs,l) == '\n' && l == 1); |
1295
|
|
|
|
|
|
Perl_sv_catpvf(aTHX_ sv, ", <%"SVf"> %s %"IVdf, |
1296
|
|
|
|
|
|
SVfARG(PL_last_in_gv == PL_argvgv |
1297
|
|
|
|
|
|
? &PL_sv_no |
1298
|
|
|
|
|
|
: sv_2mortal(newSVhek(GvNAME_HEK(PL_last_in_gv)))), |
1299
|
|
|
|
|
|
line_mode ? "line" : "chunk", |
1300
|
|
|
|
|
|
(IV)IoLINES(GvIOp(PL_last_in_gv))); |
1301
|
|
|
|
|
|
} |
1302
|
|
|
|
|
|
if (PL_phase == PERL_PHASE_DESTRUCT) |
1303
|
|
|
|
|
|
sv_catpvs(sv, " during global destruction"); |
1304
|
|
|
|
|
|
sv_catpvs(sv, ".\n"); |
1305
|
|
|
|
|
|
} |
1306
|
|
|
|
|
|
return sv; |
1307
|
|
|
|
|
|
} |
1308
|
|
|
|
|
|
|
1309
|
|
|
|
|
|
/* |
1310
|
|
|
|
|
|
=for apidoc Am|SV *|vmess|const char *pat|va_list *args |
1311
|
|
|
|
|
|
|
1312
|
|
|
|
|
|
C and C are a sprintf-style format pattern and encapsulated |
1313
|
|
|
|
|
|
argument list. These are used to generate a string message. If the |
1314
|
|
|
|
|
|
message does not end with a newline, then it will be extended with |
1315
|
|
|
|
|
|
some indication of the current location in the code, as described for |
1316
|
|
|
|
|
|
L. |
1317
|
|
|
|
|
|
|
1318
|
|
|
|
|
|
Normally, the resulting message is returned in a new mortal SV. |
1319
|
|
|
|
|
|
During global destruction a single SV may be shared between uses of |
1320
|
|
|
|
|
|
this function. |
1321
|
|
|
|
|
|
|
1322
|
|
|
|
|
|
=cut |
1323
|
|
|
|
|
|
*/ |
1324
|
|
|
|
|
|
|
1325
|
|
|
|
|
|
SV * |
1326
|
|
|
|
|
|
Perl_vmess(pTHX_ const char *pat, va_list *args) |
1327
|
|
|
|
|
|
{ |
1328
|
|
|
|
|
|
dVAR; |
1329
|
|
|
|
|
|
SV * const sv = mess_alloc(); |
1330
|
|
|
|
|
|
|
1331
|
|
|
|
|
|
PERL_ARGS_ASSERT_VMESS; |
1332
|
|
|
|
|
|
|
1333
|
|
|
|
|
|
sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL); |
1334
|
|
|
|
|
|
return mess_sv(sv, 1); |
1335
|
|
|
|
|
|
} |
1336
|
|
|
|
|
|
|
1337
|
|
|
|
|
|
void |
1338
|
|
|
|
|
|
Perl_write_to_stderr(pTHX_ SV* msv) |
1339
|
|
|
|
|
|
{ |
1340
|
|
|
|
|
|
dVAR; |
1341
|
|
|
|
|
|
IO *io; |
1342
|
|
|
|
|
|
MAGIC *mg; |
1343
|
|
|
|
|
|
|
1344
|
|
|
|
|
|
PERL_ARGS_ASSERT_WRITE_TO_STDERR; |
1345
|
|
|
|
|
|
|
1346
|
|
|
|
|
|
if (PL_stderrgv && SvREFCNT(PL_stderrgv) |
1347
|
|
|
|
|
|
&& (io = GvIO(PL_stderrgv)) |
1348
|
|
|
|
|
|
&& (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) |
1349
|
|
|
|
|
|
Perl_magic_methcall(aTHX_ MUTABLE_SV(io), mg, SV_CONST(PRINT), |
1350
|
|
|
|
|
|
G_SCALAR | G_DISCARD | G_WRITING_TO_STDERR, 1, msv); |
1351
|
|
|
|
|
|
else { |
1352
|
|
|
|
|
|
#ifdef USE_SFIO |
1353
|
|
|
|
|
|
/* SFIO can really mess with your errno */ |
1354
|
|
|
|
|
|
dSAVED_ERRNO; |
1355
|
|
|
|
|
|
#endif |
1356
|
|
|
|
|
|
PerlIO * const serr = Perl_error_log; |
1357
|
|
|
|
|
|
|
1358
|
|
|
|
|
|
do_print(msv, serr); |
1359
|
|
|
|
|
|
(void)PerlIO_flush(serr); |
1360
|
|
|
|
|
|
#ifdef USE_SFIO |
1361
|
|
|
|
|
|
RESTORE_ERRNO; |
1362
|
|
|
|
|
|
#endif |
1363
|
|
|
|
|
|
} |
1364
|
|
|
|
|
|
} |
1365
|
|
|
|
|
|
|
1366
|
|
|
|
|
|
/* |
1367
|
|
|
|
|
|
=head1 Warning and Dieing |
1368
|
|
|
|
|
|
*/ |
1369
|
|
|
|
|
|
|
1370
|
|
|
|
|
|
/* Common code used in dieing and warning */ |
1371
|
|
|
|
|
|
|
1372
|
|
|
|
|
|
STATIC SV * |
1373
|
|
|
|
|
|
S_with_queued_errors(pTHX_ SV *ex) |
1374
|
|
|
|
|
|
{ |
1375
|
|
|
|
|
|
PERL_ARGS_ASSERT_WITH_QUEUED_ERRORS; |
1376
|
|
|
|
|
|
if (PL_errors && SvCUR(PL_errors) && !SvROK(ex)) { |
1377
|
|
|
|
|
|
sv_catsv(PL_errors, ex); |
1378
|
|
|
|
|
|
ex = sv_mortalcopy(PL_errors); |
1379
|
|
|
|
|
|
SvCUR_set(PL_errors, 0); |
1380
|
|
|
|
|
|
} |
1381
|
|
|
|
|
|
return ex; |
1382
|
|
|
|
|
|
} |
1383
|
|
|
|
|
|
|
1384
|
|
|
|
|
|
STATIC bool |
1385
|
|
|
|
|
|
S_invoke_exception_hook(pTHX_ SV *ex, bool warn) |
1386
|
|
|
|
|
|
{ |
1387
|
|
|
|
|
|
dVAR; |
1388
|
|
|
|
|
|
HV *stash; |
1389
|
|
|
|
|
|
GV *gv; |
1390
|
|
|
|
|
|
CV *cv; |
1391
|
|
|
|
|
|
SV **const hook = warn ? &PL_warnhook : &PL_diehook; |
1392
|
|
|
|
|
|
/* sv_2cv might call Perl_croak() or Perl_warner() */ |
1393
|
|
|
|
|
|
SV * const oldhook = *hook; |
1394
|
|
|
|
|
|
|
1395
|
|
|
|
|
|
if (!oldhook) |
1396
|
|
|
|
|
|
return FALSE; |
1397
|
|
|
|
|
|
|
1398
|
|
|
|
|
|
ENTER; |
1399
|
|
|
|
|
|
SAVESPTR(*hook); |
1400
|
|
|
|
|
|
*hook = NULL; |
1401
|
|
|
|
|
|
cv = sv_2cv(oldhook, &stash, &gv, 0); |
1402
|
|
|
|
|
|
LEAVE; |
1403
|
|
|
|
|
|
if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) { |
1404
|
|
|
|
|
|
dSP; |
1405
|
|
|
|
|
|
SV *exarg; |
1406
|
|
|
|
|
|
|
1407
|
|
|
|
|
|
ENTER; |
1408
|
|
|
|
|
|
save_re_context(); |
1409
|
|
|
|
|
|
if (warn) { |
1410
|
|
|
|
|
|
SAVESPTR(*hook); |
1411
|
|
|
|
|
|
*hook = NULL; |
1412
|
|
|
|
|
|
} |
1413
|
|
|
|
|
|
exarg = newSVsv(ex); |
1414
|
|
|
|
|
|
SvREADONLY_on(exarg); |
1415
|
|
|
|
|
|
SAVEFREESV(exarg); |
1416
|
|
|
|
|
|
|
1417
|
|
|
|
|
|
PUSHSTACKi(warn ? PERLSI_WARNHOOK : PERLSI_DIEHOOK); |
1418
|
|
|
|
|
|
PUSHMARK(SP); |
1419
|
|
|
|
|
|
XPUSHs(exarg); |
1420
|
|
|
|
|
|
PUTBACK; |
1421
|
|
|
|
|
|
call_sv(MUTABLE_SV(cv), G_DISCARD); |
1422
|
|
|
|
|
|
POPSTACK; |
1423
|
|
|
|
|
|
LEAVE; |
1424
|
|
|
|
|
|
return TRUE; |
1425
|
|
|
|
|
|
} |
1426
|
|
|
|
|
|
return FALSE; |
1427
|
|
|
|
|
|
} |
1428
|
|
|
|
|
|
|
1429
|
|
|
|
|
|
/* |
1430
|
|
|
|
|
|
=for apidoc Am|OP *|die_sv|SV *baseex |
1431
|
|
|
|
|
|
|
1432
|
|
|
|
|
|
Behaves the same as L, except for the return type. |
1433
|
|
|
|
|
|
It should be used only where the C return type is required. |
1434
|
|
|
|
|
|
The function never actually returns. |
1435
|
|
|
|
|
|
|
1436
|
|
|
|
|
|
=cut |
1437
|
|
|
|
|
|
*/ |
1438
|
|
|
|
|
|
|
1439
|
|
|
|
|
|
OP * |
1440
|
|
|
|
|
|
Perl_die_sv(pTHX_ SV *baseex) |
1441
|
|
|
|
|
|
{ |
1442
|
|
|
|
|
|
PERL_ARGS_ASSERT_DIE_SV; |
1443
|
|
|
|
|
|
croak_sv(baseex); |
1444
|
|
|
|
|
|
assert(0); /* NOTREACHED */ |
1445
|
|
|
|
|
|
return NULL; |
1446
|
|
|
|
|
|
} |
1447
|
|
|
|
|
|
|
1448
|
|
|
|
|
|
/* |
1449
|
|
|
|
|
|
=for apidoc Am|OP *|die|const char *pat|... |
1450
|
|
|
|
|
|
|
1451
|
|
|
|
|
|
Behaves the same as L, except for the return type. |
1452
|
|
|
|
|
|
It should be used only where the C return type is required. |
1453
|
|
|
|
|
|
The function never actually returns. |
1454
|
|
|
|
|
|
|
1455
|
|
|
|
|
|
=cut |
1456
|
|
|
|
|
|
*/ |
1457
|
|
|
|
|
|
|
1458
|
|
|
|
|
|
#if defined(PERL_IMPLICIT_CONTEXT) |
1459
|
|
|
|
|
|
OP * |
1460
|
|
|
|
|
|
Perl_die_nocontext(const char* pat, ...) |
1461
|
|
|
|
|
|
{ |
1462
|
|
|
|
|
|
dTHX; |
1463
|
|
|
|
|
|
va_list args; |
1464
|
|
|
|
|
|
va_start(args, pat); |
1465
|
|
|
|
|
|
vcroak(pat, &args); |
1466
|
|
|
|
|
|
assert(0); /* NOTREACHED */ |
1467
|
|
|
|
|
|
va_end(args); |
1468
|
|
|
|
|
|
return NULL; |
1469
|
|
|
|
|
|
} |
1470
|
|
|
|
|
|
#endif /* PERL_IMPLICIT_CONTEXT */ |
1471
|
|
|
|
|
|
|
1472
|
|
|
|
|
|
OP * |
1473
|
|
|
|
|
|
Perl_die(pTHX_ const char* pat, ...) |
1474
|
|
|
|
|
|
{ |
1475
|
|
|
|
|
|
va_list args; |
1476
|
|
|
|
|
|
va_start(args, pat); |
1477
|
|
|
|
|
|
vcroak(pat, &args); |
1478
|
|
|
|
|
|
assert(0); /* NOTREACHED */ |
1479
|
|
|
|
|
|
va_end(args); |
1480
|
|
|
|
|
|
return NULL; |
1481
|
|
|
|
|
|
} |
1482
|
|
|
|
|
|
|
1483
|
|
|
|
|
|
/* |
1484
|
|
|
|
|
|
=for apidoc Am|void|croak_sv|SV *baseex |
1485
|
|
|
|
|
|
|
1486
|
|
|
|
|
|
This is an XS interface to Perl's C function. |
1487
|
|
|
|
|
|
|
1488
|
|
|
|
|
|
C is the error message or object. If it is a reference, it |
1489
|
|
|
|
|
|
will be used as-is. Otherwise it is used as a string, and if it does |
1490
|
|
|
|
|
|
not end with a newline then it will be extended with some indication of |
1491
|
|
|
|
|
|
the current location in the code, as described for L. |
1492
|
|
|
|
|
|
|
1493
|
|
|
|
|
|
The error message or object will be used as an exception, by default |
1494
|
|
|
|
|
|
returning control to the nearest enclosing C, but subject to |
1495
|
|
|
|
|
|
modification by a C<$SIG{__DIE__}> handler. In any case, the C |
1496
|
|
|
|
|
|
function never returns normally. |
1497
|
|
|
|
|
|
|
1498
|
|
|
|
|
|
To die with a simple string message, the L function may be |
1499
|
|
|
|
|
|
more convenient. |
1500
|
|
|
|
|
|
|
1501
|
|
|
|
|
|
=cut |
1502
|
|
|
|
|
|
*/ |
1503
|
|
|
|
|
|
|
1504
|
|
|
|
|
|
void |
1505
|
|
|
|
|
|
Perl_croak_sv(pTHX_ SV *baseex) |
1506
|
|
|
|
|
|
{ |
1507
|
|
|
|
|
|
SV *ex = with_queued_errors(mess_sv(baseex, 0)); |
1508
|
|
|
|
|
|
PERL_ARGS_ASSERT_CROAK_SV; |
1509
|
|
|
|
|
|
invoke_exception_hook(ex, FALSE); |
1510
|
|
|
|
|
|
die_unwind(ex); |
1511
|
|
|
|
|
|
} |
1512
|
|
|
|
|
|
|
1513
|
|
|
|
|
|
/* |
1514
|
|
|
|
|
|
=for apidoc Am|void|vcroak|const char *pat|va_list *args |
1515
|
|
|
|
|
|
|
1516
|
|
|
|
|
|
This is an XS interface to Perl's C function. |
1517
|
|
|
|
|
|
|
1518
|
|
|
|
|
|
C and C are a sprintf-style format pattern and encapsulated |
1519
|
|
|
|
|
|
argument list. These are used to generate a string message. If the |
1520
|
|
|
|
|
|
message does not end with a newline, then it will be extended with |
1521
|
|
|
|
|
|
some indication of the current location in the code, as described for |
1522
|
|
|
|
|
|
L. |
1523
|
|
|
|
|
|
|
1524
|
|
|
|
|
|
The error message will be used as an exception, by default |
1525
|
|
|
|
|
|
returning control to the nearest enclosing C, but subject to |
1526
|
|
|
|
|
|
modification by a C<$SIG{__DIE__}> handler. In any case, the C |
1527
|
|
|
|
|
|
function never returns normally. |
1528
|
|
|
|
|
|
|
1529
|
|
|
|
|
|
For historical reasons, if C is null then the contents of C |
1530
|
|
|
|
|
|
(C<$@>) will be used as an error message or object instead of building an |
1531
|
|
|
|
|
|
error message from arguments. If you want to throw a non-string object, |
1532
|
|
|
|
|
|
or build an error message in an SV yourself, it is preferable to use |
1533
|
|
|
|
|
|
the L function, which does not involve clobbering C. |
1534
|
|
|
|
|
|
|
1535
|
|
|
|
|
|
=cut |
1536
|
|
|
|
|
|
*/ |
1537
|
|
|
|
|
|
|
1538
|
|
|
|
|
|
void |
1539
|
|
|
|
|
|
Perl_vcroak(pTHX_ const char* pat, va_list *args) |
1540
|
|
|
|
|
|
{ |
1541
|
|
|
|
|
|
SV *ex = with_queued_errors(pat ? vmess(pat, args) : mess_sv(ERRSV, 0)); |
1542
|
|
|
|
|
|
invoke_exception_hook(ex, FALSE); |
1543
|
|
|
|
|
|
die_unwind(ex); |
1544
|
|
|
|
|
|
} |
1545
|
|
|
|
|
|
|
1546
|
|
|
|
|
|
/* |
1547
|
|
|
|
|
|
=for apidoc Am|void|croak|const char *pat|... |
1548
|
|
|
|
|
|
|
1549
|
|
|
|
|
|
This is an XS interface to Perl's C function. |
1550
|
|
|
|
|
|
|
1551
|
|
|
|
|
|
Take a sprintf-style format pattern and argument list. These are used to |
1552
|
|
|
|
|
|
generate a string message. If the message does not end with a newline, |
1553
|
|
|
|
|
|
then it will be extended with some indication of the current location |
1554
|
|
|
|
|
|
in the code, as described for L. |
1555
|
|
|
|
|
|
|
1556
|
|
|
|
|
|
The error message will be used as an exception, by default |
1557
|
|
|
|
|
|
returning control to the nearest enclosing C, but subject to |
1558
|
|
|
|
|
|
modification by a C<$SIG{__DIE__}> handler. In any case, the C |
1559
|
|
|
|
|
|
function never returns normally. |
1560
|
|
|
|
|
|
|
1561
|
|
|
|
|
|
For historical reasons, if C is null then the contents of C |
1562
|
|
|
|
|
|
(C<$@>) will be used as an error message or object instead of building an |
1563
|
|
|
|
|
|
error message from arguments. If you want to throw a non-string object, |
1564
|
|
|
|
|
|
or build an error message in an SV yourself, it is preferable to use |
1565
|
|
|
|
|
|
the L function, which does not involve clobbering C. |
1566
|
|
|
|
|
|
|
1567
|
|
|
|
|
|
=cut |
1568
|
|
|
|
|
|
*/ |
1569
|
|
|
|
|
|
|
1570
|
|
|
|
|
|
#if defined(PERL_IMPLICIT_CONTEXT) |
1571
|
|
|
|
|
|
void |
1572
|
|
|
|
|
|
Perl_croak_nocontext(const char *pat, ...) |
1573
|
|
|
|
|
|
{ |
1574
|
|
|
|
|
|
dTHX; |
1575
|
|
|
|
|
|
va_list args; |
1576
|
|
|
|
|
|
va_start(args, pat); |
1577
|
|
|
|
|
|
vcroak(pat, &args); |
1578
|
|
|
|
|
|
assert(0); /* NOTREACHED */ |
1579
|
|
|
|
|
|
va_end(args); |
1580
|
|
|
|
|
|
} |
1581
|
|
|
|
|
|
#endif /* PERL_IMPLICIT_CONTEXT */ |
1582
|
|
|
|
|
|
|
1583
|
|
|
|
|
|
void |
1584
|
|
|
|
|
|
Perl_croak(pTHX_ const char *pat, ...) |
1585
|
|
|
|
|
|
{ |
1586
|
|
|
|
|
|
va_list args; |
1587
|
|
|
|
|
|
va_start(args, pat); |
1588
|
|
|
|
|
|
vcroak(pat, &args); |
1589
|
|
|
|
|
|
assert(0); /* NOTREACHED */ |
1590
|
|
|
|
|
|
va_end(args); |
1591
|
|
|
|
|
|
} |
1592
|
|
|
|
|
|
|
1593
|
|
|
|
|
|
/* |
1594
|
|
|
|
|
|
=for apidoc Am|void|croak_no_modify |
1595
|
|
|
|
|
|
|
1596
|
|
|
|
|
|
Exactly equivalent to C, but generates |
1597
|
|
|
|
|
|
terser object code than using C. Less code used on exception code |
1598
|
|
|
|
|
|
paths reduces CPU cache pressure. |
1599
|
|
|
|
|
|
|
1600
|
|
|
|
|
|
=cut |
1601
|
|
|
|
|
|
*/ |
1602
|
|
|
|
|
|
|
1603
|
|
|
|
|
|
void |
1604
|
|
|
|
|
|
Perl_croak_no_modify() |
1605
|
|
|
|
|
|
{ |
1606
|
|
|
|
|
|
Perl_croak_nocontext( "%s", PL_no_modify); |
1607
|
|
|
|
|
|
} |
1608
|
|
|
|
|
|
|
1609
|
|
|
|
|
|
/* does not return, used in util.c perlio.c and win32.c |
1610
|
|
|
|
|
|
This is typically called when malloc returns NULL. |
1611
|
|
|
|
|
|
*/ |
1612
|
|
|
|
|
|
void |
1613
|
|
|
|
|
|
Perl_croak_no_mem() |
1614
|
|
|
|
|
|
{ |
1615
|
|
|
|
|
|
dTHX; |
1616
|
|
|
|
|
|
|
1617
|
|
|
|
|
|
/* Can't use PerlIO to write as it allocates memory */ |
1618
|
|
|
|
|
|
PerlLIO_write(PerlIO_fileno(Perl_error_log), |
1619
|
|
|
|
|
|
PL_no_mem, sizeof(PL_no_mem)-1); |
1620
|
|
|
|
|
|
my_exit(1); |
1621
|
|
|
|
|
|
} |
1622
|
|
|
|
|
|
|
1623
|
|
|
|
|
|
/* does not return, used only in POPSTACK */ |
1624
|
|
|
|
|
|
void |
1625
|
|
|
|
|
|
Perl_croak_popstack(void) |
1626
|
|
|
|
|
|
{ |
1627
|
|
|
|
|
|
dTHX; |
1628
|
|
|
|
|
|
PerlIO_printf(Perl_error_log, "panic: POPSTACK\n"); |
1629
|
|
|
|
|
|
my_exit(1); |
1630
|
|
|
|
|
|
} |
1631
|
|
|
|
|
|
|
1632
|
|
|
|
|
|
/* |
1633
|
|
|
|
|
|
=for apidoc Am|void|warn_sv|SV *baseex |
1634
|
|
|
|
|
|
|
1635
|
|
|
|
|
|
This is an XS interface to Perl's C function. |
1636
|
|
|
|
|
|
|
1637
|
|
|
|
|
|
C is the error message or object. If it is a reference, it |
1638
|
|
|
|
|
|
will be used as-is. Otherwise it is used as a string, and if it does |
1639
|
|
|
|
|
|
not end with a newline then it will be extended with some indication of |
1640
|
|
|
|
|
|
the current location in the code, as described for L. |
1641
|
|
|
|
|
|
|
1642
|
|
|
|
|
|
The error message or object will by default be written to standard error, |
1643
|
|
|
|
|
|
but this is subject to modification by a C<$SIG{__WARN__}> handler. |
1644
|
|
|
|
|
|
|
1645
|
|
|
|
|
|
To warn with a simple string message, the L function may be |
1646
|
|
|
|
|
|
more convenient. |
1647
|
|
|
|
|
|
|
1648
|
|
|
|
|
|
=cut |
1649
|
|
|
|
|
|
*/ |
1650
|
|
|
|
|
|
|
1651
|
|
|
|
|
|
void |
1652
|
|
|
|
|
|
Perl_warn_sv(pTHX_ SV *baseex) |
1653
|
|
|
|
|
|
{ |
1654
|
|
|
|
|
|
SV *ex = mess_sv(baseex, 0); |
1655
|
|
|
|
|
|
PERL_ARGS_ASSERT_WARN_SV; |
1656
|
|
|
|
|
|
if (!invoke_exception_hook(ex, TRUE)) |
1657
|
|
|
|
|
|
write_to_stderr(ex); |
1658
|
|
|
|
|
|
} |
1659
|
|
|
|
|
|
|
1660
|
|
|
|
|
|
/* |
1661
|
|
|
|
|
|
=for apidoc Am|void|vwarn|const char *pat|va_list *args |
1662
|
|
|
|
|
|
|
1663
|
|
|
|
|
|
This is an XS interface to Perl's C function. |
1664
|
|
|
|
|
|
|
1665
|
|
|
|
|
|
C and C are a sprintf-style format pattern and encapsulated |
1666
|
|
|
|
|
|
argument list. These are used to generate a string message. If the |
1667
|
|
|
|
|
|
message does not end with a newline, then it will be extended with |
1668
|
|
|
|
|
|
some indication of the current location in the code, as described for |
1669
|
|
|
|
|
|
L. |
1670
|
|
|
|
|
|
|
1671
|
|
|
|
|
|
The error message or object will by default be written to standard error, |
1672
|
|
|
|
|
|
but this is subject to modification by a C<$SIG{__WARN__}> handler. |
1673
|
|
|
|
|
|
|
1674
|
|
|
|
|
|
Unlike with L, C is not permitted to be null. |
1675
|
|
|
|
|
|
|
1676
|
|
|
|
|
|
=cut |
1677
|
|
|
|
|
|
*/ |
1678
|
|
|
|
|
|
|
1679
|
|
|
|
|
|
void |
1680
|
|
|
|
|
|
Perl_vwarn(pTHX_ const char* pat, va_list *args) |
1681
|
|
|
|
|
|
{ |
1682
|
|
|
|
|
|
SV *ex = vmess(pat, args); |
1683
|
|
|
|
|
|
PERL_ARGS_ASSERT_VWARN; |
1684
|
|
|
|
|
|
if (!invoke_exception_hook(ex, TRUE)) |
1685
|
|
|
|
|
|
write_to_stderr(ex); |
1686
|
|
|
|
|
|
} |
1687
|
|
|
|
|
|
|
1688
|
|
|
|
|
|
/* |
1689
|
|
|
|
|
|
=for apidoc Am|void|warn|const char *pat|... |
1690
|
|
|
|
|
|
|
1691
|
|
|
|
|
|
This is an XS interface to Perl's C function. |
1692
|
|
|
|
|
|
|
1693
|
|
|
|
|
|
Take a sprintf-style format pattern and argument list. These are used to |
1694
|
|
|
|
|
|
generate a string message. If the message does not end with a newline, |
1695
|
|
|
|
|
|
then it will be extended with some indication of the current location |
1696
|
|
|
|
|
|
in the code, as described for L. |
1697
|
|
|
|
|
|
|
1698
|
|
|
|
|
|
The error message or object will by default be written to standard error, |
1699
|
|
|
|
|
|
but this is subject to modification by a C<$SIG{__WARN__}> handler. |
1700
|
|
|
|
|
|
|
1701
|
|
|
|
|
|
Unlike with L, C is not permitted to be null. |
1702
|
|
|
|
|
|
|
1703
|
|
|
|
|
|
=cut |
1704
|
|
|
|
|
|
*/ |
1705
|
|
|
|
|
|
|
1706
|
|
|
|
|
|
#if defined(PERL_IMPLICIT_CONTEXT) |
1707
|
|
|
|
|
|
void |
1708
|
|
|
|
|
|
Perl_warn_nocontext(const char *pat, ...) |
1709
|
|
|
|
|
|
{ |
1710
|
|
|
|
|
|
dTHX; |
1711
|
|
|
|
|
|
va_list args; |
1712
|
|
|
|
|
|
PERL_ARGS_ASSERT_WARN_NOCONTEXT; |
1713
|
|
|
|
|
|
va_start(args, pat); |
1714
|
|
|
|
|
|
vwarn(pat, &args); |
1715
|
|
|
|
|
|
va_end(args); |
1716
|
|
|
|
|
|
} |
1717
|
|
|
|
|
|
#endif /* PERL_IMPLICIT_CONTEXT */ |
1718
|
|
|
|
|
|
|
1719
|
|
|
|
|
|
void |
1720
|
|
|
|
|
|
Perl_warn(pTHX_ const char *pat, ...) |
1721
|
|
|
|
|
|
{ |
1722
|
|
|
|
|
|
va_list args; |
1723
|
|
|
|
|
|
PERL_ARGS_ASSERT_WARN; |
1724
|
|
|
|
|
|
va_start(args, pat); |
1725
|
|
|
|
|
|
vwarn(pat, &args); |
1726
|
|
|
|
|
|
va_end(args); |
1727
|
|
|
|
|
|
} |
1728
|
|
|
|
|
|
|
1729
|
|
|
|
|
|
#if defined(PERL_IMPLICIT_CONTEXT) |
1730
|
|
|
|
|
|
void |
1731
|
|
|
|
|
|
Perl_warner_nocontext(U32 err, const char *pat, ...) |
1732
|
|
|
|
|
|
{ |
1733
|
|
|
|
|
|
dTHX; |
1734
|
|
|
|
|
|
va_list args; |
1735
|
|
|
|
|
|
PERL_ARGS_ASSERT_WARNER_NOCONTEXT; |
1736
|
|
|
|
|
|
va_start(args, pat); |
1737
|
|
|
|
|
|
vwarner(err, pat, &args); |
1738
|
|
|
|
|
|
va_end(args); |
1739
|
|
|
|
|
|
} |
1740
|
|
|
|
|
|
#endif /* PERL_IMPLICIT_CONTEXT */ |
1741
|
|
|
|
|
|
|
1742
|
|
|
|
|
|
void |
1743
|
|
|
|
|
|
Perl_ck_warner_d(pTHX_ U32 err, const char* pat, ...) |
1744
|
|
|
|
|
|
{ |
1745
|
|
|
|
|
|
PERL_ARGS_ASSERT_CK_WARNER_D; |
1746
|
|
|
|
|
|
|
1747
|
|
|
|
|
|
if (Perl_ckwarn_d(aTHX_ err)) { |
1748
|
|
|
|
|
|
va_list args; |
1749
|
|
|
|
|
|
va_start(args, pat); |
1750
|
|
|
|
|
|
vwarner(err, pat, &args); |
1751
|
|
|
|
|
|
va_end(args); |
1752
|
|
|
|
|
|
} |
1753
|
|
|
|
|
|
} |
1754
|
|
|
|
|
|
|
1755
|
|
|
|
|
|
void |
1756
|
|
|
|
|
|
Perl_ck_warner(pTHX_ U32 err, const char* pat, ...) |
1757
|
|
|
|
|
|
{ |
1758
|
|
|
|
|
|
PERL_ARGS_ASSERT_CK_WARNER; |
1759
|
|
|
|
|
|
|
1760
|
|
|
|
|
|
if (Perl_ckwarn(aTHX_ err)) { |
1761
|
|
|
|
|
|
va_list args; |
1762
|
|
|
|
|
|
va_start(args, pat); |
1763
|
|
|
|
|
|
vwarner(err, pat, &args); |
1764
|
|
|
|
|
|
va_end(args); |
1765
|
|
|
|
|
|
} |
1766
|
|
|
|
|
|
} |
1767
|
|
|
|
|
|
|
1768
|
|
|
|
|
|
void |
1769
|
|
|
|
|
|
Perl_warner(pTHX_ U32 err, const char* pat,...) |
1770
|
|
|
|
|
|
{ |
1771
|
|
|
|
|
|
va_list args; |
1772
|
|
|
|
|
|
PERL_ARGS_ASSERT_WARNER; |
1773
|
|
|
|
|
|
va_start(args, pat); |
1774
|
|
|
|
|
|
vwarner(err, pat, &args); |
1775
|
|
|
|
|
|
va_end(args); |
1776
|
|
|
|
|
|
} |
1777
|
|
|
|
|
|
|
1778
|
|
|
|
|
|
void |
1779
|
|
|
|
|
|
Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args) |
1780
|
|
|
|
|
|
{ |
1781
|
|
|
|
|
|
dVAR; |
1782
|
|
|
|
|
|
PERL_ARGS_ASSERT_VWARNER; |
1783
|
|
|
|
|
|
if (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) { |
1784
|
|
|
|
|
|
SV * const msv = vmess(pat, args); |
1785
|
|
|
|
|
|
|
1786
|
|
|
|
|
|
invoke_exception_hook(msv, FALSE); |
1787
|
|
|
|
|
|
die_unwind(msv); |
1788
|
|
|
|
|
|
} |
1789
|
|
|
|
|
|
else { |
1790
|
|
|
|
|
|
Perl_vwarn(aTHX_ pat, args); |
1791
|
|
|
|
|
|
} |
1792
|
|
|
|
|
|
} |
1793
|
|
|
|
|
|
|
1794
|
|
|
|
|
|
/* implements the ckWARN? macros */ |
1795
|
|
|
|
|
|
|
1796
|
|
|
|
|
|
bool |
1797
|
|
|
|
|
|
Perl_ckwarn(pTHX_ U32 w) |
1798
|
|
|
|
|
|
{ |
1799
|
|
|
|
|
|
dVAR; |
1800
|
|
|
|
|
|
/* If lexical warnings have not been set, use $^W. */ |
1801
|
|
|
|
|
|
if (isLEXWARN_off) |
1802
|
|
|
|
|
|
return PL_dowarn & G_WARN_ON; |
1803
|
|
|
|
|
|
|
1804
|
|
|
|
|
|
return ckwarn_common(w); |
1805
|
|
|
|
|
|
} |
1806
|
|
|
|
|
|
|
1807
|
|
|
|
|
|
/* implements the ckWARN?_d macro */ |
1808
|
|
|
|
|
|
|
1809
|
|
|
|
|
|
bool |
1810
|
|
|
|
|
|
Perl_ckwarn_d(pTHX_ U32 w) |
1811
|
|
|
|
|
|
{ |
1812
|
|
|
|
|
|
dVAR; |
1813
|
|
|
|
|
|
/* If lexical warnings have not been set then default classes warn. */ |
1814
|
|
|
|
|
|
if (isLEXWARN_off) |
1815
|
|
|
|
|
|
return TRUE; |
1816
|
|
|
|
|
|
|
1817
|
|
|
|
|
|
return ckwarn_common(w); |
1818
|
|
|
|
|
|
} |
1819
|
|
|
|
|
|
|
1820
|
|
|
|
|
|
static bool |
1821
|
|
|
|
|
|
S_ckwarn_common(pTHX_ U32 w) |
1822
|
|
|
|
|
|
{ |
1823
|
|
|
|
|
|
if (PL_curcop->cop_warnings == pWARN_ALL) |
1824
|
|
|
|
|
|
return TRUE; |
1825
|
|
|
|
|
|
|
1826
|
|
|
|
|
|
if (PL_curcop->cop_warnings == pWARN_NONE) |
1827
|
|
|
|
|
|
return FALSE; |
1828
|
|
|
|
|
|
|
1829
|
|
|
|
|
|
/* Check the assumption that at least the first slot is non-zero. */ |
1830
|
|
|
|
|
|
assert(unpackWARN1(w)); |
1831
|
|
|
|
|
|
|
1832
|
|
|
|
|
|
/* Check the assumption that it is valid to stop as soon as a zero slot is |
1833
|
|
|
|
|
|
seen. */ |
1834
|
|
|
|
|
|
if (!unpackWARN2(w)) { |
1835
|
|
|
|
|
|
assert(!unpackWARN3(w)); |
1836
|
|
|
|
|
|
assert(!unpackWARN4(w)); |
1837
|
|
|
|
|
|
} else if (!unpackWARN3(w)) { |
1838
|
|
|
|
|
|
assert(!unpackWARN4(w)); |
1839
|
|
|
|
|
|
} |
1840
|
|
|
|
|
|
|
1841
|
|
|
|
|
|
/* Right, dealt with all the special cases, which are implemented as non- |
1842
|
|
|
|
|
|
pointers, so there is a pointer to a real warnings mask. */ |
1843
|
|
|
|
|
|
do { |
1844
|
|
|
|
|
|
if (isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w))) |
1845
|
|
|
|
|
|
return TRUE; |
1846
|
|
|
|
|
|
} while (w >>= WARNshift); |
1847
|
|
|
|
|
|
|
1848
|
|
|
|
|
|
return FALSE; |
1849
|
|
|
|
|
|
} |
1850
|
|
|
|
|
|
|
1851
|
|
|
|
|
|
/* Set buffer=NULL to get a new one. */ |
1852
|
|
|
|
|
|
STRLEN * |
1853
|
|
|
|
|
|
Perl_new_warnings_bitfield(pTHX_ STRLEN *buffer, const char *const bits, |
1854
|
|
|
|
|
|
STRLEN size) { |
1855
|
|
|
|
|
|
const MEM_SIZE len_wanted = |
1856
|
|
|
|
|
|
sizeof(STRLEN) + (size > WARNsize ? size : WARNsize); |
1857
|
|
|
|
|
|
PERL_UNUSED_CONTEXT; |
1858
|
|
|
|
|
|
PERL_ARGS_ASSERT_NEW_WARNINGS_BITFIELD; |
1859
|
|
|
|
|
|
|
1860
|
|
|
|
|
|
buffer = (STRLEN*) |
1861
|
|
|
|
|
|
(specialWARN(buffer) ? |
1862
|
|
|
|
|
|
PerlMemShared_malloc(len_wanted) : |
1863
|
|
|
|
|
|
PerlMemShared_realloc(buffer, len_wanted)); |
1864
|
|
|
|
|
|
buffer[0] = size; |
1865
|
|
|
|
|
|
Copy(bits, (buffer + 1), size, char); |
1866
|
|
|
|
|
|
if (size < WARNsize) |
1867
|
|
|
|
|
|
Zero((char *)(buffer + 1) + size, WARNsize - size, char); |
1868
|
|
|
|
|
|
return buffer; |
1869
|
|
|
|
|
|
} |
1870
|
|
|
|
|
|
|
1871
|
|
|
|
|
|
/* since we've already done strlen() for both nam and val |
1872
|
|
|
|
|
|
* we can use that info to make things faster than |
1873
|
|
|
|
|
|
* sprintf(s, "%s=%s", nam, val) |
1874
|
|
|
|
|
|
*/ |
1875
|
|
|
|
|
|
#define my_setenv_format(s, nam, nlen, val, vlen) \ |
1876
|
|
|
|
|
|
Copy(nam, s, nlen, char); \ |
1877
|
|
|
|
|
|
*(s+nlen) = '='; \ |
1878
|
|
|
|
|
|
Copy(val, s+(nlen+1), vlen, char); \ |
1879
|
|
|
|
|
|
*(s+(nlen+1+vlen)) = '\0' |
1880
|
|
|
|
|
|
|
1881
|
|
|
|
|
|
#ifdef USE_ENVIRON_ARRAY |
1882
|
|
|
|
|
|
/* VMS' my_setenv() is in vms.c */ |
1883
|
|
|
|
|
|
#if !defined(WIN32) && !defined(NETWARE) |
1884
|
|
|
|
|
|
void |
1885
|
|
|
|
|
|
Perl_my_setenv(pTHX_ const char *nam, const char *val) |
1886
|
|
|
|
|
|
{ |
1887
|
|
|
|
|
|
dVAR; |
1888
|
|
|
|
|
|
#ifdef USE_ITHREADS |
1889
|
|
|
|
|
|
/* only parent thread can modify process environment */ |
1890
|
|
|
|
|
|
if (PL_curinterp == aTHX) |
1891
|
|
|
|
|
|
#endif |
1892
|
|
|
|
|
|
{ |
1893
|
|
|
|
|
|
#ifndef PERL_USE_SAFE_PUTENV |
1894
|
|
|
|
|
|
if (!PL_use_safe_putenv) { |
1895
|
|
|
|
|
|
/* most putenv()s leak, so we manipulate environ directly */ |
1896
|
|
|
|
|
|
I32 i; |
1897
|
|
|
|
|
|
const I32 len = strlen(nam); |
1898
|
|
|
|
|
|
int nlen, vlen; |
1899
|
|
|
|
|
|
|
1900
|
|
|
|
|
|
/* where does it go? */ |
1901
|
|
|
|
|
|
for (i = 0; environ[i]; i++) { |
1902
|
|
|
|
|
|
if (strnEQ(environ[i],nam,len) && environ[i][len] == '=') |
1903
|
|
|
|
|
|
break; |
1904
|
|
|
|
|
|
} |
1905
|
|
|
|
|
|
|
1906
|
|
|
|
|
|
if (environ == PL_origenviron) { /* need we copy environment? */ |
1907
|
|
|
|
|
|
I32 j; |
1908
|
|
|
|
|
|
I32 max; |
1909
|
|
|
|
|
|
char **tmpenv; |
1910
|
|
|
|
|
|
|
1911
|
|
|
|
|
|
max = i; |
1912
|
|
|
|
|
|
while (environ[max]) |
1913
|
|
|
|
|
|
max++; |
1914
|
|
|
|
|
|
tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*)); |
1915
|
|
|
|
|
|
for (j=0; j
|
1916
|
|
|
|
|
|
const int len = strlen(environ[j]); |
1917
|
|
|
|
|
|
tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char)); |
1918
|
|
|
|
|
|
Copy(environ[j], tmpenv[j], len+1, char); |
1919
|
|
|
|
|
|
} |
1920
|
|
|
|
|
|
tmpenv[max] = NULL; |
1921
|
|
|
|
|
|
environ = tmpenv; /* tell exec where it is now */ |
1922
|
|
|
|
|
|
} |
1923
|
|
|
|
|
|
if (!val) { |
1924
|
|
|
|
|
|
safesysfree(environ[i]); |
1925
|
|
|
|
|
|
while (environ[i]) { |
1926
|
|
|
|
|
|
environ[i] = environ[i+1]; |
1927
|
|
|
|
|
|
i++; |
1928
|
|
|
|
|
|
} |
1929
|
|
|
|
|
|
return; |
1930
|
|
|
|
|
|
} |
1931
|
|
|
|
|
|
if (!environ[i]) { /* does not exist yet */ |
1932
|
|
|
|
|
|
environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*)); |
1933
|
|
|
|
|
|
environ[i+1] = NULL; /* make sure it's null terminated */ |
1934
|
|
|
|
|
|
} |
1935
|
|
|
|
|
|
else |
1936
|
|
|
|
|
|
safesysfree(environ[i]); |
1937
|
|
|
|
|
|
nlen = strlen(nam); |
1938
|
|
|
|
|
|
vlen = strlen(val); |
1939
|
|
|
|
|
|
|
1940
|
|
|
|
|
|
environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char)); |
1941
|
|
|
|
|
|
/* all that work just for this */ |
1942
|
|
|
|
|
|
my_setenv_format(environ[i], nam, nlen, val, vlen); |
1943
|
|
|
|
|
|
} else { |
1944
|
|
|
|
|
|
# endif |
1945
|
|
|
|
|
|
# if defined(__CYGWIN__)|| defined(__SYMBIAN32__) || defined(__riscos__) |
1946
|
|
|
|
|
|
# if defined(HAS_UNSETENV) |
1947
|
|
|
|
|
|
if (val == NULL) { |
1948
|
|
|
|
|
|
(void)unsetenv(nam); |
1949
|
|
|
|
|
|
} else { |
1950
|
|
|
|
|
|
(void)setenv(nam, val, 1); |
1951
|
|
|
|
|
|
} |
1952
|
|
|
|
|
|
# else /* ! HAS_UNSETENV */ |
1953
|
|
|
|
|
|
(void)setenv(nam, val, 1); |
1954
|
|
|
|
|
|
# endif /* HAS_UNSETENV */ |
1955
|
|
|
|
|
|
# else |
1956
|
|
|
|
|
|
# if defined(HAS_UNSETENV) |
1957
|
|
|
|
|
|
if (val == NULL) { |
1958
|
|
|
|
|
|
if (environ) /* old glibc can crash with null environ */ |
1959
|
|
|
|
|
|
(void)unsetenv(nam); |
1960
|
|
|
|
|
|
} else { |
1961
|
|
|
|
|
|
const int nlen = strlen(nam); |
1962
|
|
|
|
|
|
const int vlen = strlen(val); |
1963
|
|
|
|
|
|
char * const new_env = |
1964
|
|
|
|
|
|
(char*)safesysmalloc((nlen + vlen + 2) * sizeof(char)); |
1965
|
|
|
|
|
|
my_setenv_format(new_env, nam, nlen, val, vlen); |
1966
|
|
|
|
|
|
(void)putenv(new_env); |
1967
|
|
|
|
|
|
} |
1968
|
|
|
|
|
|
# else /* ! HAS_UNSETENV */ |
1969
|
|
|
|
|
|
char *new_env; |
1970
|
|
|
|
|
|
const int nlen = strlen(nam); |
1971
|
|
|
|
|
|
int vlen; |
1972
|
|
|
|
|
|
if (!val) { |
1973
|
|
|
|
|
|
val = ""; |
1974
|
|
|
|
|
|
} |
1975
|
|
|
|
|
|
vlen = strlen(val); |
1976
|
|
|
|
|
|
new_env = (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char)); |
1977
|
|
|
|
|
|
/* all that work just for this */ |
1978
|
|
|
|
|
|
my_setenv_format(new_env, nam, nlen, val, vlen); |
1979
|
|
|
|
|
|
(void)putenv(new_env); |
1980
|
|
|
|
|
|
# endif /* HAS_UNSETENV */ |
1981
|
|
|
|
|
|
# endif /* __CYGWIN__ */ |
1982
|
|
|
|
|
|
#ifndef PERL_USE_SAFE_PUTENV |
1983
|
|
|
|
|
|
} |
1984
|
|
|
|
|
|
#endif |
1985
|
|
|
|
|
|
} |
1986
|
|
|
|
|
|
} |
1987
|
|
|
|
|
|
|
1988
|
|
|
|
|
|
#else /* WIN32 || NETWARE */ |
1989
|
|
|
|
|
|
|
1990
|
|
|
|
|
|
void |
1991
|
|
|
|
|
|
Perl_my_setenv(pTHX_ const char *nam, const char *val) |
1992
|
|
|
|
|
|
{ |
1993
|
|
|
|
|
|
dVAR; |
1994
|
|
|
|
|
|
char *envstr; |
1995
|
|
|
|
|
|
const int nlen = strlen(nam); |
1996
|
|
|
|
|
|
int vlen; |
1997
|
|
|
|
|
|
|
1998
|
|
|
|
|
|
if (!val) { |
1999
|
|
|
|
|
|
val = ""; |
2000
|
|
|
|
|
|
} |
2001
|
|
|
|
|
|
vlen = strlen(val); |
2002
|
|
|
|
|
|
Newx(envstr, nlen+vlen+2, char); |
2003
|
|
|
|
|
|
my_setenv_format(envstr, nam, nlen, val, vlen); |
2004
|
|
|
|
|
|
(void)PerlEnv_putenv(envstr); |
2005
|
|
|
|
|
|
Safefree(envstr); |
2006
|
|
|
|
|
|
} |
2007
|
|
|
|
|
|
|
2008
|
|
|
|
|
|
#endif /* WIN32 || NETWARE */ |
2009
|
|
|
|
|
|
|
2010
|
|
|
|
|
|
#endif /* !VMS */ |
2011
|
|
|
|
|
|
|
2012
|
|
|
|
|
|
#ifdef UNLINK_ALL_VERSIONS |
2013
|
|
|
|
|
|
I32 |
2014
|
|
|
|
|
|
Perl_unlnk(pTHX_ const char *f) /* unlink all versions of a file */ |
2015
|
|
|
|
|
|
{ |
2016
|
|
|
|
|
|
I32 retries = 0; |
2017
|
|
|
|
|
|
|
2018
|
|
|
|
|
|
PERL_ARGS_ASSERT_UNLNK; |
2019
|
|
|
|
|
|
|
2020
|
|
|
|
|
|
while (PerlLIO_unlink(f) >= 0) |
2021
|
|
|
|
|
|
retries++; |
2022
|
|
|
|
|
|
return retries ? 0 : -1; |
2023
|
|
|
|
|
|
} |
2024
|
|
|
|
|
|
#endif |
2025
|
|
|
|
|
|
|
2026
|
|
|
|
|
|
/* this is a drop-in replacement for bcopy() */ |
2027
|
|
|
|
|
|
#if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY)) |
2028
|
|
|
|
|
|
char * |
2029
|
|
|
|
|
|
Perl_my_bcopy(const char *from, char *to, I32 len) |
2030
|
|
|
|
|
|
{ |
2031
|
|
|
|
|
|
char * const retval = to; |
2032
|
|
|
|
|
|
|
2033
|
|
|
|
|
|
PERL_ARGS_ASSERT_MY_BCOPY; |
2034
|
|
|
|
|
|
|
2035
|
|
|
|
|
|
assert(len >= 0); |
2036
|
|
|
|
|
|
|
2037
|
|
|
|
|
|
if (from - to >= 0) { |
2038
|
|
|
|
|
|
while (len--) |
2039
|
|
|
|
|
|
*to++ = *from++; |
2040
|
|
|
|
|
|
} |
2041
|
|
|
|
|
|
else { |
2042
|
|
|
|
|
|
to += len; |
2043
|
|
|
|
|
|
from += len; |
2044
|
|
|
|
|
|
while (len--) |
2045
|
|
|
|
|
|
*(--to) = *(--from); |
2046
|
|
|
|
|
|
} |
2047
|
|
|
|
|
|
return retval; |
2048
|
|
|
|
|
|
} |
2049
|
|
|
|
|
|
#endif |
2050
|
|
|
|
|
|
|
2051
|
|
|
|
|
|
/* this is a drop-in replacement for memset() */ |
2052
|
|
|
|
|
|
#ifndef HAS_MEMSET |
2053
|
|
|
|
|
|
void * |
2054
|
|
|
|
|
|
Perl_my_memset(char *loc, I32 ch, I32 len) |
2055
|
|
|
|
|
|
{ |
2056
|
|
|
|
|
|
char * const retval = loc; |
2057
|
|
|
|
|
|
|
2058
|
|
|
|
|
|
PERL_ARGS_ASSERT_MY_MEMSET; |
2059
|
|
|
|
|
|
|
2060
|
|
|
|
|
|
assert(len >= 0); |
2061
|
|
|
|
|
|
|
2062
|
|
|
|
|
|
while (len--) |
2063
|
|
|
|
|
|
*loc++ = ch; |
2064
|
|
|
|
|
|
return retval; |
2065
|
|
|
|
|
|
} |
2066
|
|
|
|
|
|
#endif |
2067
|
|
|
|
|
|
|
2068
|
|
|
|
|
|
/* this is a drop-in replacement for bzero() */ |
2069
|
|
|
|
|
|
#if !defined(HAS_BZERO) && !defined(HAS_MEMSET) |
2070
|
|
|
|
|
|
char * |
2071
|
|
|
|
|
|
Perl_my_bzero(char *loc, I32 len) |
2072
|
|
|
|
|
|
{ |
2073
|
|
|
|
|
|
char * const retval = loc; |
2074
|
|
|
|
|
|
|
2075
|
|
|
|
|
|
PERL_ARGS_ASSERT_MY_BZERO; |
2076
|
|
|
|
|
|
|
2077
|
|
|
|
|
|
assert(len >= 0); |
2078
|
|
|
|
|
|
|
2079
|
|
|
|
|
|
while (len--) |
2080
|
|
|
|
|
|
*loc++ = 0; |
2081
|
|
|
|
|
|
return retval; |
2082
|
|
|
|
|
|
} |
2083
|
|
|
|
|
|
#endif |
2084
|
|
|
|
|
|
|
2085
|
|
|
|
|
|
/* this is a drop-in replacement for memcmp() */ |
2086
|
|
|
|
|
|
#if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP) |
2087
|
|
|
|
|
|
I32 |
2088
|
|
|
|
|
|
Perl_my_memcmp(const char *s1, const char *s2, I32 len) |
2089
|
|
|
|
|
|
{ |
2090
|
|
|
|
|
|
const U8 *a = (const U8 *)s1; |
2091
|
|
|
|
|
|
const U8 *b = (const U8 *)s2; |
2092
|
|
|
|
|
|
I32 tmp; |
2093
|
|
|
|
|
|
|
2094
|
|
|
|
|
|
PERL_ARGS_ASSERT_MY_MEMCMP; |
2095
|
|
|
|
|
|
|
2096
|
|
|
|
|
|
assert(len >= 0); |
2097
|
|
|
|
|
|
|
2098
|
|
|
|
|
|
while (len--) { |
2099
|
|
|
|
|
|
if ((tmp = *a++ - *b++)) |
2100
|
|
|
|
|
|
return tmp; |
2101
|
|
|
|
|
|
} |
2102
|
|
|
|
|
|
return 0; |
2103
|
|
|
|
|
|
} |
2104
|
|
|
|
|
|
#endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */ |
2105
|
|
|
|
|
|
|
2106
|
|
|
|
|
|
#ifndef HAS_VPRINTF |
2107
|
|
|
|
|
|
/* This vsprintf replacement should generally never get used, since |
2108
|
|
|
|
|
|
vsprintf was available in both System V and BSD 2.11. (There may |
2109
|
|
|
|
|
|
be some cross-compilation or embedded set-ups where it is needed, |
2110
|
|
|
|
|
|
however.) |
2111
|
|
|
|
|
|
|
2112
|
|
|
|
|
|
If you encounter a problem in this function, it's probably a symptom |
2113
|
|
|
|
|
|
that Configure failed to detect your system's vprintf() function. |
2114
|
|
|
|
|
|
See the section on "item vsprintf" in the INSTALL file. |
2115
|
|
|
|
|
|
|
2116
|
|
|
|
|
|
This version may compile on systems with BSD-ish , |
2117
|
|
|
|
|
|
but probably won't on others. |
2118
|
|
|
|
|
|
*/ |
2119
|
|
|
|
|
|
|
2120
|
|
|
|
|
|
#ifdef USE_CHAR_VSPRINTF |
2121
|
|
|
|
|
|
char * |
2122
|
|
|
|
|
|
#else |
2123
|
|
|
|
|
|
int |
2124
|
|
|
|
|
|
#endif |
2125
|
|
|
|
|
|
vsprintf(char *dest, const char *pat, void *args) |
2126
|
|
|
|
|
|
{ |
2127
|
|
|
|
|
|
FILE fakebuf; |
2128
|
|
|
|
|
|
|
2129
|
|
|
|
|
|
#if defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE) |
2130
|
|
|
|
|
|
FILE_ptr(&fakebuf) = (STDCHAR *) dest; |
2131
|
|
|
|
|
|
FILE_cnt(&fakebuf) = 32767; |
2132
|
|
|
|
|
|
#else |
2133
|
|
|
|
|
|
/* These probably won't compile -- If you really need |
2134
|
|
|
|
|
|
this, you'll have to figure out some other method. */ |
2135
|
|
|
|
|
|
fakebuf._ptr = dest; |
2136
|
|
|
|
|
|
fakebuf._cnt = 32767; |
2137
|
|
|
|
|
|
#endif |
2138
|
|
|
|
|
|
#ifndef _IOSTRG |
2139
|
|
|
|
|
|
#define _IOSTRG 0 |
2140
|
|
|
|
|
|
#endif |
2141
|
|
|
|
|
|
fakebuf._flag = _IOWRT|_IOSTRG; |
2142
|
|
|
|
|
|
_doprnt(pat, args, &fakebuf); /* what a kludge */ |
2143
|
|
|
|
|
|
#if defined(STDIO_PTR_LVALUE) |
2144
|
|
|
|
|
|
*(FILE_ptr(&fakebuf)++) = '\0'; |
2145
|
|
|
|
|
|
#else |
2146
|
|
|
|
|
|
/* PerlIO has probably #defined away fputc, but we want it here. */ |
2147
|
|
|
|
|
|
# ifdef fputc |
2148
|
|
|
|
|
|
# undef fputc /* XXX Should really restore it later */ |
2149
|
|
|
|
|
|
# endif |
2150
|
|
|
|
|
|
(void)fputc('\0', &fakebuf); |
2151
|
|
|
|
|
|
#endif |
2152
|
|
|
|
|
|
#ifdef USE_CHAR_VSPRINTF |
2153
|
|
|
|
|
|
return(dest); |
2154
|
|
|
|
|
|
#else |
2155
|
|
|
|
|
|
return 0; /* perl doesn't use return value */ |
2156
|
|
|
|
|
|
#endif |
2157
|
|
|
|
|
|
} |
2158
|
|
|
|
|
|
|
2159
|
|
|
|
|
|
#endif /* HAS_VPRINTF */ |
2160
|
|
|
|
|
|
|
2161
|
|
|
|
|
|
PerlIO * |
2162
|
|
|
|
|
|
Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args) |
2163
|
|
|
|
|
|
{ |
2164
|
|
|
|
|
|
#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(NETWARE) && !defined(__LIBCATAMOUNT__) |
2165
|
|
|
|
|
|
dVAR; |
2166
|
|
|
|
|
|
int p[2]; |
2167
|
|
|
|
|
|
I32 This, that; |
2168
|
|
|
|
|
|
Pid_t pid; |
2169
|
|
|
|
|
|
SV *sv; |
2170
|
|
|
|
|
|
I32 did_pipes = 0; |
2171
|
|
|
|
|
|
int pp[2]; |
2172
|
|
|
|
|
|
|
2173
|
|
|
|
|
|
PERL_ARGS_ASSERT_MY_POPEN_LIST; |
2174
|
|
|
|
|
|
|
2175
|
|
|
|
|
|
PERL_FLUSHALL_FOR_CHILD; |
2176
|
|
|
|
|
|
This = (*mode == 'w'); |
2177
|
|
|
|
|
|
that = !This; |
2178
|
|
|
|
|
|
if (TAINTING_get) { |
2179
|
|
|
|
|
|
taint_env(); |
2180
|
|
|
|
|
|
taint_proper("Insecure %s%s", "EXEC"); |
2181
|
|
|
|
|
|
} |
2182
|
|
|
|
|
|
if (PerlProc_pipe(p) < 0) |
2183
|
|
|
|
|
|
return NULL; |
2184
|
|
|
|
|
|
/* Try for another pipe pair for error return */ |
2185
|
|
|
|
|
|
if (PerlProc_pipe(pp) >= 0) |
2186
|
|
|
|
|
|
did_pipes = 1; |
2187
|
|
|
|
|
|
while ((pid = PerlProc_fork()) < 0) { |
2188
|
|
|
|
|
|
if (errno != EAGAIN) { |
2189
|
|
|
|
|
|
PerlLIO_close(p[This]); |
2190
|
|
|
|
|
|
PerlLIO_close(p[that]); |
2191
|
|
|
|
|
|
if (did_pipes) { |
2192
|
|
|
|
|
|
PerlLIO_close(pp[0]); |
2193
|
|
|
|
|
|
PerlLIO_close(pp[1]); |
2194
|
|
|
|
|
|
} |
2195
|
|
|
|
|
|
return NULL; |
2196
|
|
|
|
|
|
} |
2197
|
|
|
|
|
|
Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds"); |
2198
|
|
|
|
|
|
sleep(5); |
2199
|
|
|
|
|
|
} |
2200
|
|
|
|
|
|
if (pid == 0) { |
2201
|
|
|
|
|
|
/* Child */ |
2202
|
|
|
|
|
|
#undef THIS |
2203
|
|
|
|
|
|
#undef THAT |
2204
|
|
|
|
|
|
#define THIS that |
2205
|
|
|
|
|
|
#define THAT This |
2206
|
|
|
|
|
|
/* Close parent's end of error status pipe (if any) */ |
2207
|
|
|
|
|
|
if (did_pipes) { |
2208
|
|
|
|
|
|
PerlLIO_close(pp[0]); |
2209
|
|
|
|
|
|
#if defined(HAS_FCNTL) && defined(F_SETFD) |
2210
|
|
|
|
|
|
/* Close error pipe automatically if exec works */ |
2211
|
|
|
|
|
|
fcntl(pp[1], F_SETFD, FD_CLOEXEC); |
2212
|
|
|
|
|
|
#endif |
2213
|
|
|
|
|
|
} |
2214
|
|
|
|
|
|
/* Now dup our end of _the_ pipe to right position */ |
2215
|
|
|
|
|
|
if (p[THIS] != (*mode == 'r')) { |
2216
|
|
|
|
|
|
PerlLIO_dup2(p[THIS], *mode == 'r'); |
2217
|
|
|
|
|
|
PerlLIO_close(p[THIS]); |
2218
|
|
|
|
|
|
if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */ |
2219
|
|
|
|
|
|
PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */ |
2220
|
|
|
|
|
|
} |
2221
|
|
|
|
|
|
else |
2222
|
|
|
|
|
|
PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */ |
2223
|
|
|
|
|
|
#if !defined(HAS_FCNTL) || !defined(F_SETFD) |
2224
|
|
|
|
|
|
/* No automatic close - do it by hand */ |
2225
|
|
|
|
|
|
# ifndef NOFILE |
2226
|
|
|
|
|
|
# define NOFILE 20 |
2227
|
|
|
|
|
|
# endif |
2228
|
|
|
|
|
|
{ |
2229
|
|
|
|
|
|
int fd; |
2230
|
|
|
|
|
|
|
2231
|
|
|
|
|
|
for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) { |
2232
|
|
|
|
|
|
if (fd != pp[1]) |
2233
|
|
|
|
|
|
PerlLIO_close(fd); |
2234
|
|
|
|
|
|
} |
2235
|
|
|
|
|
|
} |
2236
|
|
|
|
|
|
#endif |
2237
|
|
|
|
|
|
do_aexec5(NULL, args-1, args-1+n, pp[1], did_pipes); |
2238
|
|
|
|
|
|
PerlProc__exit(1); |
2239
|
|
|
|
|
|
#undef THIS |
2240
|
|
|
|
|
|
#undef THAT |
2241
|
|
|
|
|
|
} |
2242
|
|
|
|
|
|
/* Parent */ |
2243
|
|
|
|
|
|
do_execfree(); /* free any memory malloced by child on fork */ |
2244
|
|
|
|
|
|
if (did_pipes) |
2245
|
|
|
|
|
|
PerlLIO_close(pp[1]); |
2246
|
|
|
|
|
|
/* Keep the lower of the two fd numbers */ |
2247
|
|
|
|
|
|
if (p[that] < p[This]) { |
2248
|
|
|
|
|
|
PerlLIO_dup2(p[This], p[that]); |
2249
|
|
|
|
|
|
PerlLIO_close(p[This]); |
2250
|
|
|
|
|
|
p[This] = p[that]; |
2251
|
|
|
|
|
|
} |
2252
|
|
|
|
|
|
else |
2253
|
|
|
|
|
|
PerlLIO_close(p[that]); /* close child's end of pipe */ |
2254
|
|
|
|
|
|
|
2255
|
|
|
|
|
|
sv = *av_fetch(PL_fdpid,p[This],TRUE); |
2256
|
|
|
|
|
|
SvUPGRADE(sv,SVt_IV); |
2257
|
|
|
|
|
|
SvIV_set(sv, pid); |
2258
|
|
|
|
|
|
PL_forkprocess = pid; |
2259
|
|
|
|
|
|
/* If we managed to get status pipe check for exec fail */ |
2260
|
|
|
|
|
|
if (did_pipes && pid > 0) { |
2261
|
|
|
|
|
|
int errkid; |
2262
|
|
|
|
|
|
unsigned n = 0; |
2263
|
|
|
|
|
|
SSize_t n1; |
2264
|
|
|
|
|
|
|
2265
|
|
|
|
|
|
while (n < sizeof(int)) { |
2266
|
|
|
|
|
|
n1 = PerlLIO_read(pp[0], |
2267
|
|
|
|
|
|
(void*)(((char*)&errkid)+n), |
2268
|
|
|
|
|
|
(sizeof(int)) - n); |
2269
|
|
|
|
|
|
if (n1 <= 0) |
2270
|
|
|
|
|
|
break; |
2271
|
|
|
|
|
|
n += n1; |
2272
|
|
|
|
|
|
} |
2273
|
|
|
|
|
|
PerlLIO_close(pp[0]); |
2274
|
|
|
|
|
|
did_pipes = 0; |
2275
|
|
|
|
|
|
if (n) { /* Error */ |
2276
|
|
|
|
|
|
int pid2, status; |
2277
|
|
|
|
|
|
PerlLIO_close(p[This]); |
2278
|
|
|
|
|
|
if (n != sizeof(int)) |
2279
|
|
|
|
|
|
Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", n); |
2280
|
|
|
|
|
|
do { |
2281
|
|
|
|
|
|
pid2 = wait4pid(pid, &status, 0); |
2282
|
|
|
|
|
|
} while (pid2 == -1 && errno == EINTR); |
2283
|
|
|
|
|
|
errno = errkid; /* Propagate errno from kid */ |
2284
|
|
|
|
|
|
return NULL; |
2285
|
|
|
|
|
|
} |
2286
|
|
|
|
|
|
} |
2287
|
|
|
|
|
|
if (did_pipes) |
2288
|
|
|
|
|
|
PerlLIO_close(pp[0]); |
2289
|
|
|
|
|
|
return PerlIO_fdopen(p[This], mode); |
2290
|
|
|
|
|
|
#else |
2291
|
|
|
|
|
|
# ifdef OS2 /* Same, without fork()ing and all extra overhead... */ |
2292
|
|
|
|
|
|
return my_syspopen4(aTHX_ NULL, mode, n, args); |
2293
|
|
|
|
|
|
# else |
2294
|
|
|
|
|
|
Perl_croak(aTHX_ "List form of piped open not implemented"); |
2295
|
|
|
|
|
|
return (PerlIO *) NULL; |
2296
|
|
|
|
|
|
# endif |
2297
|
|
|
|
|
|
#endif |
2298
|
|
|
|
|
|
} |
2299
|
|
|
|
|
|
|
2300
|
|
|
|
|
|
/* VMS' my_popen() is in VMS.c, same with OS/2. */ |
2301
|
|
|
|
|
|
#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__LIBCATAMOUNT__) |
2302
|
|
|
|
|
|
PerlIO * |
2303
|
|
|
|
|
|
Perl_my_popen(pTHX_ const char *cmd, const char *mode) |
2304
|
|
|
|
|
|
{ |
2305
|
|
|
|
|
|
dVAR; |
2306
|
|
|
|
|
|
int p[2]; |
2307
|
|
|
|
|
|
I32 This, that; |
2308
|
|
|
|
|
|
Pid_t pid; |
2309
|
|
|
|
|
|
SV *sv; |
2310
|
|
|
|
|
|
const I32 doexec = !(*cmd == '-' && cmd[1] == '\0'); |
2311
|
|
|
|
|
|
I32 did_pipes = 0; |
2312
|
|
|
|
|
|
int pp[2]; |
2313
|
|
|
|
|
|
|
2314
|
|
|
|
|
|
PERL_ARGS_ASSERT_MY_POPEN; |
2315
|
|
|
|
|
|
|
2316
|
|
|
|
|
|
PERL_FLUSHALL_FOR_CHILD; |
2317
|
|
|
|
|
|
#ifdef OS2 |
2318
|
|
|
|
|
|
if (doexec) { |
2319
|
|
|
|
|
|
return my_syspopen(aTHX_ cmd,mode); |
2320
|
|
|
|
|
|
} |
2321
|
|
|
|
|
|
#endif |
2322
|
|
|
|
|
|
This = (*mode == 'w'); |
2323
|
|
|
|
|
|
that = !This; |
2324
|
|
|
|
|
|
if (doexec && TAINTING_get) { |
2325
|
|
|
|
|
|
taint_env(); |
2326
|
|
|
|
|
|
taint_proper("Insecure %s%s", "EXEC"); |
2327
|
|
|
|
|
|
} |
2328
|
|
|
|
|
|
if (PerlProc_pipe(p) < 0) |
2329
|
|
|
|
|
|
return NULL; |
2330
|
|
|
|
|
|
if (doexec && PerlProc_pipe(pp) >= 0) |
2331
|
|
|
|
|
|
did_pipes = 1; |
2332
|
|
|
|
|
|
while ((pid = PerlProc_fork()) < 0) { |
2333
|
|
|
|
|
|
if (errno != EAGAIN) { |
2334
|
|
|
|
|
|
PerlLIO_close(p[This]); |
2335
|
|
|
|
|
|
PerlLIO_close(p[that]); |
2336
|
|
|
|
|
|
if (did_pipes) { |
2337
|
|
|
|
|
|
PerlLIO_close(pp[0]); |
2338
|
|
|
|
|
|
PerlLIO_close(pp[1]); |
2339
|
|
|
|
|
|
} |
2340
|
|
|
|
|
|
if (!doexec) |
2341
|
|
|
|
|
|
Perl_croak(aTHX_ "Can't fork: %s", Strerror(errno)); |
2342
|
|
|
|
|
|
return NULL; |
2343
|
|
|
|
|
|
} |
2344
|
|
|
|
|
|
Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds"); |
2345
|
|
|
|
|
|
sleep(5); |
2346
|
|
|
|
|
|
} |
2347
|
|
|
|
|
|
if (pid == 0) { |
2348
|
|
|
|
|
|
|
2349
|
|
|
|
|
|
#undef THIS |
2350
|
|
|
|
|
|
#undef THAT |
2351
|
|
|
|
|
|
#define THIS that |
2352
|
|
|
|
|
|
#define THAT This |
2353
|
|
|
|
|
|
if (did_pipes) { |
2354
|
|
|
|
|
|
PerlLIO_close(pp[0]); |
2355
|
|
|
|
|
|
#if defined(HAS_FCNTL) && defined(F_SETFD) |
2356
|
|
|
|
|
|
fcntl(pp[1], F_SETFD, FD_CLOEXEC); |
2357
|
|
|
|
|
|
#endif |
2358
|
|
|
|
|
|
} |
2359
|
|
|
|
|
|
if (p[THIS] != (*mode == 'r')) { |
2360
|
|
|
|
|
|
PerlLIO_dup2(p[THIS], *mode == 'r'); |
2361
|
|
|
|
|
|
PerlLIO_close(p[THIS]); |
2362
|
|
|
|
|
|
if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */ |
2363
|
|
|
|
|
|
PerlLIO_close(p[THAT]); |
2364
|
|
|
|
|
|
} |
2365
|
|
|
|
|
|
else |
2366
|
|
|
|
|
|
PerlLIO_close(p[THAT]); |
2367
|
|
|
|
|
|
#ifndef OS2 |
2368
|
|
|
|
|
|
if (doexec) { |
2369
|
|
|
|
|
|
#if !defined(HAS_FCNTL) || !defined(F_SETFD) |
2370
|
|
|
|
|
|
#ifndef NOFILE |
2371
|
|
|
|
|
|
#define NOFILE 20 |
2372
|
|
|
|
|
|
#endif |
2373
|
|
|
|
|
|
{ |
2374
|
|
|
|
|
|
int fd; |
2375
|
|
|
|
|
|
|
2376
|
|
|
|
|
|
for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) |
2377
|
|
|
|
|
|
if (fd != pp[1]) |
2378
|
|
|
|
|
|
PerlLIO_close(fd); |
2379
|
|
|
|
|
|
} |
2380
|
|
|
|
|
|
#endif |
2381
|
|
|
|
|
|
/* may or may not use the shell */ |
2382
|
|
|
|
|
|
do_exec3(cmd, pp[1], did_pipes); |
2383
|
|
|
|
|
|
PerlProc__exit(1); |
2384
|
|
|
|
|
|
} |
2385
|
|
|
|
|
|
#endif /* defined OS2 */ |
2386
|
|
|
|
|
|
|
2387
|
|
|
|
|
|
#ifdef PERLIO_USING_CRLF |
2388
|
|
|
|
|
|
/* Since we circumvent IO layers when we manipulate low-level |
2389
|
|
|
|
|
|
filedescriptors directly, need to manually switch to the |
2390
|
|
|
|
|
|
default, binary, low-level mode; see PerlIOBuf_open(). */ |
2391
|
|
|
|
|
|
PerlLIO_setmode((*mode == 'r'), O_BINARY); |
2392
|
|
|
|
|
|
#endif |
2393
|
|
|
|
|
|
PL_forkprocess = 0; |
2394
|
|
|
|
|
|
#ifdef PERL_USES_PL_PIDSTATUS |
2395
|
|
|
|
|
|
hv_clear(PL_pidstatus); /* we have no children */ |
2396
|
|
|
|
|
|
#endif |
2397
|
|
|
|
|
|
return NULL; |
2398
|
|
|
|
|
|
#undef THIS |
2399
|
|
|
|
|
|
#undef THAT |
2400
|
|
|
|
|
|
} |
2401
|
|
|
|
|
|
do_execfree(); /* free any memory malloced by child on vfork */ |
2402
|
|
|
|
|
|
if (did_pipes) |
2403
|
|
|
|
|
|
PerlLIO_close(pp[1]); |
2404
|
|
|
|
|
|
if (p[that] < p[This]) { |
2405
|
|
|
|
|
|
PerlLIO_dup2(p[This], p[that]); |
2406
|
|
|
|
|
|
PerlLIO_close(p[This]); |
2407
|
|
|
|
|
|
p[This] = p[that]; |
2408
|
|
|
|
|
|
} |
2409
|
|
|
|
|
|
else |
2410
|
|
|
|
|
|
PerlLIO_close(p[that]); |
2411
|
|
|
|
|
|
|
2412
|
|
|
|
|
|
sv = *av_fetch(PL_fdpid,p[This],TRUE); |
2413
|
|
|
|
|
|
SvUPGRADE(sv,SVt_IV); |
2414
|
|
|
|
|
|
SvIV_set(sv, pid); |
2415
|
|
|
|
|
|
PL_forkprocess = pid; |
2416
|
|
|
|
|
|
if (did_pipes && pid > 0) { |
2417
|
|
|
|
|
|
int errkid; |
2418
|
|
|
|
|
|
unsigned n = 0; |
2419
|
|
|
|
|
|
SSize_t n1; |
2420
|
|
|
|
|
|
|
2421
|
|
|
|
|
|
while (n < sizeof(int)) { |
2422
|
|
|
|
|
|
n1 = PerlLIO_read(pp[0], |
2423
|
|
|
|
|
|
(void*)(((char*)&errkid)+n), |
2424
|
|
|
|
|
|
(sizeof(int)) - n); |
2425
|
|
|
|
|
|
if (n1 <= 0) |
2426
|
|
|
|
|
|
break; |
2427
|
|
|
|
|
|
n += n1; |
2428
|
|
|
|
|
|
} |
2429
|
|
|
|
|
|
PerlLIO_close(pp[0]); |
2430
|
|
|
|
|
|
did_pipes = 0; |
2431
|
|
|
|
|
|
if (n) { /* Error */ |
2432
|
|
|
|
|
|
int pid2, status; |
2433
|
|
|
|
|
|
PerlLIO_close(p[This]); |
2434
|
|
|
|
|
|
if (n != sizeof(int)) |
2435
|
|
|
|
|
|
Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", n); |
2436
|
|
|
|
|
|
do { |
2437
|
|
|
|
|
|
pid2 = wait4pid(pid, &status, 0); |
2438
|
|
|
|
|
|
} while (pid2 == -1 && errno == EINTR); |
2439
|
|
|
|
|
|
errno = errkid; /* Propagate errno from kid */ |
2440
|
|
|
|
|
|
return NULL; |
2441
|
|
|
|
|
|
} |
2442
|
|
|
|
|
|
} |
2443
|
|
|
|
|
|
if (did_pipes) |
2444
|
|
|
|
|
|
PerlLIO_close(pp[0]); |
2445
|
|
|
|
|
|
return PerlIO_fdopen(p[This], mode); |
2446
|
|
|
|
|
|
} |
2447
|
|
|
|
|
|
#else |
2448
|
|
|
|
|
|
#if defined(DJGPP) |
2449
|
|
|
|
|
|
FILE *djgpp_popen(); |
2450
|
|
|
|
|
|
PerlIO * |
2451
|
|
|
|
|
|
Perl_my_popen(pTHX_ const char *cmd, const char *mode) |
2452
|
|
|
|
|
|
{ |
2453
|
|
|
|
|
|
PERL_FLUSHALL_FOR_CHILD; |
2454
|
|
|
|
|
|
/* Call system's popen() to get a FILE *, then import it. |
2455
|
|
|
|
|
|
used 0 for 2nd parameter to PerlIO_importFILE; |
2456
|
|
|
|
|
|
apparently not used |
2457
|
|
|
|
|
|
*/ |
2458
|
|
|
|
|
|
return PerlIO_importFILE(djgpp_popen(cmd, mode), 0); |
2459
|
|
|
|
|
|
} |
2460
|
|
|
|
|
|
#else |
2461
|
|
|
|
|
|
#if defined(__LIBCATAMOUNT__) |
2462
|
|
|
|
|
|
PerlIO * |
2463
|
|
|
|
|
|
Perl_my_popen(pTHX_ const char *cmd, const char *mode) |
2464
|
|
|
|
|
|
{ |
2465
|
|
|
|
|
|
return NULL; |
2466
|
|
|
|
|
|
} |
2467
|
|
|
|
|
|
#endif |
2468
|
|
|
|
|
|
#endif |
2469
|
|
|
|
|
|
|
2470
|
|
|
|
|
|
#endif /* !DOSISH */ |
2471
|
|
|
|
|
|
|
2472
|
|
|
|
|
|
/* this is called in parent before the fork() */ |
2473
|
|
|
|
|
|
void |
2474
|
|
|
|
|
|
Perl_atfork_lock(void) |
2475
|
|
|
|
|
|
{ |
2476
|
|
|
|
|
|
dVAR; |
2477
|
|
|
|
|
|
#if defined(USE_ITHREADS) |
2478
|
|
|
|
|
|
/* locks must be held in locking order (if any) */ |
2479
|
|
|
|
|
|
# ifdef USE_PERLIO |
2480
|
|
|
|
|
|
MUTEX_LOCK(&PL_perlio_mutex); |
2481
|
|
|
|
|
|
# endif |
2482
|
|
|
|
|
|
# ifdef MYMALLOC |
2483
|
|
|
|
|
|
MUTEX_LOCK(&PL_malloc_mutex); |
2484
|
|
|
|
|
|
# endif |
2485
|
|
|
|
|
|
OP_REFCNT_LOCK; |
2486
|
|
|
|
|
|
#endif |
2487
|
|
|
|
|
|
} |
2488
|
|
|
|
|
|
|
2489
|
|
|
|
|
|
/* this is called in both parent and child after the fork() */ |
2490
|
|
|
|
|
|
void |
2491
|
|
|
|
|
|
Perl_atfork_unlock(void) |
2492
|
|
|
|
|
|
{ |
2493
|
|
|
|
|
|
dVAR; |
2494
|
|
|
|
|
|
#if defined(USE_ITHREADS) |
2495
|
|
|
|
|
|
/* locks must be released in same order as in atfork_lock() */ |
2496
|
|
|
|
|
|
# ifdef USE_PERLIO |
2497
|
|
|
|
|
|
MUTEX_UNLOCK(&PL_perlio_mutex); |
2498
|
|
|
|
|
|
# endif |
2499
|
|
|
|
|
|
# ifdef MYMALLOC |
2500
|
|
|
|
|
|
MUTEX_UNLOCK(&PL_malloc_mutex); |
2501
|
|
|
|
|
|
# endif |
2502
|
|
|
|
|
|
OP_REFCNT_UNLOCK; |
2503
|
|
|
|
|
|
#endif |
2504
|
|
|
|
|
|
} |
2505
|
|
|
|
|
|
|
2506
|
|
|
|
|
|
Pid_t |
2507
|
|
|
|
|
|
Perl_my_fork(void) |
2508
|
|
|
|
|
|
{ |
2509
|
|
|
|
|
|
#if defined(HAS_FORK) |
2510
|
|
|
|
|
|
Pid_t pid; |
2511
|
|
|
|
|
|
#if defined(USE_ITHREADS) && !defined(HAS_PTHREAD_ATFORK) |
2512
|
|
|
|
|
|
atfork_lock(); |
2513
|
|
|
|
|
|
pid = fork(); |
2514
|
|
|
|
|
|
atfork_unlock(); |
2515
|
|
|
|
|
|
#else |
2516
|
|
|
|
|
|
/* atfork_lock() and atfork_unlock() are installed as pthread_atfork() |
2517
|
|
|
|
|
|
* handlers elsewhere in the code */ |
2518
|
|
|
|
|
|
pid = fork(); |
2519
|
|
|
|
|
|
#endif |
2520
|
|
|
|
|
|
return pid; |
2521
|
|
|
|
|
|
#else |
2522
|
|
|
|
|
|
/* this "canna happen" since nothing should be calling here if !HAS_FORK */ |
2523
|
|
|
|
|
|
Perl_croak_nocontext("fork() not available"); |
2524
|
|
|
|
|
|
return 0; |
2525
|
|
|
|
|
|
#endif /* HAS_FORK */ |
2526
|
|
|
|
|
|
} |
2527
|
|
|
|
|
|
|
2528
|
|
|
|
|
|
#ifdef DUMP_FDS |
2529
|
|
|
|
|
|
void |
2530
|
|
|
|
|
|
Perl_dump_fds(pTHX_ const char *const s) |
2531
|
|
|
|
|
|
{ |
2532
|
|
|
|
|
|
int fd; |
2533
|
|
|
|
|
|
Stat_t tmpstatbuf; |
2534
|
|
|
|
|
|
|
2535
|
|
|
|
|
|
PERL_ARGS_ASSERT_DUMP_FDS; |
2536
|
|
|
|
|
|
|
2537
|
|
|
|
|
|
PerlIO_printf(Perl_debug_log,"%s", s); |
2538
|
|
|
|
|
|
for (fd = 0; fd < 32; fd++) { |
2539
|
|
|
|
|
|
if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0) |
2540
|
|
|
|
|
|
PerlIO_printf(Perl_debug_log," %d",fd); |
2541
|
|
|
|
|
|
} |
2542
|
|
|
|
|
|
PerlIO_printf(Perl_debug_log,"\n"); |
2543
|
|
|
|
|
|
return; |
2544
|
|
|
|
|
|
} |
2545
|
|
|
|
|
|
#endif /* DUMP_FDS */ |
2546
|
|
|
|
|
|
|
2547
|
|
|
|
|
|
#ifndef HAS_DUP2 |
2548
|
|
|
|
|
|
int |
2549
|
|
|
|
|
|
dup2(int oldfd, int newfd) |
2550
|
|
|
|
|
|
{ |
2551
|
|
|
|
|
|
#if defined(HAS_FCNTL) && defined(F_DUPFD) |
2552
|
|
|
|
|
|
if (oldfd == newfd) |
2553
|
|
|
|
|
|
return oldfd; |
2554
|
|
|
|
|
|
PerlLIO_close(newfd); |
2555
|
|
|
|
|
|
return fcntl(oldfd, F_DUPFD, newfd); |
2556
|
|
|
|
|
|
#else |
2557
|
|
|
|
|
|
#define DUP2_MAX_FDS 256 |
2558
|
|
|
|
|
|
int fdtmp[DUP2_MAX_FDS]; |
2559
|
|
|
|
|
|
I32 fdx = 0; |
2560
|
|
|
|
|
|
int fd; |
2561
|
|
|
|
|
|
|
2562
|
|
|
|
|
|
if (oldfd == newfd) |
2563
|
|
|
|
|
|
return oldfd; |
2564
|
|
|
|
|
|
PerlLIO_close(newfd); |
2565
|
|
|
|
|
|
/* good enough for low fd's... */ |
2566
|
|
|
|
|
|
while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) { |
2567
|
|
|
|
|
|
if (fdx >= DUP2_MAX_FDS) { |
2568
|
|
|
|
|
|
PerlLIO_close(fd); |
2569
|
|
|
|
|
|
fd = -1; |
2570
|
|
|
|
|
|
break; |
2571
|
|
|
|
|
|
} |
2572
|
|
|
|
|
|
fdtmp[fdx++] = fd; |
2573
|
|
|
|
|
|
} |
2574
|
|
|
|
|
|
while (fdx > 0) |
2575
|
|
|
|
|
|
PerlLIO_close(fdtmp[--fdx]); |
2576
|
|
|
|
|
|
return fd; |
2577
|
|
|
|
|
|
#endif |
2578
|
|
|
|
|
|
} |
2579
|
|
|
|
|
|
#endif |
2580
|
|
|
|
|
|
|
2581
|
|
|
|
|
|
#ifndef PERL_MICRO |
2582
|
|
|
|
|
|
#ifdef HAS_SIGACTION |
2583
|
|
|
|
|
|
|
2584
|
|
|
|
|
|
Sighandler_t |
2585
|
|
|
|
|
|
Perl_rsignal(pTHX_ int signo, Sighandler_t handler) |
2586
|
|
|
|
|
|
{ |
2587
|
|
|
|
|
|
dVAR; |
2588
|
|
|
|
|
|
struct sigaction act, oact; |
2589
|
|
|
|
|
|
|
2590
|
|
|
|
|
|
#ifdef USE_ITHREADS |
2591
|
|
|
|
|
|
/* only "parent" interpreter can diddle signals */ |
2592
|
|
|
|
|
|
if (PL_curinterp != aTHX) |
2593
|
|
|
|
|
|
return (Sighandler_t) SIG_ERR; |
2594
|
|
|
|
|
|
#endif |
2595
|
|
|
|
|
|
|
2596
|
|
|
|
|
|
act.sa_handler = (void(*)(int))handler; |
2597
|
|
|
|
|
|
sigemptyset(&act.sa_mask); |
2598
|
|
|
|
|
|
act.sa_flags = 0; |
2599
|
|
|
|
|
|
#ifdef SA_RESTART |
2600
|
|
|
|
|
|
if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) |
2601
|
|
|
|
|
|
act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */ |
2602
|
|
|
|
|
|
#endif |
2603
|
|
|
|
|
|
#if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */ |
2604
|
|
|
|
|
|
if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN) |
2605
|
|
|
|
|
|
act.sa_flags |= SA_NOCLDWAIT; |
2606
|
|
|
|
|
|
#endif |
2607
|
|
|
|
|
|
if (sigaction(signo, &act, &oact) == -1) |
2608
|
|
|
|
|
|
return (Sighandler_t) SIG_ERR; |
2609
|
|
|
|
|
|
else |
2610
|
|
|
|
|
|
return (Sighandler_t) oact.sa_handler; |
2611
|
|
|
|
|
|
} |
2612
|
|
|
|
|
|
|
2613
|
|
|
|
|
|
Sighandler_t |
2614
|
|
|
|
|
|
Perl_rsignal_state(pTHX_ int signo) |
2615
|
|
|
|
|
|
{ |
2616
|
|
|
|
|
|
struct sigaction oact; |
2617
|
|
|
|
|
|
PERL_UNUSED_CONTEXT; |
2618
|
|
|
|
|
|
|
2619
|
|
|
|
|
|
if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1) |
2620
|
|
|
|
|
|
return (Sighandler_t) SIG_ERR; |
2621
|
|
|
|
|
|
else |
2622
|
|
|
|
|
|
return (Sighandler_t) oact.sa_handler; |
2623
|
|
|
|
|
|
} |
2624
|
|
|
|
|
|
|
2625
|
|
|
|
|
|
int |
2626
|
|
|
|
|
|
Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save) |
2627
|
|
|
|
|
|
{ |
2628
|
|
|
|
|
|
dVAR; |
2629
|
|
|
|
|
|
struct sigaction act; |
2630
|
|
|
|
|
|
|
2631
|
|
|
|
|
|
PERL_ARGS_ASSERT_RSIGNAL_SAVE; |
2632
|
|
|
|
|
|
|
2633
|
|
|
|
|
|
#ifdef USE_ITHREADS |
2634
|
|
|
|
|
|
/* only "parent" interpreter can diddle signals */ |
2635
|
|
|
|
|
|
if (PL_curinterp != aTHX) |
2636
|
|
|
|
|
|
return -1; |
2637
|
|
|
|
|
|
#endif |
2638
|
|
|
|
|
|
|
2639
|
|
|
|
|
|
act.sa_handler = (void(*)(int))handler; |
2640
|
|
|
|
|
|
sigemptyset(&act.sa_mask); |
2641
|
|
|
|
|
|
act.sa_flags = 0; |
2642
|
|
|
|
|
|
#ifdef SA_RESTART |
2643
|
|
|
|
|
|
if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) |
2644
|
|
|
|
|
|
act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */ |
2645
|
|
|
|
|
|
#endif |
2646
|
|
|
|
|
|
#if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */ |
2647
|
|
|
|
|
|
if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN) |
2648
|
|
|
|
|
|
act.sa_flags |= SA_NOCLDWAIT; |
2649
|
|
|
|
|
|
#endif |
2650
|
|
|
|
|
|
return sigaction(signo, &act, save); |
2651
|
|
|
|
|
|
} |
2652
|
|
|
|
|
|
|
2653
|
|
|
|
|
|
int |
2654
|
|
|
|
|
|
Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save) |
2655
|
|
|
|
|
|
{ |
2656
|
|
|
|
|
|
dVAR; |
2657
|
|
|
|
|
|
#ifdef USE_ITHREADS |
2658
|
|
|
|
|
|
/* only "parent" interpreter can diddle signals */ |
2659
|
|
|
|
|
|
if (PL_curinterp != aTHX) |
2660
|
|
|
|
|
|
return -1; |
2661
|
|
|
|
|
|
#endif |
2662
|
|
|
|
|
|
|
2663
|
|
|
|
|
|
return sigaction(signo, save, (struct sigaction *)NULL); |
2664
|
|
|
|
|
|
} |
2665
|
|
|
|
|
|
|
2666
|
|
|
|
|
|
#else /* !HAS_SIGACTION */ |
2667
|
|
|
|
|
|
|
2668
|
|
|
|
|
|
Sighandler_t |
2669
|
|
|
|
|
|
Perl_rsignal(pTHX_ int signo, Sighandler_t handler) |
2670
|
|
|
|
|
|
{ |
2671
|
|
|
|
|
|
#if defined(USE_ITHREADS) && !defined(WIN32) |
2672
|
|
|
|
|
|
/* only "parent" interpreter can diddle signals */ |
2673
|
|
|
|
|
|
if (PL_curinterp != aTHX) |
2674
|
|
|
|
|
|
return (Sighandler_t) SIG_ERR; |
2675
|
|
|
|
|
|
#endif |
2676
|
|
|
|
|
|
|
2677
|
|
|
|
|
|
return PerlProc_signal(signo, handler); |
2678
|
|
|
|
|
|
} |
2679
|
|
|
|
|
|
|
2680
|
|
|
|
|
|
static Signal_t |
2681
|
|
|
|
|
|
sig_trap(int signo) |
2682
|
|
|
|
|
|
{ |
2683
|
|
|
|
|
|
dVAR; |
2684
|
|
|
|
|
|
PL_sig_trapped++; |
2685
|
|
|
|
|
|
} |
2686
|
|
|
|
|
|
|
2687
|
|
|
|
|
|
Sighandler_t |
2688
|
|
|
|
|
|
Perl_rsignal_state(pTHX_ int signo) |
2689
|
|
|
|
|
|
{ |
2690
|
|
|
|
|
|
dVAR; |
2691
|
|
|
|
|
|
Sighandler_t oldsig; |
2692
|
|
|
|
|
|
|
2693
|
|
|
|
|
|
#if defined(USE_ITHREADS) && !defined(WIN32) |
2694
|
|
|
|
|
|
/* only "parent" interpreter can diddle signals */ |
2695
|
|
|
|
|
|
if (PL_curinterp != aTHX) |
2696
|
|
|
|
|
|
return (Sighandler_t) SIG_ERR; |
2697
|
|
|
|
|
|
#endif |
2698
|
|
|
|
|
|
|
2699
|
|
|
|
|
|
PL_sig_trapped = 0; |
2700
|
|
|
|
|
|
oldsig = PerlProc_signal(signo, sig_trap); |
2701
|
|
|
|
|
|
PerlProc_signal(signo, oldsig); |
2702
|
|
|
|
|
|
if (PL_sig_trapped) |
2703
|
|
|
|
|
|
PerlProc_kill(PerlProc_getpid(), signo); |
2704
|
|
|
|
|
|
return oldsig; |
2705
|
|
|
|
|
|
} |
2706
|
|
|
|
|
|
|
2707
|
|
|
|
|
|
int |
2708
|
|
|
|
|
|
Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save) |
2709
|
|
|
|
|
|
{ |
2710
|
|
|
|
|
|
#if defined(USE_ITHREADS) && !defined(WIN32) |
2711
|
|
|
|
|
|
/* only "parent" interpreter can diddle signals */ |
2712
|
|
|
|
|
|
if (PL_curinterp != aTHX) |
2713
|
|
|
|
|
|
return -1; |
2714
|
|
|
|
|
|
#endif |
2715
|
|
|
|
|
|
*save = PerlProc_signal(signo, handler); |
2716
|
|
|
|
|
|
return (*save == (Sighandler_t) SIG_ERR) ? -1 : 0; |
2717
|
|
|
|
|
|
} |
2718
|
|
|
|
|
|
|
2719
|
|
|
|
|
|
int |
2720
|
|
|
|
|
|
Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save) |
2721
|
|
|
|
|
|
{ |
2722
|
|
|
|
|
|
#if defined(USE_ITHREADS) && !defined(WIN32) |
2723
|
|
|
|
|
|
/* only "parent" interpreter can diddle signals */ |
2724
|
|
|
|
|
|
if (PL_curinterp != aTHX) |
2725
|
|
|
|
|
|
return -1; |
2726
|
|
|
|
|
|
#endif |
2727
|
|
|
|
|
|
return (PerlProc_signal(signo, *save) == (Sighandler_t) SIG_ERR) ? -1 : 0; |
2728
|
|
|
|
|
|
} |
2729
|
|
|
|
|
|
|
2730
|
|
|
|
|
|
#endif /* !HAS_SIGACTION */ |
2731
|
|
|
|
|
|
#endif /* !PERL_MICRO */ |
2732
|
|
|
|
|
|
|
2733
|
|
|
|
|
|
/* VMS' my_pclose() is in VMS.c; same with OS/2 */ |
2734
|
|
|
|
|
|
#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__LIBCATAMOUNT__) |
2735
|
|
|
|
|
|
I32 |
2736
|
|
|
|
|
|
Perl_my_pclose(pTHX_ PerlIO *ptr) |
2737
|
|
|
|
|
|
{ |
2738
|
|
|
|
|
|
dVAR; |
2739
|
|
|
|
|
|
int status; |
2740
|
|
|
|
|
|
SV **svp; |
2741
|
|
|
|
|
|
Pid_t pid; |
2742
|
|
|
|
|
|
Pid_t pid2 = 0; |
2743
|
|
|
|
|
|
bool close_failed; |
2744
|
|
|
|
|
|
dSAVEDERRNO; |
2745
|
|
|
|
|
|
const int fd = PerlIO_fileno(ptr); |
2746
|
|
|
|
|
|
|
2747
|
|
|
|
|
|
#ifdef USE_PERLIO |
2748
|
|
|
|
|
|
/* Find out whether the refcount is low enough for us to wait for the |
2749
|
|
|
|
|
|
child proc without blocking. */ |
2750
|
|
|
|
|
|
const bool should_wait = PerlIOUnix_refcnt(fd) == 1; |
2751
|
|
|
|
|
|
#else |
2752
|
|
|
|
|
|
const bool should_wait = 1; |
2753
|
|
|
|
|
|
#endif |
2754
|
|
|
|
|
|
|
2755
|
|
|
|
|
|
svp = av_fetch(PL_fdpid,fd,TRUE); |
2756
|
|
|
|
|
|
pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1; |
2757
|
|
|
|
|
|
SvREFCNT_dec(*svp); |
2758
|
|
|
|
|
|
*svp = &PL_sv_undef; |
2759
|
|
|
|
|
|
#ifdef OS2 |
2760
|
|
|
|
|
|
if (pid == -1) { /* Opened by popen. */ |
2761
|
|
|
|
|
|
return my_syspclose(ptr); |
2762
|
|
|
|
|
|
} |
2763
|
|
|
|
|
|
#endif |
2764
|
|
|
|
|
|
close_failed = (PerlIO_close(ptr) == EOF); |
2765
|
|
|
|
|
|
SAVE_ERRNO; |
2766
|
|
|
|
|
|
if (should_wait) do { |
2767
|
|
|
|
|
|
pid2 = wait4pid(pid, &status, 0); |
2768
|
|
|
|
|
|
} while (pid2 == -1 && errno == EINTR); |
2769
|
|
|
|
|
|
if (close_failed) { |
2770
|
|
|
|
|
|
RESTORE_ERRNO; |
2771
|
|
|
|
|
|
return -1; |
2772
|
|
|
|
|
|
} |
2773
|
|
|
|
|
|
return( |
2774
|
|
|
|
|
|
should_wait |
2775
|
|
|
|
|
|
? pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status) |
2776
|
|
|
|
|
|
: 0 |
2777
|
|
|
|
|
|
); |
2778
|
|
|
|
|
|
} |
2779
|
|
|
|
|
|
#else |
2780
|
|
|
|
|
|
#if defined(__LIBCATAMOUNT__) |
2781
|
|
|
|
|
|
I32 |
2782
|
|
|
|
|
|
Perl_my_pclose(pTHX_ PerlIO *ptr) |
2783
|
|
|
|
|
|
{ |
2784
|
|
|
|
|
|
return -1; |
2785
|
|
|
|
|
|
} |
2786
|
|
|
|
|
|
#endif |
2787
|
|
|
|
|
|
#endif /* !DOSISH */ |
2788
|
|
|
|
|
|
|
2789
|
|
|
|
|
|
#if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(__LIBCATAMOUNT__) |
2790
|
|
|
|
|
|
I32 |
2791
|
|
|
|
|
|
Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags) |
2792
|
|
|
|
|
|
{ |
2793
|
|
|
|
|
|
dVAR; |
2794
|
|
|
|
|
|
I32 result = 0; |
2795
|
|
|
|
|
|
PERL_ARGS_ASSERT_WAIT4PID; |
2796
|
|
|
|
|
|
if (!pid) |
2797
|
|
|
|
|
|
return -1; |
2798
|
|
|
|
|
|
#ifdef PERL_USES_PL_PIDSTATUS |
2799
|
|
|
|
|
|
{ |
2800
|
|
|
|
|
|
if (pid > 0) { |
2801
|
|
|
|
|
|
/* The keys in PL_pidstatus are now the raw 4 (or 8) bytes of the |
2802
|
|
|
|
|
|
pid, rather than a string form. */ |
2803
|
|
|
|
|
|
SV * const * const svp = hv_fetch(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),FALSE); |
2804
|
|
|
|
|
|
if (svp && *svp != &PL_sv_undef) { |
2805
|
|
|
|
|
|
*statusp = SvIVX(*svp); |
2806
|
|
|
|
|
|
(void)hv_delete(PL_pidstatus,(const char*) &pid,sizeof(Pid_t), |
2807
|
|
|
|
|
|
G_DISCARD); |
2808
|
|
|
|
|
|
return pid; |
2809
|
|
|
|
|
|
} |
2810
|
|
|
|
|
|
} |
2811
|
|
|
|
|
|
else { |
2812
|
|
|
|
|
|
HE *entry; |
2813
|
|
|
|
|
|
|
2814
|
|
|
|
|
|
hv_iterinit(PL_pidstatus); |
2815
|
|
|
|
|
|
if ((entry = hv_iternext(PL_pidstatus))) { |
2816
|
|
|
|
|
|
SV * const sv = hv_iterval(PL_pidstatus,entry); |
2817
|
|
|
|
|
|
I32 len; |
2818
|
|
|
|
|
|
const char * const spid = hv_iterkey(entry,&len); |
2819
|
|
|
|
|
|
|
2820
|
|
|
|
|
|
assert (len == sizeof(Pid_t)); |
2821
|
|
|
|
|
|
memcpy((char *)&pid, spid, len); |
2822
|
|
|
|
|
|
*statusp = SvIVX(sv); |
2823
|
|
|
|
|
|
/* The hash iterator is currently on this entry, so simply |
2824
|
|
|
|
|
|
calling hv_delete would trigger the lazy delete, which on |
2825
|
|
|
|
|
|
aggregate does more work, beacuse next call to hv_iterinit() |
2826
|
|
|
|
|
|
would spot the flag, and have to call the delete routine, |
2827
|
|
|
|
|
|
while in the meantime any new entries can't re-use that |
2828
|
|
|
|
|
|
memory. */ |
2829
|
|
|
|
|
|
hv_iterinit(PL_pidstatus); |
2830
|
|
|
|
|
|
(void)hv_delete(PL_pidstatus,spid,len,G_DISCARD); |
2831
|
|
|
|
|
|
return pid; |
2832
|
|
|
|
|
|
} |
2833
|
|
|
|
|
|
} |
2834
|
|
|
|
|
|
} |
2835
|
|
|
|
|
|
#endif |
2836
|
|
|
|
|
|
#ifdef HAS_WAITPID |
2837
|
|
|
|
|
|
# ifdef HAS_WAITPID_RUNTIME |
2838
|
|
|
|
|
|
if (!HAS_WAITPID_RUNTIME) |
2839
|
|
|
|
|
|
goto hard_way; |
2840
|
|
|
|
|
|
# endif |
2841
|
|
|
|
|
|
result = PerlProc_waitpid(pid,statusp,flags); |
2842
|
|
|
|
|
|
goto finish; |
2843
|
|
|
|
|
|
#endif |
2844
|
|
|
|
|
|
#if !defined(HAS_WAITPID) && defined(HAS_WAIT4) |
2845
|
|
|
|
|
|
result = wait4((pid==-1)?0:pid,statusp,flags,NULL); |
2846
|
|
|
|
|
|
goto finish; |
2847
|
|
|
|
|
|
#endif |
2848
|
|
|
|
|
|
#ifdef PERL_USES_PL_PIDSTATUS |
2849
|
|
|
|
|
|
#if defined(HAS_WAITPID) && defined(HAS_WAITPID_RUNTIME) |
2850
|
|
|
|
|
|
hard_way: |
2851
|
|
|
|
|
|
#endif |
2852
|
|
|
|
|
|
{ |
2853
|
|
|
|
|
|
if (flags) |
2854
|
|
|
|
|
|
Perl_croak(aTHX_ "Can't do waitpid with flags"); |
2855
|
|
|
|
|
|
else { |
2856
|
|
|
|
|
|
while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0) |
2857
|
|
|
|
|
|
pidgone(result,*statusp); |
2858
|
|
|
|
|
|
if (result < 0) |
2859
|
|
|
|
|
|
*statusp = -1; |
2860
|
|
|
|
|
|
} |
2861
|
|
|
|
|
|
} |
2862
|
|
|
|
|
|
#endif |
2863
|
|
|
|
|
|
#if defined(HAS_WAITPID) || defined(HAS_WAIT4) |
2864
|
|
|
|
|
|
finish: |
2865
|
|
|
|
|
|
#endif |
2866
|
|
|
|
|
|
if (result < 0 && errno == EINTR) { |
2867
|
|
|
|
|
|
PERL_ASYNC_CHECK(); |
2868
|
|
|
|
|
|
errno = EINTR; /* reset in case a signal handler changed $! */ |
2869
|
|
|
|
|
|
} |
2870
|
|
|
|
|
|
return result; |
2871
|
|
|
|
|
|
} |
2872
|
|
|
|
|
|
#endif /* !DOSISH || OS2 || WIN32 || NETWARE */ |
2873
|
|
|
|
|
|
|
2874
|
|
|
|
|
|
#ifdef PERL_USES_PL_PIDSTATUS |
2875
|
|
|
|
|
|
void |
2876
|
|
|
|
|
|
S_pidgone(pTHX_ Pid_t pid, int status) |
2877
|
|
|
|
|
|
{ |
2878
|
|
|
|
|
|
SV *sv; |
2879
|
|
|
|
|
|
|
2880
|
|
|
|
|
|
sv = *hv_fetch(PL_pidstatus,(const char*)&pid,sizeof(Pid_t),TRUE); |
2881
|
|
|
|
|
|
SvUPGRADE(sv,SVt_IV); |
2882
|
|
|
|
|
|
SvIV_set(sv, status); |
2883
|
|
|
|
|
|
return; |
2884
|
|
|
|
|
|
} |
2885
|
|
|
|
|
|
#endif |
2886
|
|
|
|
|
|
|
2887
|
|
|
|
|
|
#if defined(OS2) |
2888
|
|
|
|
|
|
int pclose(); |
2889
|
|
|
|
|
|
#ifdef HAS_FORK |
2890
|
|
|
|
|
|
int /* Cannot prototype with I32 |
2891
|
|
|
|
|
|
in os2ish.h. */ |
2892
|
|
|
|
|
|
my_syspclose(PerlIO *ptr) |
2893
|
|
|
|
|
|
#else |
2894
|
|
|
|
|
|
I32 |
2895
|
|
|
|
|
|
Perl_my_pclose(pTHX_ PerlIO *ptr) |
2896
|
|
|
|
|
|
#endif |
2897
|
|
|
|
|
|
{ |
2898
|
|
|
|
|
|
/* Needs work for PerlIO ! */ |
2899
|
|
|
|
|
|
FILE * const f = PerlIO_findFILE(ptr); |
2900
|
|
|
|
|
|
const I32 result = pclose(f); |
2901
|
|
|
|
|
|
PerlIO_releaseFILE(ptr,f); |
2902
|
|
|
|
|
|
return result; |
2903
|
|
|
|
|
|
} |
2904
|
|
|
|
|
|
#endif |
2905
|
|
|
|
|
|
|
2906
|
|
|
|
|
|
#if defined(DJGPP) |
2907
|
|
|
|
|
|
int djgpp_pclose(); |
2908
|
|
|
|
|
|
I32 |
2909
|
|
|
|
|
|
Perl_my_pclose(pTHX_ PerlIO *ptr) |
2910
|
|
|
|
|
|
{ |
2911
|
|
|
|
|
|
/* Needs work for PerlIO ! */ |
2912
|
|
|
|
|
|
FILE * const f = PerlIO_findFILE(ptr); |
2913
|
|
|
|
|
|
I32 result = djgpp_pclose(f); |
2914
|
|
|
|
|
|
result = (result << 8) & 0xff00; |
2915
|
|
|
|
|
|
PerlIO_releaseFILE(ptr,f); |
2916
|
|
|
|
|
|
return result; |
2917
|
|
|
|
|
|
} |
2918
|
|
|
|
|
|
#endif |
2919
|
|
|
|
|
|
|
2920
|
|
|
|
|
|
#define PERL_REPEATCPY_LINEAR 4 |
2921
|
|
|
|
|
|
void |
2922
|
|
|
|
|
|
Perl_repeatcpy(char *to, const char *from, I32 len, IV count) |
2923
|
|
|
|
|
|
{ |
2924
|
|
|
|
|
|
PERL_ARGS_ASSERT_REPEATCPY; |
2925
|
|
|
|
|
|
|
2926
|
|
|
|
|
|
assert(len >= 0); |
2927
|
|
|
|
|
|
|
2928
|
|
|
|
|
|
if (count < 0) |
2929
|
|
|
|
|
|
croak_memory_wrap(); |
2930
|
|
|
|
|
|
|
2931
|
|
|
|
|
|
if (len == 1) |
2932
|
|
|
|
|
|
memset(to, *from, count); |
2933
|
|
|
|
|
|
else if (count) { |
2934
|
|
|
|
|
|
char *p = to; |
2935
|
|
|
|
|
|
IV items, linear, half; |
2936
|
|
|
|
|
|
|
2937
|
|
|
|
|
|
linear = count < PERL_REPEATCPY_LINEAR ? count : PERL_REPEATCPY_LINEAR; |
2938
|
|
|
|
|
|
for (items = 0; items < linear; ++items) { |
2939
|
|
|
|
|
|
const char *q = from; |
2940
|
|
|
|
|
|
IV todo; |
2941
|
|
|
|
|
|
for (todo = len; todo > 0; todo--) |
2942
|
|
|
|
|
|
*p++ = *q++; |
2943
|
|
|
|
|
|
} |
2944
|
|
|
|
|
|
|
2945
|
|
|
|
|
|
half = count / 2; |
2946
|
|
|
|
|
|
while (items <= half) { |
2947
|
|
|
|
|
|
IV size = items * len; |
2948
|
|
|
|
|
|
memcpy(p, to, size); |
2949
|
|
|
|
|
|
p += size; |
2950
|
|
|
|
|
|
items *= 2; |
2951
|
|
|
|
|
|
} |
2952
|
|
|
|
|
|
|
2953
|
|
|
|
|
|
if (count > items) |
2954
|
|
|
|
|
|
memcpy(p, to, (count - items) * len); |
2955
|
|
|
|
|
|
} |
2956
|
|
|
|
|
|
} |
2957
|
|
|
|
|
|
|
2958
|
|
|
|
|
|
#ifndef HAS_RENAME |
2959
|
|
|
|
|
|
I32 |
2960
|
|
|
|
|
|
Perl_same_dirent(pTHX_ const char *a, const char *b) |
2961
|
|
|
|
|
|
{ |
2962
|
|
|
|
|
|
char *fa = strrchr(a,'/'); |
2963
|
|
|
|
|
|
char *fb = strrchr(b,'/'); |
2964
|
|
|
|
|
|
Stat_t tmpstatbuf1; |
2965
|
|
|
|
|
|
Stat_t tmpstatbuf2; |
2966
|
|
|
|
|
|
SV * const tmpsv = sv_newmortal(); |
2967
|
|
|
|
|
|
|
2968
|
|
|
|
|
|
PERL_ARGS_ASSERT_SAME_DIRENT; |
2969
|
|
|
|
|
|
|
2970
|
|
|
|
|
|
if (fa) |
2971
|
|
|
|
|
|
fa++; |
2972
|
|
|
|
|
|
else |
2973
|
|
|
|
|
|
fa = a; |
2974
|
|
|
|
|
|
if (fb) |
2975
|
|
|
|
|
|
fb++; |
2976
|
|
|
|
|
|
else |
2977
|
|
|
|
|
|
fb = b; |
2978
|
|
|
|
|
|
if (strNE(a,b)) |
2979
|
|
|
|
|
|
return FALSE; |
2980
|
|
|
|
|
|
if (fa == a) |
2981
|
|
|
|
|
|
sv_setpvs(tmpsv, "."); |
2982
|
|
|
|
|
|
else |
2983
|
|
|
|
|
|
sv_setpvn(tmpsv, a, fa - a); |
2984
|
|
|
|
|
|
if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0) |
2985
|
|
|
|
|
|
return FALSE; |
2986
|
|
|
|
|
|
if (fb == b) |
2987
|
|
|
|
|
|
sv_setpvs(tmpsv, "."); |
2988
|
|
|
|
|
|
else |
2989
|
|
|
|
|
|
sv_setpvn(tmpsv, b, fb - b); |
2990
|
|
|
|
|
|
if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0) |
2991
|
|
|
|
|
|
return FALSE; |
2992
|
|
|
|
|
|
return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev && |
2993
|
|
|
|
|
|
tmpstatbuf1.st_ino == tmpstatbuf2.st_ino; |
2994
|
|
|
|
|
|
} |
2995
|
|
|
|
|
|
#endif /* !HAS_RENAME */ |
2996
|
|
|
|
|
|
|
2997
|
|
|
|
|
|
char* |
2998
|
|
|
|
|
|
Perl_find_script(pTHX_ const char *scriptname, bool dosearch, |
2999
|
|
|
|
|
|
const char *const *const search_ext, I32 flags) |
3000
|
|
|
|
|
|
{ |
3001
|
|
|
|
|
|
dVAR; |
3002
|
|
|
|
|
|
const char *xfound = NULL; |
3003
|
|
|
|
|
|
char *xfailed = NULL; |
3004
|
|
|
|
|
|
char tmpbuf[MAXPATHLEN]; |
3005
|
|
|
|
|
|
char *s; |
3006
|
|
|
|
|
|
I32 len = 0; |
3007
|
|
|
|
|
|
int retval; |
3008
|
|
|
|
|
|
char *bufend; |
3009
|
|
|
|
|
|
#if defined(DOSISH) && !defined(OS2) |
3010
|
|
|
|
|
|
# define SEARCH_EXTS ".bat", ".cmd", NULL |
3011
|
|
|
|
|
|
# define MAX_EXT_LEN 4 |
3012
|
|
|
|
|
|
#endif |
3013
|
|
|
|
|
|
#ifdef OS2 |
3014
|
|
|
|
|
|
# define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL |
3015
|
|
|
|
|
|
# define MAX_EXT_LEN 4 |
3016
|
|
|
|
|
|
#endif |
3017
|
|
|
|
|
|
#ifdef VMS |
3018
|
|
|
|
|
|
# define SEARCH_EXTS ".pl", ".com", NULL |
3019
|
|
|
|
|
|
# define MAX_EXT_LEN 4 |
3020
|
|
|
|
|
|
#endif |
3021
|
|
|
|
|
|
/* additional extensions to try in each dir if scriptname not found */ |
3022
|
|
|
|
|
|
#ifdef SEARCH_EXTS |
3023
|
|
|
|
|
|
static const char *const exts[] = { SEARCH_EXTS }; |
3024
|
|
|
|
|
|
const char *const *const ext = search_ext ? search_ext : exts; |
3025
|
|
|
|
|
|
int extidx = 0, i = 0; |
3026
|
|
|
|
|
|
const char *curext = NULL; |
3027
|
|
|
|
|
|
#else |
3028
|
|
|
|
|
|
PERL_UNUSED_ARG(search_ext); |
3029
|
|
|
|
|
|
# define MAX_EXT_LEN 0 |
3030
|
|
|
|
|
|
#endif |
3031
|
|
|
|
|
|
|
3032
|
|
|
|
|
|
PERL_ARGS_ASSERT_FIND_SCRIPT; |
3033
|
|
|
|
|
|
|
3034
|
|
|
|
|
|
/* |
3035
|
|
|
|
|
|
* If dosearch is true and if scriptname does not contain path |
3036
|
|
|
|
|
|
* delimiters, search the PATH for scriptname. |
3037
|
|
|
|
|
|
* |
3038
|
|
|
|
|
|
* If SEARCH_EXTS is also defined, will look for each |
3039
|
|
|
|
|
|
* scriptname{SEARCH_EXTS} whenever scriptname is not found |
3040
|
|
|
|
|
|
* while searching the PATH. |
3041
|
|
|
|
|
|
* |
3042
|
|
|
|
|
|
* Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search |
3043
|
|
|
|
|
|
* proceeds as follows: |
3044
|
|
|
|
|
|
* If DOSISH or VMSISH: |
3045
|
|
|
|
|
|
* + look for ./scriptname{,.foo,.bar} |
3046
|
|
|
|
|
|
* + search the PATH for scriptname{,.foo,.bar} |
3047
|
|
|
|
|
|
* |
3048
|
|
|
|
|
|
* If !DOSISH: |
3049
|
|
|
|
|
|
* + look *only* in the PATH for scriptname{,.foo,.bar} (note |
3050
|
|
|
|
|
|
* this will not look in '.' if it's not in the PATH) |
3051
|
|
|
|
|
|
*/ |
3052
|
|
|
|
|
|
tmpbuf[0] = '\0'; |
3053
|
|
|
|
|
|
|
3054
|
|
|
|
|
|
#ifdef VMS |
3055
|
|
|
|
|
|
# ifdef ALWAYS_DEFTYPES |
3056
|
|
|
|
|
|
len = strlen(scriptname); |
3057
|
|
|
|
|
|
if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') { |
3058
|
|
|
|
|
|
int idx = 0, deftypes = 1; |
3059
|
|
|
|
|
|
bool seen_dot = 1; |
3060
|
|
|
|
|
|
|
3061
|
|
|
|
|
|
const int hasdir = !dosearch || (strpbrk(scriptname,":[") != NULL); |
3062
|
|
|
|
|
|
# else |
3063
|
|
|
|
|
|
if (dosearch) { |
3064
|
|
|
|
|
|
int idx = 0, deftypes = 1; |
3065
|
|
|
|
|
|
bool seen_dot = 1; |
3066
|
|
|
|
|
|
|
3067
|
|
|
|
|
|
const int hasdir = (strpbrk(scriptname,":[") != NULL); |
3068
|
|
|
|
|
|
# endif |
3069
|
|
|
|
|
|
/* The first time through, just add SEARCH_EXTS to whatever we |
3070
|
|
|
|
|
|
* already have, so we can check for default file types. */ |
3071
|
|
|
|
|
|
while (deftypes || |
3072
|
|
|
|
|
|
(!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) ) |
3073
|
|
|
|
|
|
{ |
3074
|
|
|
|
|
|
if (deftypes) { |
3075
|
|
|
|
|
|
deftypes = 0; |
3076
|
|
|
|
|
|
*tmpbuf = '\0'; |
3077
|
|
|
|
|
|
} |
3078
|
|
|
|
|
|
if ((strlen(tmpbuf) + strlen(scriptname) |
3079
|
|
|
|
|
|
+ MAX_EXT_LEN) >= sizeof tmpbuf) |
3080
|
|
|
|
|
|
continue; /* don't search dir with too-long name */ |
3081
|
|
|
|
|
|
my_strlcat(tmpbuf, scriptname, sizeof(tmpbuf)); |
3082
|
|
|
|
|
|
#else /* !VMS */ |
3083
|
|
|
|
|
|
|
3084
|
|
|
|
|
|
#ifdef DOSISH |
3085
|
|
|
|
|
|
if (strEQ(scriptname, "-")) |
3086
|
|
|
|
|
|
dosearch = 0; |
3087
|
|
|
|
|
|
if (dosearch) { /* Look in '.' first. */ |
3088
|
|
|
|
|
|
const char *cur = scriptname; |
3089
|
|
|
|
|
|
#ifdef SEARCH_EXTS |
3090
|
|
|
|
|
|
if ((curext = strrchr(scriptname,'.'))) /* possible current ext */ |
3091
|
|
|
|
|
|
while (ext[i]) |
3092
|
|
|
|
|
|
if (strEQ(ext[i++],curext)) { |
3093
|
|
|
|
|
|
extidx = -1; /* already has an ext */ |
3094
|
|
|
|
|
|
break; |
3095
|
|
|
|
|
|
} |
3096
|
|
|
|
|
|
do { |
3097
|
|
|
|
|
|
#endif |
3098
|
|
|
|
|
|
DEBUG_p(PerlIO_printf(Perl_debug_log, |
3099
|
|
|
|
|
|
"Looking for %s\n",cur)); |
3100
|
|
|
|
|
|
if (PerlLIO_stat(cur,&PL_statbuf) >= 0 |
3101
|
|
|
|
|
|
&& !S_ISDIR(PL_statbuf.st_mode)) { |
3102
|
|
|
|
|
|
dosearch = 0; |
3103
|
|
|
|
|
|
scriptname = cur; |
3104
|
|
|
|
|
|
#ifdef SEARCH_EXTS |
3105
|
|
|
|
|
|
break; |
3106
|
|
|
|
|
|
#endif |
3107
|
|
|
|
|
|
} |
3108
|
|
|
|
|
|
#ifdef SEARCH_EXTS |
3109
|
|
|
|
|
|
if (cur == scriptname) { |
3110
|
|
|
|
|
|
len = strlen(scriptname); |
3111
|
|
|
|
|
|
if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf)) |
3112
|
|
|
|
|
|
break; |
3113
|
|
|
|
|
|
my_strlcpy(tmpbuf, scriptname, sizeof(tmpbuf)); |
3114
|
|
|
|
|
|
cur = tmpbuf; |
3115
|
|
|
|
|
|
} |
3116
|
|
|
|
|
|
} while (extidx >= 0 && ext[extidx] /* try an extension? */ |
3117
|
|
|
|
|
|
&& my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len)); |
3118
|
|
|
|
|
|
#endif |
3119
|
|
|
|
|
|
} |
3120
|
|
|
|
|
|
#endif |
3121
|
|
|
|
|
|
|
3122
|
|
|
|
|
|
if (dosearch && !strchr(scriptname, '/') |
3123
|
|
|
|
|
|
#ifdef DOSISH |
3124
|
|
|
|
|
|
&& !strchr(scriptname, '\\') |
3125
|
|
|
|
|
|
#endif |
3126
|
|
|
|
|
|
&& (s = PerlEnv_getenv("PATH"))) |
3127
|
|
|
|
|
|
{ |
3128
|
|
|
|
|
|
bool seen_dot = 0; |
3129
|
|
|
|
|
|
|
3130
|
|
|
|
|
|
bufend = s + strlen(s); |
3131
|
|
|
|
|
|
while (s < bufend) { |
3132
|
|
|
|
|
|
# ifdef DOSISH |
3133
|
|
|
|
|
|
for (len = 0; *s |
3134
|
|
|
|
|
|
&& *s != ';'; len++, s++) { |
3135
|
|
|
|
|
|
if (len < sizeof tmpbuf) |
3136
|
|
|
|
|
|
tmpbuf[len] = *s; |
3137
|
|
|
|
|
|
} |
3138
|
|
|
|
|
|
if (len < sizeof tmpbuf) |
3139
|
|
|
|
|
|
tmpbuf[len] = '\0'; |
3140
|
|
|
|
|
|
# else |
3141
|
|
|
|
|
|
s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend, |
3142
|
|
|
|
|
|
':', |
3143
|
|
|
|
|
|
&len); |
3144
|
|
|
|
|
|
# endif |
3145
|
|
|
|
|
|
if (s < bufend) |
3146
|
|
|
|
|
|
s++; |
3147
|
|
|
|
|
|
if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf) |
3148
|
|
|
|
|
|
continue; /* don't search dir with too-long name */ |
3149
|
|
|
|
|
|
if (len |
3150
|
|
|
|
|
|
# ifdef DOSISH |
3151
|
|
|
|
|
|
&& tmpbuf[len - 1] != '/' |
3152
|
|
|
|
|
|
&& tmpbuf[len - 1] != '\\' |
3153
|
|
|
|
|
|
# endif |
3154
|
|
|
|
|
|
) |
3155
|
|
|
|
|
|
tmpbuf[len++] = '/'; |
3156
|
|
|
|
|
|
if (len == 2 && tmpbuf[0] == '.') |
3157
|
|
|
|
|
|
seen_dot = 1; |
3158
|
|
|
|
|
|
(void)my_strlcpy(tmpbuf + len, scriptname, sizeof(tmpbuf) - len); |
3159
|
|
|
|
|
|
#endif /* !VMS */ |
3160
|
|
|
|
|
|
|
3161
|
|
|
|
|
|
#ifdef SEARCH_EXTS |
3162
|
|
|
|
|
|
len = strlen(tmpbuf); |
3163
|
|
|
|
|
|
if (extidx > 0) /* reset after previous loop */ |
3164
|
|
|
|
|
|
extidx = 0; |
3165
|
|
|
|
|
|
do { |
3166
|
|
|
|
|
|
#endif |
3167
|
|
|
|
|
|
DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf)); |
3168
|
|
|
|
|
|
retval = PerlLIO_stat(tmpbuf,&PL_statbuf); |
3169
|
|
|
|
|
|
if (S_ISDIR(PL_statbuf.st_mode)) { |
3170
|
|
|
|
|
|
retval = -1; |
3171
|
|
|
|
|
|
} |
3172
|
|
|
|
|
|
#ifdef SEARCH_EXTS |
3173
|
|
|
|
|
|
} while ( retval < 0 /* not there */ |
3174
|
|
|
|
|
|
&& extidx>=0 && ext[extidx] /* try an extension? */ |
3175
|
|
|
|
|
|
&& my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len) |
3176
|
|
|
|
|
|
); |
3177
|
|
|
|
|
|
#endif |
3178
|
|
|
|
|
|
if (retval < 0) |
3179
|
|
|
|
|
|
continue; |
3180
|
|
|
|
|
|
if (S_ISREG(PL_statbuf.st_mode) |
3181
|
|
|
|
|
|
&& cando(S_IRUSR,TRUE,&PL_statbuf) |
3182
|
|
|
|
|
|
#if !defined(DOSISH) |
3183
|
|
|
|
|
|
&& cando(S_IXUSR,TRUE,&PL_statbuf) |
3184
|
|
|
|
|
|
#endif |
3185
|
|
|
|
|
|
) |
3186
|
|
|
|
|
|
{ |
3187
|
|
|
|
|
|
xfound = tmpbuf; /* bingo! */ |
3188
|
|
|
|
|
|
break; |
3189
|
|
|
|
|
|
} |
3190
|
|
|
|
|
|
if (!xfailed) |
3191
|
|
|
|
|
|
xfailed = savepv(tmpbuf); |
3192
|
|
|
|
|
|
} |
3193
|
|
|
|
|
|
#ifndef DOSISH |
3194
|
|
|
|
|
|
if (!xfound && !seen_dot && !xfailed && |
3195
|
|
|
|
|
|
(PerlLIO_stat(scriptname,&PL_statbuf) < 0 |
3196
|
|
|
|
|
|
|| S_ISDIR(PL_statbuf.st_mode))) |
3197
|
|
|
|
|
|
#endif |
3198
|
|
|
|
|
|
seen_dot = 1; /* Disable message. */ |
3199
|
|
|
|
|
|
if (!xfound) { |
3200
|
|
|
|
|
|
if (flags & 1) { /* do or die? */ |
3201
|
|
|
|
|
|
/* diag_listed_as: Can't execute %s */ |
3202
|
|
|
|
|
|
Perl_croak(aTHX_ "Can't %s %s%s%s", |
3203
|
|
|
|
|
|
(xfailed ? "execute" : "find"), |
3204
|
|
|
|
|
|
(xfailed ? xfailed : scriptname), |
3205
|
|
|
|
|
|
(xfailed ? "" : " on PATH"), |
3206
|
|
|
|
|
|
(xfailed || seen_dot) ? "" : ", '.' not in PATH"); |
3207
|
|
|
|
|
|
} |
3208
|
|
|
|
|
|
scriptname = NULL; |
3209
|
|
|
|
|
|
} |
3210
|
|
|
|
|
|
Safefree(xfailed); |
3211
|
|
|
|
|
|
scriptname = xfound; |
3212
|
|
|
|
|
|
} |
3213
|
|
|
|
|
|
return (scriptname ? savepv(scriptname) : NULL); |
3214
|
|
|
|
|
|
} |
3215
|
|
|
|
|
|
|
3216
|
|
|
|
|
|
#ifndef PERL_GET_CONTEXT_DEFINED |
3217
|
|
|
|
|
|
|
3218
|
|
|
|
|
|
void * |
3219
|
|
|
|
|
|
Perl_get_context(void) |
3220
|
|
|
|
|
|
{ |
3221
|
|
|
|
|
|
dVAR; |
3222
|
|
|
|
|
|
#if defined(USE_ITHREADS) |
3223
|
|
|
|
|
|
# ifdef OLD_PTHREADS_API |
3224
|
|
|
|
|
|
pthread_addr_t t; |
3225
|
|
|
|
|
|
int error = pthread_getspecific(PL_thr_key, &t) |
3226
|
|
|
|
|
|
if (error) |
3227
|
|
|
|
|
|
Perl_croak_nocontext("panic: pthread_getspecific, error=%d", error); |
3228
|
|
|
|
|
|
return (void*)t; |
3229
|
|
|
|
|
|
# else |
3230
|
|
|
|
|
|
# ifdef I_MACH_CTHREADS |
3231
|
|
|
|
|
|
return (void*)cthread_data(cthread_self()); |
3232
|
|
|
|
|
|
# else |
3233
|
|
|
|
|
|
return (void*)PTHREAD_GETSPECIFIC(PL_thr_key); |
3234
|
|
|
|
|
|
# endif |
3235
|
|
|
|
|
|
# endif |
3236
|
|
|
|
|
|
#else |
3237
|
|
|
|
|
|
return (void*)NULL; |
3238
|
|
|
|
|
|
#endif |
3239
|
|
|
|
|
|
} |
3240
|
|
|
|
|
|
|
3241
|
|
|
|
|
|
void |
3242
|
|
|
|
|
|
Perl_set_context(void *t) |
3243
|
|
|
|
|
|
{ |
3244
|
|
|
|
|
|
dVAR; |
3245
|
|
|
|
|
|
PERL_ARGS_ASSERT_SET_CONTEXT; |
3246
|
|
|
|
|
|
#if defined(USE_ITHREADS) |
3247
|
|
|
|
|
|
# ifdef I_MACH_CTHREADS |
3248
|
|
|
|
|
|
cthread_set_data(cthread_self(), t); |
3249
|
|
|
|
|
|
# else |
3250
|
|
|
|
|
|
{ |
3251
|
|
|
|
|
|
const int error = pthread_setspecific(PL_thr_key, t); |
3252
|
|
|
|
|
|
if (error) |
3253
|
|
|
|
|
|
Perl_croak_nocontext("panic: pthread_setspecific, error=%d", error); |
3254
|
|
|
|
|
|
} |
3255
|
|
|
|
|
|
# endif |
3256
|
|
|
|
|
|
#else |
3257
|
|
|
|
|
|
PERL_UNUSED_ARG(t); |
3258
|
|
|
|
|
|
#endif |
3259
|
|
|
|
|
|
} |
3260
|
|
|
|
|
|
|
3261
|
|
|
|
|
|
#endif /* !PERL_GET_CONTEXT_DEFINED */ |
3262
|
|
|
|
|
|
|
3263
|
|
|
|
|
|
#if defined(PERL_GLOBAL_STRUCT) && !defined(PERL_GLOBAL_STRUCT_PRIVATE) |
3264
|
|
|
|
|
|
struct perl_vars * |
3265
|
|
|
|
|
|
Perl_GetVars(pTHX) |
3266
|
|
|
|
|
|
{ |
3267
|
|
|
|
|
|
return &PL_Vars; |
3268
|
|
|
|
|
|
} |
3269
|
|
|
|
|
|
#endif |
3270
|
|
|
|
|
|
|
3271
|
|
|
|
|
|
char ** |
3272
|
|
|
|
|
|
Perl_get_op_names(pTHX) |
3273
|
|
|
|
|
|
{ |
3274
|
|
|
|
|
|
PERL_UNUSED_CONTEXT; |
3275
|
|
|
|
|
|
return (char **)PL_op_name; |
3276
|
|
|
|
|
|
} |
3277
|
|
|
|
|
|
|
3278
|
|
|
|
|
|
char ** |
3279
|
|
|
|
|
|
Perl_get_op_descs(pTHX) |
3280
|
|
|
|
|
|
{ |
3281
|
|
|
|
|
|
PERL_UNUSED_CONTEXT; |
3282
|
|
|
|
|
|
return (char **)PL_op_desc; |
3283
|
|
|
|
|
|
} |
3284
|
|
|
|
|
|
|
3285
|
|
|
|
|
|
const char * |
3286
|
|
|
|
|
|
Perl_get_no_modify(pTHX) |
3287
|
|
|
|
|
|
{ |
3288
|
|
|
|
|
|
PERL_UNUSED_CONTEXT; |
3289
|
|
|
|
|
|
return PL_no_modify; |
3290
|
|
|
|
|
|
} |
3291
|
|
|
|
|
|
|
3292
|
|
|
|
|
|
U32 * |
3293
|
|
|
|
|
|
Perl_get_opargs(pTHX) |
3294
|
|
|
|
|
|
{ |
3295
|
|
|
|
|
|
PERL_UNUSED_CONTEXT; |
3296
|
|
|
|
|
|
return (U32 *)PL_opargs; |
3297
|
|
|
|
|
|
} |
3298
|
|
|
|
|
|
|
3299
|
|
|
|
|
|
PPADDR_t* |
3300
|
|
|
|
|
|
Perl_get_ppaddr(pTHX) |
3301
|
|
|
|
|
|
{ |
3302
|
|
|
|
|
|
dVAR; |
3303
|
|
|
|
|
|
PERL_UNUSED_CONTEXT; |
3304
|
|
|
|
|
|
return (PPADDR_t*)PL_ppaddr; |
3305
|
|
|
|
|
|
} |
3306
|
|
|
|
|
|
|
3307
|
|
|
|
|
|
#ifndef HAS_GETENV_LEN |
3308
|
|
|
|
|
|
char * |
3309
|
|
|
|
|
|
Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len) |
3310
|
|
|
|
|
|
{ |
3311
|
|
|
|
|
|
char * const env_trans = PerlEnv_getenv(env_elem); |
3312
|
|
|
|
|
|
PERL_UNUSED_CONTEXT; |
3313
|
|
|
|
|
|
PERL_ARGS_ASSERT_GETENV_LEN; |
3314
|
|
|
|
|
|
if (env_trans) |
3315
|
|
|
|
|
|
*len = strlen(env_trans); |
3316
|
|
|
|
|
|
return env_trans; |
3317
|
|
|
|
|
|
} |
3318
|
|
|
|
|
|
#endif |
3319
|
|
|
|
|
|
|
3320
|
|
|
|
|
|
|
3321
|
|
|
|
|
|
MGVTBL* |
3322
|
|
|
|
|
|
Perl_get_vtbl(pTHX_ int vtbl_id) |
3323
|
|
|
|
|
|
{ |
3324
|
|
|
|
|
|
PERL_UNUSED_CONTEXT; |
3325
|
|
|
|
|
|
|
3326
|
|
|
|
|
|
return (vtbl_id < 0 || vtbl_id >= magic_vtable_max) |
3327
|
|
|
|
|
|
? NULL : PL_magic_vtables + vtbl_id; |
3328
|
|
|
|
|
|
} |
3329
|
|
|
|
|
|
|
3330
|
|
|
|
|
|
I32 |
3331
|
|
|
|
|
|
Perl_my_fflush_all(pTHX) |
3332
|
|
|
|
|
|
{ |
3333
|
|
|
|
|
|
#if defined(USE_PERLIO) || defined(FFLUSH_NULL) || defined(USE_SFIO) |
3334
|
|
|
|
|
|
return PerlIO_flush(NULL); |
3335
|
|
|
|
|
|
#else |
3336
|
|
|
|
|
|
# if defined(HAS__FWALK) |
3337
|
|
|
|
|
|
extern int fflush(FILE *); |
3338
|
|
|
|
|
|
/* undocumented, unprototyped, but very useful BSDism */ |
3339
|
|
|
|
|
|
extern void _fwalk(int (*)(FILE *)); |
3340
|
|
|
|
|
|
_fwalk(&fflush); |
3341
|
|
|
|
|
|
return 0; |
3342
|
|
|
|
|
|
# else |
3343
|
|
|
|
|
|
# if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY) |
3344
|
|
|
|
|
|
long open_max = -1; |
3345
|
|
|
|
|
|
# ifdef PERL_FFLUSH_ALL_FOPEN_MAX |
3346
|
|
|
|
|
|
open_max = PERL_FFLUSH_ALL_FOPEN_MAX; |
3347
|
|
|
|
|
|
# else |
3348
|
|
|
|
|
|
# if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX) |
3349
|
|
|
|
|
|
open_max = sysconf(_SC_OPEN_MAX); |
3350
|
|
|
|
|
|
# else |
3351
|
|
|
|
|
|
# ifdef FOPEN_MAX |
3352
|
|
|
|
|
|
open_max = FOPEN_MAX; |
3353
|
|
|
|
|
|
# else |
3354
|
|
|
|
|
|
# ifdef OPEN_MAX |
3355
|
|
|
|
|
|
open_max = OPEN_MAX; |
3356
|
|
|
|
|
|
# else |
3357
|
|
|
|
|
|
# ifdef _NFILE |
3358
|
|
|
|
|
|
open_max = _NFILE; |
3359
|
|
|
|
|
|
# endif |
3360
|
|
|
|
|
|
# endif |
3361
|
|
|
|
|
|
# endif |
3362
|
|
|
|
|
|
# endif |
3363
|
|
|
|
|
|
# endif |
3364
|
|
|
|
|
|
if (open_max > 0) { |
3365
|
|
|
|
|
|
long i; |
3366
|
|
|
|
|
|
for (i = 0; i < open_max; i++) |
3367
|
|
|
|
|
|
if (STDIO_STREAM_ARRAY[i]._file >= 0 && |
3368
|
|
|
|
|
|
STDIO_STREAM_ARRAY[i]._file < open_max && |
3369
|
|
|
|
|
|
STDIO_STREAM_ARRAY[i]._flag) |
3370
|
|
|
|
|
|
PerlIO_flush(&STDIO_STREAM_ARRAY[i]); |
3371
|
|
|
|
|
|
return 0; |
3372
|
|
|
|
|
|
} |
3373
|
|
|
|
|
|
# endif |
3374
|
|
|
|
|
|
SETERRNO(EBADF,RMS_IFI); |
3375
|
|
|
|
|
|
return EOF; |
3376
|
|
|
|
|
|
# endif |
3377
|
|
|
|
|
|
#endif |
3378
|
|
|
|
|
|
} |
3379
|
|
|
|
|
|
|
3380
|
|
|
|
|
|
void |
3381
|
|
|
|
|
|
Perl_report_wrongway_fh(pTHX_ const GV *gv, const char have) |
3382
|
|
|
|
|
|
{ |
3383
|
|
|
|
|
|
if (ckWARN(WARN_IO)) { |
3384
|
|
|
|
|
|
HEK * const name |
3385
|
|
|
|
|
|
= gv && (isGV_with_GP(gv)) |
3386
|
|
|
|
|
|
? GvENAME_HEK((gv)) |
3387
|
|
|
|
|
|
: NULL; |
3388
|
|
|
|
|
|
const char * const direction = have == '>' ? "out" : "in"; |
3389
|
|
|
|
|
|
|
3390
|
|
|
|
|
|
if (name && HEK_LEN(name)) |
3391
|
|
|
|
|
|
Perl_warner(aTHX_ packWARN(WARN_IO), |
3392
|
|
|
|
|
|
"Filehandle %"HEKf" opened only for %sput", |
3393
|
|
|
|
|
|
name, direction); |
3394
|
|
|
|
|
|
else |
3395
|
|
|
|
|
|
Perl_warner(aTHX_ packWARN(WARN_IO), |
3396
|
|
|
|
|
|
"Filehandle opened only for %sput", direction); |
3397
|
|
|
|
|
|
} |
3398
|
|
|
|
|
|
} |
3399
|
|
|
|
|
|
|
3400
|
|
|
|
|
|
void |
3401
|
|
|
|
|
|
Perl_report_evil_fh(pTHX_ const GV *gv) |
3402
|
|
|
|
|
|
{ |
3403
|
|
|
|
|
|
const IO *io = gv ? GvIO(gv) : NULL; |
3404
|
|
|
|
|
|
const PERL_BITFIELD16 op = PL_op->op_type; |
3405
|
|
|
|
|
|
const char *vile; |
3406
|
|
|
|
|
|
I32 warn_type; |
3407
|
|
|
|
|
|
|
3408
|
|
|
|
|
|
if (io && IoTYPE(io) == IoTYPE_CLOSED) { |
3409
|
|
|
|
|
|
vile = "closed"; |
3410
|
|
|
|
|
|
warn_type = WARN_CLOSED; |
3411
|
|
|
|
|
|
} |
3412
|
|
|
|
|
|
else { |
3413
|
|
|
|
|
|
vile = "unopened"; |
3414
|
|
|
|
|
|
warn_type = WARN_UNOPENED; |
3415
|
|
|
|
|
|
} |
3416
|
|
|
|
|
|
|
3417
|
|
|
|
|
|
if (ckWARN(warn_type)) { |
3418
|
|
|
|
|
|
SV * const name |
3419
|
|
|
|
|
|
= gv && isGV_with_GP(gv) && GvENAMELEN(gv) ? |
3420
|
|
|
|
|
|
sv_2mortal(newSVhek(GvENAME_HEK(gv))) : NULL; |
3421
|
|
|
|
|
|
const char * const pars = |
3422
|
|
|
|
|
|
(const char *)(OP_IS_FILETEST(op) ? "" : "()"); |
3423
|
|
|
|
|
|
const char * const func = |
3424
|
|
|
|
|
|
(const char *) |
3425
|
|
|
|
|
|
(op == OP_READLINE ? "readline" : /* "" not nice */ |
3426
|
|
|
|
|
|
op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */ |
3427
|
|
|
|
|
|
PL_op_desc[op]); |
3428
|
|
|
|
|
|
const char * const type = |
3429
|
|
|
|
|
|
(const char *) |
3430
|
|
|
|
|
|
(OP_IS_SOCKET(op) || (io && IoTYPE(io) == IoTYPE_SOCKET) |
3431
|
|
|
|
|
|
? "socket" : "filehandle"); |
3432
|
|
|
|
|
|
const bool have_name = name && SvCUR(name); |
3433
|
|
|
|
|
|
Perl_warner(aTHX_ packWARN(warn_type), |
3434
|
|
|
|
|
|
"%s%s on %s %s%s%"SVf, func, pars, vile, type, |
3435
|
|
|
|
|
|
have_name ? " " : "", |
3436
|
|
|
|
|
|
SVfARG(have_name ? name : &PL_sv_no)); |
3437
|
|
|
|
|
|
if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP)) |
3438
|
|
|
|
|
|
Perl_warner( |
3439
|
|
|
|
|
|
aTHX_ packWARN(warn_type), |
3440
|
|
|
|
|
|
"\t(Are you trying to call %s%s on dirhandle%s%"SVf"?)\n", |
3441
|
|
|
|
|
|
func, pars, have_name ? " " : "", |
3442
|
|
|
|
|
|
SVfARG(have_name ? name : &PL_sv_no) |
3443
|
|
|
|
|
|
); |
3444
|
|
|
|
|
|
} |
3445
|
|
|
|
|
|
} |
3446
|
|
|
|
|
|
|
3447
|
|
|
|
|
|
/* To workaround core dumps from the uninitialised tm_zone we get the |
3448
|
|
|
|
|
|
* system to give us a reasonable struct to copy. This fix means that |
3449
|
|
|
|
|
|
* strftime uses the tm_zone and tm_gmtoff values returned by |
3450
|
|
|
|
|
|
* localtime(time()). That should give the desired result most of the |
3451
|
|
|
|
|
|
* time. But probably not always! |
3452
|
|
|
|
|
|
* |
3453
|
|
|
|
|
|
* This does not address tzname aspects of NETaa14816. |
3454
|
|
|
|
|
|
* |
3455
|
|
|
|
|
|
*/ |
3456
|
|
|
|
|
|
|
3457
|
|
|
|
|
|
#ifdef HAS_GNULIBC |
3458
|
|
|
|
|
|
# ifndef STRUCT_TM_HASZONE |
3459
|
|
|
|
|
|
# define STRUCT_TM_HASZONE |
3460
|
|
|
|
|
|
# endif |
3461
|
|
|
|
|
|
#endif |
3462
|
|
|
|
|
|
|
3463
|
|
|
|
|
|
#ifdef STRUCT_TM_HASZONE /* Backward compat */ |
3464
|
|
|
|
|
|
# ifndef HAS_TM_TM_ZONE |
3465
|
|
|
|
|
|
# define HAS_TM_TM_ZONE |
3466
|
|
|
|
|
|
# endif |
3467
|
|
|
|
|
|
#endif |
3468
|
|
|
|
|
|
|
3469
|
|
|
|
|
|
void |
3470
|
|
|
|
|
|
Perl_init_tm(pTHX_ struct tm *ptm) /* see mktime, strftime and asctime */ |
3471
|
|
|
|
|
|
{ |
3472
|
|
|
|
|
|
#ifdef HAS_TM_TM_ZONE |
3473
|
|
|
|
|
|
Time_t now; |
3474
|
|
|
|
|
|
const struct tm* my_tm; |
3475
|
|
|
|
|
|
PERL_ARGS_ASSERT_INIT_TM; |
3476
|
|
|
|
|
|
(void)time(&now); |
3477
|
|
|
|
|
|
my_tm = localtime(&now); |
3478
|
|
|
|
|
|
if (my_tm) |
3479
|
|
|
|
|
|
Copy(my_tm, ptm, 1, struct tm); |
3480
|
|
|
|
|
|
#else |
3481
|
|
|
|
|
|
PERL_ARGS_ASSERT_INIT_TM; |
3482
|
|
|
|
|
|
PERL_UNUSED_ARG(ptm); |
3483
|
|
|
|
|
|
#endif |
3484
|
|
|
|
|
|
} |
3485
|
|
|
|
|
|
|
3486
|
|
|
|
|
|
/* |
3487
|
|
|
|
|
|
* mini_mktime - normalise struct tm values without the localtime() |
3488
|
|
|
|
|
|
* semantics (and overhead) of mktime(). |
3489
|
|
|
|
|
|
*/ |
3490
|
|
|
|
|
|
void |
3491
|
|
|
|
|
|
Perl_mini_mktime(pTHX_ struct tm *ptm) |
3492
|
|
|
|
|
|
{ |
3493
|
|
|
|
|
|
int yearday; |
3494
|
|
|
|
|
|
int secs; |
3495
|
|
|
|
|
|
int month, mday, year, jday; |
3496
|
|
|
|
|
|
int odd_cent, odd_year; |
3497
|
|
|
|
|
|
PERL_UNUSED_CONTEXT; |
3498
|
|
|
|
|
|
|
3499
|
|
|
|
|
|
PERL_ARGS_ASSERT_MINI_MKTIME; |
3500
|
|
|
|
|
|
|
3501
|
|
|
|
|
|
#define DAYS_PER_YEAR 365 |
3502
|
|
|
|
|
|
#define DAYS_PER_QYEAR (4*DAYS_PER_YEAR+1) |
3503
|
|
|
|
|
|
#define DAYS_PER_CENT (25*DAYS_PER_QYEAR-1) |
3504
|
|
|
|
|
|
#define DAYS_PER_QCENT (4*DAYS_PER_CENT+1) |
3505
|
|
|
|
|
|
#define SECS_PER_HOUR (60*60) |
3506
|
|
|
|
|
|
#define SECS_PER_DAY (24*SECS_PER_HOUR) |
3507
|
|
|
|
|
|
/* parentheses deliberately absent on these two, otherwise they don't work */ |
3508
|
|
|
|
|
|
#define MONTH_TO_DAYS 153/5 |
3509
|
|
|
|
|
|
#define DAYS_TO_MONTH 5/153 |
3510
|
|
|
|
|
|
/* offset to bias by March (month 4) 1st between month/mday & year finding */ |
3511
|
|
|
|
|
|
#define YEAR_ADJUST (4*MONTH_TO_DAYS+1) |
3512
|
|
|
|
|
|
/* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */ |
3513
|
|
|
|
|
|
#define WEEKDAY_BIAS 6 /* (1+6)%7 makes Sunday 0 again */ |
3514
|
|
|
|
|
|
|
3515
|
|
|
|
|
|
/* |
3516
|
|
|
|
|
|
* Year/day algorithm notes: |
3517
|
|
|
|
|
|
* |
3518
|
|
|
|
|
|
* With a suitable offset for numeric value of the month, one can find |
3519
|
|
|
|
|
|
* an offset into the year by considering months to have 30.6 (153/5) days, |
3520
|
|
|
|
|
|
* using integer arithmetic (i.e., with truncation). To avoid too much |
3521
|
|
|
|
|
|
* messing about with leap days, we consider January and February to be |
3522
|
|
|
|
|
|
* the 13th and 14th month of the previous year. After that transformation, |
3523
|
|
|
|
|
|
* we need the month index we use to be high by 1 from 'normal human' usage, |
3524
|
|
|
|
|
|
* so the month index values we use run from 4 through 15. |
3525
|
|
|
|
|
|
* |
3526
|
|
|
|
|
|
* Given that, and the rules for the Gregorian calendar (leap years are those |
3527
|
|
|
|
|
|
* divisible by 4 unless also divisible by 100, when they must be divisible |
3528
|
|
|
|
|
|
* by 400 instead), we can simply calculate the number of days since some |
3529
|
|
|
|
|
|
* arbitrary 'beginning of time' by futzing with the (adjusted) year number, |
3530
|
|
|
|
|
|
* the days we derive from our month index, and adding in the day of the |
3531
|
|
|
|
|
|
* month. The value used here is not adjusted for the actual origin which |
3532
|
|
|
|
|
|
* it normally would use (1 January A.D. 1), since we're not exposing it. |
3533
|
|
|
|
|
|
* We're only building the value so we can turn around and get the |
3534
|
|
|
|
|
|
* normalised values for the year, month, day-of-month, and day-of-year. |
3535
|
|
|
|
|
|
* |
3536
|
|
|
|
|
|
* For going backward, we need to bias the value we're using so that we find |
3537
|
|
|
|
|
|
* the right year value. (Basically, we don't want the contribution of |
3538
|
|
|
|
|
|
* March 1st to the number to apply while deriving the year). Having done |
3539
|
|
|
|
|
|
* that, we 'count up' the contribution to the year number by accounting for |
3540
|
|
|
|
|
|
* full quadracenturies (400-year periods) with their extra leap days, plus |
3541
|
|
|
|
|
|
* the contribution from full centuries (to avoid counting in the lost leap |
3542
|
|
|
|
|
|
* days), plus the contribution from full quad-years (to count in the normal |
3543
|
|
|
|
|
|
* leap days), plus the leftover contribution from any non-leap years. |
3544
|
|
|
|
|
|
* At this point, if we were working with an actual leap day, we'll have 0 |
3545
|
|
|
|
|
|
* days left over. This is also true for March 1st, however. So, we have |
3546
|
|
|
|
|
|
* to special-case that result, and (earlier) keep track of the 'odd' |
3547
|
|
|
|
|
|
* century and year contributions. If we got 4 extra centuries in a qcent, |
3548
|
|
|
|
|
|
* or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb. |
3549
|
|
|
|
|
|
* Otherwise, we add back in the earlier bias we removed (the 123 from |
3550
|
|
|
|
|
|
* figuring in March 1st), find the month index (integer division by 30.6), |
3551
|
|
|
|
|
|
* and the remainder is the day-of-month. We then have to convert back to |
3552
|
|
|
|
|
|
* 'real' months (including fixing January and February from being 14/15 in |
3553
|
|
|
|
|
|
* the previous year to being in the proper year). After that, to get |
3554
|
|
|
|
|
|
* tm_yday, we work with the normalised year and get a new yearday value for |
3555
|
|
|
|
|
|
* January 1st, which we subtract from the yearday value we had earlier, |
3556
|
|
|
|
|
|
* representing the date we've re-built. This is done from January 1 |
3557
|
|
|
|
|
|
* because tm_yday is 0-origin. |
3558
|
|
|
|
|
|
* |
3559
|
|
|
|
|
|
* Since POSIX time routines are only guaranteed to work for times since the |
3560
|
|
|
|
|
|
* UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm |
3561
|
|
|
|
|
|
* applies Gregorian calendar rules even to dates before the 16th century |
3562
|
|
|
|
|
|
* doesn't bother me. Besides, you'd need cultural context for a given |
3563
|
|
|
|
|
|
* date to know whether it was Julian or Gregorian calendar, and that's |
3564
|
|
|
|
|
|
* outside the scope for this routine. Since we convert back based on the |
3565
|
|
|
|
|
|
* same rules we used to build the yearday, you'll only get strange results |
3566
|
|
|
|
|
|
* for input which needed normalising, or for the 'odd' century years which |
3567
|
|
|
|
|
|
* were leap years in the Julian calendar but not in the Gregorian one. |
3568
|
|
|
|
|
|
* I can live with that. |
3569
|
|
|
|
|
|
* |
3570
|
|
|
|
|
|
* This algorithm also fails to handle years before A.D. 1 gracefully, but |
3571
|
|
|
|
|
|
* that's still outside the scope for POSIX time manipulation, so I don't |
3572
|
|
|
|
|
|
* care. |
3573
|
|
|
|
|
|
*/ |
3574
|
|
|
|
|
|
|
3575
|
|
|
|
|
|
year = 1900 + ptm->tm_year; |
3576
|
|
|
|
|
|
month = ptm->tm_mon; |
3577
|
|
|
|
|
|
mday = ptm->tm_mday; |
3578
|
|
|
|
|
|
jday = 0; |
3579
|
|
|
|
|
|
if (month >= 2) |
3580
|
|
|
|
|
|
month+=2; |
3581
|
|
|
|
|
|
else |
3582
|
|
|
|
|
|
month+=14, year--; |
3583
|
|
|
|
|
|
yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400; |
3584
|
|
|
|
|
|
yearday += month*MONTH_TO_DAYS + mday + jday; |
3585
|
|
|
|
|
|
/* |
3586
|
|
|
|
|
|
* Note that we don't know when leap-seconds were or will be, |
3587
|
|
|
|
|
|
* so we have to trust the user if we get something which looks |
3588
|
|
|
|
|
|
* like a sensible leap-second. Wild values for seconds will |
3589
|
|
|
|
|
|
* be rationalised, however. |
3590
|
|
|
|
|
|
*/ |
3591
|
|
|
|
|
|
if ((unsigned) ptm->tm_sec <= 60) { |
3592
|
|
|
|
|
|
secs = 0; |
3593
|
|
|
|
|
|
} |
3594
|
|
|
|
|
|
else { |
3595
|
|
|
|
|
|
secs = ptm->tm_sec; |
3596
|
|
|
|
|
|
ptm->tm_sec = 0; |
3597
|
|
|
|
|
|
} |
3598
|
|
|
|
|
|
secs += 60 * ptm->tm_min; |
3599
|
|
|
|
|
|
secs += SECS_PER_HOUR * ptm->tm_hour; |
3600
|
|
|
|
|
|
if (secs < 0) { |
3601
|
|
|
|
|
|
if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) { |
3602
|
|
|
|
|
|
/* got negative remainder, but need positive time */ |
3603
|
|
|
|
|
|
/* back off an extra day to compensate */ |
3604
|
|
|
|
|
|
yearday += (secs/SECS_PER_DAY)-1; |
3605
|
|
|
|
|
|
secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1); |
3606
|
|
|
|
|
|
} |
3607
|
|
|
|
|
|
else { |
3608
|
|
|
|
|
|
yearday += (secs/SECS_PER_DAY); |
3609
|
|
|
|
|
|
secs -= SECS_PER_DAY * (secs/SECS_PER_DAY); |
3610
|
|
|
|
|
|
} |
3611
|
|
|
|
|
|
} |
3612
|
|
|
|
|
|
else if (secs >= SECS_PER_DAY) { |
3613
|
|
|
|
|
|
yearday += (secs/SECS_PER_DAY); |
3614
|
|
|
|
|
|
secs %= SECS_PER_DAY; |
3615
|
|
|
|
|
|
} |
3616
|
|
|
|
|
|
ptm->tm_hour = secs/SECS_PER_HOUR; |
3617
|
|
|
|
|
|
secs %= SECS_PER_HOUR; |
3618
|
|
|
|
|
|
ptm->tm_min = secs/60; |
3619
|
|
|
|
|
|
secs %= 60; |
3620
|
|
|
|
|
|
ptm->tm_sec += secs; |
3621
|
|
|
|
|
|
/* done with time of day effects */ |
3622
|
|
|
|
|
|
/* |
3623
|
|
|
|
|
|
* The algorithm for yearday has (so far) left it high by 428. |
3624
|
|
|
|
|
|
* To avoid mistaking a legitimate Feb 29 as Mar 1, we need to |
3625
|
|
|
|
|
|
* bias it by 123 while trying to figure out what year it |
3626
|
|
|
|
|
|
* really represents. Even with this tweak, the reverse |
3627
|
|
|
|
|
|
* translation fails for years before A.D. 0001. |
3628
|
|
|
|
|
|
* It would still fail for Feb 29, but we catch that one below. |
3629
|
|
|
|
|
|
*/ |
3630
|
|
|
|
|
|
jday = yearday; /* save for later fixup vis-a-vis Jan 1 */ |
3631
|
|
|
|
|
|
yearday -= YEAR_ADJUST; |
3632
|
|
|
|
|
|
year = (yearday / DAYS_PER_QCENT) * 400; |
3633
|
|
|
|
|
|
yearday %= DAYS_PER_QCENT; |
3634
|
|
|
|
|
|
odd_cent = yearday / DAYS_PER_CENT; |
3635
|
|
|
|
|
|
year += odd_cent * 100; |
3636
|
|
|
|
|
|
yearday %= DAYS_PER_CENT; |
3637
|
|
|
|
|
|
year += (yearday / DAYS_PER_QYEAR) * 4; |
3638
|
|
|
|
|
|
yearday %= DAYS_PER_QYEAR; |
3639
|
|
|
|
|
|
odd_year = yearday / DAYS_PER_YEAR; |
3640
|
|
|
|
|
|
year += odd_year; |
3641
|
|
|
|
|
|
yearday %= DAYS_PER_YEAR; |
3642
|
|
|
|
|
|
if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */ |
3643
|
|
|
|
|
|
month = 1; |
3644
|
|
|
|
|
|
yearday = 29; |
3645
|
|
|
|
|
|
} |
3646
|
|
|
|
|
|
else { |
3647
|
|
|
|
|
|
yearday += YEAR_ADJUST; /* recover March 1st crock */ |
3648
|
|
|
|
|
|
month = yearday*DAYS_TO_MONTH; |
3649
|
|
|
|
|
|
yearday -= month*MONTH_TO_DAYS; |
3650
|
|
|
|
|
|
/* recover other leap-year adjustment */ |
3651
|
|
|
|
|
|
if (month > 13) { |
3652
|
|
|
|
|
|
month-=14; |
3653
|
|
|
|
|
|
year++; |
3654
|
|
|
|
|
|
} |
3655
|
|
|
|
|
|
else { |
3656
|
|
|
|
|
|
month-=2; |
3657
|
|
|
|
|
|
} |
3658
|
|
|
|
|
|
} |
3659
|
|
|
|
|
|
ptm->tm_year = year - 1900; |
3660
|
|
|
|
|
|
if (yearday) { |
3661
|
|
|
|
|
|
ptm->tm_mday = yearday; |
3662
|
|
|
|
|
|
ptm->tm_mon = month; |
3663
|
|
|
|
|
|
} |
3664
|
|
|
|
|
|
else { |
3665
|
|
|
|
|
|
ptm->tm_mday = 31; |
3666
|
|
|
|
|
|
ptm->tm_mon = month - 1; |
3667
|
|
|
|
|
|
} |
3668
|
|
|
|
|
|
/* re-build yearday based on Jan 1 to get tm_yday */ |
3669
|
|
|
|
|
|
year--; |
3670
|
|
|
|
|
|
yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400; |
3671
|
|
|
|
|
|
yearday += 14*MONTH_TO_DAYS + 1; |
3672
|
|
|
|
|
|
ptm->tm_yday = jday - yearday; |
3673
|
|
|
|
|
|
ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7; |
3674
|
|
|
|
|
|
} |
3675
|
|
|
|
|
|
|
3676
|
|
|
|
|
|
char * |
3677
|
|
|
|
|
|
Perl_my_strftime(pTHX_ const char *fmt, int sec, int min, int hour, int mday, int mon, int year, int wday, int yday, int isdst) |
3678
|
|
|
|
|
|
{ |
3679
|
|
|
|
|
|
#ifdef HAS_STRFTIME |
3680
|
|
|
|
|
|
char *buf; |
3681
|
|
|
|
|
|
int buflen; |
3682
|
|
|
|
|
|
struct tm mytm; |
3683
|
|
|
|
|
|
int len; |
3684
|
|
|
|
|
|
|
3685
|
|
|
|
|
|
PERL_ARGS_ASSERT_MY_STRFTIME; |
3686
|
|
|
|
|
|
|
3687
|
|
|
|
|
|
init_tm(&mytm); /* XXX workaround - see init_tm() above */ |
3688
|
|
|
|
|
|
mytm.tm_sec = sec; |
3689
|
|
|
|
|
|
mytm.tm_min = min; |
3690
|
|
|
|
|
|
mytm.tm_hour = hour; |
3691
|
|
|
|
|
|
mytm.tm_mday = mday; |
3692
|
|
|
|
|
|
mytm.tm_mon = mon; |
3693
|
|
|
|
|
|
mytm.tm_year = year; |
3694
|
|
|
|
|
|
mytm.tm_wday = wday; |
3695
|
|
|
|
|
|
mytm.tm_yday = yday; |
3696
|
|
|
|
|
|
mytm.tm_isdst = isdst; |
3697
|
|
|
|
|
|
mini_mktime(&mytm); |
3698
|
|
|
|
|
|
/* use libc to get the values for tm_gmtoff and tm_zone [perl #18238] */ |
3699
|
|
|
|
|
|
#if defined(HAS_MKTIME) && (defined(HAS_TM_TM_GMTOFF) || defined(HAS_TM_TM_ZONE)) |
3700
|
|
|
|
|
|
STMT_START { |
3701
|
|
|
|
|
|
struct tm mytm2; |
3702
|
|
|
|
|
|
mytm2 = mytm; |
3703
|
|
|
|
|
|
mktime(&mytm2); |
3704
|
|
|
|
|
|
#ifdef HAS_TM_TM_GMTOFF |
3705
|
|
|
|
|
|
mytm.tm_gmtoff = mytm2.tm_gmtoff; |
3706
|
|
|
|
|
|
#endif |
3707
|
|
|
|
|
|
#ifdef HAS_TM_TM_ZONE |
3708
|
|
|
|
|
|
mytm.tm_zone = mytm2.tm_zone; |
3709
|
|
|
|
|
|
#endif |
3710
|
|
|
|
|
|
} STMT_END; |
3711
|
|
|
|
|
|
#endif |
3712
|
|
|
|
|
|
buflen = 64; |
3713
|
|
|
|
|
|
Newx(buf, buflen, char); |
3714
|
|
|
|
|
|
len = strftime(buf, buflen, fmt, &mytm); |
3715
|
|
|
|
|
|
/* |
3716
|
|
|
|
|
|
** The following is needed to handle to the situation where |
3717
|
|
|
|
|
|
** tmpbuf overflows. Basically we want to allocate a buffer |
3718
|
|
|
|
|
|
** and try repeatedly. The reason why it is so complicated |
3719
|
|
|
|
|
|
** is that getting a return value of 0 from strftime can indicate |
3720
|
|
|
|
|
|
** one of the following: |
3721
|
|
|
|
|
|
** 1. buffer overflowed, |
3722
|
|
|
|
|
|
** 2. illegal conversion specifier, or |
3723
|
|
|
|
|
|
** 3. the format string specifies nothing to be returned(not |
3724
|
|
|
|
|
|
** an error). This could be because format is an empty string |
3725
|
|
|
|
|
|
** or it specifies %p that yields an empty string in some locale. |
3726
|
|
|
|
|
|
** If there is a better way to make it portable, go ahead by |
3727
|
|
|
|
|
|
** all means. |
3728
|
|
|
|
|
|
*/ |
3729
|
|
|
|
|
|
if ((len > 0 && len < buflen) || (len == 0 && *fmt == '\0')) |
3730
|
|
|
|
|
|
return buf; |
3731
|
|
|
|
|
|
else { |
3732
|
|
|
|
|
|
/* Possibly buf overflowed - try again with a bigger buf */ |
3733
|
|
|
|
|
|
const int fmtlen = strlen(fmt); |
3734
|
|
|
|
|
|
int bufsize = fmtlen + buflen; |
3735
|
|
|
|
|
|
|
3736
|
|
|
|
|
|
Renew(buf, bufsize, char); |
3737
|
|
|
|
|
|
while (buf) { |
3738
|
|
|
|
|
|
buflen = strftime(buf, bufsize, fmt, &mytm); |
3739
|
|
|
|
|
|
if (buflen > 0 && buflen < bufsize) |
3740
|
|
|
|
|
|
break; |
3741
|
|
|
|
|
|
/* heuristic to prevent out-of-memory errors */ |
3742
|
|
|
|
|
|
if (bufsize > 100*fmtlen) { |
3743
|
|
|
|
|
|
Safefree(buf); |
3744
|
|
|
|
|
|
buf = NULL; |
3745
|
|
|
|
|
|
break; |
3746
|
|
|
|
|
|
} |
3747
|
|
|
|
|
|
bufsize *= 2; |
3748
|
|
|
|
|
|
Renew(buf, bufsize, char); |
3749
|
|
|
|
|
|
} |
3750
|
|
|
|
|
|
return buf; |
3751
|
|
|
|
|
|
} |
3752
|
|
|
|
|
|
#else |
3753
|
|
|
|
|
|
Perl_croak(aTHX_ "panic: no strftime"); |
3754
|
|
|
|
|
|
return NULL; |
3755
|
|
|
|
|
|
#endif |
3756
|
|
|
|
|
|
} |
3757
|
|
|
|
|
|
|
3758
|
|
|
|
|
|
|
3759
|
|
|
|
|
|
#define SV_CWD_RETURN_UNDEF \ |
3760
|
|
|
|
|
|
sv_setsv(sv, &PL_sv_undef); \ |
3761
|
|
|
|
|
|
return FALSE |
3762
|
|
|
|
|
|
|
3763
|
|
|
|
|
|
#define SV_CWD_ISDOT(dp) \ |
3764
|
|
|
|
|
|
(dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \ |
3765
|
|
|
|
|
|
(dp->d_name[1] == '.' && dp->d_name[2] == '\0'))) |
3766
|
|
|
|
|
|
|
3767
|
|
|
|
|
|
/* |
3768
|
|
|
|
|
|
=head1 Miscellaneous Functions |
3769
|
|
|
|
|
|
|
3770
|
|
|
|
|
|
=for apidoc getcwd_sv |
3771
|
|
|
|
|
|
|
3772
|
|
|
|
|
|
Fill the sv with current working directory |
3773
|
|
|
|
|
|
|
3774
|
|
|
|
|
|
=cut |
3775
|
|
|
|
|
|
*/ |
3776
|
|
|
|
|
|
|
3777
|
|
|
|
|
|
/* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars. |
3778
|
|
|
|
|
|
* rewritten again by dougm, optimized for use with xs TARG, and to prefer |
3779
|
|
|
|
|
|
* getcwd(3) if available |
3780
|
|
|
|
|
|
* Comments from the orignal: |
3781
|
|
|
|
|
|
* This is a faster version of getcwd. It's also more dangerous |
3782
|
|
|
|
|
|
* because you might chdir out of a directory that you can't chdir |
3783
|
|
|
|
|
|
* back into. */ |
3784
|
|
|
|
|
|
|
3785
|
|
|
|
|
|
int |
3786
|
|
|
|
|
|
Perl_getcwd_sv(pTHX_ SV *sv) |
3787
|
|
|
|
|
|
{ |
3788
|
|
|
|
|
|
#ifndef PERL_MICRO |
3789
|
|
|
|
|
|
dVAR; |
3790
|
|
|
|
|
|
#ifndef INCOMPLETE_TAINTS |
3791
|
|
|
|
|
|
SvTAINTED_on(sv); |
3792
|
|
|
|
|
|
#endif |
3793
|
|
|
|
|
|
|
3794
|
|
|
|
|
|
PERL_ARGS_ASSERT_GETCWD_SV; |
3795
|
|
|
|
|
|
|
3796
|
|
|
|
|
|
#ifdef HAS_GETCWD |
3797
|
|
|
|
|
|
{ |
3798
|
|
|
|
|
|
char buf[MAXPATHLEN]; |
3799
|
|
|
|
|
|
|
3800
|
|
|
|
|
|
/* Some getcwd()s automatically allocate a buffer of the given |
3801
|
|
|
|
|
|
* size from the heap if they are given a NULL buffer pointer. |
3802
|
|
|
|
|
|
* The problem is that this behaviour is not portable. */ |
3803
|
|
|
|
|
|
if (getcwd(buf, sizeof(buf) - 1)) { |
3804
|
|
|
|
|
|
sv_setpv(sv, buf); |
3805
|
|
|
|
|
|
return TRUE; |
3806
|
|
|
|
|
|
} |
3807
|
|
|
|
|
|
else { |
3808
|
|
|
|
|
|
sv_setsv(sv, &PL_sv_undef); |
3809
|
|
|
|
|
|
return FALSE; |
3810
|
|
|
|
|
|
} |
3811
|
|
|
|
|
|
} |
3812
|
|
|
|
|
|
|
3813
|
|
|
|
|
|
#else |
3814
|
|
|
|
|
|
|
3815
|
|
|
|
|
|
Stat_t statbuf; |
3816
|
|
|
|
|
|
int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino; |
3817
|
|
|
|
|
|
int pathlen=0; |
3818
|
|
|
|
|
|
Direntry_t *dp; |
3819
|
|
|
|
|
|
|
3820
|
|
|
|
|
|
SvUPGRADE(sv, SVt_PV); |
3821
|
|
|
|
|
|
|
3822
|
|
|
|
|
|
if (PerlLIO_lstat(".", &statbuf) < 0) { |
3823
|
|
|
|
|
|
SV_CWD_RETURN_UNDEF; |
3824
|
|
|
|
|
|
} |
3825
|
|
|
|
|
|
|
3826
|
|
|
|
|
|
orig_cdev = statbuf.st_dev; |
3827
|
|
|
|
|
|
orig_cino = statbuf.st_ino; |
3828
|
|
|
|
|
|
cdev = orig_cdev; |
3829
|
|
|
|
|
|
cino = orig_cino; |
3830
|
|
|
|
|
|
|
3831
|
|
|
|
|
|
for (;;) { |
3832
|
|
|
|
|
|
DIR *dir; |
3833
|
|
|
|
|
|
int namelen; |
3834
|
|
|
|
|
|
odev = cdev; |
3835
|
|
|
|
|
|
oino = cino; |
3836
|
|
|
|
|
|
|
3837
|
|
|
|
|
|
if (PerlDir_chdir("..") < 0) { |
3838
|
|
|
|
|
|
SV_CWD_RETURN_UNDEF; |
3839
|
|
|
|
|
|
} |
3840
|
|
|
|
|
|
if (PerlLIO_stat(".", &statbuf) < 0) { |
3841
|
|
|
|
|
|
SV_CWD_RETURN_UNDEF; |
3842
|
|
|
|
|
|
} |
3843
|
|
|
|
|
|
|
3844
|
|
|
|
|
|
cdev = statbuf.st_dev; |
3845
|
|
|
|
|
|
cino = statbuf.st_ino; |
3846
|
|
|
|
|
|
|
3847
|
|
|
|
|
|
if (odev == cdev && oino == cino) { |
3848
|
|
|
|
|
|
break; |
3849
|
|
|
|
|
|
} |
3850
|
|
|
|
|
|
if (!(dir = PerlDir_open("."))) { |
3851
|
|
|
|
|
|
SV_CWD_RETURN_UNDEF; |
3852
|
|
|
|
|
|
} |
3853
|
|
|
|
|
|
|
3854
|
|
|
|
|
|
while ((dp = PerlDir_read(dir)) != NULL) { |
3855
|
|
|
|
|
|
#ifdef DIRNAMLEN |
3856
|
|
|
|
|
|
namelen = dp->d_namlen; |
3857
|
|
|
|
|
|
#else |
3858
|
|
|
|
|
|
namelen = strlen(dp->d_name); |
3859
|
|
|
|
|
|
#endif |
3860
|
|
|
|
|
|
/* skip . and .. */ |
3861
|
|
|
|
|
|
if (SV_CWD_ISDOT(dp)) { |
3862
|
|
|
|
|
|
continue; |
3863
|
|
|
|
|
|
} |
3864
|
|
|
|
|
|
|
3865
|
|
|
|
|
|
if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) { |
3866
|
|
|
|
|
|
SV_CWD_RETURN_UNDEF; |
3867
|
|
|
|
|
|
} |
3868
|
|
|
|
|
|
|
3869
|
|
|
|
|
|
tdev = statbuf.st_dev; |
3870
|
|
|
|
|
|
tino = statbuf.st_ino; |
3871
|
|
|
|
|
|
if (tino == oino && tdev == odev) { |
3872
|
|
|
|
|
|
break; |
3873
|
|
|
|
|
|
} |
3874
|
|
|
|
|
|
} |
3875
|
|
|
|
|
|
|
3876
|
|
|
|
|
|
if (!dp) { |
3877
|
|
|
|
|
|
SV_CWD_RETURN_UNDEF; |
3878
|
|
|
|
|
|
} |
3879
|
|
|
|
|
|
|
3880
|
|
|
|
|
|
if (pathlen + namelen + 1 >= MAXPATHLEN) { |
3881
|
|
|
|
|
|
SV_CWD_RETURN_UNDEF; |
3882
|
|
|
|
|
|
} |
3883
|
|
|
|
|
|
|
3884
|
|
|
|
|
|
SvGROW(sv, pathlen + namelen + 1); |
3885
|
|
|
|
|
|
|
3886
|
|
|
|
|
|
if (pathlen) { |
3887
|
|
|
|
|
|
/* shift down */ |
3888
|
|
|
|
|
|
Move(SvPVX_const(sv), SvPVX(sv) + namelen + 1, pathlen, char); |
3889
|
|
|
|
|
|
} |
3890
|
|
|
|
|
|
|
3891
|
|
|
|
|
|
/* prepend current directory to the front */ |
3892
|
|
|
|
|
|
*SvPVX(sv) = '/'; |
3893
|
|
|
|
|
|
Move(dp->d_name, SvPVX(sv)+1, namelen, char); |
3894
|
|
|
|
|
|
pathlen += (namelen + 1); |
3895
|
|
|
|
|
|
|
3896
|
|
|
|
|
|
#ifdef VOID_CLOSEDIR |
3897
|
|
|
|
|
|
PerlDir_close(dir); |
3898
|
|
|
|
|
|
#else |
3899
|
|
|
|
|
|
if (PerlDir_close(dir) < 0) { |
3900
|
|
|
|
|
|
SV_CWD_RETURN_UNDEF; |
3901
|
|
|
|
|
|
} |
3902
|
|
|
|
|
|
#endif |
3903
|
|
|
|
|
|
} |
3904
|
|
|
|
|
|
|
3905
|
|
|
|
|
|
if (pathlen) { |
3906
|
|
|
|
|
|
SvCUR_set(sv, pathlen); |
3907
|
|
|
|
|
|
*SvEND(sv) = '\0'; |
3908
|
|
|
|
|
|
SvPOK_only(sv); |
3909
|
|
|
|
|
|
|
3910
|
|
|
|
|
|
if (PerlDir_chdir(SvPVX_const(sv)) < 0) { |
3911
|
|
|
|
|
|
SV_CWD_RETURN_UNDEF; |
3912
|
|
|
|
|
|
} |
3913
|
|
|
|
|
|
} |
3914
|
|
|
|
|
|
if (PerlLIO_stat(".", &statbuf) < 0) { |
3915
|
|
|
|
|
|
SV_CWD_RETURN_UNDEF; |
3916
|
|
|
|
|
|
} |
3917
|
|
|
|
|
|
|
3918
|
|
|
|
|
|
cdev = statbuf.st_dev; |
3919
|
|
|
|
|
|
cino = statbuf.st_ino; |
3920
|
|
|
|
|
|
|
3921
|
|
|
|
|
|
if (cdev != orig_cdev || cino != orig_cino) { |
3922
|
|
|
|
|
|
Perl_croak(aTHX_ "Unstable directory path, " |
3923
|
|
|
|
|
|
"current directory changed unexpectedly"); |
3924
|
|
|
|
|
|
} |
3925
|
|
|
|
|
|
|
3926
|
|
|
|
|
|
return TRUE; |
3927
|
|
|
|
|
|
#endif |
3928
|
|
|
|
|
|
|
3929
|
|
|
|
|
|
#else |
3930
|
|
|
|
|
|
return FALSE; |
3931
|
|
|
|
|
|
#endif |
3932
|
|
|
|
|
|
} |
3933
|
|
|
|
|
|
|
3934
|
|
|
|
|
|
#define VERSION_MAX 0x7FFFFFFF |
3935
|
|
|
|
|
|
|
3936
|
|
|
|
|
|
/* |
3937
|
|
|
|
|
|
=for apidoc prescan_version |
3938
|
|
|
|
|
|
|
3939
|
|
|
|
|
|
Validate that a given string can be parsed as a version object, but doesn't |
3940
|
|
|
|
|
|
actually perform the parsing. Can use either strict or lax validation rules. |
3941
|
|
|
|
|
|
Can optionally set a number of hint variables to save the parsing code |
3942
|
|
|
|
|
|
some time when tokenizing. |
3943
|
|
|
|
|
|
|
3944
|
|
|
|
|
|
=cut |
3945
|
|
|
|
|
|
*/ |
3946
|
|
|
|
|
|
const char * |
3947
|
|
|
|
|
|
Perl_prescan_version(pTHX_ const char *s, bool strict, |
3948
|
|
|
|
|
|
const char **errstr, |
3949
|
|
|
|
|
|
bool *sqv, int *ssaw_decimal, int *swidth, bool *salpha) { |
3950
|
|
|
|
|
|
bool qv = (sqv ? *sqv : FALSE); |
3951
|
|
|
|
|
|
int width = 3; |
3952
|
|
|
|
|
|
int saw_decimal = 0; |
3953
|
|
|
|
|
|
bool alpha = FALSE; |
3954
|
|
|
|
|
|
const char *d = s; |
3955
|
|
|
|
|
|
|
3956
|
|
|
|
|
|
PERL_ARGS_ASSERT_PRESCAN_VERSION; |
3957
|
|
|
|
|
|
|
3958
|
|
|
|
|
|
if (qv && isDIGIT(*d)) |
3959
|
|
|
|
|
|
goto dotted_decimal_version; |
3960
|
|
|
|
|
|
|
3961
|
|
|
|
|
|
if (*d == 'v') { /* explicit v-string */ |
3962
|
|
|
|
|
|
d++; |
3963
|
|
|
|
|
|
if (isDIGIT(*d)) { |
3964
|
|
|
|
|
|
qv = TRUE; |
3965
|
|
|
|
|
|
} |
3966
|
|
|
|
|
|
else { /* degenerate v-string */ |
3967
|
|
|
|
|
|
/* requires v1.2.3 */ |
3968
|
|
|
|
|
|
BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)"); |
3969
|
|
|
|
|
|
} |
3970
|
|
|
|
|
|
|
3971
|
|
|
|
|
|
dotted_decimal_version: |
3972
|
|
|
|
|
|
if (strict && d[0] == '0' && isDIGIT(d[1])) { |
3973
|
|
|
|
|
|
/* no leading zeros allowed */ |
3974
|
|
|
|
|
|
BADVERSION(s,errstr,"Invalid version format (no leading zeros)"); |
3975
|
|
|
|
|
|
} |
3976
|
|
|
|
|
|
|
3977
|
|
|
|
|
|
while (isDIGIT(*d)) /* integer part */ |
3978
|
|
|
|
|
|
d++; |
3979
|
|
|
|
|
|
|
3980
|
|
|
|
|
|
if (*d == '.') |
3981
|
|
|
|
|
|
{ |
3982
|
|
|
|
|
|
saw_decimal++; |
3983
|
|
|
|
|
|
d++; /* decimal point */ |
3984
|
|
|
|
|
|
} |
3985
|
|
|
|
|
|
else |
3986
|
|
|
|
|
|
{ |
3987
|
|
|
|
|
|
if (strict) { |
3988
|
|
|
|
|
|
/* require v1.2.3 */ |
3989
|
|
|
|
|
|
BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)"); |
3990
|
|
|
|
|
|
} |
3991
|
|
|
|
|
|
else { |
3992
|
|
|
|
|
|
goto version_prescan_finish; |
3993
|
|
|
|
|
|
} |
3994
|
|
|
|
|
|
} |
3995
|
|
|
|
|
|
|
3996
|
|
|
|
|
|
{ |
3997
|
|
|
|
|
|
int i = 0; |
3998
|
|
|
|
|
|
int j = 0; |
3999
|
|
|
|
|
|
while (isDIGIT(*d)) { /* just keep reading */ |
4000
|
|
|
|
|
|
i++; |
4001
|
|
|
|
|
|
while (isDIGIT(*d)) { |
4002
|
|
|
|
|
|
d++; j++; |
4003
|
|
|
|
|
|
/* maximum 3 digits between decimal */ |
4004
|
|
|
|
|
|
if (strict && j > 3) { |
4005
|
|
|
|
|
|
BADVERSION(s,errstr,"Invalid version format (maximum 3 digits between decimals)"); |
4006
|
|
|
|
|
|
} |
4007
|
|
|
|
|
|
} |
4008
|
|
|
|
|
|
if (*d == '_') { |
4009
|
|
|
|
|
|
if (strict) { |
4010
|
|
|
|
|
|
BADVERSION(s,errstr,"Invalid version format (no underscores)"); |
4011
|
|
|
|
|
|
} |
4012
|
|
|
|
|
|
if ( alpha ) { |
4013
|
|
|
|
|
|
BADVERSION(s,errstr,"Invalid version format (multiple underscores)"); |
4014
|
|
|
|
|
|
} |
4015
|
|
|
|
|
|
d++; |
4016
|
|
|
|
|
|
alpha = TRUE; |
4017
|
|
|
|
|
|
} |
4018
|
|
|
|
|
|
else if (*d == '.') { |
4019
|
|
|
|
|
|
if (alpha) { |
4020
|
|
|
|
|
|
BADVERSION(s,errstr,"Invalid version format (underscores before decimal)"); |
4021
|
|
|
|
|
|
} |
4022
|
|
|
|
|
|
saw_decimal++; |
4023
|
|
|
|
|
|
d++; |
4024
|
|
|
|
|
|
} |
4025
|
|
|
|
|
|
else if (!isDIGIT(*d)) { |
4026
|
|
|
|
|
|
break; |
4027
|
|
|
|
|
|
} |
4028
|
|
|
|
|
|
j = 0; |
4029
|
|
|
|
|
|
} |
4030
|
|
|
|
|
|
|
4031
|
|
|
|
|
|
if (strict && i < 2) { |
4032
|
|
|
|
|
|
/* requires v1.2.3 */ |
4033
|
|
|
|
|
|
BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)"); |
4034
|
|
|
|
|
|
} |
4035
|
|
|
|
|
|
} |
4036
|
|
|
|
|
|
} /* end if dotted-decimal */ |
4037
|
|
|
|
|
|
else |
4038
|
|
|
|
|
|
{ /* decimal versions */ |
4039
|
|
|
|
|
|
int j = 0; /* may need this later */ |
4040
|
|
|
|
|
|
/* special strict case for leading '.' or '0' */ |
4041
|
|
|
|
|
|
if (strict) { |
4042
|
|
|
|
|
|
if (*d == '.') { |
4043
|
|
|
|
|
|
BADVERSION(s,errstr,"Invalid version format (0 before decimal required)"); |
4044
|
|
|
|
|
|
} |
4045
|
|
|
|
|
|
if (*d == '0' && isDIGIT(d[1])) { |
4046
|
|
|
|
|
|
BADVERSION(s,errstr,"Invalid version format (no leading zeros)"); |
4047
|
|
|
|
|
|
} |
4048
|
|
|
|
|
|
} |
4049
|
|
|
|
|
|
|
4050
|
|
|
|
|
|
/* and we never support negative versions */ |
4051
|
|
|
|
|
|
if ( *d == '-') { |
4052
|
|
|
|
|
|
BADVERSION(s,errstr,"Invalid version format (negative version number)"); |
4053
|
|
|
|
|
|
} |
4054
|
|
|
|
|
|
|
4055
|
|
|
|
|
|
/* consume all of the integer part */ |
4056
|
|
|
|
|
|
while (isDIGIT(*d)) |
4057
|
|
|
|
|
|
d++; |
4058
|
|
|
|
|
|
|
4059
|
|
|
|
|
|
/* look for a fractional part */ |
4060
|
|
|
|
|
|
if (*d == '.') { |
4061
|
|
|
|
|
|
/* we found it, so consume it */ |
4062
|
|
|
|
|
|
saw_decimal++; |
4063
|
|
|
|
|
|
d++; |
4064
|
|
|
|
|
|
} |
4065
|
|
|
|
|
|
else if (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') { |
4066
|
|
|
|
|
|
if ( d == s ) { |
4067
|
|
|
|
|
|
/* found nothing */ |
4068
|
|
|
|
|
|
BADVERSION(s,errstr,"Invalid version format (version required)"); |
4069
|
|
|
|
|
|
} |
4070
|
|
|
|
|
|
/* found just an integer */ |
4071
|
|
|
|
|
|
goto version_prescan_finish; |
4072
|
|
|
|
|
|
} |
4073
|
|
|
|
|
|
else if ( d == s ) { |
4074
|
|
|
|
|
|
/* didn't find either integer or period */ |
4075
|
|
|
|
|
|
BADVERSION(s,errstr,"Invalid version format (non-numeric data)"); |
4076
|
|
|
|
|
|
} |
4077
|
|
|
|
|
|
else if (*d == '_') { |
4078
|
|
|
|
|
|
/* underscore can't come after integer part */ |
4079
|
|
|
|
|
|
if (strict) { |
4080
|
|
|
|
|
|
BADVERSION(s,errstr,"Invalid version format (no underscores)"); |
4081
|
|
|
|
|
|
} |
4082
|
|
|
|
|
|
else if (isDIGIT(d[1])) { |
4083
|
|
|
|
|
|
BADVERSION(s,errstr,"Invalid version format (alpha without decimal)"); |
4084
|
|
|
|
|
|
} |
4085
|
|
|
|
|
|
else { |
4086
|
|
|
|
|
|
BADVERSION(s,errstr,"Invalid version format (misplaced underscore)"); |
4087
|
|
|
|
|
|
} |
4088
|
|
|
|
|
|
} |
4089
|
|
|
|
|
|
else { |
4090
|
|
|
|
|
|
/* anything else after integer part is just invalid data */ |
4091
|
|
|
|
|
|
BADVERSION(s,errstr,"Invalid version format (non-numeric data)"); |
4092
|
|
|
|
|
|
} |
4093
|
|
|
|
|
|
|
4094
|
|
|
|
|
|
/* scan the fractional part after the decimal point*/ |
4095
|
|
|
|
|
|
|
4096
|
|
|
|
|
|
if (!isDIGIT(*d) && (strict || ! (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') )) { |
4097
|
|
|
|
|
|
/* strict or lax-but-not-the-end */ |
4098
|
|
|
|
|
|
BADVERSION(s,errstr,"Invalid version format (fractional part required)"); |
4099
|
|
|
|
|
|
} |
4100
|
|
|
|
|
|
|
4101
|
|
|
|
|
|
while (isDIGIT(*d)) { |
4102
|
|
|
|
|
|
d++; j++; |
4103
|
|
|
|
|
|
if (*d == '.' && isDIGIT(d[-1])) { |
4104
|
|
|
|
|
|
if (alpha) { |
4105
|
|
|
|
|
|
BADVERSION(s,errstr,"Invalid version format (underscores before decimal)"); |
4106
|
|
|
|
|
|
} |
4107
|
|
|
|
|
|
if (strict) { |
4108
|
|
|
|
|
|
BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions must begin with 'v')"); |
4109
|
|
|
|
|
|
} |
4110
|
|
|
|
|
|
d = (char *)s; /* start all over again */ |
4111
|
|
|
|
|
|
qv = TRUE; |
4112
|
|
|
|
|
|
goto dotted_decimal_version; |
4113
|
|
|
|
|
|
} |
4114
|
|
|
|
|
|
if (*d == '_') { |
4115
|
|
|
|
|
|
if (strict) { |
4116
|
|
|
|
|
|
BADVERSION(s,errstr,"Invalid version format (no underscores)"); |
4117
|
|
|
|
|
|
} |
4118
|
|
|
|
|
|
if ( alpha ) { |
4119
|
|
|
|
|
|
BADVERSION(s,errstr,"Invalid version format (multiple underscores)"); |
4120
|
|
|
|
|
|
} |
4121
|
|
|
|
|
|
if ( ! isDIGIT(d[1]) ) { |
4122
|
|
|
|
|
|
BADVERSION(s,errstr,"Invalid version format (misplaced underscore)"); |
4123
|
|
|
|
|
|
} |
4124
|
|
|
|
|
|
width = j; |
4125
|
|
|
|
|
|
d++; |
4126
|
|
|
|
|
|
alpha = TRUE; |
4127
|
|
|
|
|
|
} |
4128
|
|
|
|
|
|
} |
4129
|
|
|
|
|
|
} |
4130
|
|
|
|
|
|
|
4131
|
|
|
|
|
|
version_prescan_finish: |
4132
|
|
|
|
|
|
while (isSPACE(*d)) |
4133
|
|
|
|
|
|
d++; |
4134
|
|
|
|
|
|
|
4135
|
|
|
|
|
|
if (!isDIGIT(*d) && (! (!*d || *d == ';' || *d == '{' || *d == '}') )) { |
4136
|
|
|
|
|
|
/* trailing non-numeric data */ |
4137
|
|
|
|
|
|
BADVERSION(s,errstr,"Invalid version format (non-numeric data)"); |
4138
|
|
|
|
|
|
} |
4139
|
|
|
|
|
|
|
4140
|
|
|
|
|
|
if (sqv) |
4141
|
|
|
|
|
|
*sqv = qv; |
4142
|
|
|
|
|
|
if (swidth) |
4143
|
|
|
|
|
|
*swidth = width; |
4144
|
|
|
|
|
|
if (ssaw_decimal) |
4145
|
|
|
|
|
|
*ssaw_decimal = saw_decimal; |
4146
|
|
|
|
|
|
if (salpha) |
4147
|
|
|
|
|
|
*salpha = alpha; |
4148
|
|
|
|
|
|
return d; |
4149
|
|
|
|
|
|
} |
4150
|
|
|
|
|
|
|
4151
|
|
|
|
|
|
/* |
4152
|
|
|
|
|
|
=for apidoc scan_version |
4153
|
|
|
|
|
|
|
4154
|
|
|
|
|
|
Returns a pointer to the next character after the parsed |
4155
|
|
|
|
|
|
version string, as well as upgrading the passed in SV to |
4156
|
|
|
|
|
|
an RV. |
4157
|
|
|
|
|
|
|
4158
|
|
|
|
|
|
Function must be called with an already existing SV like |
4159
|
|
|
|
|
|
|
4160
|
|
|
|
|
|
sv = newSV(0); |
4161
|
|
|
|
|
|
s = scan_version(s, SV *sv, bool qv); |
4162
|
|
|
|
|
|
|
4163
|
|
|
|
|
|
Performs some preprocessing to the string to ensure that |
4164
|
|
|
|
|
|
it has the correct characteristics of a version. Flags the |
4165
|
|
|
|
|
|
object if it contains an underscore (which denotes this |
4166
|
|
|
|
|
|
is an alpha version). The boolean qv denotes that the version |
4167
|
|
|
|
|
|
should be interpreted as if it had multiple decimals, even if |
4168
|
|
|
|
|
|
it doesn't. |
4169
|
|
|
|
|
|
|
4170
|
|
|
|
|
|
=cut |
4171
|
|
|
|
|
|
*/ |
4172
|
|
|
|
|
|
|
4173
|
|
|
|
|
|
const char * |
4174
|
|
|
|
|
|
Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) |
4175
|
|
|
|
|
|
{ |
4176
|
|
|
|
|
|
const char *start = s; |
4177
|
|
|
|
|
|
const char *pos; |
4178
|
|
|
|
|
|
const char *last; |
4179
|
|
|
|
|
|
const char *errstr = NULL; |
4180
|
|
|
|
|
|
int saw_decimal = 0; |
4181
|
|
|
|
|
|
int width = 3; |
4182
|
|
|
|
|
|
bool alpha = FALSE; |
4183
|
|
|
|
|
|
bool vinf = FALSE; |
4184
|
|
|
|
|
|
AV * av; |
4185
|
|
|
|
|
|
SV * hv; |
4186
|
|
|
|
|
|
|
4187
|
|
|
|
|
|
PERL_ARGS_ASSERT_SCAN_VERSION; |
4188
|
|
|
|
|
|
|
4189
|
|
|
|
|
|
while (isSPACE(*s)) /* leading whitespace is OK */ |
4190
|
|
|
|
|
|
s++; |
4191
|
|
|
|
|
|
|
4192
|
|
|
|
|
|
last = prescan_version(s, FALSE, &errstr, &qv, &saw_decimal, &width, &alpha); |
4193
|
|
|
|
|
|
if (errstr) { |
4194
|
|
|
|
|
|
/* "undef" is a special case and not an error */ |
4195
|
|
|
|
|
|
if ( ! ( *s == 'u' && strEQ(s,"undef")) ) { |
4196
|
|
|
|
|
|
Safefree(start); |
4197
|
|
|
|
|
|
Perl_croak(aTHX_ "%s", errstr); |
4198
|
|
|
|
|
|
} |
4199
|
|
|
|
|
|
} |
4200
|
|
|
|
|
|
|
4201
|
|
|
|
|
|
start = s; |
4202
|
|
|
|
|
|
if (*s == 'v') |
4203
|
|
|
|
|
|
s++; |
4204
|
|
|
|
|
|
pos = s; |
4205
|
|
|
|
|
|
|
4206
|
|
|
|
|
|
/* Now that we are through the prescan, start creating the object */ |
4207
|
|
|
|
|
|
av = newAV(); |
4208
|
|
|
|
|
|
hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */ |
4209
|
|
|
|
|
|
(void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */ |
4210
|
|
|
|
|
|
|
4211
|
|
|
|
|
|
#ifndef NODEFAULT_SHAREKEYS |
4212
|
|
|
|
|
|
HvSHAREKEYS_on(hv); /* key-sharing on by default */ |
4213
|
|
|
|
|
|
#endif |
4214
|
|
|
|
|
|
|
4215
|
|
|
|
|
|
if ( qv ) |
4216
|
|
|
|
|
|
(void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(qv)); |
4217
|
|
|
|
|
|
if ( alpha ) |
4218
|
|
|
|
|
|
(void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(alpha)); |
4219
|
|
|
|
|
|
if ( !qv && width < 3 ) |
4220
|
|
|
|
|
|
(void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width)); |
4221
|
|
|
|
|
|
|
4222
|
|
|
|
|
|
while (isDIGIT(*pos)) |
4223
|
|
|
|
|
|
pos++; |
4224
|
|
|
|
|
|
if (!isALPHA(*pos)) { |
4225
|
|
|
|
|
|
I32 rev; |
4226
|
|
|
|
|
|
|
4227
|
|
|
|
|
|
for (;;) { |
4228
|
|
|
|
|
|
rev = 0; |
4229
|
|
|
|
|
|
{ |
4230
|
|
|
|
|
|
/* this is atoi() that delimits on underscores */ |
4231
|
|
|
|
|
|
const char *end = pos; |
4232
|
|
|
|
|
|
I32 mult = 1; |
4233
|
|
|
|
|
|
I32 orev; |
4234
|
|
|
|
|
|
|
4235
|
|
|
|
|
|
/* the following if() will only be true after the decimal |
4236
|
|
|
|
|
|
* point of a version originally created with a bare |
4237
|
|
|
|
|
|
* floating point number, i.e. not quoted in any way |
4238
|
|
|
|
|
|
*/ |
4239
|
|
|
|
|
|
if ( !qv && s > start && saw_decimal == 1 ) { |
4240
|
|
|
|
|
|
mult *= 100; |
4241
|
|
|
|
|
|
while ( s < end ) { |
4242
|
|
|
|
|
|
orev = rev; |
4243
|
|
|
|
|
|
rev += (*s - '0') * mult; |
4244
|
|
|
|
|
|
mult /= 10; |
4245
|
|
|
|
|
|
if ( (PERL_ABS(orev) > PERL_ABS(rev)) |
4246
|
|
|
|
|
|
|| (PERL_ABS(rev) > VERSION_MAX )) { |
4247
|
|
|
|
|
|
Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), |
4248
|
|
|
|
|
|
"Integer overflow in version %d",VERSION_MAX); |
4249
|
|
|
|
|
|
s = end - 1; |
4250
|
|
|
|
|
|
rev = VERSION_MAX; |
4251
|
|
|
|
|
|
vinf = 1; |
4252
|
|
|
|
|
|
} |
4253
|
|
|
|
|
|
s++; |
4254
|
|
|
|
|
|
if ( *s == '_' ) |
4255
|
|
|
|
|
|
s++; |
4256
|
|
|
|
|
|
} |
4257
|
|
|
|
|
|
} |
4258
|
|
|
|
|
|
else { |
4259
|
|
|
|
|
|
while (--end >= s) { |
4260
|
|
|
|
|
|
orev = rev; |
4261
|
|
|
|
|
|
rev += (*end - '0') * mult; |
4262
|
|
|
|
|
|
mult *= 10; |
4263
|
|
|
|
|
|
if ( (PERL_ABS(orev) > PERL_ABS(rev)) |
4264
|
|
|
|
|
|
|| (PERL_ABS(rev) > VERSION_MAX )) { |
4265
|
|
|
|
|
|
Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), |
4266
|
|
|
|
|
|
"Integer overflow in version"); |
4267
|
|
|
|
|
|
end = s - 1; |
4268
|
|
|
|
|
|
rev = VERSION_MAX; |
4269
|
|
|
|
|
|
vinf = 1; |
4270
|
|
|
|
|
|
} |
4271
|
|
|
|
|
|
} |
4272
|
|
|
|
|
|
} |
4273
|
|
|
|
|
|
} |
4274
|
|
|
|
|
|
|
4275
|
|
|
|
|
|
/* Append revision */ |
4276
|
|
|
|
|
|
av_push(av, newSViv(rev)); |
4277
|
|
|
|
|
|
if ( vinf ) { |
4278
|
|
|
|
|
|
s = last; |
4279
|
|
|
|
|
|
break; |
4280
|
|
|
|
|
|
} |
4281
|
|
|
|
|
|
else if ( *pos == '.' ) |
4282
|
|
|
|
|
|
s = ++pos; |
4283
|
|
|
|
|
|
else if ( *pos == '_' && isDIGIT(pos[1]) ) |
4284
|
|
|
|
|
|
s = ++pos; |
4285
|
|
|
|
|
|
else if ( *pos == ',' && isDIGIT(pos[1]) ) |
4286
|
|
|
|
|
|
s = ++pos; |
4287
|
|
|
|
|
|
else if ( isDIGIT(*pos) ) |
4288
|
|
|
|
|
|
s = pos; |
4289
|
|
|
|
|
|
else { |
4290
|
|
|
|
|
|
s = pos; |
4291
|
|
|
|
|
|
break; |
4292
|
|
|
|
|
|
} |
4293
|
|
|
|
|
|
if ( qv ) { |
4294
|
|
|
|
|
|
while ( isDIGIT(*pos) ) |
4295
|
|
|
|
|
|
pos++; |
4296
|
|
|
|
|
|
} |
4297
|
|
|
|
|
|
else { |
4298
|
|
|
|
|
|
int digits = 0; |
4299
|
|
|
|
|
|
while ( ( isDIGIT(*pos) || *pos == '_' ) && digits < 3 ) { |
4300
|
|
|
|
|
|
if ( *pos != '_' ) |
4301
|
|
|
|
|
|
digits++; |
4302
|
|
|
|
|
|
pos++; |
4303
|
|
|
|
|
|
} |
4304
|
|
|
|
|
|
} |
4305
|
|
|
|
|
|
} |
4306
|
|
|
|
|
|
} |
4307
|
|
|
|
|
|
if ( qv ) { /* quoted versions always get at least three terms*/ |
4308
|
|
|
|
|
|
SSize_t len = av_len(av); |
4309
|
|
|
|
|
|
/* This for loop appears to trigger a compiler bug on OS X, as it |
4310
|
|
|
|
|
|
loops infinitely. Yes, len is negative. No, it makes no sense. |
4311
|
|
|
|
|
|
Compiler in question is: |
4312
|
|
|
|
|
|
gcc version 3.3 20030304 (Apple Computer, Inc. build 1640) |
4313
|
|
|
|
|
|
for ( len = 2 - len; len > 0; len-- ) |
4314
|
|
|
|
|
|
av_push(MUTABLE_AV(sv), newSViv(0)); |
4315
|
|
|
|
|
|
*/ |
4316
|
|
|
|
|
|
len = 2 - len; |
4317
|
|
|
|
|
|
while (len-- > 0) |
4318
|
|
|
|
|
|
av_push(av, newSViv(0)); |
4319
|
|
|
|
|
|
} |
4320
|
|
|
|
|
|
|
4321
|
|
|
|
|
|
/* need to save off the current version string for later */ |
4322
|
|
|
|
|
|
if ( vinf ) { |
4323
|
|
|
|
|
|
SV * orig = newSVpvn("v.Inf", sizeof("v.Inf")-1); |
4324
|
|
|
|
|
|
(void)hv_stores(MUTABLE_HV(hv), "original", orig); |
4325
|
|
|
|
|
|
(void)hv_stores(MUTABLE_HV(hv), "vinf", newSViv(1)); |
4326
|
|
|
|
|
|
} |
4327
|
|
|
|
|
|
else if ( s > start ) { |
4328
|
|
|
|
|
|
SV * orig = newSVpvn(start,s-start); |
4329
|
|
|
|
|
|
if ( qv && saw_decimal == 1 && *start != 'v' ) { |
4330
|
|
|
|
|
|
/* need to insert a v to be consistent */ |
4331
|
|
|
|
|
|
sv_insert(orig, 0, 0, "v", 1); |
4332
|
|
|
|
|
|
} |
4333
|
|
|
|
|
|
(void)hv_stores(MUTABLE_HV(hv), "original", orig); |
4334
|
|
|
|
|
|
} |
4335
|
|
|
|
|
|
else { |
4336
|
|
|
|
|
|
(void)hv_stores(MUTABLE_HV(hv), "original", newSVpvs("0")); |
4337
|
|
|
|
|
|
av_push(av, newSViv(0)); |
4338
|
|
|
|
|
|
} |
4339
|
|
|
|
|
|
|
4340
|
|
|
|
|
|
/* And finally, store the AV in the hash */ |
4341
|
|
|
|
|
|
(void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av))); |
4342
|
|
|
|
|
|
|
4343
|
|
|
|
|
|
/* fix RT#19517 - special case 'undef' as string */ |
4344
|
|
|
|
|
|
if ( *s == 'u' && strEQ(s,"undef") ) { |
4345
|
|
|
|
|
|
s += 5; |
4346
|
|
|
|
|
|
} |
4347
|
|
|
|
|
|
|
4348
|
|
|
|
|
|
return s; |
4349
|
|
|
|
|
|
} |
4350
|
|
|
|
|
|
|
4351
|
|
|
|
|
|
/* |
4352
|
|
|
|
|
|
=for apidoc new_version |
4353
|
|
|
|
|
|
|
4354
|
|
|
|
|
|
Returns a new version object based on the passed in SV: |
4355
|
|
|
|
|
|
|
4356
|
|
|
|
|
|
SV *sv = new_version(SV *ver); |
4357
|
|
|
|
|
|
|
4358
|
|
|
|
|
|
Does not alter the passed in ver SV. See "upg_version" if you |
4359
|
|
|
|
|
|
want to upgrade the SV. |
4360
|
|
|
|
|
|
|
4361
|
|
|
|
|
|
=cut |
4362
|
|
|
|
|
|
*/ |
4363
|
|
|
|
|
|
|
4364
|
|
|
|
|
|
SV * |
4365
|
|
|
|
|
|
Perl_new_version(pTHX_ SV *ver) |
4366
|
|
|
|
|
|
{ |
4367
|
|
|
|
|
|
dVAR; |
4368
|
|
|
|
|
|
SV * const rv = newSV(0); |
4369
|
|
|
|
|
|
PERL_ARGS_ASSERT_NEW_VERSION; |
4370
|
|
|
|
|
|
if ( sv_isobject(ver) && sv_derived_from(ver, "version") ) |
4371
|
|
|
|
|
|
/* can just copy directly */ |
4372
|
|
|
|
|
|
{ |
4373
|
|
|
|
|
|
SSize_t key; |
4374
|
|
|
|
|
|
AV * const av = newAV(); |
4375
|
|
|
|
|
|
AV *sav; |
4376
|
|
|
|
|
|
/* This will get reblessed later if a derived class*/ |
4377
|
|
|
|
|
|
SV * const hv = newSVrv(rv, "version"); |
4378
|
|
|
|
|
|
(void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */ |
4379
|
|
|
|
|
|
#ifndef NODEFAULT_SHAREKEYS |
4380
|
|
|
|
|
|
HvSHAREKEYS_on(hv); /* key-sharing on by default */ |
4381
|
|
|
|
|
|
#endif |
4382
|
|
|
|
|
|
|
4383
|
|
|
|
|
|
if ( SvROK(ver) ) |
4384
|
|
|
|
|
|
ver = SvRV(ver); |
4385
|
|
|
|
|
|
|
4386
|
|
|
|
|
|
/* Begin copying all of the elements */ |
4387
|
|
|
|
|
|
if ( hv_exists(MUTABLE_HV(ver), "qv", 2) ) |
4388
|
|
|
|
|
|
(void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(1)); |
4389
|
|
|
|
|
|
|
4390
|
|
|
|
|
|
if ( hv_exists(MUTABLE_HV(ver), "alpha", 5) ) |
4391
|
|
|
|
|
|
(void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(1)); |
4392
|
|
|
|
|
|
|
4393
|
|
|
|
|
|
if ( hv_exists(MUTABLE_HV(ver), "width", 5 ) ) |
4394
|
|
|
|
|
|
{ |
4395
|
|
|
|
|
|
const I32 width = SvIV(*hv_fetchs(MUTABLE_HV(ver), "width", FALSE)); |
4396
|
|
|
|
|
|
(void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width)); |
4397
|
|
|
|
|
|
} |
4398
|
|
|
|
|
|
|
4399
|
|
|
|
|
|
if ( hv_exists(MUTABLE_HV(ver), "original", 8 ) ) |
4400
|
|
|
|
|
|
{ |
4401
|
|
|
|
|
|
SV * pv = *hv_fetchs(MUTABLE_HV(ver), "original", FALSE); |
4402
|
|
|
|
|
|
(void)hv_stores(MUTABLE_HV(hv), "original", newSVsv(pv)); |
4403
|
|
|
|
|
|
} |
4404
|
|
|
|
|
|
|
4405
|
|
|
|
|
|
sav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(ver), "version", FALSE))); |
4406
|
|
|
|
|
|
/* This will get reblessed later if a derived class*/ |
4407
|
|
|
|
|
|
for ( key = 0; key <= av_len(sav); key++ ) |
4408
|
|
|
|
|
|
{ |
4409
|
|
|
|
|
|
const I32 rev = SvIV(*av_fetch(sav, key, FALSE)); |
4410
|
|
|
|
|
|
av_push(av, newSViv(rev)); |
4411
|
|
|
|
|
|
} |
4412
|
|
|
|
|
|
|
4413
|
|
|
|
|
|
(void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av))); |
4414
|
|
|
|
|
|
return rv; |
4415
|
|
|
|
|
|
} |
4416
|
|
|
|
|
|
#ifdef SvVOK |
4417
|
|
|
|
|
|
{ |
4418
|
|
|
|
|
|
const MAGIC* const mg = SvVSTRING_mg(ver); |
4419
|
|
|
|
|
|
if ( mg ) { /* already a v-string */ |
4420
|
|
|
|
|
|
const STRLEN len = mg->mg_len; |
4421
|
|
|
|
|
|
char * const version = savepvn( (const char*)mg->mg_ptr, len); |
4422
|
|
|
|
|
|
sv_setpvn(rv,version,len); |
4423
|
|
|
|
|
|
/* this is for consistency with the pure Perl class */ |
4424
|
|
|
|
|
|
if ( isDIGIT(*version) ) |
4425
|
|
|
|
|
|
sv_insert(rv, 0, 0, "v", 1); |
4426
|
|
|
|
|
|
Safefree(version); |
4427
|
|
|
|
|
|
} |
4428
|
|
|
|
|
|
else { |
4429
|
|
|
|
|
|
#endif |
4430
|
|
|
|
|
|
sv_setsv(rv,ver); /* make a duplicate */ |
4431
|
|
|
|
|
|
#ifdef SvVOK |
4432
|
|
|
|
|
|
} |
4433
|
|
|
|
|
|
} |
4434
|
|
|
|
|
|
#endif |
4435
|
|
|
|
|
|
return upg_version(rv, FALSE); |
4436
|
|
|
|
|
|
} |
4437
|
|
|
|
|
|
|
4438
|
|
|
|
|
|
/* |
4439
|
|
|
|
|
|
=for apidoc upg_version |
4440
|
|
|
|
|
|
|
4441
|
|
|
|
|
|
In-place upgrade of the supplied SV to a version object. |
4442
|
|
|
|
|
|
|
4443
|
|
|
|
|
|
SV *sv = upg_version(SV *sv, bool qv); |
4444
|
|
|
|
|
|
|
4445
|
|
|
|
|
|
Returns a pointer to the upgraded SV. Set the boolean qv if you want |
4446
|
|
|
|
|
|
to force this SV to be interpreted as an "extended" version. |
4447
|
|
|
|
|
|
|
4448
|
|
|
|
|
|
=cut |
4449
|
|
|
|
|
|
*/ |
4450
|
|
|
|
|
|
|
4451
|
|
|
|
|
|
SV * |
4452
|
|
|
|
|
|
Perl_upg_version(pTHX_ SV *ver, bool qv) |
4453
|
|
|
|
|
|
{ |
4454
|
|
|
|
|
|
const char *version, *s; |
4455
|
|
|
|
|
|
#ifdef SvVOK |
4456
|
|
|
|
|
|
const MAGIC *mg; |
4457
|
|
|
|
|
|
#endif |
4458
|
|
|
|
|
|
|
4459
|
|
|
|
|
|
PERL_ARGS_ASSERT_UPG_VERSION; |
4460
|
|
|
|
|
|
|
4461
|
|
|
|
|
|
if ( SvNOK(ver) && !( SvPOK(ver) && sv_len(ver) == 3 ) ) |
4462
|
|
|
|
|
|
{ |
4463
|
|
|
|
|
|
STRLEN len; |
4464
|
|
|
|
|
|
|
4465
|
|
|
|
|
|
/* may get too much accuracy */ |
4466
|
|
|
|
|
|
char tbuf[64]; |
4467
|
|
|
|
|
|
SV *sv = SvNVX(ver) > 10e50 ? newSV(64) : 0; |
4468
|
|
|
|
|
|
char *buf; |
4469
|
|
|
|
|
|
#ifdef USE_LOCALE_NUMERIC |
4470
|
|
|
|
|
|
char *loc = NULL; |
4471
|
|
|
|
|
|
if (! PL_numeric_standard) { |
4472
|
|
|
|
|
|
loc = savepv(setlocale(LC_NUMERIC, NULL)); |
4473
|
|
|
|
|
|
setlocale(LC_NUMERIC, "C"); |
4474
|
|
|
|
|
|
} |
4475
|
|
|
|
|
|
#endif |
4476
|
|
|
|
|
|
if (sv) { |
4477
|
|
|
|
|
|
Perl_sv_setpvf(aTHX_ sv, "%.9"NVff, SvNVX(ver)); |
4478
|
|
|
|
|
|
buf = SvPV(sv, len); |
4479
|
|
|
|
|
|
} |
4480
|
|
|
|
|
|
else { |
4481
|
|
|
|
|
|
len = my_snprintf(tbuf, sizeof(tbuf), "%.9"NVff, SvNVX(ver)); |
4482
|
|
|
|
|
|
buf = tbuf; |
4483
|
|
|
|
|
|
} |
4484
|
|
|
|
|
|
#ifdef USE_LOCALE_NUMERIC |
4485
|
|
|
|
|
|
if (loc) { |
4486
|
|
|
|
|
|
setlocale(LC_NUMERIC, loc); |
4487
|
|
|
|
|
|
Safefree(loc); |
4488
|
|
|
|
|
|
} |
4489
|
|
|
|
|
|
#endif |
4490
|
|
|
|
|
|
while (buf[len-1] == '0' && len > 0) len--; |
4491
|
|
|
|
|
|
if ( buf[len-1] == '.' ) len--; /* eat the trailing decimal */ |
4492
|
|
|
|
|
|
version = savepvn(buf, len); |
4493
|
|
|
|
|
|
SvREFCNT_dec(sv); |
4494
|
|
|
|
|
|
} |
4495
|
|
|
|
|
|
#ifdef SvVOK |
4496
|
|
|
|
|
|
else if ( (mg = SvVSTRING_mg(ver)) ) { /* already a v-string */ |
4497
|
|
|
|
|
|
version = savepvn( (const char*)mg->mg_ptr,mg->mg_len ); |
4498
|
|
|
|
|
|
qv = TRUE; |
4499
|
|
|
|
|
|
} |
4500
|
|
|
|
|
|
#endif |
4501
|
|
|
|
|
|
else /* must be a string or something like a string */ |
4502
|
|
|
|
|
|
{ |
4503
|
|
|
|
|
|
STRLEN len; |
4504
|
|
|
|
|
|
version = savepv(SvPV(ver,len)); |
4505
|
|
|
|
|
|
#ifndef SvVOK |
4506
|
|
|
|
|
|
# if PERL_VERSION > 5 |
4507
|
|
|
|
|
|
/* This will only be executed for 5.6.0 - 5.8.0 inclusive */ |
4508
|
|
|
|
|
|
if ( len >= 3 && !instr(version,".") && !instr(version,"_")) { |
4509
|
|
|
|
|
|
/* may be a v-string */ |
4510
|
|
|
|
|
|
char *testv = (char *)version; |
4511
|
|
|
|
|
|
STRLEN tlen = len; |
4512
|
|
|
|
|
|
for (tlen=0; tlen < len; tlen++, testv++) { |
4513
|
|
|
|
|
|
/* if one of the characters is non-text assume v-string */ |
4514
|
|
|
|
|
|
if (testv[0] < ' ') { |
4515
|
|
|
|
|
|
SV * const nsv = sv_newmortal(); |
4516
|
|
|
|
|
|
const char *nver; |
4517
|
|
|
|
|
|
const char *pos; |
4518
|
|
|
|
|
|
int saw_decimal = 0; |
4519
|
|
|
|
|
|
sv_setpvf(nsv,"v%vd",ver); |
4520
|
|
|
|
|
|
pos = nver = savepv(SvPV_nolen(nsv)); |
4521
|
|
|
|
|
|
|
4522
|
|
|
|
|
|
/* scan the resulting formatted string */ |
4523
|
|
|
|
|
|
pos++; /* skip the leading 'v' */ |
4524
|
|
|
|
|
|
while ( *pos == '.' || isDIGIT(*pos) ) { |
4525
|
|
|
|
|
|
if ( *pos == '.' ) |
4526
|
|
|
|
|
|
saw_decimal++ ; |
4527
|
|
|
|
|
|
pos++; |
4528
|
|
|
|
|
|
} |
4529
|
|
|
|
|
|
|
4530
|
|
|
|
|
|
/* is definitely a v-string */ |
4531
|
|
|
|
|
|
if ( saw_decimal >= 2 ) { |
4532
|
|
|
|
|
|
Safefree(version); |
4533
|
|
|
|
|
|
version = nver; |
4534
|
|
|
|
|
|
} |
4535
|
|
|
|
|
|
break; |
4536
|
|
|
|
|
|
} |
4537
|
|
|
|
|
|
} |
4538
|
|
|
|
|
|
} |
4539
|
|
|
|
|
|
# endif |
4540
|
|
|
|
|
|
#endif |
4541
|
|
|
|
|
|
} |
4542
|
|
|
|
|
|
|
4543
|
|
|
|
|
|
s = scan_version(version, ver, qv); |
4544
|
|
|
|
|
|
if ( *s != '\0' ) |
4545
|
|
|
|
|
|
Perl_ck_warner(aTHX_ packWARN(WARN_MISC), |
4546
|
|
|
|
|
|
"Version string '%s' contains invalid data; " |
4547
|
|
|
|
|
|
"ignoring: '%s'", version, s); |
4548
|
|
|
|
|
|
Safefree(version); |
4549
|
|
|
|
|
|
return ver; |
4550
|
|
|
|
|
|
} |
4551
|
|
|
|
|
|
|
4552
|
|
|
|
|
|
/* |
4553
|
|
|
|
|
|
=for apidoc vverify |
4554
|
|
|
|
|
|
|
4555
|
|
|
|
|
|
Validates that the SV contains valid internal structure for a version object. |
4556
|
|
|
|
|
|
It may be passed either the version object (RV) or the hash itself (HV). If |
4557
|
|
|
|
|
|
the structure is valid, it returns the HV. If the structure is invalid, |
4558
|
|
|
|
|
|
it returns NULL. |
4559
|
|
|
|
|
|
|
4560
|
|
|
|
|
|
SV *hv = vverify(sv); |
4561
|
|
|
|
|
|
|
4562
|
|
|
|
|
|
Note that it only confirms the bare minimum structure (so as not to get |
4563
|
|
|
|
|
|
confused by derived classes which may contain additional hash entries): |
4564
|
|
|
|
|
|
|
4565
|
|
|
|
|
|
=over 4 |
4566
|
|
|
|
|
|
|
4567
|
|
|
|
|
|
=item * The SV is an HV or a reference to an HV |
4568
|
|
|
|
|
|
|
4569
|
|
|
|
|
|
=item * The hash contains a "version" key |
4570
|
|
|
|
|
|
|
4571
|
|
|
|
|
|
=item * The "version" key has a reference to an AV as its value |
4572
|
|
|
|
|
|
|
4573
|
|
|
|
|
|
=back |
4574
|
|
|
|
|
|
|
4575
|
|
|
|
|
|
=cut |
4576
|
|
|
|
|
|
*/ |
4577
|
|
|
|
|
|
|
4578
|
|
|
|
|
|
SV * |
4579
|
|
|
|
|
|
Perl_vverify(pTHX_ SV *vs) |
4580
|
|
|
|
|
|
{ |
4581
|
|
|
|
|
|
SV *sv; |
4582
|
|
|
|
|
|
|
4583
|
|
|
|
|
|
PERL_ARGS_ASSERT_VVERIFY; |
4584
|
|
|
|
|
|
|
4585
|
|
|
|
|
|
if ( SvROK(vs) ) |
4586
|
|
|
|
|
|
vs = SvRV(vs); |
4587
|
|
|
|
|
|
|
4588
|
|
|
|
|
|
/* see if the appropriate elements exist */ |
4589
|
|
|
|
|
|
if ( SvTYPE(vs) == SVt_PVHV |
4590
|
|
|
|
|
|
&& hv_exists(MUTABLE_HV(vs), "version", 7) |
4591
|
|
|
|
|
|
&& (sv = SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE))) |
4592
|
|
|
|
|
|
&& SvTYPE(sv) == SVt_PVAV ) |
4593
|
|
|
|
|
|
return vs; |
4594
|
|
|
|
|
|
else |
4595
|
|
|
|
|
|
return NULL; |
4596
|
|
|
|
|
|
} |
4597
|
|
|
|
|
|
|
4598
|
|
|
|
|
|
/* |
4599
|
|
|
|
|
|
=for apidoc vnumify |
4600
|
|
|
|
|
|
|
4601
|
|
|
|
|
|
Accepts a version object and returns the normalized floating |
4602
|
|
|
|
|
|
point representation. Call like: |
4603
|
|
|
|
|
|
|
4604
|
|
|
|
|
|
sv = vnumify(rv); |
4605
|
|
|
|
|
|
|
4606
|
|
|
|
|
|
NOTE: you can pass either the object directly or the SV |
4607
|
|
|
|
|
|
contained within the RV. |
4608
|
|
|
|
|
|
|
4609
|
|
|
|
|
|
The SV returned has a refcount of 1. |
4610
|
|
|
|
|
|
|
4611
|
|
|
|
|
|
=cut |
4612
|
|
|
|
|
|
*/ |
4613
|
|
|
|
|
|
|
4614
|
|
|
|
|
|
SV * |
4615
|
|
|
|
|
|
Perl_vnumify(pTHX_ SV *vs) |
4616
|
|
|
|
|
|
{ |
4617
|
|
|
|
|
|
SSize_t i, len; |
4618
|
|
|
|
|
|
I32 digit; |
4619
|
|
|
|
|
|
int width; |
4620
|
|
|
|
|
|
bool alpha = FALSE; |
4621
|
|
|
|
|
|
SV *sv; |
4622
|
|
|
|
|
|
AV *av; |
4623
|
|
|
|
|
|
|
4624
|
|
|
|
|
|
PERL_ARGS_ASSERT_VNUMIFY; |
4625
|
|
|
|
|
|
|
4626
|
|
|
|
|
|
/* extract the HV from the object */ |
4627
|
|
|
|
|
|
vs = vverify(vs); |
4628
|
|
|
|
|
|
if ( ! vs ) |
4629
|
|
|
|
|
|
Perl_croak(aTHX_ "Invalid version object"); |
4630
|
|
|
|
|
|
|
4631
|
|
|
|
|
|
/* see if various flags exist */ |
4632
|
|
|
|
|
|
if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) ) |
4633
|
|
|
|
|
|
alpha = TRUE; |
4634
|
|
|
|
|
|
if ( hv_exists(MUTABLE_HV(vs), "width", 5 ) ) |
4635
|
|
|
|
|
|
width = SvIV(*hv_fetchs(MUTABLE_HV(vs), "width", FALSE)); |
4636
|
|
|
|
|
|
else |
4637
|
|
|
|
|
|
width = 3; |
4638
|
|
|
|
|
|
|
4639
|
|
|
|
|
|
|
4640
|
|
|
|
|
|
/* attempt to retrieve the version array */ |
4641
|
|
|
|
|
|
if ( !(av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE))) ) ) { |
4642
|
|
|
|
|
|
return newSVpvs("0"); |
4643
|
|
|
|
|
|
} |
4644
|
|
|
|
|
|
|
4645
|
|
|
|
|
|
len = av_len(av); |
4646
|
|
|
|
|
|
if ( len == -1 ) |
4647
|
|
|
|
|
|
{ |
4648
|
|
|
|
|
|
return newSVpvs("0"); |
4649
|
|
|
|
|
|
} |
4650
|
|
|
|
|
|
|
4651
|
|
|
|
|
|
digit = SvIV(*av_fetch(av, 0, 0)); |
4652
|
|
|
|
|
|
sv = Perl_newSVpvf(aTHX_ "%d.", (int)PERL_ABS(digit)); |
4653
|
|
|
|
|
|
for ( i = 1 ; i < len ; i++ ) |
4654
|
|
|
|
|
|
{ |
4655
|
|
|
|
|
|
digit = SvIV(*av_fetch(av, i, 0)); |
4656
|
|
|
|
|
|
if ( width < 3 ) { |
4657
|
|
|
|
|
|
const int denom = (width == 2 ? 10 : 100); |
4658
|
|
|
|
|
|
const div_t term = div((int)PERL_ABS(digit),denom); |
4659
|
|
|
|
|
|
Perl_sv_catpvf(aTHX_ sv, "%0*d_%d", width, term.quot, term.rem); |
4660
|
|
|
|
|
|
} |
4661
|
|
|
|
|
|
else { |
4662
|
|
|
|
|
|
Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit); |
4663
|
|
|
|
|
|
} |
4664
|
|
|
|
|
|
} |
4665
|
|
|
|
|
|
|
4666
|
|
|
|
|
|
if ( len > 0 ) |
4667
|
|
|
|
|
|
{ |
4668
|
|
|
|
|
|
digit = SvIV(*av_fetch(av, len, 0)); |
4669
|
|
|
|
|
|
if ( alpha && width == 3 ) /* alpha version */ |
4670
|
|
|
|
|
|
sv_catpvs(sv,"_"); |
4671
|
|
|
|
|
|
Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit); |
4672
|
|
|
|
|
|
} |
4673
|
|
|
|
|
|
else /* len == 0 */ |
4674
|
|
|
|
|
|
{ |
4675
|
|
|
|
|
|
sv_catpvs(sv, "000"); |
4676
|
|
|
|
|
|
} |
4677
|
|
|
|
|
|
return sv; |
4678
|
|
|
|
|
|
} |
4679
|
|
|
|
|
|
|
4680
|
|
|
|
|
|
/* |
4681
|
|
|
|
|
|
=for apidoc vnormal |
4682
|
|
|
|
|
|
|
4683
|
|
|
|
|
|
Accepts a version object and returns the normalized string |
4684
|
|
|
|
|
|
representation. Call like: |
4685
|
|
|
|
|
|
|
4686
|
|
|
|
|
|
sv = vnormal(rv); |
4687
|
|
|
|
|
|
|
4688
|
|
|
|
|
|
NOTE: you can pass either the object directly or the SV |
4689
|
|
|
|
|
|
contained within the RV. |
4690
|
|
|
|
|
|
|
4691
|
|
|
|
|
|
The SV returned has a refcount of 1. |
4692
|
|
|
|
|
|
|
4693
|
|
|
|
|
|
=cut |
4694
|
|
|
|
|
|
*/ |
4695
|
|
|
|
|
|
|
4696
|
|
|
|
|
|
SV * |
4697
|
|
|
|
|
|
Perl_vnormal(pTHX_ SV *vs) |
4698
|
|
|
|
|
|
{ |
4699
|
|
|
|
|
|
I32 i, len, digit; |
4700
|
|
|
|
|
|
bool alpha = FALSE; |
4701
|
|
|
|
|
|
SV *sv; |
4702
|
|
|
|
|
|
AV *av; |
4703
|
|
|
|
|
|
|
4704
|
|
|
|
|
|
PERL_ARGS_ASSERT_VNORMAL; |
4705
|
|
|
|
|
|
|
4706
|
|
|
|
|
|
/* extract the HV from the object */ |
4707
|
|
|
|
|
|
vs = vverify(vs); |
4708
|
|
|
|
|
|
if ( ! vs ) |
4709
|
|
|
|
|
|
Perl_croak(aTHX_ "Invalid version object"); |
4710
|
|
|
|
|
|
|
4711
|
|
|
|
|
|
if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) ) |
4712
|
|
|
|
|
|
alpha = TRUE; |
4713
|
|
|
|
|
|
av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE))); |
4714
|
|
|
|
|
|
|
4715
|
|
|
|
|
|
len = av_len(av); |
4716
|
|
|
|
|
|
if ( len == -1 ) |
4717
|
|
|
|
|
|
{ |
4718
|
|
|
|
|
|
return newSVpvs(""); |
4719
|
|
|
|
|
|
} |
4720
|
|
|
|
|
|
digit = SvIV(*av_fetch(av, 0, 0)); |
4721
|
|
|
|
|
|
sv = Perl_newSVpvf(aTHX_ "v%"IVdf, (IV)digit); |
4722
|
|
|
|
|
|
for ( i = 1 ; i < len ; i++ ) { |
4723
|
|
|
|
|
|
digit = SvIV(*av_fetch(av, i, 0)); |
4724
|
|
|
|
|
|
Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit); |
4725
|
|
|
|
|
|
} |
4726
|
|
|
|
|
|
|
4727
|
|
|
|
|
|
if ( len > 0 ) |
4728
|
|
|
|
|
|
{ |
4729
|
|
|
|
|
|
/* handle last digit specially */ |
4730
|
|
|
|
|
|
digit = SvIV(*av_fetch(av, len, 0)); |
4731
|
|
|
|
|
|
if ( alpha ) |
4732
|
|
|
|
|
|
Perl_sv_catpvf(aTHX_ sv, "_%"IVdf, (IV)digit); |
4733
|
|
|
|
|
|
else |
4734
|
|
|
|
|
|
Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit); |
4735
|
|
|
|
|
|
} |
4736
|
|
|
|
|
|
|
4737
|
|
|
|
|
|
if ( len <= 2 ) { /* short version, must be at least three */ |
4738
|
|
|
|
|
|
for ( len = 2 - len; len != 0; len-- ) |
4739
|
|
|
|
|
|
sv_catpvs(sv,".0"); |
4740
|
|
|
|
|
|
} |
4741
|
|
|
|
|
|
return sv; |
4742
|
|
|
|
|
|
} |
4743
|
|
|
|
|
|
|
4744
|
|
|
|
|
|
/* |
4745
|
|
|
|
|
|
=for apidoc vstringify |
4746
|
|
|
|
|
|
|
4747
|
|
|
|
|
|
In order to maintain maximum compatibility with earlier versions |
4748
|
|
|
|
|
|
of Perl, this function will return either the floating point |
4749
|
|
|
|
|
|
notation or the multiple dotted notation, depending on whether |
4750
|
|
|
|
|
|
the original version contained 1 or more dots, respectively. |
4751
|
|
|
|
|
|
|
4752
|
|
|
|
|
|
The SV returned has a refcount of 1. |
4753
|
|
|
|
|
|
|
4754
|
|
|
|
|
|
=cut |
4755
|
|
|
|
|
|
*/ |
4756
|
|
|
|
|
|
|
4757
|
|
|
|
|
|
SV * |
4758
|
|
|
|
|
|
Perl_vstringify(pTHX_ SV *vs) |
4759
|
|
|
|
|
|
{ |
4760
|
|
|
|
|
|
PERL_ARGS_ASSERT_VSTRINGIFY; |
4761
|
|
|
|
|
|
|
4762
|
|
|
|
|
|
/* extract the HV from the object */ |
4763
|
|
|
|
|
|
vs = vverify(vs); |
4764
|
|
|
|
|
|
if ( ! vs ) |
4765
|
|
|
|
|
|
Perl_croak(aTHX_ "Invalid version object"); |
4766
|
|
|
|
|
|
|
4767
|
|
|
|
|
|
if (hv_exists(MUTABLE_HV(vs), "original", sizeof("original") - 1)) { |
4768
|
|
|
|
|
|
SV *pv; |
4769
|
|
|
|
|
|
pv = *hv_fetchs(MUTABLE_HV(vs), "original", FALSE); |
4770
|
|
|
|
|
|
if ( SvPOK(pv) ) |
4771
|
|
|
|
|
|
return newSVsv(pv); |
4772
|
|
|
|
|
|
else |
4773
|
|
|
|
|
|
return &PL_sv_undef; |
4774
|
|
|
|
|
|
} |
4775
|
|
|
|
|
|
else { |
4776
|
|
|
|
|
|
if ( hv_exists(MUTABLE_HV(vs), "qv", 2) ) |
4777
|
|
|
|
|
|
return vnormal(vs); |
4778
|
|
|
|
|
|
else |
4779
|
|
|
|
|
|
return vnumify(vs); |
4780
|
|
|
|
|
|
} |
4781
|
|
|
|
|
|
} |
4782
|
|
|
|
|
|
|
4783
|
|
|
|
|
|
/* |
4784
|
|
|
|
|
|
=for apidoc vcmp |
4785
|
|
|
|
|
|
|
4786
|
|
|
|
|
|
Version object aware cmp. Both operands must already have been |
4787
|
|
|
|
|
|
converted into version objects. |
4788
|
|
|
|
|
|
|
4789
|
|
|
|
|
|
=cut |
4790
|
|
|
|
|
|
*/ |
4791
|
|
|
|
|
|
|
4792
|
|
|
|
|
|
int |
4793
|
|
|
|
|
|
Perl_vcmp(pTHX_ SV *lhv, SV *rhv) |
4794
|
|
|
|
|
|
{ |
4795
|
|
|
|
|
|
I32 i,l,m,r; |
4796
|
|
|
|
|
|
I32 retval; |
4797
|
|
|
|
|
|
bool lalpha = FALSE; |
4798
|
|
|
|
|
|
bool ralpha = FALSE; |
4799
|
|
|
|
|
|
I32 left = 0; |
4800
|
|
|
|
|
|
I32 right = 0; |
4801
|
|
|
|
|
|
AV *lav, *rav; |
4802
|
|
|
|
|
|
|
4803
|
|
|
|
|
|
PERL_ARGS_ASSERT_VCMP; |
4804
|
|
|
|
|
|
|
4805
|
|
|
|
|
|
/* extract the HVs from the objects */ |
4806
|
|
|
|
|
|
lhv = vverify(lhv); |
4807
|
|
|
|
|
|
rhv = vverify(rhv); |
4808
|
|
|
|
|
|
if ( ! ( lhv && rhv ) ) |
4809
|
|
|
|
|
|
Perl_croak(aTHX_ "Invalid version object"); |
4810
|
|
|
|
|
|
|
4811
|
|
|
|
|
|
/* get the left hand term */ |
4812
|
|
|
|
|
|
lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(lhv), "version", FALSE))); |
4813
|
|
|
|
|
|
if ( hv_exists(MUTABLE_HV(lhv), "alpha", 5 ) ) |
4814
|
|
|
|
|
|
lalpha = TRUE; |
4815
|
|
|
|
|
|
|
4816
|
|
|
|
|
|
/* and the right hand term */ |
4817
|
|
|
|
|
|
rav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(rhv), "version", FALSE))); |
4818
|
|
|
|
|
|
if ( hv_exists(MUTABLE_HV(rhv), "alpha", 5 ) ) |
4819
|
|
|
|
|
|
ralpha = TRUE; |
4820
|
|
|
|
|
|
|
4821
|
|
|
|
|
|
l = av_len(lav); |
4822
|
|
|
|
|
|
r = av_len(rav); |
4823
|
|
|
|
|
|
m = l < r ? l : r; |
4824
|
|
|
|
|
|
retval = 0; |
4825
|
|
|
|
|
|
i = 0; |
4826
|
|
|
|
|
|
while ( i <= m && retval == 0 ) |
4827
|
|
|
|
|
|
{ |
4828
|
|
|
|
|
|
left = SvIV(*av_fetch(lav,i,0)); |
4829
|
|
|
|
|
|
right = SvIV(*av_fetch(rav,i,0)); |
4830
|
|
|
|
|
|
if ( left < right ) |
4831
|
|
|
|
|
|
retval = -1; |
4832
|
|
|
|
|
|
if ( left > right ) |
4833
|
|
|
|
|
|
retval = +1; |
4834
|
|
|
|
|
|
i++; |
4835
|
|
|
|
|
|
} |
4836
|
|
|
|
|
|
|
4837
|
|
|
|
|
|
/* tiebreaker for alpha with identical terms */ |
4838
|
|
|
|
|
|
if ( retval == 0 && l == r && left == right && ( lalpha || ralpha ) ) |
4839
|
|
|
|
|
|
{ |
4840
|
|
|
|
|
|
if ( lalpha && !ralpha ) |
4841
|
|
|
|
|
|
{ |
4842
|
|
|
|
|
|
retval = -1; |
4843
|
|
|
|
|
|
} |
4844
|
|
|
|
|
|
else if ( ralpha && !lalpha) |
4845
|
|
|
|
|
|
{ |
4846
|
|
|
|
|
|
retval = +1; |
4847
|
|
|
|
|
|
} |
4848
|
|
|
|
|
|
} |
4849
|
|
|
|
|
|
|
4850
|
|
|
|
|
|
if ( l != r && retval == 0 ) /* possible match except for trailing 0's */ |
4851
|
|
|
|
|
|
{ |
4852
|
|
|
|
|
|
if ( l < r ) |
4853
|
|
|
|
|
|
{ |
4854
|
|
|
|
|
|
while ( i <= r && retval == 0 ) |
4855
|
|
|
|
|
|
{ |
4856
|
|
|
|
|
|
if ( SvIV(*av_fetch(rav,i,0)) != 0 ) |
4857
|
|
|
|
|
|
retval = -1; /* not a match after all */ |
4858
|
|
|
|
|
|
i++; |
4859
|
|
|
|
|
|
} |
4860
|
|
|
|
|
|
} |
4861
|
|
|
|
|
|
else |
4862
|
|
|
|
|
|
{ |
4863
|
|
|
|
|
|
while ( i <= l && retval == 0 ) |
4864
|
|
|
|
|
|
{ |
4865
|
|
|
|
|
|
if ( SvIV(*av_fetch(lav,i,0)) != 0 ) |
4866
|
|
|
|
|
|
retval = +1; /* not a match after all */ |
4867
|
|
|
|
|
|
i++; |
4868
|
|
|
|
|
|
} |
4869
|
|
|
|
|
|
} |
4870
|
|
|
|
|
|
} |
4871
|
|
|
|
|
|
return retval; |
4872
|
|
|
|
|
|
} |
4873
|
|
|
|
|
|
|
4874
|
|
|
|
|
|
#if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT) |
4875
|
|
|
|
|
|
# define EMULATE_SOCKETPAIR_UDP |
4876
|
|
|
|
|
|
#endif |
4877
|
|
|
|
|
|
|
4878
|
|
|
|
|
|
#ifdef EMULATE_SOCKETPAIR_UDP |
4879
|
|
|
|
|
|
static int |
4880
|
|
|
|
|
|
S_socketpair_udp (int fd[2]) { |
4881
|
|
|
|
|
|
dTHX; |
4882
|
|
|
|
|
|
/* Fake a datagram socketpair using UDP to localhost. */ |
4883
|
|
|
|
|
|
int sockets[2] = {-1, -1}; |
4884
|
|
|
|
|
|
struct sockaddr_in addresses[2]; |
4885
|
|
|
|
|
|
int i; |
4886
|
|
|
|
|
|
Sock_size_t size = sizeof(struct sockaddr_in); |
4887
|
|
|
|
|
|
unsigned short port; |
4888
|
|
|
|
|
|
int got; |
4889
|
|
|
|
|
|
|
4890
|
|
|
|
|
|
memset(&addresses, 0, sizeof(addresses)); |
4891
|
|
|
|
|
|
i = 1; |
4892
|
|
|
|
|
|
do { |
4893
|
|
|
|
|
|
sockets[i] = PerlSock_socket(AF_INET, SOCK_DGRAM, PF_INET); |
4894
|
|
|
|
|
|
if (sockets[i] == -1) |
4895
|
|
|
|
|
|
goto tidy_up_and_fail; |
4896
|
|
|
|
|
|
|
4897
|
|
|
|
|
|
addresses[i].sin_family = AF_INET; |
4898
|
|
|
|
|
|
addresses[i].sin_addr.s_addr = htonl(INADDR_LOOPBACK); |
4899
|
|
|
|
|
|
addresses[i].sin_port = 0; /* kernel choses port. */ |
4900
|
|
|
|
|
|
if (PerlSock_bind(sockets[i], (struct sockaddr *) &addresses[i], |
4901
|
|
|
|
|
|
sizeof(struct sockaddr_in)) == -1) |
4902
|
|
|
|
|
|
goto tidy_up_and_fail; |
4903
|
|
|
|
|
|
} while (i--); |
4904
|
|
|
|
|
|
|
4905
|
|
|
|
|
|
/* Now have 2 UDP sockets. Find out which port each is connected to, and |
4906
|
|
|
|
|
|
for each connect the other socket to it. */ |
4907
|
|
|
|
|
|
i = 1; |
4908
|
|
|
|
|
|
do { |
4909
|
|
|
|
|
|
if (PerlSock_getsockname(sockets[i], (struct sockaddr *) &addresses[i], |
4910
|
|
|
|
|
|
&size) == -1) |
4911
|
|
|
|
|
|
goto tidy_up_and_fail; |
4912
|
|
|
|
|
|
if (size != sizeof(struct sockaddr_in)) |
4913
|
|
|
|
|
|
goto abort_tidy_up_and_fail; |
4914
|
|
|
|
|
|
/* !1 is 0, !0 is 1 */ |
4915
|
|
|
|
|
|
if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i], |
4916
|
|
|
|
|
|
sizeof(struct sockaddr_in)) == -1) |
4917
|
|
|
|
|
|
goto tidy_up_and_fail; |
4918
|
|
|
|
|
|
} while (i--); |
4919
|
|
|
|
|
|
|
4920
|
|
|
|
|
|
/* Now we have 2 sockets connected to each other. I don't trust some other |
4921
|
|
|
|
|
|
process not to have already sent a packet to us (by random) so send |
4922
|
|
|
|
|
|
a packet from each to the other. */ |
4923
|
|
|
|
|
|
i = 1; |
4924
|
|
|
|
|
|
do { |
4925
|
|
|
|
|
|
/* I'm going to send my own port number. As a short. |
4926
|
|
|
|
|
|
(Who knows if someone somewhere has sin_port as a bitfield and needs |
4927
|
|
|
|
|
|
this routine. (I'm assuming crays have socketpair)) */ |
4928
|
|
|
|
|
|
port = addresses[i].sin_port; |
4929
|
|
|
|
|
|
got = PerlLIO_write(sockets[i], &port, sizeof(port)); |
4930
|
|
|
|
|
|
if (got != sizeof(port)) { |
4931
|
|
|
|
|
|
if (got == -1) |
4932
|
|
|
|
|
|
goto tidy_up_and_fail; |
4933
|
|
|
|
|
|
goto abort_tidy_up_and_fail; |
4934
|
|
|
|
|
|
} |
4935
|
|
|
|
|
|
} while (i--); |
4936
|
|
|
|
|
|
|
4937
|
|
|
|
|
|
/* Packets sent. I don't trust them to have arrived though. |
4938
|
|
|
|
|
|
(As I understand it Solaris TCP stack is multithreaded. Non-blocking |
4939
|
|
|
|
|
|
connect to localhost will use a second kernel thread. In 2.6 the |
4940
|
|
|
|
|
|
first thread running the connect() returns before the second completes, |
4941
|
|
|
|
|
|
so EINPROGRESS> In 2.7 the improved stack is faster and connect() |
4942
|
|
|
|
|
|
returns 0. Poor programs have tripped up. One poor program's authors' |
4943
|
|
|
|
|
|
had a 50-1 reverse stock split. Not sure how connected these were.) |
4944
|
|
|
|
|
|
So I don't trust someone not to have an unpredictable UDP stack. |
4945
|
|
|
|
|
|
*/ |
4946
|
|
|
|
|
|
|
4947
|
|
|
|
|
|
{ |
4948
|
|
|
|
|
|
struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */ |
4949
|
|
|
|
|
|
int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0]; |
4950
|
|
|
|
|
|
fd_set rset; |
4951
|
|
|
|
|
|
|
4952
|
|
|
|
|
|
FD_ZERO(&rset); |
4953
|
|
|
|
|
|
FD_SET((unsigned int)sockets[0], &rset); |
4954
|
|
|
|
|
|
FD_SET((unsigned int)sockets[1], &rset); |
4955
|
|
|
|
|
|
|
4956
|
|
|
|
|
|
got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor); |
4957
|
|
|
|
|
|
if (got != 2 || !FD_ISSET(sockets[0], &rset) |
4958
|
|
|
|
|
|
|| !FD_ISSET(sockets[1], &rset)) { |
4959
|
|
|
|
|
|
/* I hope this is portable and appropriate. */ |
4960
|
|
|
|
|
|
if (got == -1) |
4961
|
|
|
|
|
|
goto tidy_up_and_fail; |
4962
|
|
|
|
|
|
goto abort_tidy_up_and_fail; |
4963
|
|
|
|
|
|
} |
4964
|
|
|
|
|
|
} |
4965
|
|
|
|
|
|
|
4966
|
|
|
|
|
|
/* And the paranoia department even now doesn't trust it to have arrive |
4967
|
|
|
|
|
|
(hence MSG_DONTWAIT). Or that what arrives was sent by us. */ |
4968
|
|
|
|
|
|
{ |
4969
|
|
|
|
|
|
struct sockaddr_in readfrom; |
4970
|
|
|
|
|
|
unsigned short buffer[2]; |
4971
|
|
|
|
|
|
|
4972
|
|
|
|
|
|
i = 1; |
4973
|
|
|
|
|
|
do { |
4974
|
|
|
|
|
|
#ifdef MSG_DONTWAIT |
4975
|
|
|
|
|
|
got = PerlSock_recvfrom(sockets[i], (char *) &buffer, |
4976
|
|
|
|
|
|
sizeof(buffer), MSG_DONTWAIT, |
4977
|
|
|
|
|
|
(struct sockaddr *) &readfrom, &size); |
4978
|
|
|
|
|
|
#else |
4979
|
|
|
|
|
|
got = PerlSock_recvfrom(sockets[i], (char *) &buffer, |
4980
|
|
|
|
|
|
sizeof(buffer), 0, |
4981
|
|
|
|
|
|
(struct sockaddr *) &readfrom, &size); |
4982
|
|
|
|
|
|
#endif |
4983
|
|
|
|
|
|
|
4984
|
|
|
|
|
|
if (got == -1) |
4985
|
|
|
|
|
|
goto tidy_up_and_fail; |
4986
|
|
|
|
|
|
if (got != sizeof(port) |
4987
|
|
|
|
|
|
|| size != sizeof(struct sockaddr_in) |
4988
|
|
|
|
|
|
/* Check other socket sent us its port. */ |
4989
|
|
|
|
|
|
|| buffer[0] != (unsigned short) addresses[!i].sin_port |
4990
|
|
|
|
|
|
/* Check kernel says we got the datagram from that socket */ |
4991
|
|
|
|
|
|
|| readfrom.sin_family != addresses[!i].sin_family |
4992
|
|
|
|
|
|
|| readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr |
4993
|
|
|
|
|
|
|| readfrom.sin_port != addresses[!i].sin_port) |
4994
|
|
|
|
|
|
goto abort_tidy_up_and_fail; |
4995
|
|
|
|
|
|
} while (i--); |
4996
|
|
|
|
|
|
} |
4997
|
|
|
|
|
|
/* My caller (my_socketpair) has validated that this is non-NULL */ |
4998
|
|
|
|
|
|
fd[0] = sockets[0]; |
4999
|
|
|
|
|
|
fd[1] = sockets[1]; |
5000
|
|
|
|
|
|
/* I hereby declare this connection open. May God bless all who cross |
5001
|
|
|
|
|
|
her. */ |
5002
|
|
|
|
|
|
return 0; |
5003
|
|
|
|
|
|
|
5004
|
|
|
|
|
|
abort_tidy_up_and_fail: |
5005
|
|
|
|
|
|
errno = ECONNABORTED; |
5006
|
|
|
|
|
|
tidy_up_and_fail: |
5007
|
|
|
|
|
|
{ |
5008
|
|
|
|
|
|
dSAVE_ERRNO; |
5009
|
|
|
|
|
|
if (sockets[0] != -1) |
5010
|
|
|
|
|
|
PerlLIO_close(sockets[0]); |
5011
|
|
|
|
|
|
if (sockets[1] != -1) |
5012
|
|
|
|
|
|
PerlLIO_close(sockets[1]); |
5013
|
|
|
|
|
|
RESTORE_ERRNO; |
5014
|
|
|
|
|
|
return -1; |
5015
|
|
|
|
|
|
} |
5016
|
|
|
|
|
|
} |
5017
|
|
|
|
|
|
#endif /* EMULATE_SOCKETPAIR_UDP */ |
5018
|
|
|
|
|
|
|
5019
|
|
|
|
|
|
#if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) |
5020
|
|
|
|
|
|
int |
5021
|
|
|
|
|
|
Perl_my_socketpair (int family, int type, int protocol, int fd[2]) { |
5022
|
|
|
|
|
|
/* Stevens says that family must be AF_LOCAL, protocol 0. |
5023
|
|
|
|
|
|
I'm going to enforce that, then ignore it, and use TCP (or UDP). */ |
5024
|
|
|
|
|
|
dTHXa(NULL); |
5025
|
|
|
|
|
|
int listener = -1; |
5026
|
|
|
|
|
|
int connector = -1; |
5027
|
|
|
|
|
|
int acceptor = -1; |
5028
|
|
|
|
|
|
struct sockaddr_in listen_addr; |
5029
|
|
|
|
|
|
struct sockaddr_in connect_addr; |
5030
|
|
|
|
|
|
Sock_size_t size; |
5031
|
|
|
|
|
|
|
5032
|
|
|
|
|
|
if (protocol |
5033
|
|
|
|
|
|
#ifdef AF_UNIX |
5034
|
|
|
|
|
|
|| family != AF_UNIX |
5035
|
|
|
|
|
|
#endif |
5036
|
|
|
|
|
|
) { |
5037
|
|
|
|
|
|
errno = EAFNOSUPPORT; |
5038
|
|
|
|
|
|
return -1; |
5039
|
|
|
|
|
|
} |
5040
|
|
|
|
|
|
if (!fd) { |
5041
|
|
|
|
|
|
errno = EINVAL; |
5042
|
|
|
|
|
|
return -1; |
5043
|
|
|
|
|
|
} |
5044
|
|
|
|
|
|
|
5045
|
|
|
|
|
|
#ifdef EMULATE_SOCKETPAIR_UDP |
5046
|
|
|
|
|
|
if (type == SOCK_DGRAM) |
5047
|
|
|
|
|
|
return S_socketpair_udp(fd); |
5048
|
|
|
|
|
|
#endif |
5049
|
|
|
|
|
|
|
5050
|
|
|
|
|
|
aTHXa(PERL_GET_THX); |
5051
|
|
|
|
|
|
listener = PerlSock_socket(AF_INET, type, 0); |
5052
|
|
|
|
|
|
if (listener == -1) |
5053
|
|
|
|
|
|
return -1; |
5054
|
|
|
|
|
|
memset(&listen_addr, 0, sizeof(listen_addr)); |
5055
|
|
|
|
|
|
listen_addr.sin_family = AF_INET; |
5056
|
|
|
|
|
|
listen_addr.sin_addr.s_addr = htonl(INADDR_LOOPBACK); |
5057
|
|
|
|
|
|
listen_addr.sin_port = 0; /* kernel choses port. */ |
5058
|
|
|
|
|
|
if (PerlSock_bind(listener, (struct sockaddr *) &listen_addr, |
5059
|
|
|
|
|
|
sizeof(listen_addr)) == -1) |
5060
|
|
|
|
|
|
goto tidy_up_and_fail; |
5061
|
|
|
|
|
|
if (PerlSock_listen(listener, 1) == -1) |
5062
|
|
|
|
|
|
goto tidy_up_and_fail; |
5063
|
|
|
|
|
|
|
5064
|
|
|
|
|
|
connector = PerlSock_socket(AF_INET, type, 0); |
5065
|
|
|
|
|
|
if (connector == -1) |
5066
|
|
|
|
|
|
goto tidy_up_and_fail; |
5067
|
|
|
|
|
|
/* We want to find out the port number to connect to. */ |
5068
|
|
|
|
|
|
size = sizeof(connect_addr); |
5069
|
|
|
|
|
|
if (PerlSock_getsockname(listener, (struct sockaddr *) &connect_addr, |
5070
|
|
|
|
|
|
&size) == -1) |
5071
|
|
|
|
|
|
goto tidy_up_and_fail; |
5072
|
|
|
|
|
|
if (size != sizeof(connect_addr)) |
5073
|
|
|
|
|
|
goto abort_tidy_up_and_fail; |
5074
|
|
|
|
|
|
if (PerlSock_connect(connector, (struct sockaddr *) &connect_addr, |
5075
|
|
|
|
|
|
sizeof(connect_addr)) == -1) |
5076
|
|
|
|
|
|
goto tidy_up_and_fail; |
5077
|
|
|
|
|
|
|
5078
|
|
|
|
|
|
size = sizeof(listen_addr); |
5079
|
|
|
|
|
|
acceptor = PerlSock_accept(listener, (struct sockaddr *) &listen_addr, |
5080
|
|
|
|
|
|
&size); |
5081
|
|
|
|
|
|
if (acceptor == -1) |
5082
|
|
|
|
|
|
goto tidy_up_and_fail; |
5083
|
|
|
|
|
|
if (size != sizeof(listen_addr)) |
5084
|
|
|
|
|
|
goto abort_tidy_up_and_fail; |
5085
|
|
|
|
|
|
PerlLIO_close(listener); |
5086
|
|
|
|
|
|
/* Now check we are talking to ourself by matching port and host on the |
5087
|
|
|
|
|
|
two sockets. */ |
5088
|
|
|
|
|
|
if (PerlSock_getsockname(connector, (struct sockaddr *) &connect_addr, |
5089
|
|
|
|
|
|
&size) == -1) |
5090
|
|
|
|
|
|
goto tidy_up_and_fail; |
5091
|
|
|
|
|
|
if (size != sizeof(connect_addr) |
5092
|
|
|
|
|
|
|| listen_addr.sin_family != connect_addr.sin_family |
5093
|
|
|
|
|
|
|| listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr |
5094
|
|
|
|
|
|
|| listen_addr.sin_port != connect_addr.sin_port) { |
5095
|
|
|
|
|
|
goto abort_tidy_up_and_fail; |
5096
|
|
|
|
|
|
} |
5097
|
|
|
|
|
|
fd[0] = connector; |
5098
|
|
|
|
|
|
fd[1] = acceptor; |
5099
|
|
|
|
|
|
return 0; |
5100
|
|
|
|
|
|
|
5101
|
|
|
|
|
|
abort_tidy_up_and_fail: |
5102
|
|
|
|
|
|
#ifdef ECONNABORTED |
5103
|
|
|
|
|
|
errno = ECONNABORTED; /* This would be the standard thing to do. */ |
5104
|
|
|
|
|
|
#else |
5105
|
|
|
|
|
|
# ifdef ECONNREFUSED |
5106
|
|
|
|
|
|
errno = ECONNREFUSED; /* E.g. Symbian does not have ECONNABORTED. */ |
5107
|
|
|
|
|
|
# else |
5108
|
|
|
|
|
|
errno = ETIMEDOUT; /* Desperation time. */ |
5109
|
|
|
|
|
|
# endif |
5110
|
|
|
|
|
|
#endif |
5111
|
|
|
|
|
|
tidy_up_and_fail: |
5112
|
|
|
|
|
|
{ |
5113
|
|
|
|
|
|
dSAVE_ERRNO; |
5114
|
|
|
|
|
|
if (listener != -1) |
5115
|
|
|
|
|
|
PerlLIO_close(listener); |
5116
|
|
|
|
|
|
if (connector != -1) |
5117
|
|
|
|
|
|
PerlLIO_close(connector); |
5118
|
|
|
|
|
|
if (acceptor != -1) |
5119
|
|
|
|
|
|
PerlLIO_close(acceptor); |
5120
|
|
|
|
|
|
RESTORE_ERRNO; |
5121
|
|
|
|
|
|
return -1; |
5122
|
|
|
|
|
|
} |
5123
|
|
|
|
|
|
} |
5124
|
|
|
|
|
|
#else |
5125
|
|
|
|
|
|
/* In any case have a stub so that there's code corresponding |
5126
|
|
|
|
|
|
* to the my_socketpair in embed.fnc. */ |
5127
|
|
|
|
|
|
int |
5128
|
|
|
|
|
|
Perl_my_socketpair (int family, int type, int protocol, int fd[2]) { |
5129
|
|
|
|
|
|
#ifdef HAS_SOCKETPAIR |
5130
|
|
|
|
|
|
return socketpair(family, type, protocol, fd); |
5131
|
|
|
|
|
|
#else |
5132
|
|
|
|
|
|
return -1; |
5133
|
|
|
|
|
|
#endif |
5134
|
|
|
|
|
|
} |
5135
|
|
|
|
|
|
#endif |
5136
|
|
|
|
|
|
|
5137
|
|
|
|
|
|
/* |
5138
|
|
|
|
|
|
|
5139
|
|
|
|
|
|
=for apidoc sv_nosharing |
5140
|
|
|
|
|
|
|
5141
|
|
|
|
|
|
Dummy routine which "shares" an SV when there is no sharing module present. |
5142
|
|
|
|
|
|
Or "locks" it. Or "unlocks" it. In other words, ignores its single SV argument. |
5143
|
|
|
|
|
|
Exists to avoid test for a NULL function pointer and because it could |
5144
|
|
|
|
|
|
potentially warn under some level of strict-ness. |
5145
|
|
|
|
|
|
|
5146
|
|
|
|
|
|
=cut |
5147
|
|
|
|
|
|
*/ |
5148
|
|
|
|
|
|
|
5149
|
|
|
|
|
|
void |
5150
|
|
|
|
|
|
Perl_sv_nosharing(pTHX_ SV *sv) |
5151
|
|
|
|
|
|
{ |
5152
|
|
|
|
|
|
PERL_UNUSED_CONTEXT; |
5153
|
|
|
|
|
|
PERL_UNUSED_ARG(sv); |
5154
|
|
|
|
|
|
} |
5155
|
|
|
|
|
|
|
5156
|
|
|
|
|
|
/* |
5157
|
|
|
|
|
|
|
5158
|
|
|
|
|
|
=for apidoc sv_destroyable |
5159
|
|
|
|
|
|
|
5160
|
|
|
|
|
|
Dummy routine which reports that object can be destroyed when there is no |
5161
|
|
|
|
|
|
sharing module present. It ignores its single SV argument, and returns |
5162
|
|
|
|
|
|
'true'. Exists to avoid test for a NULL function pointer and because it |
5163
|
|
|
|
|
|
could potentially warn under some level of strict-ness. |
5164
|
|
|
|
|
|
|
5165
|
|
|
|
|
|
=cut |
5166
|
|
|
|
|
|
*/ |
5167
|
|
|
|
|
|
|
5168
|
|
|
|
|
|
bool |
5169
|
|
|
|
|
|
Perl_sv_destroyable(pTHX_ SV *sv) |
5170
|
|
|
|
|
|
{ |
5171
|
|
|
|
|
|
PERL_UNUSED_CONTEXT; |
5172
|
|
|
|
|
|
PERL_UNUSED_ARG(sv); |
5173
|
|
|
|
|
|
return TRUE; |
5174
|
|
|
|
|
|
} |
5175
|
|
|
|
|
|
|
5176
|
|
|
|
|
|
U32 |
5177
|
|
|
|
|
|
Perl_parse_unicode_opts(pTHX_ const char **popt) |
5178
|
|
|
|
|
|
{ |
5179
|
|
|
|
|
|
const char *p = *popt; |
5180
|
|
|
|
|
|
U32 opt = 0; |
5181
|
|
|
|
|
|
|
5182
|
|
|
|
|
|
PERL_ARGS_ASSERT_PARSE_UNICODE_OPTS; |
5183
|
|
|
|
|
|
|
5184
|
|
|
|
|
|
if (*p) { |
5185
|
|
|
|
|
|
if (isDIGIT(*p)) { |
5186
|
|
|
|
|
|
opt = (U32) atoi(p); |
5187
|
|
|
|
|
|
while (isDIGIT(*p)) |
5188
|
|
|
|
|
|
p++; |
5189
|
|
|
|
|
|
if (*p && *p != '\n' && *p != '\r') { |
5190
|
|
|
|
|
|
if(isSPACE(*p)) goto the_end_of_the_opts_parser; |
5191
|
|
|
|
|
|
else |
5192
|
|
|
|
|
|
Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p); |
5193
|
|
|
|
|
|
} |
5194
|
|
|
|
|
|
} |
5195
|
|
|
|
|
|
else { |
5196
|
|
|
|
|
|
for (; *p; p++) { |
5197
|
|
|
|
|
|
switch (*p) { |
5198
|
|
|
|
|
|
case PERL_UNICODE_STDIN: |
5199
|
|
|
|
|
|
opt |= PERL_UNICODE_STDIN_FLAG; break; |
5200
|
|
|
|
|
|
case PERL_UNICODE_STDOUT: |
5201
|
|
|
|
|
|
opt |= PERL_UNICODE_STDOUT_FLAG; break; |
5202
|
|
|
|
|
|
case PERL_UNICODE_STDERR: |
5203
|
|
|
|
|
|
opt |= PERL_UNICODE_STDERR_FLAG; break; |
5204
|
|
|
|
|
|
case PERL_UNICODE_STD: |
5205
|
|
|
|
|
|
opt |= PERL_UNICODE_STD_FLAG; break; |
5206
|
|
|
|
|
|
case PERL_UNICODE_IN: |
5207
|
|
|
|
|
|
opt |= PERL_UNICODE_IN_FLAG; break; |
5208
|
|
|
|
|
|
case PERL_UNICODE_OUT: |
5209
|
|
|
|
|
|
opt |= PERL_UNICODE_OUT_FLAG; break; |
5210
|
|
|
|
|
|
case PERL_UNICODE_INOUT: |
5211
|
|
|
|
|
|
opt |= PERL_UNICODE_INOUT_FLAG; break; |
5212
|
|
|
|
|
|
case PERL_UNICODE_LOCALE: |
5213
|
|
|
|
|
|
opt |= PERL_UNICODE_LOCALE_FLAG; break; |
5214
|
|
|
|
|
|
case PERL_UNICODE_ARGV: |
5215
|
|
|
|
|
|
opt |= PERL_UNICODE_ARGV_FLAG; break; |
5216
|
|
|
|
|
|
case PERL_UNICODE_UTF8CACHEASSERT: |
5217
|
|
|
|
|
|
opt |= PERL_UNICODE_UTF8CACHEASSERT_FLAG; break; |
5218
|
|
|
|
|
|
default: |
5219
|
|
|
|
|
|
if (*p != '\n' && *p != '\r') { |
5220
|
|
|
|
|
|
if(isSPACE(*p)) goto the_end_of_the_opts_parser; |
5221
|
|
|
|
|
|
else |
5222
|
|
|
|
|
|
Perl_croak(aTHX_ |
5223
|
|
|
|
|
|
"Unknown Unicode option letter '%c'", *p); |
5224
|
|
|
|
|
|
} |
5225
|
|
|
|
|
|
} |
5226
|
|
|
|
|
|
} |
5227
|
|
|
|
|
|
} |
5228
|
|
|
|
|
|
} |
5229
|
|
|
|
|
|
else |
5230
|
|
|
|
|
|
opt = PERL_UNICODE_DEFAULT_FLAGS; |
5231
|
|
|
|
|
|
|
5232
|
|
|
|
|
|
the_end_of_the_opts_parser: |
5233
|
|
|
|
|
|
|
5234
|
|
|
|
|
|
if (opt & ~PERL_UNICODE_ALL_FLAGS) |
5235
|
|
|
|
|
|
Perl_croak(aTHX_ "Unknown Unicode option value %"UVuf, |
5236
|
|
|
|
|
|
(UV) (opt & ~PERL_UNICODE_ALL_FLAGS)); |
5237
|
|
|
|
|
|
|
5238
|
|
|
|
|
|
*popt = p; |
5239
|
|
|
|
|
|
|
5240
|
|
|
|
|
|
return opt; |
5241
|
|
|
|
|
|
} |
5242
|
|
|
|
|
|
|
5243
|
|
|
|
|
|
#ifdef VMS |
5244
|
|
|
|
|
|
# include |
5245
|
|
|
|
|
|
#endif |
5246
|
|
|
|
|
|
|
5247
|
|
|
|
|
|
U32 |
5248
|
|
|
|
|
|
Perl_seed(pTHX) |
5249
|
|
|
|
|
|
{ |
5250
|
|
|
|
|
|
dVAR; |
5251
|
|
|
|
|
|
/* |
5252
|
|
|
|
|
|
* This is really just a quick hack which grabs various garbage |
5253
|
|
|
|
|
|
* values. It really should be a real hash algorithm which |
5254
|
|
|
|
|
|
* spreads the effect of every input bit onto every output bit, |
5255
|
|
|
|
|
|
* if someone who knows about such things would bother to write it. |
5256
|
|
|
|
|
|
* Might be a good idea to add that function to CORE as well. |
5257
|
|
|
|
|
|
* No numbers below come from careful analysis or anything here, |
5258
|
|
|
|
|
|
* except they are primes and SEED_C1 > 1E6 to get a full-width |
5259
|
|
|
|
|
|
* value from (tv_sec * SEED_C1 + tv_usec). The multipliers should |
5260
|
|
|
|
|
|
* probably be bigger too. |
5261
|
|
|
|
|
|
*/ |
5262
|
|
|
|
|
|
#if RANDBITS > 16 |
5263
|
|
|
|
|
|
# define SEED_C1 1000003 |
5264
|
|
|
|
|
|
#define SEED_C4 73819 |
5265
|
|
|
|
|
|
#else |
5266
|
|
|
|
|
|
# define SEED_C1 25747 |
5267
|
|
|
|
|
|
#define SEED_C4 20639 |
5268
|
|
|
|
|
|
#endif |
5269
|
|
|
|
|
|
#define SEED_C2 3 |
5270
|
|
|
|
|
|
#define SEED_C3 269 |
5271
|
|
|
|
|
|
#define SEED_C5 26107 |
5272
|
|
|
|
|
|
|
5273
|
|
|
|
|
|
#ifndef PERL_NO_DEV_RANDOM |
5274
|
|
|
|
|
|
int fd; |
5275
|
|
|
|
|
|
#endif |
5276
|
|
|
|
|
|
U32 u; |
5277
|
|
|
|
|
|
#ifdef VMS |
5278
|
|
|
|
|
|
/* when[] = (low 32 bits, high 32 bits) of time since epoch |
5279
|
|
|
|
|
|
* in 100-ns units, typically incremented ever 10 ms. */ |
5280
|
|
|
|
|
|
unsigned int when[2]; |
5281
|
|
|
|
|
|
#else |
5282
|
|
|
|
|
|
# ifdef HAS_GETTIMEOFDAY |
5283
|
|
|
|
|
|
struct timeval when; |
5284
|
|
|
|
|
|
# else |
5285
|
|
|
|
|
|
Time_t when; |
5286
|
|
|
|
|
|
# endif |
5287
|
|
|
|
|
|
#endif |
5288
|
|
|
|
|
|
|
5289
|
|
|
|
|
|
/* This test is an escape hatch, this symbol isn't set by Configure. */ |
5290
|
|
|
|
|
|
#ifndef PERL_NO_DEV_RANDOM |
5291
|
|
|
|
|
|
#ifndef PERL_RANDOM_DEVICE |
5292
|
|
|
|
|
|
/* /dev/random isn't used by default because reads from it will block |
5293
|
|
|
|
|
|
* if there isn't enough entropy available. You can compile with |
5294
|
|
|
|
|
|
* PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there |
5295
|
|
|
|
|
|
* is enough real entropy to fill the seed. */ |
5296
|
|
|
|
|
|
# define PERL_RANDOM_DEVICE "/dev/urandom" |
5297
|
|
|
|
|
|
#endif |
5298
|
|
|
|
|
|
fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0); |
5299
|
|
|
|
|
|
if (fd != -1) { |
5300
|
|
|
|
|
|
if (PerlLIO_read(fd, (void*)&u, sizeof u) != sizeof u) |
5301
|
|
|
|
|
|
u = 0; |
5302
|
|
|
|
|
|
PerlLIO_close(fd); |
5303
|
|
|
|
|
|
if (u) |
5304
|
|
|
|
|
|
return u; |
5305
|
|
|
|
|
|
} |
5306
|
|
|
|
|
|
#endif |
5307
|
|
|
|
|
|
|
5308
|
|
|
|
|
|
#ifdef VMS |
5309
|
|
|
|
|
|
_ckvmssts(sys$gettim(when)); |
5310
|
|
|
|
|
|
u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1]; |
5311
|
|
|
|
|
|
#else |
5312
|
|
|
|
|
|
# ifdef HAS_GETTIMEOFDAY |
5313
|
|
|
|
|
|
PerlProc_gettimeofday(&when,NULL); |
5314
|
|
|
|
|
|
u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec; |
5315
|
|
|
|
|
|
# else |
5316
|
|
|
|
|
|
(void)time(&when); |
5317
|
|
|
|
|
|
u = (U32)SEED_C1 * when; |
5318
|
|
|
|
|
|
# endif |
5319
|
|
|
|
|
|
#endif |
5320
|
|
|
|
|
|
u += SEED_C3 * (U32)PerlProc_getpid(); |
5321
|
|
|
|
|
|
u += SEED_C4 * (U32)PTR2UV(PL_stack_sp); |
5322
|
|
|
|
|
|
#ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */ |
5323
|
|
|
|
|
|
u += SEED_C5 * (U32)PTR2UV(&when); |
5324
|
|
|
|
|
|
#endif |
5325
|
|
|
|
|
|
return u; |
5326
|
|
|
|
|
|
} |
5327
|
|
|
|
|
|
|
5328
|
|
|
|
|
|
void |
5329
|
|
|
|
|
|
Perl_get_hash_seed(pTHX_ unsigned char * const seed_buffer) |
5330
|
|
|
|
|
|
{ |
5331
|
|
|
|
|
|
dVAR; |
5332
|
|
|
|
|
|
const char *env_pv; |
5333
|
|
|
|
|
|
unsigned long i; |
5334
|
|
|
|
|
|
|
5335
|
|
|
|
|
|
PERL_ARGS_ASSERT_GET_HASH_SEED; |
5336
|
|
|
|
|
|
|
5337
|
|
|
|
|
|
env_pv= PerlEnv_getenv("PERL_HASH_SEED"); |
5338
|
|
|
|
|
|
|
5339
|
|
|
|
|
|
if ( env_pv ) |
5340
|
|
|
|
|
|
#ifndef USE_HASH_SEED_EXPLICIT |
5341
|
|
|
|
|
|
{ |
5342
|
|
|
|
|
|
/* ignore leading spaces */ |
5343
|
|
|
|
|
|
while (isSPACE(*env_pv)) |
5344
|
|
|
|
|
|
env_pv++; |
5345
|
|
|
|
|
|
#ifdef USE_PERL_PERTURB_KEYS |
5346
|
|
|
|
|
|
/* if they set it to "0" we disable key traversal randomization completely */ |
5347
|
|
|
|
|
|
if (strEQ(env_pv,"0")) { |
5348
|
|
|
|
|
|
PL_hash_rand_bits_enabled= 0; |
5349
|
|
|
|
|
|
} else { |
5350
|
|
|
|
|
|
/* otherwise switch to deterministic mode */ |
5351
|
|
|
|
|
|
PL_hash_rand_bits_enabled= 2; |
5352
|
|
|
|
|
|
} |
5353
|
|
|
|
|
|
#endif |
5354
|
|
|
|
|
|
/* ignore a leading 0x... if it is there */ |
5355
|
|
|
|
|
|
if (env_pv[0] == '0' && env_pv[1] == 'x') |
5356
|
|
|
|
|
|
env_pv += 2; |
5357
|
|
|
|
|
|
|
5358
|
|
|
|
|
|
for( i = 0; isXDIGIT(*env_pv) && i < PERL_HASH_SEED_BYTES; i++ ) { |
5359
|
|
|
|
|
|
seed_buffer[i] = READ_XDIGIT(env_pv) << 4; |
5360
|
|
|
|
|
|
if ( isXDIGIT(*env_pv)) { |
5361
|
|
|
|
|
|
seed_buffer[i] |= READ_XDIGIT(env_pv); |
5362
|
|
|
|
|
|
} |
5363
|
|
|
|
|
|
} |
5364
|
|
|
|
|
|
while (isSPACE(*env_pv)) |
5365
|
|
|
|
|
|
env_pv++; |
5366
|
|
|
|
|
|
|
5367
|
|
|
|
|
|
if (*env_pv && !isXDIGIT(*env_pv)) { |
5368
|
|
|
|
|
|
Perl_warn(aTHX_ "perl: warning: Non hex character in '$ENV{PERL_HASH_SEED}', seed only partially set\n"); |
5369
|
|
|
|
|
|
} |
5370
|
|
|
|
|
|
/* should we check for unparsed crap? */ |
5371
|
|
|
|
|
|
/* should we warn about unused hex? */ |
5372
|
|
|
|
|
|
/* should we warn about insufficient hex? */ |
5373
|
|
|
|
|
|
} |
5374
|
|
|
|
|
|
else |
5375
|
|
|
|
|
|
#endif |
5376
|
|
|
|
|
|
{ |
5377
|
|
|
|
|
|
(void)seedDrand01((Rand_seed_t)seed()); |
5378
|
|
|
|
|
|
|
5379
|
|
|
|
|
|
for( i = 0; i < PERL_HASH_SEED_BYTES; i++ ) { |
5380
|
|
|
|
|
|
seed_buffer[i] = (unsigned char)(Drand01() * (U8_MAX+1)); |
5381
|
|
|
|
|
|
} |
5382
|
|
|
|
|
|
} |
5383
|
|
|
|
|
|
#ifdef USE_PERL_PERTURB_KEYS |
5384
|
|
|
|
|
|
{ /* initialize PL_hash_rand_bits from the hash seed. |
5385
|
|
|
|
|
|
* This value is highly volatile, it is updated every |
5386
|
|
|
|
|
|
* hash insert, and is used as part of hash bucket chain |
5387
|
|
|
|
|
|
* randomization and hash iterator randomization. */ |
5388
|
|
|
|
|
|
PL_hash_rand_bits= 0xbe49d17f; /* I just picked a number */ |
5389
|
|
|
|
|
|
for( i = 0; i < sizeof(UV) ; i++ ) { |
5390
|
|
|
|
|
|
PL_hash_rand_bits += seed_buffer[i % PERL_HASH_SEED_BYTES]; |
5391
|
|
|
|
|
|
PL_hash_rand_bits = ROTL_UV(PL_hash_rand_bits,8); |
5392
|
|
|
|
|
|
} |
5393
|
|
|
|
|
|
} |
5394
|
|
|
|
|
|
env_pv= PerlEnv_getenv("PERL_PERTURB_KEYS"); |
5395
|
|
|
|
|
|
if (env_pv) { |
5396
|
|
|
|
|
|
if (strEQ(env_pv,"0") || strEQ(env_pv,"NO")) { |
5397
|
|
|
|
|
|
PL_hash_rand_bits_enabled= 0; |
5398
|
|
|
|
|
|
} else if (strEQ(env_pv,"1") || strEQ(env_pv,"RANDOM")) { |
5399
|
|
|
|
|
|
PL_hash_rand_bits_enabled= 1; |
5400
|
|
|
|
|
|
} else if (strEQ(env_pv,"2") || strEQ(env_pv,"DETERMINISTIC")) { |
5401
|
|
|
|
|
|
PL_hash_rand_bits_enabled= 2; |
5402
|
|
|
|
|
|
} else { |
5403
|
|
|
|
|
|
Perl_warn(aTHX_ "perl: warning: strange setting in '$ENV{PERL_PERTURB_KEYS}': '%s'\n", env_pv); |
5404
|
|
|
|
|
|
} |
5405
|
|
|
|
|
|
} |
5406
|
|
|
|
|
|
#endif |
5407
|
|
|
|
|
|
} |
5408
|
|
|
|
|
|
|
5409
|
|
|
|
|
|
#ifdef PERL_GLOBAL_STRUCT |
5410
|
|
|
|
|
|
|
5411
|
|
|
|
|
|
#define PERL_GLOBAL_STRUCT_INIT |
5412
|
|
|
|
|
|
#include "opcode.h" /* the ppaddr and check */ |
5413
|
|
|
|
|
|
|
5414
|
|
|
|
|
|
struct perl_vars * |
5415
|
|
|
|
|
|
Perl_init_global_struct(pTHX) |
5416
|
|
|
|
|
|
{ |
5417
|
|
|
|
|
|
struct perl_vars *plvarsp = NULL; |
5418
|
|
|
|
|
|
# ifdef PERL_GLOBAL_STRUCT |
5419
|
|
|
|
|
|
const IV nppaddr = sizeof(Gppaddr)/sizeof(Perl_ppaddr_t); |
5420
|
|
|
|
|
|
const IV ncheck = sizeof(Gcheck) /sizeof(Perl_check_t); |
5421
|
|
|
|
|
|
# ifdef PERL_GLOBAL_STRUCT_PRIVATE |
5422
|
|
|
|
|
|
/* PerlMem_malloc() because can't use even safesysmalloc() this early. */ |
5423
|
|
|
|
|
|
plvarsp = (struct perl_vars*)PerlMem_malloc(sizeof(struct perl_vars)); |
5424
|
|
|
|
|
|
if (!plvarsp) |
5425
|
|
|
|
|
|
exit(1); |
5426
|
|
|
|
|
|
# else |
5427
|
|
|
|
|
|
plvarsp = PL_VarsPtr; |
5428
|
|
|
|
|
|
# endif /* PERL_GLOBAL_STRUCT_PRIVATE */ |
5429
|
|
|
|
|
|
# undef PERLVAR |
5430
|
|
|
|
|
|
# undef PERLVARA |
5431
|
|
|
|
|
|
# undef PERLVARI |
5432
|
|
|
|
|
|
# undef PERLVARIC |
5433
|
|
|
|
|
|
# define PERLVAR(prefix,var,type) /**/ |
5434
|
|
|
|
|
|
# define PERLVARA(prefix,var,n,type) /**/ |
5435
|
|
|
|
|
|
# define PERLVARI(prefix,var,type,init) plvarsp->prefix##var = init; |
5436
|
|
|
|
|
|
# define PERLVARIC(prefix,var,type,init) plvarsp->prefix##var = init; |
5437
|
|
|
|
|
|
# include "perlvars.h" |
5438
|
|
|
|
|
|
# undef PERLVAR |
5439
|
|
|
|
|
|
# undef PERLVARA |
5440
|
|
|
|
|
|
# undef PERLVARI |
5441
|
|
|
|
|
|
# undef PERLVARIC |
5442
|
|
|
|
|
|
# ifdef PERL_GLOBAL_STRUCT |
5443
|
|
|
|
|
|
plvarsp->Gppaddr = |
5444
|
|
|
|
|
|
(Perl_ppaddr_t*) |
5445
|
|
|
|
|
|
PerlMem_malloc(nppaddr * sizeof(Perl_ppaddr_t)); |
5446
|
|
|
|
|
|
if (!plvarsp->Gppaddr) |
5447
|
|
|
|
|
|
exit(1); |
5448
|
|
|
|
|
|
plvarsp->Gcheck = |
5449
|
|
|
|
|
|
(Perl_check_t*) |
5450
|
|
|
|
|
|
PerlMem_malloc(ncheck * sizeof(Perl_check_t)); |
5451
|
|
|
|
|
|
if (!plvarsp->Gcheck) |
5452
|
|
|
|
|
|
exit(1); |
5453
|
|
|
|
|
|
Copy(Gppaddr, plvarsp->Gppaddr, nppaddr, Perl_ppaddr_t); |
5454
|
|
|
|
|
|
Copy(Gcheck, plvarsp->Gcheck, ncheck, Perl_check_t); |
5455
|
|
|
|
|
|
# endif |
5456
|
|
|
|
|
|
# ifdef PERL_SET_VARS |
5457
|
|
|
|
|
|
PERL_SET_VARS(plvarsp); |
5458
|
|
|
|
|
|
# endif |
5459
|
|
|
|
|
|
# ifdef PERL_GLOBAL_STRUCT_PRIVATE |
5460
|
|
|
|
|
|
plvarsp->Gsv_placeholder.sv_flags = 0; |
5461
|
|
|
|
|
|
memset(plvarsp->Ghash_seed, 0, sizeof(plvarsp->Ghash_seed)); |
5462
|
|
|
|
|
|
# endif |
5463
|
|
|
|
|
|
# undef PERL_GLOBAL_STRUCT_INIT |
5464
|
|
|
|
|
|
# endif |
5465
|
|
|
|
|
|
return plvarsp; |
5466
|
|
|
|
|
|
} |
5467
|
|
|
|
|
|
|
5468
|
|
|
|
|
|
#endif /* PERL_GLOBAL_STRUCT */ |
5469
|
|
|
|
|
|
|
5470
|
|
|
|
|
|
#ifdef PERL_GLOBAL_STRUCT |
5471
|
|
|
|
|
|
|
5472
|
|
|
|
|
|
void |
5473
|
|
|
|
|
|
Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp) |
5474
|
|
|
|
|
|
{ |
5475
|
|
|
|
|
|
PERL_ARGS_ASSERT_FREE_GLOBAL_STRUCT; |
5476
|
|
|
|
|
|
# ifdef PERL_GLOBAL_STRUCT |
5477
|
|
|
|
|
|
# ifdef PERL_UNSET_VARS |
5478
|
|
|
|
|
|
PERL_UNSET_VARS(plvarsp); |
5479
|
|
|
|
|
|
# endif |
5480
|
|
|
|
|
|
free(plvarsp->Gppaddr); |
5481
|
|
|
|
|
|
free(plvarsp->Gcheck); |
5482
|
|
|
|
|
|
# ifdef PERL_GLOBAL_STRUCT_PRIVATE |
5483
|
|
|
|
|
|
free(plvarsp); |
5484
|
|
|
|
|
|
# endif |
5485
|
|
|
|
|
|
# endif |
5486
|
|
|
|
|
|
} |
5487
|
|
|
|
|
|
|
5488
|
|
|
|
|
|
#endif /* PERL_GLOBAL_STRUCT */ |
5489
|
|
|
|
|
|
|
5490
|
|
|
|
|
|
#ifdef PERL_MEM_LOG |
5491
|
|
|
|
|
|
|
5492
|
|
|
|
|
|
/* -DPERL_MEM_LOG: the Perl_mem_log_..() is compiled, including the |
5493
|
|
|
|
|
|
* the default implementation, unless -DPERL_MEM_LOG_NOIMPL is also |
5494
|
|
|
|
|
|
* given, and you supply your own implementation. |
5495
|
|
|
|
|
|
* |
5496
|
|
|
|
|
|
* The default implementation reads a single env var, PERL_MEM_LOG, |
5497
|
|
|
|
|
|
* expecting one or more of the following: |
5498
|
|
|
|
|
|
* |
5499
|
|
|
|
|
|
* \d+ - fd fd to write to : must be 1st (atoi) |
5500
|
|
|
|
|
|
* 'm' - memlog was PERL_MEM_LOG=1 |
5501
|
|
|
|
|
|
* 's' - svlog was PERL_SV_LOG=1 |
5502
|
|
|
|
|
|
* 't' - timestamp was PERL_MEM_LOG_TIMESTAMP=1 |
5503
|
|
|
|
|
|
* |
5504
|
|
|
|
|
|
* This makes the logger controllable enough that it can reasonably be |
5505
|
|
|
|
|
|
* added to the system perl. |
5506
|
|
|
|
|
|
*/ |
5507
|
|
|
|
|
|
|
5508
|
|
|
|
|
|
/* -DPERL_MEM_LOG_SPRINTF_BUF_SIZE=X: size of a (stack-allocated) buffer |
5509
|
|
|
|
|
|
* the Perl_mem_log_...() will use (either via sprintf or snprintf). |
5510
|
|
|
|
|
|
*/ |
5511
|
|
|
|
|
|
#define PERL_MEM_LOG_SPRINTF_BUF_SIZE 128 |
5512
|
|
|
|
|
|
|
5513
|
|
|
|
|
|
/* -DPERL_MEM_LOG_FD=N: the file descriptor the Perl_mem_log_...() |
5514
|
|
|
|
|
|
* writes to. In the default logger, this is settable at runtime. |
5515
|
|
|
|
|
|
*/ |
5516
|
|
|
|
|
|
#ifndef PERL_MEM_LOG_FD |
5517
|
|
|
|
|
|
# define PERL_MEM_LOG_FD 2 /* If STDERR is too boring for you. */ |
5518
|
|
|
|
|
|
#endif |
5519
|
|
|
|
|
|
|
5520
|
|
|
|
|
|
#ifndef PERL_MEM_LOG_NOIMPL |
5521
|
|
|
|
|
|
|
5522
|
|
|
|
|
|
# ifdef DEBUG_LEAKING_SCALARS |
5523
|
|
|
|
|
|
# define SV_LOG_SERIAL_FMT " [%lu]" |
5524
|
|
|
|
|
|
# define _SV_LOG_SERIAL_ARG(sv) , (unsigned long) (sv)->sv_debug_serial |
5525
|
|
|
|
|
|
# else |
5526
|
|
|
|
|
|
# define SV_LOG_SERIAL_FMT |
5527
|
|
|
|
|
|
# define _SV_LOG_SERIAL_ARG(sv) |
5528
|
|
|
|
|
|
# endif |
5529
|
|
|
|
|
|
|
5530
|
|
|
|
|
|
static void |
5531
|
|
|
|
|
|
S_mem_log_common(enum mem_log_type mlt, const UV n, |
5532
|
|
|
|
|
|
const UV typesize, const char *type_name, const SV *sv, |
5533
|
|
|
|
|
|
Malloc_t oldalloc, Malloc_t newalloc, |
5534
|
|
|
|
|
|
const char *filename, const int linenumber, |
5535
|
|
|
|
|
|
const char *funcname) |
5536
|
|
|
|
|
|
{ |
5537
|
|
|
|
|
|
const char *pmlenv; |
5538
|
|
|
|
|
|
|
5539
|
|
|
|
|
|
PERL_ARGS_ASSERT_MEM_LOG_COMMON; |
5540
|
|
|
|
|
|
|
5541
|
|
|
|
|
|
pmlenv = PerlEnv_getenv("PERL_MEM_LOG"); |
5542
|
|
|
|
|
|
if (!pmlenv) |
5543
|
|
|
|
|
|
return; |
5544
|
|
|
|
|
|
if (mlt < MLT_NEW_SV ? strchr(pmlenv,'m') : strchr(pmlenv,'s')) |
5545
|
|
|
|
|
|
{ |
5546
|
|
|
|
|
|
/* We can't use SVs or PerlIO for obvious reasons, |
5547
|
|
|
|
|
|
* so we'll use stdio and low-level IO instead. */ |
5548
|
|
|
|
|
|
char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE]; |
5549
|
|
|
|
|
|
|
5550
|
|
|
|
|
|
# ifdef HAS_GETTIMEOFDAY |
5551
|
|
|
|
|
|
# define MEM_LOG_TIME_FMT "%10d.%06d: " |
5552
|
|
|
|
|
|
# define MEM_LOG_TIME_ARG (int)tv.tv_sec, (int)tv.tv_usec |
5553
|
|
|
|
|
|
struct timeval tv; |
5554
|
|
|
|
|
|
gettimeofday(&tv, 0); |
5555
|
|
|
|
|
|
# else |
5556
|
|
|
|
|
|
# define MEM_LOG_TIME_FMT "%10d: " |
5557
|
|
|
|
|
|
# define MEM_LOG_TIME_ARG (int)when |
5558
|
|
|
|
|
|
Time_t when; |
5559
|
|
|
|
|
|
(void)time(&when); |
5560
|
|
|
|
|
|
# endif |
5561
|
|
|
|
|
|
/* If there are other OS specific ways of hires time than |
5562
|
|
|
|
|
|
* gettimeofday() (see ext/Time-HiRes), the easiest way is |
5563
|
|
|
|
|
|
* probably that they would be used to fill in the struct |
5564
|
|
|
|
|
|
* timeval. */ |
5565
|
|
|
|
|
|
{ |
5566
|
|
|
|
|
|
STRLEN len; |
5567
|
|
|
|
|
|
int fd = atoi(pmlenv); |
5568
|
|
|
|
|
|
if (!fd) |
5569
|
|
|
|
|
|
fd = PERL_MEM_LOG_FD; |
5570
|
|
|
|
|
|
|
5571
|
|
|
|
|
|
if (strchr(pmlenv, 't')) { |
5572
|
|
|
|
|
|
len = my_snprintf(buf, sizeof(buf), |
5573
|
|
|
|
|
|
MEM_LOG_TIME_FMT, MEM_LOG_TIME_ARG); |
5574
|
|
|
|
|
|
PerlLIO_write(fd, buf, len); |
5575
|
|
|
|
|
|
} |
5576
|
|
|
|
|
|
switch (mlt) { |
5577
|
|
|
|
|
|
case MLT_ALLOC: |
5578
|
|
|
|
|
|
len = my_snprintf(buf, sizeof(buf), |
5579
|
|
|
|
|
|
"alloc: %s:%d:%s: %"IVdf" %"UVuf |
5580
|
|
|
|
|
|
" %s = %"IVdf": %"UVxf"\n", |
5581
|
|
|
|
|
|
filename, linenumber, funcname, n, typesize, |
5582
|
|
|
|
|
|
type_name, n * typesize, PTR2UV(newalloc)); |
5583
|
|
|
|
|
|
break; |
5584
|
|
|
|
|
|
case MLT_REALLOC: |
5585
|
|
|
|
|
|
len = my_snprintf(buf, sizeof(buf), |
5586
|
|
|
|
|
|
"realloc: %s:%d:%s: %"IVdf" %"UVuf |
5587
|
|
|
|
|
|
" %s = %"IVdf": %"UVxf" -> %"UVxf"\n", |
5588
|
|
|
|
|
|
filename, linenumber, funcname, n, typesize, |
5589
|
|
|
|
|
|
type_name, n * typesize, PTR2UV(oldalloc), |
5590
|
|
|
|
|
|
PTR2UV(newalloc)); |
5591
|
|
|
|
|
|
break; |
5592
|
|
|
|
|
|
case MLT_FREE: |
5593
|
|
|
|
|
|
len = my_snprintf(buf, sizeof(buf), |
5594
|
|
|
|
|
|
"free: %s:%d:%s: %"UVxf"\n", |
5595
|
|
|
|
|
|
filename, linenumber, funcname, |
5596
|
|
|
|
|
|
PTR2UV(oldalloc)); |
5597
|
|
|
|
|
|
break; |
5598
|
|
|
|
|
|
case MLT_NEW_SV: |
5599
|
|
|
|
|
|
case MLT_DEL_SV: |
5600
|
|
|
|
|
|
len = my_snprintf(buf, sizeof(buf), |
5601
|
|
|
|
|
|
"%s_SV: %s:%d:%s: %"UVxf SV_LOG_SERIAL_FMT "\n", |
5602
|
|
|
|
|
|
mlt == MLT_NEW_SV ? "new" : "del", |
5603
|
|
|
|
|
|
filename, linenumber, funcname, |
5604
|
|
|
|
|
|
PTR2UV(sv) _SV_LOG_SERIAL_ARG(sv)); |
5605
|
|
|
|
|
|
break; |
5606
|
|
|
|
|
|
default: |
5607
|
|
|
|
|
|
len = 0; |
5608
|
|
|
|
|
|
} |
5609
|
|
|
|
|
|
PerlLIO_write(fd, buf, len); |
5610
|
|
|
|
|
|
} |
5611
|
|
|
|
|
|
} |
5612
|
|
|
|
|
|
} |
5613
|
|
|
|
|
|
#endif /* !PERL_MEM_LOG_NOIMPL */ |
5614
|
|
|
|
|
|
|
5615
|
|
|
|
|
|
#ifndef PERL_MEM_LOG_NOIMPL |
5616
|
|
|
|
|
|
# define \ |
5617
|
|
|
|
|
|
mem_log_common_if(alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm) \ |
5618
|
|
|
|
|
|
mem_log_common (alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm) |
5619
|
|
|
|
|
|
#else |
5620
|
|
|
|
|
|
/* this is suboptimal, but bug compatible. User is providing their |
5621
|
|
|
|
|
|
own implementation, but is getting these functions anyway, and they |
5622
|
|
|
|
|
|
do nothing. But _NOIMPL users should be able to cope or fix */ |
5623
|
|
|
|
|
|
# define \ |
5624
|
|
|
|
|
|
mem_log_common_if(alty, num, tysz, tynm, u, oal, nal, flnm, ln, fnnm) \ |
5625
|
|
|
|
|
|
/* mem_log_common_if_PERL_MEM_LOG_NOIMPL */ |
5626
|
|
|
|
|
|
#endif |
5627
|
|
|
|
|
|
|
5628
|
|
|
|
|
|
Malloc_t |
5629
|
|
|
|
|
|
Perl_mem_log_alloc(const UV n, const UV typesize, const char *type_name, |
5630
|
|
|
|
|
|
Malloc_t newalloc, |
5631
|
|
|
|
|
|
const char *filename, const int linenumber, |
5632
|
|
|
|
|
|
const char *funcname) |
5633
|
|
|
|
|
|
{ |
5634
|
|
|
|
|
|
mem_log_common_if(MLT_ALLOC, n, typesize, type_name, |
5635
|
|
|
|
|
|
NULL, NULL, newalloc, |
5636
|
|
|
|
|
|
filename, linenumber, funcname); |
5637
|
|
|
|
|
|
return newalloc; |
5638
|
|
|
|
|
|
} |
5639
|
|
|
|
|
|
|
5640
|
|
|
|
|
|
Malloc_t |
5641
|
|
|
|
|
|
Perl_mem_log_realloc(const UV n, const UV typesize, const char *type_name, |
5642
|
|
|
|
|
|
Malloc_t oldalloc, Malloc_t newalloc, |
5643
|
|
|
|
|
|
const char *filename, const int linenumber, |
5644
|
|
|
|
|
|
const char *funcname) |
5645
|
|
|
|
|
|
{ |
5646
|
|
|
|
|
|
mem_log_common_if(MLT_REALLOC, n, typesize, type_name, |
5647
|
|
|
|
|
|
NULL, oldalloc, newalloc, |
5648
|
|
|
|
|
|
filename, linenumber, funcname); |
5649
|
|
|
|
|
|
return newalloc; |
5650
|
|
|
|
|
|
} |
5651
|
|
|
|
|
|
|
5652
|
|
|
|
|
|
Malloc_t |
5653
|
|
|
|
|
|
Perl_mem_log_free(Malloc_t oldalloc, |
5654
|
|
|
|
|
|
const char *filename, const int linenumber, |
5655
|
|
|
|
|
|
const char *funcname) |
5656
|
|
|
|
|
|
{ |
5657
|
|
|
|
|
|
mem_log_common_if(MLT_FREE, 0, 0, "", NULL, oldalloc, NULL, |
5658
|
|
|
|
|
|
filename, linenumber, funcname); |
5659
|
|
|
|
|
|
return oldalloc; |
5660
|
|
|
|
|
|
} |
5661
|
|
|
|
|
|
|
5662
|
|
|
|
|
|
void |
5663
|
|
|
|
|
|
Perl_mem_log_new_sv(const SV *sv, |
5664
|
|
|
|
|
|
const char *filename, const int linenumber, |
5665
|
|
|
|
|
|
const char *funcname) |
5666
|
|
|
|
|
|
{ |
5667
|
|
|
|
|
|
mem_log_common_if(MLT_NEW_SV, 0, 0, "", sv, NULL, NULL, |
5668
|
|
|
|
|
|
filename, linenumber, funcname); |
5669
|
|
|
|
|
|
} |
5670
|
|
|
|
|
|
|
5671
|
|
|
|
|
|
void |
5672
|
|
|
|
|
|
Perl_mem_log_del_sv(const SV *sv, |
5673
|
|
|
|
|
|
const char *filename, const int linenumber, |
5674
|
|
|
|
|
|
const char *funcname) |
5675
|
|
|
|
|
|
{ |
5676
|
|
|
|
|
|
mem_log_common_if(MLT_DEL_SV, 0, 0, "", sv, NULL, NULL, |
5677
|
|
|
|
|
|
filename, linenumber, funcname); |
5678
|
|
|
|
|
|
} |
5679
|
|
|
|
|
|
|
5680
|
|
|
|
|
|
#endif /* PERL_MEM_LOG */ |
5681
|
|
|
|
|
|
|
5682
|
|
|
|
|
|
/* |
5683
|
|
|
|
|
|
=for apidoc my_sprintf |
5684
|
|
|
|
|
|
|
5685
|
|
|
|
|
|
The C library C, wrapped if necessary, to ensure that it will return |
5686
|
|
|
|
|
|
the length of the string written to the buffer. Only rare pre-ANSI systems |
5687
|
|
|
|
|
|
need the wrapper function - usually this is a direct call to C. |
5688
|
|
|
|
|
|
|
5689
|
|
|
|
|
|
=cut |
5690
|
|
|
|
|
|
*/ |
5691
|
|
|
|
|
|
#ifndef SPRINTF_RETURNS_STRLEN |
5692
|
|
|
|
|
|
int |
5693
|
|
|
|
|
|
Perl_my_sprintf(char *buffer, const char* pat, ...) |
5694
|
|
|
|
|
|
{ |
5695
|
|
|
|
|
|
va_list args; |
5696
|
|
|
|
|
|
PERL_ARGS_ASSERT_MY_SPRINTF; |
5697
|
|
|
|
|
|
va_start(args, pat); |
5698
|
|
|
|
|
|
vsprintf(buffer, pat, args); |
5699
|
|
|
|
|
|
va_end(args); |
5700
|
|
|
|
|
|
return strlen(buffer); |
5701
|
|
|
|
|
|
} |
5702
|
|
|
|
|
|
#endif |
5703
|
|
|
|
|
|
|
5704
|
|
|
|
|
|
/* |
5705
|
|
|
|
|
|
=for apidoc my_snprintf |
5706
|
|
|
|
|
|
|
5707
|
|
|
|
|
|
The C library C functionality, if available and |
5708
|
|
|
|
|
|
standards-compliant (uses C, actually). However, if the |
5709
|
|
|
|
|
|
C is not available, will unfortunately use the unsafe |
5710
|
|
|
|
|
|
C which can overrun the buffer (there is an overrun check, |
5711
|
|
|
|
|
|
but that may be too late). Consider using C instead, or |
5712
|
|
|
|
|
|
getting C. |
5713
|
|
|
|
|
|
|
5714
|
|
|
|
|
|
=cut |
5715
|
|
|
|
|
|
*/ |
5716
|
|
|
|
|
|
int |
5717
|
|
|
|
|
|
Perl_my_snprintf(char *buffer, const Size_t len, const char *format, ...) |
5718
|
|
|
|
|
|
{ |
5719
|
|
|
|
|
|
int retval; |
5720
|
|
|
|
|
|
va_list ap; |
5721
|
|
|
|
|
|
PERL_ARGS_ASSERT_MY_SNPRINTF; |
5722
|
|
|
|
|
|
va_start(ap, format); |
5723
|
|
|
|
|
|
#ifdef HAS_VSNPRINTF |
5724
|
|
|
|
|
|
retval = vsnprintf(buffer, len, format, ap); |
5725
|
|
|
|
|
|
#else |
5726
|
|
|
|
|
|
retval = vsprintf(buffer, format, ap); |
5727
|
|
|
|
|
|
#endif |
5728
|
|
|
|
|
|
va_end(ap); |
5729
|
|
|
|
|
|
/* vsprintf() shows failure with < 0 */ |
5730
|
|
|
|
|
|
if (retval < 0 |
5731
|
|
|
|
|
|
#ifdef HAS_VSNPRINTF |
5732
|
|
|
|
|
|
/* vsnprintf() shows failure with >= len */ |
5733
|
|
|
|
|
|
|| |
5734
|
|
|
|
|
|
(len > 0 && (Size_t)retval >= len) |
5735
|
|
|
|
|
|
#endif |
5736
|
|
|
|
|
|
) |
5737
|
|
|
|
|
|
Perl_croak_nocontext("panic: my_snprintf buffer overflow"); |
5738
|
|
|
|
|
|
return retval; |
5739
|
|
|
|
|
|
} |
5740
|
|
|
|
|
|
|
5741
|
|
|
|
|
|
/* |
5742
|
|
|
|
|
|
=for apidoc my_vsnprintf |
5743
|
|
|
|
|
|
|
5744
|
|
|
|
|
|
The C library C if available and standards-compliant. |
5745
|
|
|
|
|
|
However, if if the C is not available, will unfortunately |
5746
|
|
|
|
|
|
use the unsafe C which can overrun the buffer (there is an |
5747
|
|
|
|
|
|
overrun check, but that may be too late). Consider using |
5748
|
|
|
|
|
|
C instead, or getting C. |
5749
|
|
|
|
|
|
|
5750
|
|
|
|
|
|
=cut |
5751
|
|
|
|
|
|
*/ |
5752
|
|
|
|
|
|
int |
5753
|
|
|
|
|
|
Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap) |
5754
|
|
|
|
|
|
{ |
5755
|
|
|
|
|
|
int retval; |
5756
|
|
|
|
|
|
#ifdef NEED_VA_COPY |
5757
|
|
|
|
|
|
va_list apc; |
5758
|
|
|
|
|
|
|
5759
|
|
|
|
|
|
PERL_ARGS_ASSERT_MY_VSNPRINTF; |
5760
|
|
|
|
|
|
|
5761
|
|
|
|
|
|
Perl_va_copy(ap, apc); |
5762
|
|
|
|
|
|
# ifdef HAS_VSNPRINTF |
5763
|
|
|
|
|
|
retval = vsnprintf(buffer, len, format, apc); |
5764
|
|
|
|
|
|
# else |
5765
|
|
|
|
|
|
retval = vsprintf(buffer, format, apc); |
5766
|
|
|
|
|
|
# endif |
5767
|
|
|
|
|
|
#else |
5768
|
|
|
|
|
|
# ifdef HAS_VSNPRINTF |
5769
|
|
|
|
|
|
retval = vsnprintf(buffer, len, format, ap); |
5770
|
|
|
|
|
|
# else |
5771
|
|
|
|
|
|
retval = vsprintf(buffer, format, ap); |
5772
|
|
|
|
|
|
# endif |
5773
|
|
|
|
|
|
#endif /* #ifdef NEED_VA_COPY */ |
5774
|
|
|
|
|
|
/* vsprintf() shows failure with < 0 */ |
5775
|
|
|
|
|
|
if (retval < 0 |
5776
|
|
|
|
|
|
#ifdef HAS_VSNPRINTF |
5777
|
|
|
|
|
|
/* vsnprintf() shows failure with >= len */ |
5778
|
|
|
|
|
|
|| |
5779
|
|
|
|
|
|
(len > 0 && (Size_t)retval >= len) |
5780
|
|
|
|
|
|
#endif |
5781
|
|
|
|
|
|
) |
5782
|
|
|
|
|
|
Perl_croak_nocontext("panic: my_vsnprintf buffer overflow"); |
5783
|
|
|
|
|
|
return retval; |
5784
|
|
|
|
|
|
} |
5785
|
|
|
|
|
|
|
5786
|
|
|
|
|
|
void |
5787
|
|
|
|
|
|
Perl_my_clearenv(pTHX) |
5788
|
|
|
|
|
|
{ |
5789
|
|
|
|
|
|
dVAR; |
5790
|
|
|
|
|
|
#if ! defined(PERL_MICRO) |
5791
|
|
|
|
|
|
# if defined(PERL_IMPLICIT_SYS) || defined(WIN32) |
5792
|
|
|
|
|
|
PerlEnv_clearenv(); |
5793
|
|
|
|
|
|
# else /* ! (PERL_IMPLICIT_SYS || WIN32) */ |
5794
|
|
|
|
|
|
# if defined(USE_ENVIRON_ARRAY) |
5795
|
|
|
|
|
|
# if defined(USE_ITHREADS) |
5796
|
|
|
|
|
|
/* only the parent thread can clobber the process environment */ |
5797
|
|
|
|
|
|
if (PL_curinterp == aTHX) |
5798
|
|
|
|
|
|
# endif /* USE_ITHREADS */ |
5799
|
|
|
|
|
|
{ |
5800
|
|
|
|
|
|
# if ! defined(PERL_USE_SAFE_PUTENV) |
5801
|
|
|
|
|
|
if ( !PL_use_safe_putenv) { |
5802
|
|
|
|
|
|
I32 i; |
5803
|
|
|
|
|
|
if (environ == PL_origenviron) |
5804
|
|
|
|
|
|
environ = (char**)safesysmalloc(sizeof(char*)); |
5805
|
|
|
|
|
|
else |
5806
|
|
|
|
|
|
for (i = 0; environ[i]; i++) |
5807
|
|
|
|
|
|
(void)safesysfree(environ[i]); |
5808
|
|
|
|
|
|
} |
5809
|
|
|
|
|
|
environ[0] = NULL; |
5810
|
|
|
|
|
|
# else /* PERL_USE_SAFE_PUTENV */ |
5811
|
|
|
|
|
|
# if defined(HAS_CLEARENV) |
5812
|
|
|
|
|
|
(void)clearenv(); |
5813
|
|
|
|
|
|
# elif defined(HAS_UNSETENV) |
5814
|
|
|
|
|
|
int bsiz = 80; /* Most envvar names will be shorter than this. */ |
5815
|
|
|
|
|
|
char *buf = (char*)safesysmalloc(bsiz); |
5816
|
|
|
|
|
|
while (*environ != NULL) { |
5817
|
|
|
|
|
|
char *e = strchr(*environ, '='); |
5818
|
|
|
|
|
|
int l = e ? e - *environ : (int)strlen(*environ); |
5819
|
|
|
|
|
|
if (bsiz < l + 1) { |
5820
|
|
|
|
|
|
(void)safesysfree(buf); |
5821
|
|
|
|
|
|
bsiz = l + 1; /* + 1 for the \0. */ |
5822
|
|
|
|
|
|
buf = (char*)safesysmalloc(bsiz); |
5823
|
|
|
|
|
|
} |
5824
|
|
|
|
|
|
memcpy(buf, *environ, l); |
5825
|
|
|
|
|
|
buf[l] = '\0'; |
5826
|
|
|
|
|
|
(void)unsetenv(buf); |
5827
|
|
|
|
|
|
} |
5828
|
|
|
|
|
|
(void)safesysfree(buf); |
5829
|
|
|
|
|
|
# else /* ! HAS_CLEARENV && ! HAS_UNSETENV */ |
5830
|
|
|
|
|
|
/* Just null environ and accept the leakage. */ |
5831
|
|
|
|
|
|
*environ = NULL; |
5832
|
|
|
|
|
|
# endif /* HAS_CLEARENV || HAS_UNSETENV */ |
5833
|
|
|
|
|
|
# endif /* ! PERL_USE_SAFE_PUTENV */ |
5834
|
|
|
|
|
|
} |
5835
|
|
|
|
|
|
# endif /* USE_ENVIRON_ARRAY */ |
5836
|
|
|
|
|
|
# endif /* PERL_IMPLICIT_SYS || WIN32 */ |
5837
|
|
|
|
|
|
#endif /* PERL_MICRO */ |
5838
|
|
|
|
|
|
} |
5839
|
|
|
|
|
|
|
5840
|
|
|
|
|
|
#ifdef PERL_IMPLICIT_CONTEXT |
5841
|
|
|
|
|
|
|
5842
|
|
|
|
|
|
/* Implements the MY_CXT_INIT macro. The first time a module is loaded, |
5843
|
|
|
|
|
|
the global PL_my_cxt_index is incremented, and that value is assigned to |
5844
|
|
|
|
|
|
that module's static my_cxt_index (who's address is passed as an arg). |
5845
|
|
|
|
|
|
Then, for each interpreter this function is called for, it makes sure a |
5846
|
|
|
|
|
|
void* slot is available to hang the static data off, by allocating or |
5847
|
|
|
|
|
|
extending the interpreter's PL_my_cxt_list array */ |
5848
|
|
|
|
|
|
|
5849
|
|
|
|
|
|
#ifndef PERL_GLOBAL_STRUCT_PRIVATE |
5850
|
|
|
|
|
|
void * |
5851
|
|
|
|
|
|
Perl_my_cxt_init(pTHX_ int *index, size_t size) |
5852
|
|
|
|
|
|
{ |
5853
|
|
|
|
|
|
dVAR; |
5854
|
|
|
|
|
|
void *p; |
5855
|
|
|
|
|
|
PERL_ARGS_ASSERT_MY_CXT_INIT; |
5856
|
|
|
|
|
|
if (*index == -1) { |
5857
|
|
|
|
|
|
/* this module hasn't been allocated an index yet */ |
5858
|
|
|
|
|
|
#if defined(USE_ITHREADS) |
5859
|
|
|
|
|
|
MUTEX_LOCK(&PL_my_ctx_mutex); |
5860
|
|
|
|
|
|
#endif |
5861
|
|
|
|
|
|
*index = PL_my_cxt_index++; |
5862
|
|
|
|
|
|
#if defined(USE_ITHREADS) |
5863
|
|
|
|
|
|
MUTEX_UNLOCK(&PL_my_ctx_mutex); |
5864
|
|
|
|
|
|
#endif |
5865
|
|
|
|
|
|
} |
5866
|
|
|
|
|
|
|
5867
|
|
|
|
|
|
/* make sure the array is big enough */ |
5868
|
|
|
|
|
|
if (PL_my_cxt_size <= *index) { |
5869
|
|
|
|
|
|
if (PL_my_cxt_size) { |
5870
|
|
|
|
|
|
while (PL_my_cxt_size <= *index) |
5871
|
|
|
|
|
|
PL_my_cxt_size *= 2; |
5872
|
|
|
|
|
|
Renew(PL_my_cxt_list, PL_my_cxt_size, void *); |
5873
|
|
|
|
|
|
} |
5874
|
|
|
|
|
|
else { |
5875
|
|
|
|
|
|
PL_my_cxt_size = 16; |
5876
|
|
|
|
|
|
Newx(PL_my_cxt_list, PL_my_cxt_size, void *); |
5877
|
|
|
|
|
|
} |
5878
|
|
|
|
|
|
} |
5879
|
|
|
|
|
|
/* newSV() allocates one more than needed */ |
5880
|
|
|
|
|
|
p = (void*)SvPVX(newSV(size-1)); |
5881
|
|
|
|
|
|
PL_my_cxt_list[*index] = p; |
5882
|
|
|
|
|
|
Zero(p, size, char); |
5883
|
|
|
|
|
|
return p; |
5884
|
|
|
|
|
|
} |
5885
|
|
|
|
|
|
|
5886
|
|
|
|
|
|
#else /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */ |
5887
|
|
|
|
|
|
|
5888
|
|
|
|
|
|
int |
5889
|
|
|
|
|
|
Perl_my_cxt_index(pTHX_ const char *my_cxt_key) |
5890
|
|
|
|
|
|
{ |
5891
|
|
|
|
|
|
dVAR; |
5892
|
|
|
|
|
|
int index; |
5893
|
|
|
|
|
|
|
5894
|
|
|
|
|
|
PERL_ARGS_ASSERT_MY_CXT_INDEX; |
5895
|
|
|
|
|
|
|
5896
|
|
|
|
|
|
for (index = 0; index < PL_my_cxt_index; index++) { |
5897
|
|
|
|
|
|
const char *key = PL_my_cxt_keys[index]; |
5898
|
|
|
|
|
|
/* try direct pointer compare first - there are chances to success, |
5899
|
|
|
|
|
|
* and it's much faster. |
5900
|
|
|
|
|
|
*/ |
5901
|
|
|
|
|
|
if ((key == my_cxt_key) || strEQ(key, my_cxt_key)) |
5902
|
|
|
|
|
|
return index; |
5903
|
|
|
|
|
|
} |
5904
|
|
|
|
|
|
return -1; |
5905
|
|
|
|
|
|
} |
5906
|
|
|
|
|
|
|
5907
|
|
|
|
|
|
void * |
5908
|
|
|
|
|
|
Perl_my_cxt_init(pTHX_ const char *my_cxt_key, size_t size) |
5909
|
|
|
|
|
|
{ |
5910
|
|
|
|
|
|
dVAR; |
5911
|
|
|
|
|
|
void *p; |
5912
|
|
|
|
|
|
int index; |
5913
|
|
|
|
|
|
|
5914
|
|
|
|
|
|
PERL_ARGS_ASSERT_MY_CXT_INIT; |
5915
|
|
|
|
|
|
|
5916
|
|
|
|
|
|
index = Perl_my_cxt_index(aTHX_ my_cxt_key); |
5917
|
|
|
|
|
|
if (index == -1) { |
5918
|
|
|
|
|
|
/* this module hasn't been allocated an index yet */ |
5919
|
|
|
|
|
|
#if defined(USE_ITHREADS) |
5920
|
|
|
|
|
|
MUTEX_LOCK(&PL_my_ctx_mutex); |
5921
|
|
|
|
|
|
#endif |
5922
|
|
|
|
|
|
index = PL_my_cxt_index++; |
5923
|
|
|
|
|
|
#if defined(USE_ITHREADS) |
5924
|
|
|
|
|
|
MUTEX_UNLOCK(&PL_my_ctx_mutex); |
5925
|
|
|
|
|
|
#endif |
5926
|
|
|
|
|
|
} |
5927
|
|
|
|
|
|
|
5928
|
|
|
|
|
|
/* make sure the array is big enough */ |
5929
|
|
|
|
|
|
if (PL_my_cxt_size <= index) { |
5930
|
|
|
|
|
|
int old_size = PL_my_cxt_size; |
5931
|
|
|
|
|
|
int i; |
5932
|
|
|
|
|
|
if (PL_my_cxt_size) { |
5933
|
|
|
|
|
|
while (PL_my_cxt_size <= index) |
5934
|
|
|
|
|
|
PL_my_cxt_size *= 2; |
5935
|
|
|
|
|
|
Renew(PL_my_cxt_list, PL_my_cxt_size, void *); |
5936
|
|
|
|
|
|
Renew(PL_my_cxt_keys, PL_my_cxt_size, const char *); |
5937
|
|
|
|
|
|
} |
5938
|
|
|
|
|
|
else { |
5939
|
|
|
|
|
|
PL_my_cxt_size = 16; |
5940
|
|
|
|
|
|
Newx(PL_my_cxt_list, PL_my_cxt_size, void *); |
5941
|
|
|
|
|
|
Newx(PL_my_cxt_keys, PL_my_cxt_size, const char *); |
5942
|
|
|
|
|
|
} |
5943
|
|
|
|
|
|
for (i = old_size; i < PL_my_cxt_size; i++) { |
5944
|
|
|
|
|
|
PL_my_cxt_keys[i] = 0; |
5945
|
|
|
|
|
|
PL_my_cxt_list[i] = 0; |
5946
|
|
|
|
|
|
} |
5947
|
|
|
|
|
|
} |
5948
|
|
|
|
|
|
PL_my_cxt_keys[index] = my_cxt_key; |
5949
|
|
|
|
|
|
/* newSV() allocates one more than needed */ |
5950
|
|
|
|
|
|
p = (void*)SvPVX(newSV(size-1)); |
5951
|
|
|
|
|
|
PL_my_cxt_list[index] = p; |
5952
|
|
|
|
|
|
Zero(p, size, char); |
5953
|
|
|
|
|
|
return p; |
5954
|
|
|
|
|
|
} |
5955
|
|
|
|
|
|
#endif /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */ |
5956
|
|
|
|
|
|
#endif /* PERL_IMPLICIT_CONTEXT */ |
5957
|
|
|
|
|
|
|
5958
|
|
|
|
|
|
void |
5959
|
|
|
|
|
|
Perl_xs_version_bootcheck(pTHX_ U32 items, U32 ax, const char *xs_p, |
5960
|
|
|
|
|
|
STRLEN xs_len) |
5961
|
|
|
|
|
|
{ |
5962
|
|
|
|
|
|
SV *sv; |
5963
|
|
|
|
|
|
const char *vn = NULL; |
5964
|
|
|
|
|
|
SV *const module = PL_stack_base[ax]; |
5965
|
|
|
|
|
|
|
5966
|
|
|
|
|
|
PERL_ARGS_ASSERT_XS_VERSION_BOOTCHECK; |
5967
|
|
|
|
|
|
|
5968
|
|
|
|
|
|
if (items >= 2) /* version supplied as bootstrap arg */ |
5969
|
|
|
|
|
|
sv = PL_stack_base[ax + 1]; |
5970
|
|
|
|
|
|
else { |
5971
|
|
|
|
|
|
/* XXX GV_ADDWARN */ |
5972
|
|
|
|
|
|
vn = "XS_VERSION"; |
5973
|
|
|
|
|
|
sv = get_sv(Perl_form(aTHX_ "%"SVf"::%s", module, vn), 0); |
5974
|
|
|
|
|
|
if (!sv || !SvOK(sv)) { |
5975
|
|
|
|
|
|
vn = "VERSION"; |
5976
|
|
|
|
|
|
sv = get_sv(Perl_form(aTHX_ "%"SVf"::%s", module, vn), 0); |
5977
|
|
|
|
|
|
} |
5978
|
|
|
|
|
|
} |
5979
|
|
|
|
|
|
if (sv) { |
5980
|
|
|
|
|
|
SV *xssv = Perl_newSVpvn_flags(aTHX_ xs_p, xs_len, SVs_TEMP); |
5981
|
|
|
|
|
|
SV *pmsv = sv_isobject(sv) && sv_derived_from(sv, "version") |
5982
|
|
|
|
|
|
? sv : sv_2mortal(new_version(sv)); |
5983
|
|
|
|
|
|
xssv = upg_version(xssv, 0); |
5984
|
|
|
|
|
|
if ( vcmp(pmsv,xssv) ) { |
5985
|
|
|
|
|
|
SV *string = vstringify(xssv); |
5986
|
|
|
|
|
|
SV *xpt = Perl_newSVpvf(aTHX_ "%"SVf" object version %"SVf |
5987
|
|
|
|
|
|
" does not match ", module, string); |
5988
|
|
|
|
|
|
|
5989
|
|
|
|
|
|
SvREFCNT_dec(string); |
5990
|
|
|
|
|
|
string = vstringify(pmsv); |
5991
|
|
|
|
|
|
|
5992
|
|
|
|
|
|
if (vn) { |
5993
|
|
|
|
|
|
Perl_sv_catpvf(aTHX_ xpt, "$%"SVf"::%s %"SVf, module, vn, |
5994
|
|
|
|
|
|
string); |
5995
|
|
|
|
|
|
} else { |
5996
|
|
|
|
|
|
Perl_sv_catpvf(aTHX_ xpt, "bootstrap parameter %"SVf, string); |
5997
|
|
|
|
|
|
} |
5998
|
|
|
|
|
|
SvREFCNT_dec(string); |
5999
|
|
|
|
|
|
|
6000
|
|
|
|
|
|
Perl_sv_2mortal(aTHX_ xpt); |
6001
|
|
|
|
|
|
Perl_croak_sv(aTHX_ xpt); |
6002
|
|
|
|
|
|
} |
6003
|
|
|
|
|
|
} |
6004
|
|
|
|
|
|
} |
6005
|
|
|
|
|
|
|
6006
|
|
|
|
|
|
void |
6007
|
|
|
|
|
|
Perl_xs_apiversion_bootcheck(pTHX_ SV *module, const char *api_p, |
6008
|
|
|
|
|
|
STRLEN api_len) |
6009
|
|
|
|
|
|
{ |
6010
|
|
|
|
|
|
SV *xpt = NULL; |
6011
|
|
|
|
|
|
SV *compver = Perl_newSVpvn_flags(aTHX_ api_p, api_len, SVs_TEMP); |
6012
|
|
|
|
|
|
SV *runver; |
6013
|
|
|
|
|
|
|
6014
|
|
|
|
|
|
PERL_ARGS_ASSERT_XS_APIVERSION_BOOTCHECK; |
6015
|
|
|
|
|
|
|
6016
|
|
|
|
|
|
/* This might croak */ |
6017
|
|
|
|
|
|
compver = upg_version(compver, 0); |
6018
|
|
|
|
|
|
/* This should never croak */ |
6019
|
|
|
|
|
|
runver = new_version(PL_apiversion); |
6020
|
|
|
|
|
|
if (vcmp(compver, runver)) { |
6021
|
|
|
|
|
|
SV *compver_string = vstringify(compver); |
6022
|
|
|
|
|
|
SV *runver_string = vstringify(runver); |
6023
|
|
|
|
|
|
xpt = Perl_newSVpvf(aTHX_ "Perl API version %"SVf |
6024
|
|
|
|
|
|
" of %"SVf" does not match %"SVf, |
6025
|
|
|
|
|
|
compver_string, module, runver_string); |
6026
|
|
|
|
|
|
Perl_sv_2mortal(aTHX_ xpt); |
6027
|
|
|
|
|
|
|
6028
|
|
|
|
|
|
SvREFCNT_dec(compver_string); |
6029
|
|
|
|
|
|
SvREFCNT_dec(runver_string); |
6030
|
|
|
|
|
|
} |
6031
|
|
|
|
|
|
SvREFCNT_dec(runver); |
6032
|
|
|
|
|
|
if (xpt) |
6033
|
|
|
|
|
|
Perl_croak_sv(aTHX_ xpt); |
6034
|
|
|
|
|
|
} |
6035
|
|
|
|
|
|
|
6036
|
|
|
|
|
|
#ifndef HAS_STRLCAT |
6037
|
|
|
|
|
|
Size_t |
6038
|
|
|
|
|
|
Perl_my_strlcat(char *dst, const char *src, Size_t size) |
6039
|
|
|
|
|
|
{ |
6040
|
|
|
|
|
|
Size_t used, length, copy; |
6041
|
|
|
|
|
|
|
6042
|
|
|
|
|
|
used = strlen(dst); |
6043
|
|
|
|
|
|
length = strlen(src); |
6044
|
|
|
|
|
|
if (size > 0 && used < size - 1) { |
6045
|
|
|
|
|
|
copy = (length >= size - used) ? size - used - 1 : length; |
6046
|
|
|
|
|
|
memcpy(dst + used, src, copy); |
6047
|
|
|
|
|
|
dst[used + copy] = '\0'; |
6048
|
|
|
|
|
|
} |
6049
|
|
|
|
|
|
return used + length; |
6050
|
|
|
|
|
|
} |
6051
|
|
|
|
|
|
#endif |
6052
|
|
|
|
|
|
|
6053
|
|
|
|
|
|
#ifndef HAS_STRLCPY |
6054
|
|
|
|
|
|
Size_t |
6055
|
|
|
|
|
|
Perl_my_strlcpy(char *dst, const char *src, Size_t size) |
6056
|
|
|
|
|
|
{ |
6057
|
|
|
|
|
|
Size_t length, copy; |
6058
|
|
|
|
|
|
|
6059
|
|
|
|
|
|
length = strlen(src); |
6060
|
|
|
|
|
|
if (size > 0) { |
6061
|
|
|
|
|
|
copy = (length >= size) ? size - 1 : length; |
6062
|
|
|
|
|
|
memcpy(dst, src, copy); |
6063
|
|
|
|
|
|
dst[copy] = '\0'; |
6064
|
|
|
|
|
|
} |
6065
|
|
|
|
|
|
return length; |
6066
|
|
|
|
|
|
} |
6067
|
|
|
|
|
|
#endif |
6068
|
|
|
|
|
|
|
6069
|
|
|
|
|
|
#if defined(_MSC_VER) && (_MSC_VER >= 1300) && (_MSC_VER < 1400) && (WINVER < 0x0500) |
6070
|
|
|
|
|
|
/* VC7 or 7.1, building with pre-VC7 runtime libraries. */ |
6071
|
|
|
|
|
|
long _ftol( double ); /* Defined by VC6 C libs. */ |
6072
|
|
|
|
|
|
long _ftol2( double dblSource ) { return _ftol( dblSource ); } |
6073
|
|
|
|
|
|
#endif |
6074
|
|
|
|
|
|
|
6075
|
|
|
|
|
|
PERL_STATIC_INLINE bool |
6076
|
|
|
|
|
|
S_gv_has_usable_name(pTHX_ GV *gv) |
6077
|
|
|
|
|
|
{ |
6078
|
|
|
|
|
|
GV **gvp; |
6079
|
|
|
|
|
|
return GvSTASH(gv) |
6080
|
|
|
|
|
|
&& HvENAME(GvSTASH(gv)) |
6081
|
|
|
|
|
|
&& (gvp = (GV **)hv_fetch( |
6082
|
|
|
|
|
|
GvSTASH(gv), GvNAME(gv), |
6083
|
|
|
|
|
|
GvNAMEUTF8(gv) ? -GvNAMELEN(gv) : GvNAMELEN(gv), 0 |
6084
|
|
|
|
|
|
)) |
6085
|
|
|
|
|
|
&& *gvp == gv; |
6086
|
|
|
|
|
|
} |
6087
|
|
|
|
|
|
|
6088
|
|
|
|
|
|
void |
6089
|
|
|
|
|
|
Perl_get_db_sub(pTHX_ SV **svp, CV *cv) |
6090
|
|
|
|
|
|
{ |
6091
|
|
|
|
|
|
dVAR; |
6092
|
|
|
|
|
|
SV * const dbsv = GvSVn(PL_DBsub); |
6093
|
|
|
|
|
|
const bool save_taint = TAINT_get; |
6094
|
|
|
|
|
|
|
6095
|
|
|
|
|
|
/* When we are called from pp_goto (svp is null), |
6096
|
|
|
|
|
|
* we do not care about using dbsv to call CV; |
6097
|
|
|
|
|
|
* it's for informational purposes only. |
6098
|
|
|
|
|
|
*/ |
6099
|
|
|
|
|
|
|
6100
|
|
|
|
|
|
PERL_ARGS_ASSERT_GET_DB_SUB; |
6101
|
|
|
|
|
|
|
6102
|
|
|
|
|
|
TAINT_set(FALSE); |
6103
|
|
|
|
|
|
save_item(dbsv); |
6104
|
|
|
|
|
|
if (!PERLDB_SUB_NN) { |
6105
|
|
|
|
|
|
GV *gv = CvGV(cv); |
6106
|
|
|
|
|
|
|
6107
|
|
|
|
|
|
if (!svp) { |
6108
|
|
|
|
|
|
gv_efullname3(dbsv, gv, NULL); |
6109
|
|
|
|
|
|
} |
6110
|
|
|
|
|
|
else if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED)) |
6111
|
|
|
|
|
|
|| strEQ(GvNAME(gv), "END") |
6112
|
|
|
|
|
|
|| ( /* Could be imported, and old sub redefined. */ |
6113
|
|
|
|
|
|
(GvCV(gv) != cv || !S_gv_has_usable_name(aTHX_ gv)) |
6114
|
|
|
|
|
|
&& |
6115
|
|
|
|
|
|
!( (SvTYPE(*svp) == SVt_PVGV) |
6116
|
|
|
|
|
|
&& (GvCV((const GV *)*svp) == cv) |
6117
|
|
|
|
|
|
/* Use GV from the stack as a fallback. */ |
6118
|
|
|
|
|
|
&& S_gv_has_usable_name(aTHX_ gv = (GV *)*svp) |
6119
|
|
|
|
|
|
) |
6120
|
|
|
|
|
|
) |
6121
|
|
|
|
|
|
) { |
6122
|
|
|
|
|
|
/* GV is potentially non-unique, or contain different CV. */ |
6123
|
|
|
|
|
|
SV * const tmp = newRV(MUTABLE_SV(cv)); |
6124
|
|
|
|
|
|
sv_setsv(dbsv, tmp); |
6125
|
|
|
|
|
|
SvREFCNT_dec(tmp); |
6126
|
|
|
|
|
|
} |
6127
|
|
|
|
|
|
else { |
6128
|
|
|
|
|
|
sv_sethek(dbsv, HvENAME_HEK(GvSTASH(gv))); |
6129
|
|
|
|
|
|
sv_catpvs(dbsv, "::"); |
6130
|
|
|
|
|
|
sv_catpvn_flags( |
6131
|
|
|
|
|
|
dbsv, GvNAME(gv), GvNAMELEN(gv), |
6132
|
|
|
|
|
|
GvNAMEUTF8(gv) ? SV_CATUTF8 : SV_CATBYTES |
6133
|
|
|
|
|
|
); |
6134
|
|
|
|
|
|
} |
6135
|
|
|
|
|
|
} |
6136
|
|
|
|
|
|
else { |
6137
|
|
|
|
|
|
const int type = SvTYPE(dbsv); |
6138
|
|
|
|
|
|
if (type < SVt_PVIV && type != SVt_IV) |
6139
|
|
|
|
|
|
sv_upgrade(dbsv, SVt_PVIV); |
6140
|
|
|
|
|
|
(void)SvIOK_on(dbsv); |
6141
|
|
|
|
|
|
SvIV_set(dbsv, PTR2IV(cv)); /* Do it the quickest way */ |
6142
|
|
|
|
|
|
} |
6143
|
|
|
|
|
|
TAINT_IF(save_taint); |
6144
|
|
|
|
|
|
#ifdef NO_TAINT_SUPPORT |
6145
|
|
|
|
|
|
PERL_UNUSED_VAR(save_taint); |
6146
|
|
|
|
|
|
#endif |
6147
|
|
|
|
|
|
} |
6148
|
|
|
|
|
|
|
6149
|
|
|
|
|
|
int |
6150
|
|
|
|
|
|
Perl_my_dirfd(pTHX_ DIR * dir) { |
6151
|
|
|
|
|
|
|
6152
|
|
|
|
|
|
/* Most dirfd implementations have problems when passed NULL. */ |
6153
|
|
|
|
|
|
if(!dir) |
6154
|
|
|
|
|
|
return -1; |
6155
|
|
|
|
|
|
#ifdef HAS_DIRFD |
6156
|
|
|
|
|
|
return dirfd(dir); |
6157
|
|
|
|
|
|
#elif defined(HAS_DIR_DD_FD) |
6158
|
|
|
|
|
|
return dir->dd_fd; |
6159
|
|
|
|
|
|
#else |
6160
|
|
|
|
|
|
Perl_die(aTHX_ PL_no_func, "dirfd"); |
6161
|
|
|
|
|
|
assert(0); /* NOT REACHED */ |
6162
|
|
|
|
|
|
return 0; |
6163
|
|
|
|
|
|
#endif |
6164
|
|
|
|
|
|
} |
6165
|
|
|
|
|
|
|
6166
|
|
|
|
|
|
REGEXP * |
6167
|
|
|
|
|
|
Perl_get_re_arg(pTHX_ SV *sv) { |
6168
|
|
|
|
|
|
|
6169
|
|
|
|
|
|
if (sv) { |
6170
|
|
|
|
|
|
if (SvMAGICAL(sv)) |
6171
|
|
|
|
|
|
mg_get(sv); |
6172
|
|
|
|
|
|
if (SvROK(sv)) |
6173
|
|
|
|
|
|
sv = MUTABLE_SV(SvRV(sv)); |
6174
|
|
|
|
|
|
if (SvTYPE(sv) == SVt_REGEXP) |
6175
|
|
|
|
|
|
return (REGEXP*) sv; |
6176
|
|
|
|
|
|
} |
6177
|
|
|
|
|
|
|
6178
|
|
|
|
|
|
return NULL; |
6179
|
|
|
|
|
|
} |
6180
|
|
|
|
|
|
|
6181
|
|
|
|
|
|
/* |
6182
|
|
|
|
|
|
* Local variables: |
6183
|
|
|
|
|
|
* c-indentation-style: bsd |
6184
|
|
|
|
|
|
* c-basic-offset: 4 |
6185
|
|
|
|
|
|
* indent-tabs-mode: nil |
6186
|
|
|
|
|
|
* End: |
6187
|
|
|
|
|
|
* |
6188
|
|
|
|
|
|
* ex: set ts=8 sts=4 sw=4 et: |
6189
|
|
|
|
|
|
*/ |