This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
All the private implementations of @foo for compilers that can't do
[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 /*
146 =for apidoc sv_iv
147
148 A private implementation of the C<SvIVx> macro for compilers which can't
149 cope with complex macro expressions. Always use the macro instead.
150
151 =cut
152 */
153
154 IV
155 Perl_sv_iv(pTHX_ register SV *sv)
156 {
157     if (SvIOK(sv)) {
158         if (SvIsUV(sv))
159             return (IV)SvUVX(sv);
160         return SvIVX(sv);
161     }
162     return sv_2iv(sv);
163 }
164
165 /*
166 =for apidoc sv_uv
167
168 A private implementation of the C<SvUVx> macro for compilers which can't
169 cope with complex macro expressions. Always use the macro instead.
170
171 =cut
172 */
173
174 UV
175 Perl_sv_uv(pTHX_ register SV *sv)
176 {
177     if (SvIOK(sv)) {
178         if (SvIsUV(sv))
179             return SvUVX(sv);
180         return (UV)SvIVX(sv);
181     }
182     return sv_2uv(sv);
183 }
184
185 /*
186 =for apidoc sv_nv
187
188 A private implementation of the C<SvNVx> macro for compilers which can't
189 cope with complex macro expressions. Always use the macro instead.
190
191 =cut
192 */
193
194 NV
195 Perl_sv_nv(pTHX_ register SV *sv)
196 {
197     if (SvNOK(sv))
198         return SvNVX(sv);
199     return sv_2nv(sv);
200 }
201
202 /*
203 =for apidoc sv_pv
204
205 Use the C<SvPV_nolen> macro instead
206
207 =for apidoc sv_pvn
208
209 A private implementation of the C<SvPV> macro for compilers which can't
210 cope with complex macro expressions. Always use the macro instead.
211
212 =cut
213 */
214
215 char *
216 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
217 {
218     if (SvPOK(sv)) {
219         *lp = SvCUR(sv);
220         return SvPVX(sv);
221     }
222     return sv_2pv(sv, lp);
223 }
224
225
226 char *
227 Perl_sv_pvn_nomg(pTHX_ register SV *sv, STRLEN *lp)
228 {
229     if (SvPOK(sv)) {
230         *lp = SvCUR(sv);
231         return SvPVX(sv);
232     }
233     return sv_2pv_flags(sv, lp, 0);
234 }
235
236 /* sv_pv() is now a macro using SvPV_nolen();
237  * this function provided for binary compatibility only
238  */
239
240 char *
241 Perl_sv_pv(pTHX_ SV *sv)
242 {
243     if (SvPOK(sv))
244         return SvPVX(sv);
245
246     return sv_2pv(sv, 0);
247 }
248
249 /* sv_pvn_force() is now a macro using Perl_sv_pvn_force_flags();
250  * this function provided for binary compatibility only
251  */
252
253 char *
254 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
255 {
256     return sv_pvn_force_flags(sv, lp, SV_GMAGIC);
257 }
258
259 /* sv_pvbyte () is now a macro using Perl_sv_2pv_flags();
260  * this function provided for binary compatibility only
261  */
262
263 char *
264 Perl_sv_pvbyte(pTHX_ SV *sv)
265 {
266     sv_utf8_downgrade(sv,0);
267     return sv_pv(sv);
268 }
269
270 /*
271 =for apidoc sv_pvbyte
272
273 Use C<SvPVbyte_nolen> instead.
274
275 =for apidoc sv_pvbyten
276
277 A private implementation of the C<SvPVbyte> macro for compilers
278 which can't cope with complex macro expressions. Always use the macro
279 instead.
280
281 =cut
282 */
283
284 char *
285 Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
286 {
287     sv_utf8_downgrade(sv,0);
288     return sv_pvn(sv,lp);
289 }
290
291 /* sv_pvutf8 () is now a macro using Perl_sv_2pv_flags();
292  * this function provided for binary compatibility only
293  */
294
295 char *
296 Perl_sv_pvutf8(pTHX_ SV *sv)
297 {
298     sv_utf8_upgrade(sv);
299     return sv_pv(sv);
300 }
301
302 /*
303 =for apidoc sv_pvutf8
304
305 Use the C<SvPVutf8_nolen> macro instead
306
307 =for apidoc sv_pvutf8n
308
309 A private implementation of the C<SvPVutf8> macro for compilers
310 which can't cope with complex macro expressions. Always use the macro
311 instead.
312
313 =cut
314 */
315
316 char *
317 Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
318 {
319     sv_utf8_upgrade(sv);
320     return sv_pvn(sv,lp);
321 }
322
323 /* sv_utf8_upgrade() is now a macro using sv_utf8_upgrade_flags();
324  * this function provided for binary compatibility only
325  */
326
327 STRLEN
328 Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
329 {
330     return sv_utf8_upgrade_flags(sv, SV_GMAGIC);
331 }
332
333 /*
334 =for apidoc A|U8 *|uvchr_to_utf8|U8 *d|UV uv
335
336 Adds the UTF-8 representation of the Native codepoint C<uv> to the end
337 of the string C<d>; C<d> should be have at least C<UTF8_MAXBYTES+1> free
338 bytes available. The return value is the pointer to the byte after the
339 end of the new character. In other words,
340
341     d = uvchr_to_utf8(d, uv);
342
343 is the recommended wide native character-aware way of saying
344
345     *(d++) = uv;
346
347 =cut
348 */
349
350 /* On ASCII machines this is normally a macro but we want a
351    real function in case XS code wants it
352 */
353 #undef Perl_uvchr_to_utf8
354 U8 *
355 Perl_uvchr_to_utf8(pTHX_ U8 *d, UV uv)
356 {
357     return Perl_uvuni_to_utf8_flags(aTHX_ d, NATIVE_TO_UNI(uv), 0);
358 }
359
360
361 /*
362 =for apidoc A|UV|utf8n_to_uvchr|U8 *s|STRLEN curlen|STRLEN *retlen|U32 
363 flags
364
365 Returns the native character value of the first character in the string 
366 C<s>
367 which is assumed to be in UTF-8 encoding; C<retlen> will be set to the
368 length, in bytes, of that character.
369
370 Allows length and flags to be passed to low level routine.
371
372 =cut
373 */
374 /* On ASCII machines this is normally a macro but we want
375    a real function in case XS code wants it
376 */
377 #undef Perl_utf8n_to_uvchr
378 UV
379 Perl_utf8n_to_uvchr(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen, 
380 U32 flags)
381 {
382     const UV uv = Perl_utf8n_to_uvuni(aTHX_ s, curlen, retlen, flags);
383     return UNI_TO_NATIVE(uv);
384 }
385 int
386 Perl_fprintf_nocontext(PerlIO *stream, const char *format, ...)
387 {
388     dTHXs;
389     va_list(arglist);
390     va_start(arglist, format);
391     return PerlIO_vprintf(stream, format, arglist);
392 }
393
394 int
395 Perl_printf_nocontext(const char *format, ...)
396 {
397     dTHX;
398     va_list(arglist);
399     va_start(arglist, format);
400     return PerlIO_vprintf(PerlIO_stdout(), format, arglist);
401 }
402
403 #if defined(HUGE_VAL) || (defined(USE_LONG_DOUBLE) && defined(HUGE_VALL))
404 /*
405  * This hack is to force load of "huge" support from libm.a
406  * So it is in perl for (say) POSIX to use.
407  * Needed for SunOS with Sun's 'acc' for example.
408  */
409 NV
410 Perl_huge(void)
411 {
412 #   if defined(USE_LONG_DOUBLE) && defined(HUGE_VALL)
413     return HUGE_VALL;
414 #   endif
415     return HUGE_VAL;
416 }
417 #endif
418
419 #ifndef USE_SFIO
420 int
421 perlsio_binmode(FILE *fp, int iotype, int mode)
422 {
423     /*
424      * This used to be contents of do_binmode in doio.c
425      */
426 #ifdef DOSISH
427 #  if defined(atarist) || defined(__MINT__)
428     if (!fflush(fp)) {
429         if (mode & O_BINARY)
430             ((FILE *) fp)->_flag |= _IOBIN;
431         else
432             ((FILE *) fp)->_flag &= ~_IOBIN;
433         return 1;
434     }
435     return 0;
436 #  else
437     dTHX;
438 #ifdef NETWARE
439     if (PerlLIO_setmode(fp, mode) != -1) {
440 #else
441     if (PerlLIO_setmode(fileno(fp), mode) != -1) {
442 #endif
443 #    if defined(WIN32) && defined(__BORLANDC__)
444         /*
445          * The translation mode of the stream is maintained independent 
446 of
447          * the translation mode of the fd in the Borland RTL (heavy
448          * digging through their runtime sources reveal).  User has to 
449 set
450          * the mode explicitly for the stream (though they don't 
451 document
452          * this anywhere). GSAR 97-5-24
453          */
454         fseek(fp, 0L, 0);
455         if (mode & O_BINARY)
456             fp->flags |= _F_BIN;
457         else
458             fp->flags &= ~_F_BIN;
459 #    endif
460         return 1;
461     }
462     else
463         return 0;
464 #  endif
465 #else
466 #  if defined(USEMYBINMODE)
467     dTHX;
468     if (my_binmode(fp, iotype, mode) != FALSE)
469         return 1;
470     else
471         return 0;
472 #  else
473     PERL_UNUSED_ARG(fp);
474     PERL_UNUSED_ARG(iotype);
475     PERL_UNUSED_ARG(mode);
476     return 1;
477 #  endif
478 #endif
479 }
480 #endif /* sfio */
481
482 /* compatibility with versions <= 5.003. */
483 void
484 Perl_gv_fullname(pTHX_ SV *sv, const GV *gv)
485 {
486     gv_fullname3(sv, gv, sv == (const SV*)gv ? "*" : "");
487 }
488
489 /* compatibility with versions <= 5.003. */
490 void
491 Perl_gv_efullname(pTHX_ SV *sv, const GV *gv)
492 {
493     gv_efullname3(sv, gv, sv == (const SV*)gv ? "*" : "");
494 }
495
496 void
497 Perl_gv_fullname3(pTHX_ SV *sv, const GV *gv, const char *prefix)
498 {
499     gv_fullname4(sv, gv, prefix, TRUE);
500 }
501
502 void
503 Perl_gv_efullname3(pTHX_ SV *sv, const GV *gv, const char *prefix)
504 {
505     gv_efullname4(sv, gv, prefix, TRUE);
506 }
507
508 AV *
509 Perl_av_fake(pTHX_ register I32 size, register SV **strp)
510 {
511     register SV** ary;
512     register AV * const av = (AV*)NEWSV(9,0);
513
514     sv_upgrade((SV *)av, SVt_PVAV);
515     Newx(ary,size+1,SV*);
516     AvALLOC(av) = ary;
517     Copy(strp,ary,size,SV*);
518     AvREIFY_only(av);
519     SvPV_set(av, (char*)ary);
520     AvFILLp(av) = size - 1;
521     AvMAX(av) = size - 1;
522     while (size--) {
523         assert (*strp);
524         SvTEMP_off(*strp);
525         strp++;
526     }
527     return av;
528 }
529
530 bool
531 Perl_do_open9(pTHX_ GV *gv, register const char *name, I32 len, int 
532 as_raw,
533               int rawmode, int rawperm, PerlIO *supplied_fp, SV *svs,
534               I32 num_svs)
535 {
536     PERL_UNUSED_ARG(num_svs);
537     return do_openn(gv, name, len, as_raw, rawmode, rawperm,
538                     supplied_fp, &svs, 1);
539 }
540
541 int
542 Perl_do_binmode(pTHX_ PerlIO *fp, int iotype, int mode)
543 {
544  /* The old body of this is now in non-LAYER part of perlio.c
545   * This is a stub for any XS code which might have been calling it.
546   */
547  const char *name = ":raw";
548 #ifdef PERLIO_USING_CRLF
549  if (!(mode & O_BINARY))
550      name = ":crlf";
551 #endif
552  return PerlIO_binmode(aTHX_ fp, iotype, mode, name);
553 }
554
555
556 /*
557  * Local variables:
558  * c-indentation-style: bsd
559  * c-basic-offset: 4
560  * indent-tabs-mode: t
561  * End:
562  *
563  * ex: set ts=8 sts=4 sw=4 noet:
564  */