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