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