This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
4f35282a843448da0e3d3fa83649dd2089f66b62
[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 /*
40 =for apidoc sv_unref
41
42 Unsets the RV status of the SV, and decrements the reference count of
43 whatever was being referenced by the RV.  This can almost be thought of
44 as a reversal of C<newSVrv>.  This is C<sv_unref_flags> with the C<flag>
45 being zero.  See C<SvROK_off>.
46
47 =cut
48 */
49
50 void
51 Perl_sv_unref(pTHX_ SV *sv)
52 {
53     sv_unref_flags(sv, 0);
54 }
55
56 /*
57 =for apidoc sv_taint
58
59 Taint an SV. Use C<SvTAINTED_on> instead.
60 =cut
61 */
62
63 void
64 Perl_sv_taint(pTHX_ SV *sv)
65 {
66     sv_magic((sv), Nullsv, PERL_MAGIC_taint, Nullch, 0);
67 }
68
69 /* sv_2iv() is now a macro using Perl_sv_2iv_flags();
70  * this function provided for binary compatibility only
71  */
72
73 IV
74 Perl_sv_2iv(pTHX_ register SV *sv)
75 {
76     return sv_2iv_flags(sv, SV_GMAGIC);
77 }
78
79 /* sv_2uv() is now a macro using Perl_sv_2uv_flags();
80  * this function provided for binary compatibility only
81  */
82
83 UV
84 Perl_sv_2uv(pTHX_ register SV *sv)
85 {
86     return sv_2uv_flags(sv, SV_GMAGIC);
87 }
88
89 /* sv_2pv() is now a macro using Perl_sv_2pv_flags();
90  * this function provided for binary compatibility only
91  */
92
93 char *
94 Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
95 {
96     return sv_2pv_flags(sv, lp, SV_GMAGIC);
97 }
98
99 /*
100 =for apidoc sv_force_normal
101
102 Undo various types of fakery on an SV: if the PV is a shared string, make
103 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
104 an xpvmg. See also C<sv_force_normal_flags>.
105
106 =cut
107 */
108
109 void
110 Perl_sv_force_normal(pTHX_ register SV *sv)
111 {
112     sv_force_normal_flags(sv, 0);
113 }
114
115 /* sv_setsv() is now a macro using Perl_sv_setsv_flags();
116  * this function provided for binary compatibility only
117  */
118
119 void
120 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
121 {
122     sv_setsv_flags(dstr, sstr, SV_GMAGIC);
123 }
124
125 /* sv_catpvn() is now a macro using Perl_sv_catpvn_flags();
126  * this function provided for binary compatibility only
127  */
128
129 void
130 Perl_sv_catpvn(pTHX_ SV *dsv, const char* sstr, STRLEN slen)
131 {
132     sv_catpvn_flags(dsv, sstr, slen, SV_GMAGIC);
133 }
134
135 /* sv_catsv() is now a macro using Perl_sv_catsv_flags();
136  * this function provided for binary compatibility only
137  */
138
139 void
140 Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
141 {
142     sv_catsv_flags(dstr, sstr, SV_GMAGIC);
143 }
144
145 /* sv_pv() is now a macro using SvPV_nolen();
146  * this function provided for binary compatibility only
147  */
148
149 char *
150 Perl_sv_pv(pTHX_ SV *sv)
151 {
152     if (SvPOK(sv))
153         return SvPVX(sv);
154
155     return sv_2pv(sv, 0);
156 }
157
158 /* sv_pvn_force() is now a macro using Perl_sv_pvn_force_flags();
159  * this function provided for binary compatibility only
160  */
161
162 char *
163 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
164 {
165     return sv_pvn_force_flags(sv, lp, SV_GMAGIC);
166 }
167
168 /* sv_pvbyte () is now a macro using Perl_sv_2pv_flags();
169  * this function provided for binary compatibility only
170  */
171
172 char *
173 Perl_sv_pvbyte(pTHX_ SV *sv)
174 {
175     sv_utf8_downgrade(sv,0);
176     return sv_pv(sv);
177 }
178
179 /* sv_pvutf8 () is now a macro using Perl_sv_2pv_flags();
180  * this function provided for binary compatibility only
181  */
182
183 char *
184 Perl_sv_pvutf8(pTHX_ SV *sv)
185 {
186     sv_utf8_upgrade(sv);
187     return sv_pv(sv);
188 }
189
190 /* sv_utf8_upgrade() is now a macro using sv_utf8_upgrade_flags();
191  * this function provided for binary compatibility only
192  */
193
194 STRLEN
195 Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
196 {
197     return sv_utf8_upgrade_flags(sv, SV_GMAGIC);
198 }
199
200 /*
201 =for apidoc A|U8 *|uvchr_to_utf8|U8 *d|UV uv
202
203 Adds the UTF-8 representation of the Native codepoint C<uv> to the end
204 of the string C<d>; C<d> should be have at least C<UTF8_MAXBYTES+1> free
205 bytes available. The return value is the pointer to the byte after the
206 end of the new character. In other words,
207
208     d = uvchr_to_utf8(d, uv);
209
210 is the recommended wide native character-aware way of saying
211
212     *(d++) = uv;
213
214 =cut
215 */
216
217 /* On ASCII machines this is normally a macro but we want a
218    real function in case XS code wants it
219 */
220 #undef Perl_uvchr_to_utf8
221 U8 *
222 Perl_uvchr_to_utf8(pTHX_ U8 *d, UV uv)
223 {
224     return Perl_uvuni_to_utf8_flags(aTHX_ d, NATIVE_TO_UNI(uv), 0);
225 }
226
227
228 /*
229 =for apidoc A|UV|utf8n_to_uvchr|U8 *s|STRLEN curlen|STRLEN *retlen|U32 
230 flags
231
232 Returns the native character value of the first character in the string 
233 C<s>
234 which is assumed to be in UTF-8 encoding; C<retlen> will be set to the
235 length, in bytes, of that character.
236
237 Allows length and flags to be passed to low level routine.
238
239 =cut
240 */
241 /* On ASCII machines this is normally a macro but we want
242    a real function in case XS code wants it
243 */
244 #undef Perl_utf8n_to_uvchr
245 UV
246 Perl_utf8n_to_uvchr(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen, 
247 U32 flags)
248 {
249     const UV uv = Perl_utf8n_to_uvuni(aTHX_ s, curlen, retlen, flags);
250     return UNI_TO_NATIVE(uv);
251 }
252 int
253 Perl_fprintf_nocontext(PerlIO *stream, const char *format, ...)
254 {
255     dTHXs;
256     va_list(arglist);
257     va_start(arglist, format);
258     return PerlIO_vprintf(stream, format, arglist);
259 }
260
261 int
262 Perl_printf_nocontext(const char *format, ...)
263 {
264     dTHX;
265     va_list(arglist);
266     va_start(arglist, format);
267     return PerlIO_vprintf(PerlIO_stdout(), format, arglist);
268 }
269
270 #if defined(HUGE_VAL) || (defined(USE_LONG_DOUBLE) && defined(HUGE_VALL))
271 /*
272  * This hack is to force load of "huge" support from libm.a
273  * So it is in perl for (say) POSIX to use.
274  * Needed for SunOS with Sun's 'acc' for example.
275  */
276 NV
277 Perl_huge(void)
278 {
279 #   if defined(USE_LONG_DOUBLE) && defined(HUGE_VALL)
280     return HUGE_VALL;
281 #   endif
282     return HUGE_VAL;
283 }
284 #endif
285
286 #ifndef USE_SFIO
287 int
288 perlsio_binmode(FILE *fp, int iotype, int mode)
289 {
290     /*
291      * This used to be contents of do_binmode in doio.c
292      */
293 #ifdef DOSISH
294 #  if defined(atarist) || defined(__MINT__)
295     if (!fflush(fp)) {
296         if (mode & O_BINARY)
297             ((FILE *) fp)->_flag |= _IOBIN;
298         else
299             ((FILE *) fp)->_flag &= ~_IOBIN;
300         return 1;
301     }
302     return 0;
303 #  else
304     dTHX;
305 #ifdef NETWARE
306     if (PerlLIO_setmode(fp, mode) != -1) {
307 #else
308     if (PerlLIO_setmode(fileno(fp), mode) != -1) {
309 #endif
310 #    if defined(WIN32) && defined(__BORLANDC__)
311         /*
312          * The translation mode of the stream is maintained independent 
313 of
314          * the translation mode of the fd in the Borland RTL (heavy
315          * digging through their runtime sources reveal).  User has to 
316 set
317          * the mode explicitly for the stream (though they don't 
318 document
319          * this anywhere). GSAR 97-5-24
320          */
321         fseek(fp, 0L, 0);
322         if (mode & O_BINARY)
323             fp->flags |= _F_BIN;
324         else
325             fp->flags &= ~_F_BIN;
326 #    endif
327         return 1;
328     }
329     else
330         return 0;
331 #  endif
332 #else
333 #  if defined(USEMYBINMODE)
334     dTHX;
335     if (my_binmode(fp, iotype, mode) != FALSE)
336         return 1;
337     else
338         return 0;
339 #  else
340     PERL_UNUSED_ARG(fp);
341     PERL_UNUSED_ARG(iotype);
342     PERL_UNUSED_ARG(mode);
343     return 1;
344 #  endif
345 #endif
346 }
347 #endif /* sfio */
348
349 /* compatibility with versions <= 5.003. */
350 void
351 Perl_gv_fullname(pTHX_ SV *sv, const GV *gv)
352 {
353     gv_fullname3(sv, gv, sv == (const SV*)gv ? "*" : "");
354 }
355
356 /* compatibility with versions <= 5.003. */
357 void
358 Perl_gv_efullname(pTHX_ SV *sv, const GV *gv)
359 {
360     gv_efullname3(sv, gv, sv == (const SV*)gv ? "*" : "");
361 }
362
363 void
364 Perl_gv_fullname3(pTHX_ SV *sv, const GV *gv, const char *prefix)
365 {
366     gv_fullname4(sv, gv, prefix, TRUE);
367 }
368
369 void
370 Perl_gv_efullname3(pTHX_ SV *sv, const GV *gv, const char *prefix)
371 {
372     gv_efullname4(sv, gv, prefix, TRUE);
373 }
374
375 AV *
376 Perl_av_fake(pTHX_ register I32 size, register SV **strp)
377 {
378     register SV** ary;
379     register AV * const av = (AV*)NEWSV(9,0);
380
381     sv_upgrade((SV *)av, SVt_PVAV);
382     Newx(ary,size+1,SV*);
383     AvALLOC(av) = ary;
384     Copy(strp,ary,size,SV*);
385     AvREIFY_only(av);
386     SvPV_set(av, (char*)ary);
387     AvFILLp(av) = size - 1;
388     AvMAX(av) = size - 1;
389     while (size--) {
390         assert (*strp);
391         SvTEMP_off(*strp);
392         strp++;
393     }
394     return av;
395 }
396
397 bool
398 Perl_do_open9(pTHX_ GV *gv, register const char *name, I32 len, int 
399 as_raw,
400               int rawmode, int rawperm, PerlIO *supplied_fp, SV *svs,
401               I32 num_svs)
402 {
403     PERL_UNUSED_ARG(num_svs);
404     return do_openn(gv, name, len, as_raw, rawmode, rawperm,
405                     supplied_fp, &svs, 1);
406 }
407
408 int
409 Perl_do_binmode(pTHX_ PerlIO *fp, int iotype, int mode)
410 {
411  /* The old body of this is now in non-LAYER part of perlio.c
412   * This is a stub for any XS code which might have been calling it.
413   */
414  const char *name = ":raw";
415 #ifdef PERLIO_USING_CRLF
416  if (!(mode & O_BINARY))
417      name = ":crlf";
418 #endif
419  return PerlIO_binmode(aTHX_ fp, iotype, mode, name);
420 }
421
422
423 /*
424  * Local variables:
425  * c-indentation-style: bsd
426  * c-basic-offset: 4
427  * indent-tabs-mode: t
428  * End:
429  *
430  * ex: set ts=8 sts=4 sw=4 noet:
431  */