This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Replace gv_fetchmethod() with a macro to call gv_fetchmethod_autoload()
[perl5.git] / mathoms.c
CommitLineData
7ee2227d
SP
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
f2f0f092
NC
19 * versions of Perl. For binary or source compatibility reasons, though,
20 * we cannot completely remove them from the core code.
7ee2227d
SP
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 */
33OP *
34Perl_ref(pTHX_ OP *o, I32 type)
35{
36 return doref(o, type, TRUE);
37}
38
aae9cea0 39/*
174c73e3
NC
40=for apidoc sv_unref
41
42Unsets the RV status of the SV, and decrements the reference count of
43whatever was being referenced by the RV. This can almost be thought of
44as a reversal of C<newSVrv>. This is C<sv_unref_flags> with the C<flag>
45being zero. See C<SvROK_off>.
46
47=cut
48*/
49
50void
51Perl_sv_unref(pTHX_ SV *sv)
52{
53 sv_unref_flags(sv, 0);
54}
55
56/*
aae9cea0
NC
57=for apidoc sv_taint
58
59Taint an SV. Use C<SvTAINTED_on> instead.
60=cut
61*/
62
63void
64Perl_sv_taint(pTHX_ SV *sv)
65{
66 sv_magic((sv), Nullsv, PERL_MAGIC_taint, Nullch, 0);
67}
68
7ee2227d
SP
69/* sv_2iv() is now a macro using Perl_sv_2iv_flags();
70 * this function provided for binary compatibility only
71 */
72
73IV
74Perl_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
83UV
84Perl_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
93char *
94Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
95{
96 return sv_2pv_flags(sv, lp, SV_GMAGIC);
97}
98
5abc721d 99/*
cb2f1b7b
NC
100=for apidoc sv_2pv_nolen
101
102Like C<sv_2pv()>, but doesn't return the length too. You should usually
103use the macro wrapper C<SvPV_nolen(sv)> instead.
104=cut
105*/
106
107char *
108Perl_sv_2pv_nolen(pTHX_ register SV *sv)
109{
110 return sv_2pv(sv, 0);
111}
112
113/*
114=for apidoc sv_2pvbyte_nolen
115
116Return a pointer to the byte-encoded representation of the SV.
117May cause the SV to be downgraded from UTF-8 as a side-effect.
118
119Usually accessed via the C<SvPVbyte_nolen> macro.
120
121=cut
122*/
123
124char *
125Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
126{
127 return sv_2pvbyte(sv, 0);
128}
129
130/*
131=for apidoc sv_2pvutf8_nolen
132
133Return a pointer to the UTF-8-encoded representation of the SV.
134May cause the SV to be upgraded to UTF-8 as a side-effect.
135
136Usually accessed via the C<SvPVutf8_nolen> macro.
137
138=cut
139*/
140
141char *
142Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
143{
144 return sv_2pvutf8(sv, 0);
145}
146
147/*
5abc721d
NC
148=for apidoc sv_force_normal
149
150Undo various types of fakery on an SV: if the PV is a shared string, make
151a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
152an xpvmg. See also C<sv_force_normal_flags>.
153
154=cut
155*/
156
157void
158Perl_sv_force_normal(pTHX_ register SV *sv)
159{
160 sv_force_normal_flags(sv, 0);
161}
7ee2227d
SP
162
163/* sv_setsv() is now a macro using Perl_sv_setsv_flags();
164 * this function provided for binary compatibility only
165 */
166
167void
168Perl_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
177void
178Perl_sv_catpvn(pTHX_ SV *dsv, const char* sstr, STRLEN slen)
179{
180 sv_catpvn_flags(dsv, sstr, slen, SV_GMAGIC);
181}
182
b347df82
NC
183/*
184=for apidoc sv_catpvn_mg
185
186Like C<sv_catpvn>, but also handles 'set' magic.
187
188=cut
189*/
190
191void
192Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
193{
194 sv_catpvn_flags(sv,ptr,len,SV_GMAGIC|SV_SMAGIC);
195}
196
7ee2227d
SP
197/* sv_catsv() is now a macro using Perl_sv_catsv_flags();
198 * this function provided for binary compatibility only
199 */
200
201void
202Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
203{
204 sv_catsv_flags(dstr, sstr, SV_GMAGIC);
205}
206
0feed65a 207/*
b347df82
NC
208=for apidoc sv_catsv_mg
209
210Like C<sv_catsv>, but also handles 'set' magic.
211
212=cut
213*/
214
215void
216Perl_sv_catsv_mg(pTHX_ SV *dsv, register SV *ssv)
217{
218 sv_catsv_flags(dsv,ssv,SV_GMAGIC|SV_SMAGIC);
219}
220
221/*
0feed65a
NC
222=for apidoc sv_iv
223
224A private implementation of the C<SvIVx> macro for compilers which can't
225cope with complex macro expressions. Always use the macro instead.
226
227=cut
228*/
229
230IV
231Perl_sv_iv(pTHX_ register SV *sv)
232{
233 if (SvIOK(sv)) {
234 if (SvIsUV(sv))
235 return (IV)SvUVX(sv);
236 return SvIVX(sv);
237 }
238 return sv_2iv(sv);
239}
240
241/*
242=for apidoc sv_uv
243
244A private implementation of the C<SvUVx> macro for compilers which can't
245cope with complex macro expressions. Always use the macro instead.
246
247=cut
248*/
249
250UV
251Perl_sv_uv(pTHX_ register SV *sv)
252{
253 if (SvIOK(sv)) {
254 if (SvIsUV(sv))
255 return SvUVX(sv);
256 return (UV)SvIVX(sv);
257 }
258 return sv_2uv(sv);
259}
260
261/*
262=for apidoc sv_nv
263
264A private implementation of the C<SvNVx> macro for compilers which can't
265cope with complex macro expressions. Always use the macro instead.
266
267=cut
268*/
269
270NV
271Perl_sv_nv(pTHX_ register SV *sv)
272{
273 if (SvNOK(sv))
274 return SvNVX(sv);
275 return sv_2nv(sv);
276}
277
278/*
279=for apidoc sv_pv
280
281Use the C<SvPV_nolen> macro instead
282
283=for apidoc sv_pvn
284
285A private implementation of the C<SvPV> macro for compilers which can't
286cope with complex macro expressions. Always use the macro instead.
287
288=cut
289*/
290
291char *
292Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
293{
294 if (SvPOK(sv)) {
295 *lp = SvCUR(sv);
296 return SvPVX(sv);
297 }
298 return sv_2pv(sv, lp);
299}
300
301
302char *
303Perl_sv_pvn_nomg(pTHX_ register SV *sv, STRLEN *lp)
304{
305 if (SvPOK(sv)) {
306 *lp = SvCUR(sv);
307 return SvPVX(sv);
308 }
309 return sv_2pv_flags(sv, lp, 0);
310}
311
7ee2227d
SP
312/* sv_pv() is now a macro using SvPV_nolen();
313 * this function provided for binary compatibility only
314 */
315
316char *
317Perl_sv_pv(pTHX_ SV *sv)
318{
319 if (SvPOK(sv))
320 return SvPVX(sv);
321
322 return sv_2pv(sv, 0);
323}
324
325/* sv_pvn_force() is now a macro using Perl_sv_pvn_force_flags();
326 * this function provided for binary compatibility only
327 */
328
329char *
330Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
331{
332 return sv_pvn_force_flags(sv, lp, SV_GMAGIC);
333}
334
335/* sv_pvbyte () is now a macro using Perl_sv_2pv_flags();
336 * this function provided for binary compatibility only
337 */
338
339char *
340Perl_sv_pvbyte(pTHX_ SV *sv)
341{
342 sv_utf8_downgrade(sv,0);
343 return sv_pv(sv);
344}
345
0feed65a
NC
346/*
347=for apidoc sv_pvbyte
348
349Use C<SvPVbyte_nolen> instead.
350
351=for apidoc sv_pvbyten
352
353A private implementation of the C<SvPVbyte> macro for compilers
354which can't cope with complex macro expressions. Always use the macro
355instead.
356
357=cut
358*/
359
360char *
361Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
362{
363 sv_utf8_downgrade(sv,0);
364 return sv_pvn(sv,lp);
365}
366
7ee2227d
SP
367/* sv_pvutf8 () is now a macro using Perl_sv_2pv_flags();
368 * this function provided for binary compatibility only
369 */
370
371char *
372Perl_sv_pvutf8(pTHX_ SV *sv)
373{
374 sv_utf8_upgrade(sv);
375 return sv_pv(sv);
376}
377
0feed65a
NC
378/*
379=for apidoc sv_pvutf8
380
381Use the C<SvPVutf8_nolen> macro instead
382
383=for apidoc sv_pvutf8n
384
385A private implementation of the C<SvPVutf8> macro for compilers
386which can't cope with complex macro expressions. Always use the macro
387instead.
388
389=cut
390*/
391
392char *
393Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
394{
395 sv_utf8_upgrade(sv);
396 return sv_pvn(sv,lp);
397}
398
205c02c2
NC
399/* sv_utf8_upgrade() is now a macro using sv_utf8_upgrade_flags();
400 * this function provided for binary compatibility only
401 */
402
403STRLEN
404Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
405{
406 return sv_utf8_upgrade_flags(sv, SV_GMAGIC);
407}
408
7ee2227d
SP
409/*
410=for apidoc A|U8 *|uvchr_to_utf8|U8 *d|UV uv
411
412Adds the UTF-8 representation of the Native codepoint C<uv> to the end
413of the string C<d>; C<d> should be have at least C<UTF8_MAXBYTES+1> free
414bytes available. The return value is the pointer to the byte after the
415end of the new character. In other words,
416
417 d = uvchr_to_utf8(d, uv);
418
419is the recommended wide native character-aware way of saying
420
421 *(d++) = uv;
422
423=cut
424*/
425
426/* On ASCII machines this is normally a macro but we want a
427 real function in case XS code wants it
428*/
429#undef Perl_uvchr_to_utf8
430U8 *
431Perl_uvchr_to_utf8(pTHX_ U8 *d, UV uv)
432{
433 return Perl_uvuni_to_utf8_flags(aTHX_ d, NATIVE_TO_UNI(uv), 0);
434}
435
436
437/*
438=for apidoc A|UV|utf8n_to_uvchr|U8 *s|STRLEN curlen|STRLEN *retlen|U32
439flags
440
441Returns the native character value of the first character in the string
442C<s>
443which is assumed to be in UTF-8 encoding; C<retlen> will be set to the
444length, in bytes, of that character.
445
446Allows length and flags to be passed to low level routine.
447
448=cut
449*/
450/* On ASCII machines this is normally a macro but we want
451 a real function in case XS code wants it
452*/
453#undef Perl_utf8n_to_uvchr
454UV
455Perl_utf8n_to_uvchr(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen,
456U32 flags)
457{
458 const UV uv = Perl_utf8n_to_uvuni(aTHX_ s, curlen, retlen, flags);
459 return UNI_TO_NATIVE(uv);
460}
461int
462Perl_fprintf_nocontext(PerlIO *stream, const char *format, ...)
463{
464 dTHXs;
465 va_list(arglist);
466 va_start(arglist, format);
467 return PerlIO_vprintf(stream, format, arglist);
468}
469
470int
471Perl_printf_nocontext(const char *format, ...)
472{
473 dTHX;
474 va_list(arglist);
475 va_start(arglist, format);
476 return PerlIO_vprintf(PerlIO_stdout(), format, arglist);
477}
478
479#if defined(HUGE_VAL) || (defined(USE_LONG_DOUBLE) && defined(HUGE_VALL))
480/*
481 * This hack is to force load of "huge" support from libm.a
482 * So it is in perl for (say) POSIX to use.
483 * Needed for SunOS with Sun's 'acc' for example.
484 */
485NV
486Perl_huge(void)
487{
488# if defined(USE_LONG_DOUBLE) && defined(HUGE_VALL)
489 return HUGE_VALL;
490# endif
491 return HUGE_VAL;
492}
493#endif
494
495#ifndef USE_SFIO
496int
497perlsio_binmode(FILE *fp, int iotype, int mode)
498{
499 /*
500 * This used to be contents of do_binmode in doio.c
501 */
502#ifdef DOSISH
503# if defined(atarist) || defined(__MINT__)
504 if (!fflush(fp)) {
505 if (mode & O_BINARY)
506 ((FILE *) fp)->_flag |= _IOBIN;
507 else
508 ((FILE *) fp)->_flag &= ~_IOBIN;
509 return 1;
510 }
511 return 0;
512# else
513 dTHX;
514#ifdef NETWARE
515 if (PerlLIO_setmode(fp, mode) != -1) {
516#else
517 if (PerlLIO_setmode(fileno(fp), mode) != -1) {
518#endif
519# if defined(WIN32) && defined(__BORLANDC__)
520 /*
521 * The translation mode of the stream is maintained independent
522of
523 * the translation mode of the fd in the Borland RTL (heavy
524 * digging through their runtime sources reveal). User has to
525set
526 * the mode explicitly for the stream (though they don't
527document
528 * this anywhere). GSAR 97-5-24
529 */
530 fseek(fp, 0L, 0);
531 if (mode & O_BINARY)
532 fp->flags |= _F_BIN;
533 else
534 fp->flags &= ~_F_BIN;
535# endif
536 return 1;
537 }
538 else
539 return 0;
540# endif
541#else
542# if defined(USEMYBINMODE)
543 dTHX;
544 if (my_binmode(fp, iotype, mode) != FALSE)
545 return 1;
546 else
547 return 0;
548# else
549 PERL_UNUSED_ARG(fp);
550 PERL_UNUSED_ARG(iotype);
551 PERL_UNUSED_ARG(mode);
552 return 1;
553# endif
554#endif
555}
556#endif /* sfio */
557
f2f0f092
NC
558/* compatibility with versions <= 5.003. */
559void
560Perl_gv_fullname(pTHX_ SV *sv, const GV *gv)
561{
562 gv_fullname3(sv, gv, sv == (const SV*)gv ? "*" : "");
563}
564
565/* compatibility with versions <= 5.003. */
566void
567Perl_gv_efullname(pTHX_ SV *sv, const GV *gv)
568{
569 gv_efullname3(sv, gv, sv == (const SV*)gv ? "*" : "");
570}
571
2674aeec
NC
572void
573Perl_gv_fullname3(pTHX_ SV *sv, const GV *gv, const char *prefix)
574{
575 gv_fullname4(sv, gv, prefix, TRUE);
576}
577
578void
579Perl_gv_efullname3(pTHX_ SV *sv, const GV *gv, const char *prefix)
580{
581 gv_efullname4(sv, gv, prefix, TRUE);
582}
583
887986eb
NC
584/*
585=for apidoc gv_fetchmethod
586
587See L<gv_fetchmethod_autoload>.
588
589=cut
590*/
591
592GV *
593Perl_gv_fetchmethod(pTHX_ HV *stash, const char *name)
594{
595 return gv_fetchmethod_autoload(stash, name, TRUE);
596}
597
b966a812
SP
598AV *
599Perl_av_fake(pTHX_ register I32 size, register SV **strp)
600{
601 register SV** ary;
602 register AV * const av = (AV*)NEWSV(9,0);
603
604 sv_upgrade((SV *)av, SVt_PVAV);
605 Newx(ary,size+1,SV*);
606 AvALLOC(av) = ary;
607 Copy(strp,ary,size,SV*);
608 AvREIFY_only(av);
609 SvPV_set(av, (char*)ary);
610 AvFILLp(av) = size - 1;
611 AvMAX(av) = size - 1;
612 while (size--) {
613 assert (*strp);
614 SvTEMP_off(*strp);
615 strp++;
616 }
617 return av;
618}
619
34d367cd 620bool
e4dba786
NC
621Perl_do_open(pTHX_ GV *gv, register const char *name, I32 len, int as_raw,
622 int rawmode, int rawperm, PerlIO *supplied_fp)
623{
624 return do_openn(gv, name, len, as_raw, rawmode, rawperm,
625 supplied_fp, (SV **) NULL, 0);
626}
627
628bool
34d367cd
SP
629Perl_do_open9(pTHX_ GV *gv, register const char *name, I32 len, int
630as_raw,
631 int rawmode, int rawperm, PerlIO *supplied_fp, SV *svs,
632 I32 num_svs)
633{
634 PERL_UNUSED_ARG(num_svs);
635 return do_openn(gv, name, len, as_raw, rawmode, rawperm,
636 supplied_fp, &svs, 1);
637}
638
639int
640Perl_do_binmode(pTHX_ PerlIO *fp, int iotype, int mode)
641{
642 /* The old body of this is now in non-LAYER part of perlio.c
643 * This is a stub for any XS code which might have been calling it.
644 */
645 const char *name = ":raw";
646#ifdef PERLIO_USING_CRLF
647 if (!(mode & O_BINARY))
648 name = ":crlf";
649#endif
650 return PerlIO_binmode(aTHX_ fp, iotype, mode, name);
651}
652
a9f96b3f
NC
653#ifndef OS2
654bool
655Perl_do_aexec(pTHX_ SV *really, register SV **mark, register SV **sp)
656{
657 return do_aexec5(really, mark, sp, 0, 0);
658}
659#endif
660
9555a685
NC
661#ifdef PERL_DEFAULT_DO_EXEC3_IMPLEMENTATION
662bool
663Perl_do_exec(pTHX_ const char *cmd)
664{
665 return do_exec3(cmd,0,0);
666}
667#endif
668
f95f476d
NC
669#ifdef HAS_PIPE
670void
671Perl_do_pipe(pTHX_ SV *sv, GV *rgv, GV *wgv)
672{
673 register IO *rstio;
674 register IO *wstio;
675 int fd[2];
676
677 if (!rgv)
678 goto badexit;
679 if (!wgv)
680 goto badexit;
681
682 rstio = GvIOn(rgv);
683 wstio = GvIOn(wgv);
684
685 if (IoIFP(rstio))
686 do_close(rgv,FALSE);
687 if (IoIFP(wstio))
688 do_close(wgv,FALSE);
689
690 if (PerlProc_pipe(fd) < 0)
691 goto badexit;
692 IoIFP(rstio) = PerlIO_fdopen(fd[0], "r"PIPE_OPEN_MODE);
693 IoOFP(wstio) = PerlIO_fdopen(fd[1], "w"PIPE_OPEN_MODE);
694 IoOFP(rstio) = IoIFP(rstio);
695 IoIFP(wstio) = IoOFP(wstio);
696 IoTYPE(rstio) = IoTYPE_RDONLY;
697 IoTYPE(wstio) = IoTYPE_WRONLY;
698 if (!IoIFP(rstio) || !IoOFP(wstio)) {
699 if (IoIFP(rstio)) PerlIO_close(IoIFP(rstio));
700 else PerlLIO_close(fd[0]);
701 if (IoOFP(wstio)) PerlIO_close(IoOFP(wstio));
702 else PerlLIO_close(fd[1]);
703 goto badexit;
704 }
705
706 sv_setsv(sv,&PL_sv_yes);
707 return;
708
709badexit:
710 sv_setsv(sv,&PL_sv_undef);
711 return;
712}
713#endif
714
7ee2227d
SP
715/*
716 * Local variables:
717 * c-indentation-style: bsd
718 * c-basic-offset: 4
719 * indent-tabs-mode: t
720 * End:
721 *
722 * ex: set ts=8 sts=4 sw=4 noet:
723 */