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 | |
39 | /* sv_2iv() is now a macro using Perl_sv_2iv_flags(); |
40 | * this function provided for binary compatibility only |
41 | */ |
42 | |
43 | IV |
44 | Perl_sv_2iv(pTHX_ register SV *sv) |
45 | { |
46 | return sv_2iv_flags(sv, SV_GMAGIC); |
47 | } |
48 | |
49 | /* sv_2uv() is now a macro using Perl_sv_2uv_flags(); |
50 | * this function provided for binary compatibility only |
51 | */ |
52 | |
53 | UV |
54 | Perl_sv_2uv(pTHX_ register SV *sv) |
55 | { |
56 | return sv_2uv_flags(sv, SV_GMAGIC); |
57 | } |
58 | |
59 | /* sv_2pv() is now a macro using Perl_sv_2pv_flags(); |
60 | * this function provided for binary compatibility only |
61 | */ |
62 | |
63 | char * |
64 | Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp) |
65 | { |
66 | return sv_2pv_flags(sv, lp, SV_GMAGIC); |
67 | } |
68 | |
69 | |
70 | /* sv_setsv() is now a macro using Perl_sv_setsv_flags(); |
71 | * this function provided for binary compatibility only |
72 | */ |
73 | |
74 | void |
75 | Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr) |
76 | { |
77 | sv_setsv_flags(dstr, sstr, SV_GMAGIC); |
78 | } |
79 | |
80 | /* sv_catpvn() is now a macro using Perl_sv_catpvn_flags(); |
81 | * this function provided for binary compatibility only |
82 | */ |
83 | |
84 | void |
85 | Perl_sv_catpvn(pTHX_ SV *dsv, const char* sstr, STRLEN slen) |
86 | { |
87 | sv_catpvn_flags(dsv, sstr, slen, SV_GMAGIC); |
88 | } |
89 | |
90 | /* sv_catsv() is now a macro using Perl_sv_catsv_flags(); |
91 | * this function provided for binary compatibility only |
92 | */ |
93 | |
94 | void |
95 | Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr) |
96 | { |
97 | sv_catsv_flags(dstr, sstr, SV_GMAGIC); |
98 | } |
99 | |
100 | /* sv_pv() is now a macro using SvPV_nolen(); |
101 | * this function provided for binary compatibility only |
102 | */ |
103 | |
104 | char * |
105 | Perl_sv_pv(pTHX_ SV *sv) |
106 | { |
107 | if (SvPOK(sv)) |
108 | return SvPVX(sv); |
109 | |
110 | return sv_2pv(sv, 0); |
111 | } |
112 | |
113 | /* sv_pvn_force() is now a macro using Perl_sv_pvn_force_flags(); |
114 | * this function provided for binary compatibility only |
115 | */ |
116 | |
117 | char * |
118 | Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp) |
119 | { |
120 | return sv_pvn_force_flags(sv, lp, SV_GMAGIC); |
121 | } |
122 | |
123 | /* sv_pvbyte () is now a macro using Perl_sv_2pv_flags(); |
124 | * this function provided for binary compatibility only |
125 | */ |
126 | |
127 | char * |
128 | Perl_sv_pvbyte(pTHX_ SV *sv) |
129 | { |
130 | sv_utf8_downgrade(sv,0); |
131 | return sv_pv(sv); |
132 | } |
133 | |
134 | /* sv_pvutf8 () is now a macro using Perl_sv_2pv_flags(); |
135 | * this function provided for binary compatibility only |
136 | */ |
137 | |
138 | char * |
139 | Perl_sv_pvutf8(pTHX_ SV *sv) |
140 | { |
141 | sv_utf8_upgrade(sv); |
142 | return sv_pv(sv); |
143 | } |
144 | |
145 | /* |
146 | =for apidoc A|U8 *|uvchr_to_utf8|U8 *d|UV uv |
147 | |
148 | Adds the UTF-8 representation of the Native codepoint C<uv> to the end |
149 | of the string C<d>; C<d> should be have at least C<UTF8_MAXBYTES+1> free |
150 | bytes available. The return value is the pointer to the byte after the |
151 | end of the new character. In other words, |
152 | |
153 | d = uvchr_to_utf8(d, uv); |
154 | |
155 | is the recommended wide native character-aware way of saying |
156 | |
157 | *(d++) = uv; |
158 | |
159 | =cut |
160 | */ |
161 | |
162 | /* On ASCII machines this is normally a macro but we want a |
163 | real function in case XS code wants it |
164 | */ |
165 | #undef Perl_uvchr_to_utf8 |
166 | U8 * |
167 | Perl_uvchr_to_utf8(pTHX_ U8 *d, UV uv) |
168 | { |
169 | return Perl_uvuni_to_utf8_flags(aTHX_ d, NATIVE_TO_UNI(uv), 0); |
170 | } |
171 | |
172 | |
173 | /* |
174 | =for apidoc A|UV|utf8n_to_uvchr|U8 *s|STRLEN curlen|STRLEN *retlen|U32 |
175 | flags |
176 | |
177 | Returns the native character value of the first character in the string |
178 | C<s> |
179 | which is assumed to be in UTF-8 encoding; C<retlen> will be set to the |
180 | length, in bytes, of that character. |
181 | |
182 | Allows length and flags to be passed to low level routine. |
183 | |
184 | =cut |
185 | */ |
186 | /* On ASCII machines this is normally a macro but we want |
187 | a real function in case XS code wants it |
188 | */ |
189 | #undef Perl_utf8n_to_uvchr |
190 | UV |
191 | Perl_utf8n_to_uvchr(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen, |
192 | U32 flags) |
193 | { |
194 | const UV uv = Perl_utf8n_to_uvuni(aTHX_ s, curlen, retlen, flags); |
195 | return UNI_TO_NATIVE(uv); |
196 | } |
197 | int |
198 | Perl_fprintf_nocontext(PerlIO *stream, const char *format, ...) |
199 | { |
200 | dTHXs; |
201 | va_list(arglist); |
202 | va_start(arglist, format); |
203 | return PerlIO_vprintf(stream, format, arglist); |
204 | } |
205 | |
206 | int |
207 | Perl_printf_nocontext(const char *format, ...) |
208 | { |
209 | dTHX; |
210 | va_list(arglist); |
211 | va_start(arglist, format); |
212 | return PerlIO_vprintf(PerlIO_stdout(), format, arglist); |
213 | } |
214 | |
215 | #if defined(HUGE_VAL) || (defined(USE_LONG_DOUBLE) && defined(HUGE_VALL)) |
216 | /* |
217 | * This hack is to force load of "huge" support from libm.a |
218 | * So it is in perl for (say) POSIX to use. |
219 | * Needed for SunOS with Sun's 'acc' for example. |
220 | */ |
221 | NV |
222 | Perl_huge(void) |
223 | { |
224 | # if defined(USE_LONG_DOUBLE) && defined(HUGE_VALL) |
225 | return HUGE_VALL; |
226 | # endif |
227 | return HUGE_VAL; |
228 | } |
229 | #endif |
230 | |
231 | #ifndef USE_SFIO |
232 | int |
233 | perlsio_binmode(FILE *fp, int iotype, int mode) |
234 | { |
235 | /* |
236 | * This used to be contents of do_binmode in doio.c |
237 | */ |
238 | #ifdef DOSISH |
239 | # if defined(atarist) || defined(__MINT__) |
240 | if (!fflush(fp)) { |
241 | if (mode & O_BINARY) |
242 | ((FILE *) fp)->_flag |= _IOBIN; |
243 | else |
244 | ((FILE *) fp)->_flag &= ~_IOBIN; |
245 | return 1; |
246 | } |
247 | return 0; |
248 | # else |
249 | dTHX; |
250 | #ifdef NETWARE |
251 | if (PerlLIO_setmode(fp, mode) != -1) { |
252 | #else |
253 | if (PerlLIO_setmode(fileno(fp), mode) != -1) { |
254 | #endif |
255 | # if defined(WIN32) && defined(__BORLANDC__) |
256 | /* |
257 | * The translation mode of the stream is maintained independent |
258 | of |
259 | * the translation mode of the fd in the Borland RTL (heavy |
260 | * digging through their runtime sources reveal). User has to |
261 | set |
262 | * the mode explicitly for the stream (though they don't |
263 | document |
264 | * this anywhere). GSAR 97-5-24 |
265 | */ |
266 | fseek(fp, 0L, 0); |
267 | if (mode & O_BINARY) |
268 | fp->flags |= _F_BIN; |
269 | else |
270 | fp->flags &= ~_F_BIN; |
271 | # endif |
272 | return 1; |
273 | } |
274 | else |
275 | return 0; |
276 | # endif |
277 | #else |
278 | # if defined(USEMYBINMODE) |
279 | dTHX; |
280 | if (my_binmode(fp, iotype, mode) != FALSE) |
281 | return 1; |
282 | else |
283 | return 0; |
284 | # else |
285 | PERL_UNUSED_ARG(fp); |
286 | PERL_UNUSED_ARG(iotype); |
287 | PERL_UNUSED_ARG(mode); |
288 | return 1; |
289 | # endif |
290 | #endif |
291 | } |
292 | #endif /* sfio */ |
293 | |
f2f0f092 |
294 | /* compatibility with versions <= 5.003. */ |
295 | void |
296 | Perl_gv_fullname(pTHX_ SV *sv, const GV *gv) |
297 | { |
298 | gv_fullname3(sv, gv, sv == (const SV*)gv ? "*" : ""); |
299 | } |
300 | |
301 | /* compatibility with versions <= 5.003. */ |
302 | void |
303 | Perl_gv_efullname(pTHX_ SV *sv, const GV *gv) |
304 | { |
305 | gv_efullname3(sv, gv, sv == (const SV*)gv ? "*" : ""); |
306 | } |
307 | |
7ee2227d |
308 | /* |
309 | * Local variables: |
310 | * c-indentation-style: bsd |
311 | * c-basic-offset: 4 |
312 | * indent-tabs-mode: t |
313 | * End: |
314 | * |
315 | * ex: set ts=8 sts=4 sw=4 noet: |
316 | */ |