This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
a9fad364a36cc6cb2ca2d2c542d72e92fdf0df68
[perl5.git] / mathoms.c
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
19  * versions of Perl.  For binary or source compatibility reasons, though,
20  * we cannot completely remove them from the core code.  
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
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
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  */