Commit | Line | Data |
7ee2227d |
1 | /* mathoms.c |
2 | * |
3 | * Copyright (C) 2005, by Larry Wall and others |
4 | * |
5 | * You may distribute under the terms of either the GNU General Public |
6 | * License or the Artistic License, as specified in the README file. |
7 | * |
8 | */ |
9 | |
10 | /* |
11 | * "Anything that Hobbits had no immediate use for, but were unwilling to |
12 | * throw away, they called a mathom. Their dwellings were apt to become |
13 | * rather crowded with mathoms, and many of the presents that passed from |
14 | * hand to hand were of that sort." |
15 | */ |
16 | |
17 | /* |
18 | * This file contains mathoms, various binary artifacts from previous |
f2f0f092 |
19 | * versions of Perl. For binary or source compatibility reasons, though, |
20 | * we cannot completely remove them from the core code. |
7ee2227d |
21 | * |
22 | * SMP - Oct. 24, 2005 |
23 | * |
24 | */ |
25 | |
26 | #include "EXTERN.h" |
27 | #define PERL_IN_MATHOMS_C |
28 | #include "perl.h" |
29 | |
30 | /* ref() is now a macro using Perl_doref; |
31 | * this version provided for binary compatibility only. |
32 | */ |
33 | OP * |
34 | Perl_ref(pTHX_ OP *o, I32 type) |
35 | { |
36 | return doref(o, type, TRUE); |
37 | } |
38 | |
aae9cea0 |
39 | /* |
40 | =for apidoc sv_taint |
41 | |
42 | Taint an SV. Use C<SvTAINTED_on> instead. |
43 | =cut |
44 | */ |
45 | |
46 | void |
47 | Perl_sv_taint(pTHX_ SV *sv) |
48 | { |
49 | sv_magic((sv), Nullsv, PERL_MAGIC_taint, Nullch, 0); |
50 | } |
51 | |
7ee2227d |
52 | /* sv_2iv() is now a macro using Perl_sv_2iv_flags(); |
53 | * this function provided for binary compatibility only |
54 | */ |
55 | |
56 | IV |
57 | Perl_sv_2iv(pTHX_ register SV *sv) |
58 | { |
59 | return sv_2iv_flags(sv, SV_GMAGIC); |
60 | } |
61 | |
62 | /* sv_2uv() is now a macro using Perl_sv_2uv_flags(); |
63 | * this function provided for binary compatibility only |
64 | */ |
65 | |
66 | UV |
67 | Perl_sv_2uv(pTHX_ register SV *sv) |
68 | { |
69 | return sv_2uv_flags(sv, SV_GMAGIC); |
70 | } |
71 | |
72 | /* sv_2pv() is now a macro using Perl_sv_2pv_flags(); |
73 | * this function provided for binary compatibility only |
74 | */ |
75 | |
76 | char * |
77 | Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp) |
78 | { |
79 | return sv_2pv_flags(sv, lp, SV_GMAGIC); |
80 | } |
81 | |
82 | |
83 | /* sv_setsv() is now a macro using Perl_sv_setsv_flags(); |
84 | * this function provided for binary compatibility only |
85 | */ |
86 | |
87 | void |
88 | Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr) |
89 | { |
90 | sv_setsv_flags(dstr, sstr, SV_GMAGIC); |
91 | } |
92 | |
93 | /* sv_catpvn() is now a macro using Perl_sv_catpvn_flags(); |
94 | * this function provided for binary compatibility only |
95 | */ |
96 | |
97 | void |
98 | Perl_sv_catpvn(pTHX_ SV *dsv, const char* sstr, STRLEN slen) |
99 | { |
100 | sv_catpvn_flags(dsv, sstr, slen, SV_GMAGIC); |
101 | } |
102 | |
103 | /* sv_catsv() is now a macro using Perl_sv_catsv_flags(); |
104 | * this function provided for binary compatibility only |
105 | */ |
106 | |
107 | void |
108 | Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr) |
109 | { |
110 | sv_catsv_flags(dstr, sstr, SV_GMAGIC); |
111 | } |
112 | |
113 | /* sv_pv() is now a macro using SvPV_nolen(); |
114 | * this function provided for binary compatibility only |
115 | */ |
116 | |
117 | char * |
118 | Perl_sv_pv(pTHX_ SV *sv) |
119 | { |
120 | if (SvPOK(sv)) |
121 | return SvPVX(sv); |
122 | |
123 | return sv_2pv(sv, 0); |
124 | } |
125 | |
126 | /* sv_pvn_force() is now a macro using Perl_sv_pvn_force_flags(); |
127 | * this function provided for binary compatibility only |
128 | */ |
129 | |
130 | char * |
131 | Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp) |
132 | { |
133 | return sv_pvn_force_flags(sv, lp, SV_GMAGIC); |
134 | } |
135 | |
136 | /* sv_pvbyte () is now a macro using Perl_sv_2pv_flags(); |
137 | * this function provided for binary compatibility only |
138 | */ |
139 | |
140 | char * |
141 | Perl_sv_pvbyte(pTHX_ SV *sv) |
142 | { |
143 | sv_utf8_downgrade(sv,0); |
144 | return sv_pv(sv); |
145 | } |
146 | |
147 | /* sv_pvutf8 () is now a macro using Perl_sv_2pv_flags(); |
148 | * this function provided for binary compatibility only |
149 | */ |
150 | |
151 | char * |
152 | Perl_sv_pvutf8(pTHX_ SV *sv) |
153 | { |
154 | sv_utf8_upgrade(sv); |
155 | return sv_pv(sv); |
156 | } |
157 | |
158 | /* |
159 | =for apidoc A|U8 *|uvchr_to_utf8|U8 *d|UV uv |
160 | |
161 | Adds the UTF-8 representation of the Native codepoint C<uv> to the end |
162 | of the string C<d>; C<d> should be have at least C<UTF8_MAXBYTES+1> free |
163 | bytes available. The return value is the pointer to the byte after the |
164 | end of the new character. In other words, |
165 | |
166 | d = uvchr_to_utf8(d, uv); |
167 | |
168 | is the recommended wide native character-aware way of saying |
169 | |
170 | *(d++) = uv; |
171 | |
172 | =cut |
173 | */ |
174 | |
175 | /* On ASCII machines this is normally a macro but we want a |
176 | real function in case XS code wants it |
177 | */ |
178 | #undef Perl_uvchr_to_utf8 |
179 | U8 * |
180 | Perl_uvchr_to_utf8(pTHX_ U8 *d, UV uv) |
181 | { |
182 | return Perl_uvuni_to_utf8_flags(aTHX_ d, NATIVE_TO_UNI(uv), 0); |
183 | } |
184 | |
185 | |
186 | /* |
187 | =for apidoc A|UV|utf8n_to_uvchr|U8 *s|STRLEN curlen|STRLEN *retlen|U32 |
188 | flags |
189 | |
190 | Returns the native character value of the first character in the string |
191 | C<s> |
192 | which is assumed to be in UTF-8 encoding; C<retlen> will be set to the |
193 | length, in bytes, of that character. |
194 | |
195 | Allows length and flags to be passed to low level routine. |
196 | |
197 | =cut |
198 | */ |
199 | /* On ASCII machines this is normally a macro but we want |
200 | a real function in case XS code wants it |
201 | */ |
202 | #undef Perl_utf8n_to_uvchr |
203 | UV |
204 | Perl_utf8n_to_uvchr(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen, |
205 | U32 flags) |
206 | { |
207 | const UV uv = Perl_utf8n_to_uvuni(aTHX_ s, curlen, retlen, flags); |
208 | return UNI_TO_NATIVE(uv); |
209 | } |
210 | int |
211 | Perl_fprintf_nocontext(PerlIO *stream, const char *format, ...) |
212 | { |
213 | dTHXs; |
214 | va_list(arglist); |
215 | va_start(arglist, format); |
216 | return PerlIO_vprintf(stream, format, arglist); |
217 | } |
218 | |
219 | int |
220 | Perl_printf_nocontext(const char *format, ...) |
221 | { |
222 | dTHX; |
223 | va_list(arglist); |
224 | va_start(arglist, format); |
225 | return PerlIO_vprintf(PerlIO_stdout(), format, arglist); |
226 | } |
227 | |
228 | #if defined(HUGE_VAL) || (defined(USE_LONG_DOUBLE) && defined(HUGE_VALL)) |
229 | /* |
230 | * This hack is to force load of "huge" support from libm.a |
231 | * So it is in perl for (say) POSIX to use. |
232 | * Needed for SunOS with Sun's 'acc' for example. |
233 | */ |
234 | NV |
235 | Perl_huge(void) |
236 | { |
237 | # if defined(USE_LONG_DOUBLE) && defined(HUGE_VALL) |
238 | return HUGE_VALL; |
239 | # endif |
240 | return HUGE_VAL; |
241 | } |
242 | #endif |
243 | |
244 | #ifndef USE_SFIO |
245 | int |
246 | perlsio_binmode(FILE *fp, int iotype, int mode) |
247 | { |
248 | /* |
249 | * This used to be contents of do_binmode in doio.c |
250 | */ |
251 | #ifdef DOSISH |
252 | # if defined(atarist) || defined(__MINT__) |
253 | if (!fflush(fp)) { |
254 | if (mode & O_BINARY) |
255 | ((FILE *) fp)->_flag |= _IOBIN; |
256 | else |
257 | ((FILE *) fp)->_flag &= ~_IOBIN; |
258 | return 1; |
259 | } |
260 | return 0; |
261 | # else |
262 | dTHX; |
263 | #ifdef NETWARE |
264 | if (PerlLIO_setmode(fp, mode) != -1) { |
265 | #else |
266 | if (PerlLIO_setmode(fileno(fp), mode) != -1) { |
267 | #endif |
268 | # if defined(WIN32) && defined(__BORLANDC__) |
269 | /* |
270 | * The translation mode of the stream is maintained independent |
271 | of |
272 | * the translation mode of the fd in the Borland RTL (heavy |
273 | * digging through their runtime sources reveal). User has to |
274 | set |
275 | * the mode explicitly for the stream (though they don't |
276 | document |
277 | * this anywhere). GSAR 97-5-24 |
278 | */ |
279 | fseek(fp, 0L, 0); |
280 | if (mode & O_BINARY) |
281 | fp->flags |= _F_BIN; |
282 | else |
283 | fp->flags &= ~_F_BIN; |
284 | # endif |
285 | return 1; |
286 | } |
287 | else |
288 | return 0; |
289 | # endif |
290 | #else |
291 | # if defined(USEMYBINMODE) |
292 | dTHX; |
293 | if (my_binmode(fp, iotype, mode) != FALSE) |
294 | return 1; |
295 | else |
296 | return 0; |
297 | # else |
298 | PERL_UNUSED_ARG(fp); |
299 | PERL_UNUSED_ARG(iotype); |
300 | PERL_UNUSED_ARG(mode); |
301 | return 1; |
302 | # endif |
303 | #endif |
304 | } |
305 | #endif /* sfio */ |
306 | |
f2f0f092 |
307 | /* compatibility with versions <= 5.003. */ |
308 | void |
309 | Perl_gv_fullname(pTHX_ SV *sv, const GV *gv) |
310 | { |
311 | gv_fullname3(sv, gv, sv == (const SV*)gv ? "*" : ""); |
312 | } |
313 | |
314 | /* compatibility with versions <= 5.003. */ |
315 | void |
316 | Perl_gv_efullname(pTHX_ SV *sv, const GV *gv) |
317 | { |
318 | gv_efullname3(sv, gv, sv == (const SV*)gv ? "*" : ""); |
319 | } |
320 | |
2674aeec |
321 | void |
322 | Perl_gv_fullname3(pTHX_ SV *sv, const GV *gv, const char *prefix) |
323 | { |
324 | gv_fullname4(sv, gv, prefix, TRUE); |
325 | } |
326 | |
327 | void |
328 | Perl_gv_efullname3(pTHX_ SV *sv, const GV *gv, const char *prefix) |
329 | { |
330 | gv_efullname4(sv, gv, prefix, TRUE); |
331 | } |
332 | |
b966a812 |
333 | AV * |
334 | Perl_av_fake(pTHX_ register I32 size, register SV **strp) |
335 | { |
336 | register SV** ary; |
337 | register AV * const av = (AV*)NEWSV(9,0); |
338 | |
339 | sv_upgrade((SV *)av, SVt_PVAV); |
340 | Newx(ary,size+1,SV*); |
341 | AvALLOC(av) = ary; |
342 | Copy(strp,ary,size,SV*); |
343 | AvREIFY_only(av); |
344 | SvPV_set(av, (char*)ary); |
345 | AvFILLp(av) = size - 1; |
346 | AvMAX(av) = size - 1; |
347 | while (size--) { |
348 | assert (*strp); |
349 | SvTEMP_off(*strp); |
350 | strp++; |
351 | } |
352 | return av; |
353 | } |
354 | |
34d367cd |
355 | bool |
356 | Perl_do_open9(pTHX_ GV *gv, register const char *name, I32 len, int |
357 | as_raw, |
358 | int rawmode, int rawperm, PerlIO *supplied_fp, SV *svs, |
359 | I32 num_svs) |
360 | { |
361 | PERL_UNUSED_ARG(num_svs); |
362 | return do_openn(gv, name, len, as_raw, rawmode, rawperm, |
363 | supplied_fp, &svs, 1); |
364 | } |
365 | |
366 | int |
367 | Perl_do_binmode(pTHX_ PerlIO *fp, int iotype, int mode) |
368 | { |
369 | /* The old body of this is now in non-LAYER part of perlio.c |
370 | * This is a stub for any XS code which might have been calling it. |
371 | */ |
372 | const char *name = ":raw"; |
373 | #ifdef PERLIO_USING_CRLF |
374 | if (!(mode & O_BINARY)) |
375 | name = ":crlf"; |
376 | #endif |
377 | return PerlIO_binmode(aTHX_ fp, iotype, mode, name); |
378 | } |
379 | |
380 | |
7ee2227d |
381 | /* |
382 | * Local variables: |
383 | * c-indentation-style: bsd |
384 | * c-basic-offset: 4 |
385 | * indent-tabs-mode: t |
386 | * End: |
387 | * |
388 | * ex: set ts=8 sts=4 sw=4 noet: |
389 | */ |