This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Replace sv_force_normal with a macro that calls sv_force_normal_flags.
[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 /*
191 =for apidoc A|U8 *|uvchr_to_utf8|U8 *d|UV uv
192
193 Adds the UTF-8 representation of the Native codepoint C<uv> to the end
194 of the string C<d>; C<d> should be have at least C<UTF8_MAXBYTES+1> free
195 bytes available. The return value is the pointer to the byte after the
196 end of the new character. In other words,
197
198     d = uvchr_to_utf8(d, uv);
199
200 is the recommended wide native character-aware way of saying
201
202     *(d++) = uv;
203
204 =cut
205 */
206
207 /* On ASCII machines this is normally a macro but we want a
208    real function in case XS code wants it
209 */
210 #undef Perl_uvchr_to_utf8
211 U8 *
212 Perl_uvchr_to_utf8(pTHX_ U8 *d, UV uv)
213 {
214     return Perl_uvuni_to_utf8_flags(aTHX_ d, NATIVE_TO_UNI(uv), 0);
215 }
216
217
218 /*
219 =for apidoc A|UV|utf8n_to_uvchr|U8 *s|STRLEN curlen|STRLEN *retlen|U32 
220 flags
221
222 Returns the native character value of the first character in the string 
223 C<s>
224 which is assumed to be in UTF-8 encoding; C<retlen> will be set to the
225 length, in bytes, of that character.
226
227 Allows length and flags to be passed to low level routine.
228
229 =cut
230 */
231 /* On ASCII machines this is normally a macro but we want
232    a real function in case XS code wants it
233 */
234 #undef Perl_utf8n_to_uvchr
235 UV
236 Perl_utf8n_to_uvchr(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen, 
237 U32 flags)
238 {
239     const UV uv = Perl_utf8n_to_uvuni(aTHX_ s, curlen, retlen, flags);
240     return UNI_TO_NATIVE(uv);
241 }
242 int
243 Perl_fprintf_nocontext(PerlIO *stream, const char *format, ...)
244 {
245     dTHXs;
246     va_list(arglist);
247     va_start(arglist, format);
248     return PerlIO_vprintf(stream, format, arglist);
249 }
250
251 int
252 Perl_printf_nocontext(const char *format, ...)
253 {
254     dTHX;
255     va_list(arglist);
256     va_start(arglist, format);
257     return PerlIO_vprintf(PerlIO_stdout(), format, arglist);
258 }
259
260 #if defined(HUGE_VAL) || (defined(USE_LONG_DOUBLE) && defined(HUGE_VALL))
261 /*
262  * This hack is to force load of "huge" support from libm.a
263  * So it is in perl for (say) POSIX to use.
264  * Needed for SunOS with Sun's 'acc' for example.
265  */
266 NV
267 Perl_huge(void)
268 {
269 #   if defined(USE_LONG_DOUBLE) && defined(HUGE_VALL)
270     return HUGE_VALL;
271 #   endif
272     return HUGE_VAL;
273 }
274 #endif
275
276 #ifndef USE_SFIO
277 int
278 perlsio_binmode(FILE *fp, int iotype, int mode)
279 {
280     /*
281      * This used to be contents of do_binmode in doio.c
282      */
283 #ifdef DOSISH
284 #  if defined(atarist) || defined(__MINT__)
285     if (!fflush(fp)) {
286         if (mode & O_BINARY)
287             ((FILE *) fp)->_flag |= _IOBIN;
288         else
289             ((FILE *) fp)->_flag &= ~_IOBIN;
290         return 1;
291     }
292     return 0;
293 #  else
294     dTHX;
295 #ifdef NETWARE
296     if (PerlLIO_setmode(fp, mode) != -1) {
297 #else
298     if (PerlLIO_setmode(fileno(fp), mode) != -1) {
299 #endif
300 #    if defined(WIN32) && defined(__BORLANDC__)
301         /*
302          * The translation mode of the stream is maintained independent 
303 of
304          * the translation mode of the fd in the Borland RTL (heavy
305          * digging through their runtime sources reveal).  User has to 
306 set
307          * the mode explicitly for the stream (though they don't 
308 document
309          * this anywhere). GSAR 97-5-24
310          */
311         fseek(fp, 0L, 0);
312         if (mode & O_BINARY)
313             fp->flags |= _F_BIN;
314         else
315             fp->flags &= ~_F_BIN;
316 #    endif
317         return 1;
318     }
319     else
320         return 0;
321 #  endif
322 #else
323 #  if defined(USEMYBINMODE)
324     dTHX;
325     if (my_binmode(fp, iotype, mode) != FALSE)
326         return 1;
327     else
328         return 0;
329 #  else
330     PERL_UNUSED_ARG(fp);
331     PERL_UNUSED_ARG(iotype);
332     PERL_UNUSED_ARG(mode);
333     return 1;
334 #  endif
335 #endif
336 }
337 #endif /* sfio */
338
339 /* compatibility with versions <= 5.003. */
340 void
341 Perl_gv_fullname(pTHX_ SV *sv, const GV *gv)
342 {
343     gv_fullname3(sv, gv, sv == (const SV*)gv ? "*" : "");
344 }
345
346 /* compatibility with versions <= 5.003. */
347 void
348 Perl_gv_efullname(pTHX_ SV *sv, const GV *gv)
349 {
350     gv_efullname3(sv, gv, sv == (const SV*)gv ? "*" : "");
351 }
352
353 void
354 Perl_gv_fullname3(pTHX_ SV *sv, const GV *gv, const char *prefix)
355 {
356     gv_fullname4(sv, gv, prefix, TRUE);
357 }
358
359 void
360 Perl_gv_efullname3(pTHX_ SV *sv, const GV *gv, const char *prefix)
361 {
362     gv_efullname4(sv, gv, prefix, TRUE);
363 }
364
365 AV *
366 Perl_av_fake(pTHX_ register I32 size, register SV **strp)
367 {
368     register SV** ary;
369     register AV * const av = (AV*)NEWSV(9,0);
370
371     sv_upgrade((SV *)av, SVt_PVAV);
372     Newx(ary,size+1,SV*);
373     AvALLOC(av) = ary;
374     Copy(strp,ary,size,SV*);
375     AvREIFY_only(av);
376     SvPV_set(av, (char*)ary);
377     AvFILLp(av) = size - 1;
378     AvMAX(av) = size - 1;
379     while (size--) {
380         assert (*strp);
381         SvTEMP_off(*strp);
382         strp++;
383     }
384     return av;
385 }
386
387 bool
388 Perl_do_open9(pTHX_ GV *gv, register const char *name, I32 len, int 
389 as_raw,
390               int rawmode, int rawperm, PerlIO *supplied_fp, SV *svs,
391               I32 num_svs)
392 {
393     PERL_UNUSED_ARG(num_svs);
394     return do_openn(gv, name, len, as_raw, rawmode, rawperm,
395                     supplied_fp, &svs, 1);
396 }
397
398 int
399 Perl_do_binmode(pTHX_ PerlIO *fp, int iotype, int mode)
400 {
401  /* The old body of this is now in non-LAYER part of perlio.c
402   * This is a stub for any XS code which might have been calling it.
403   */
404  const char *name = ":raw";
405 #ifdef PERLIO_USING_CRLF
406  if (!(mode & O_BINARY))
407      name = ":crlf";
408 #endif
409  return PerlIO_binmode(aTHX_ fp, iotype, mode, name);
410 }
411
412
413 /*
414  * Local variables:
415  * c-indentation-style: bsd
416  * c-basic-offset: 4
417  * indent-tabs-mode: t
418  * End:
419  *
420  * ex: set ts=8 sts=4 sw=4 noet:
421  */