This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
sv_taint() can easily be replaced by a macro.
[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_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
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
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
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
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
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
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  */