This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Adjust test count
[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 /*
184 =for apidoc sv_catpvn_mg
185
186 Like C<sv_catpvn>, but also handles 'set' magic.
187
188 =cut
189 */
190
191 void
192 Perl_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
197 /* sv_catsv() is now a macro using Perl_sv_catsv_flags();
198  * this function provided for binary compatibility only
199  */
200
201 void
202 Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
203 {
204     sv_catsv_flags(dstr, sstr, SV_GMAGIC);
205 }
206
207 /*
208 =for apidoc sv_catsv_mg
209
210 Like C<sv_catsv>, but also handles 'set' magic.
211
212 =cut
213 */
214
215 void
216 Perl_sv_catsv_mg(pTHX_ SV *dsv, register SV *ssv)
217 {
218     sv_catsv_flags(dsv,ssv,SV_GMAGIC|SV_SMAGIC);
219 }
220
221 /*
222 =for apidoc sv_iv
223
224 A private implementation of the C<SvIVx> macro for compilers which can't
225 cope with complex macro expressions. Always use the macro instead.
226
227 =cut
228 */
229
230 IV
231 Perl_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
244 A private implementation of the C<SvUVx> macro for compilers which can't
245 cope with complex macro expressions. Always use the macro instead.
246
247 =cut
248 */
249
250 UV
251 Perl_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
264 A private implementation of the C<SvNVx> macro for compilers which can't
265 cope with complex macro expressions. Always use the macro instead.
266
267 =cut
268 */
269
270 NV
271 Perl_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
281 Use the C<SvPV_nolen> macro instead
282
283 =for apidoc sv_pvn
284
285 A private implementation of the C<SvPV> macro for compilers which can't
286 cope with complex macro expressions. Always use the macro instead.
287
288 =cut
289 */
290
291 char *
292 Perl_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
302 char *
303 Perl_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
312 /* sv_pv() is now a macro using SvPV_nolen();
313  * this function provided for binary compatibility only
314  */
315
316 char *
317 Perl_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
329 char *
330 Perl_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
339 char *
340 Perl_sv_pvbyte(pTHX_ SV *sv)
341 {
342     sv_utf8_downgrade(sv,0);
343     return sv_pv(sv);
344 }
345
346 /*
347 =for apidoc sv_pvbyte
348
349 Use C<SvPVbyte_nolen> instead.
350
351 =for apidoc sv_pvbyten
352
353 A private implementation of the C<SvPVbyte> macro for compilers
354 which can't cope with complex macro expressions. Always use the macro
355 instead.
356
357 =cut
358 */
359
360 char *
361 Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
362 {
363     sv_utf8_downgrade(sv,0);
364     return sv_pvn(sv,lp);
365 }
366
367 /* sv_pvutf8 () is now a macro using Perl_sv_2pv_flags();
368  * this function provided for binary compatibility only
369  */
370
371 char *
372 Perl_sv_pvutf8(pTHX_ SV *sv)
373 {
374     sv_utf8_upgrade(sv);
375     return sv_pv(sv);
376 }
377
378 /*
379 =for apidoc sv_pvutf8
380
381 Use the C<SvPVutf8_nolen> macro instead
382
383 =for apidoc sv_pvutf8n
384
385 A private implementation of the C<SvPVutf8> macro for compilers
386 which can't cope with complex macro expressions. Always use the macro
387 instead.
388
389 =cut
390 */
391
392 char *
393 Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
394 {
395     sv_utf8_upgrade(sv);
396     return sv_pvn(sv,lp);
397 }
398
399 /* sv_utf8_upgrade() is now a macro using sv_utf8_upgrade_flags();
400  * this function provided for binary compatibility only
401  */
402
403 STRLEN
404 Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
405 {
406     return sv_utf8_upgrade_flags(sv, SV_GMAGIC);
407 }
408
409 int
410 Perl_fprintf_nocontext(PerlIO *stream, const char *format, ...)
411 {
412     dTHXs;
413     va_list(arglist);
414     va_start(arglist, format);
415     return PerlIO_vprintf(stream, format, arglist);
416 }
417
418 int
419 Perl_printf_nocontext(const char *format, ...)
420 {
421     dTHX;
422     va_list(arglist);
423     va_start(arglist, format);
424     return PerlIO_vprintf(PerlIO_stdout(), format, arglist);
425 }
426
427 #if defined(HUGE_VAL) || (defined(USE_LONG_DOUBLE) && defined(HUGE_VALL))
428 /*
429  * This hack is to force load of "huge" support from libm.a
430  * So it is in perl for (say) POSIX to use.
431  * Needed for SunOS with Sun's 'acc' for example.
432  */
433 NV
434 Perl_huge(void)
435 {
436 #   if defined(USE_LONG_DOUBLE) && defined(HUGE_VALL)
437     return HUGE_VALL;
438 #   endif
439     return HUGE_VAL;
440 }
441 #endif
442
443 /* compatibility with versions <= 5.003. */
444 void
445 Perl_gv_fullname(pTHX_ SV *sv, const GV *gv)
446 {
447     gv_fullname3(sv, gv, sv == (const SV*)gv ? "*" : "");
448 }
449
450 /* compatibility with versions <= 5.003. */
451 void
452 Perl_gv_efullname(pTHX_ SV *sv, const GV *gv)
453 {
454     gv_efullname3(sv, gv, sv == (const SV*)gv ? "*" : "");
455 }
456
457 void
458 Perl_gv_fullname3(pTHX_ SV *sv, const GV *gv, const char *prefix)
459 {
460     gv_fullname4(sv, gv, prefix, TRUE);
461 }
462
463 void
464 Perl_gv_efullname3(pTHX_ SV *sv, const GV *gv, const char *prefix)
465 {
466     gv_efullname4(sv, gv, prefix, TRUE);
467 }
468
469 /*
470 =for apidoc gv_fetchmethod
471
472 See L<gv_fetchmethod_autoload>.
473
474 =cut
475 */
476
477 GV *
478 Perl_gv_fetchmethod(pTHX_ HV *stash, const char *name)
479 {
480     return gv_fetchmethod_autoload(stash, name, TRUE);
481 }
482
483 HE *
484 Perl_hv_iternext(pTHX_ HV *hv)
485 {
486     return hv_iternext_flags(hv, 0);
487 }
488
489 void
490 Perl_hv_magic(pTHX_ HV *hv, GV *gv, int how)
491 {
492     sv_magic((SV*)hv, (SV*)gv, how, Nullch, 0);
493 }
494
495 #if 0 /* use the macro from hv.h instead */
496
497 char*   
498 Perl_sharepvn(pTHX_ const char *sv, I32 len, U32 hash)
499 {
500     return HEK_KEY(share_hek(sv, len, hash));
501 }
502
503 #endif
504
505 AV *
506 Perl_av_fake(pTHX_ register I32 size, register SV **strp)
507 {
508     register SV** ary;
509     register AV * const av = (AV*)NEWSV(9,0);
510
511     sv_upgrade((SV *)av, SVt_PVAV);
512     Newx(ary,size+1,SV*);
513     AvALLOC(av) = ary;
514     Copy(strp,ary,size,SV*);
515     AvREIFY_only(av);
516     SvPV_set(av, (char*)ary);
517     AvFILLp(av) = size - 1;
518     AvMAX(av) = size - 1;
519     while (size--) {
520         assert (*strp);
521         SvTEMP_off(*strp);
522         strp++;
523     }
524     return av;
525 }
526
527 bool
528 Perl_do_open(pTHX_ GV *gv, register const char *name, I32 len, int as_raw,
529              int rawmode, int rawperm, PerlIO *supplied_fp)
530 {
531     return do_openn(gv, name, len, as_raw, rawmode, rawperm,
532                     supplied_fp, (SV **) NULL, 0);
533 }
534
535 bool
536 Perl_do_open9(pTHX_ GV *gv, register const char *name, I32 len, int 
537 as_raw,
538               int rawmode, int rawperm, PerlIO *supplied_fp, SV *svs,
539               I32 num_svs)
540 {
541     PERL_UNUSED_ARG(num_svs);
542     return do_openn(gv, name, len, as_raw, rawmode, rawperm,
543                     supplied_fp, &svs, 1);
544 }
545
546 int
547 Perl_do_binmode(pTHX_ PerlIO *fp, int iotype, int mode)
548 {
549  /* The old body of this is now in non-LAYER part of perlio.c
550   * This is a stub for any XS code which might have been calling it.
551   */
552  const char *name = ":raw";
553 #ifdef PERLIO_USING_CRLF
554  if (!(mode & O_BINARY))
555      name = ":crlf";
556 #endif
557  return PerlIO_binmode(aTHX_ fp, iotype, mode, name);
558 }
559
560 #ifndef OS2
561 bool
562 Perl_do_aexec(pTHX_ SV *really, register SV **mark, register SV **sp)
563 {
564     return do_aexec5(really, mark, sp, 0, 0);
565 }
566 #endif
567
568 #ifdef PERL_DEFAULT_DO_EXEC3_IMPLEMENTATION
569 bool
570 Perl_do_exec(pTHX_ const char *cmd)
571 {
572     return do_exec3(cmd,0,0);
573 }
574 #endif
575
576 #ifdef HAS_PIPE
577 void
578 Perl_do_pipe(pTHX_ SV *sv, GV *rgv, GV *wgv)
579 {
580     register IO *rstio;
581     register IO *wstio;
582     int fd[2];
583
584     if (!rgv)
585         goto badexit;
586     if (!wgv)
587         goto badexit;
588
589     rstio = GvIOn(rgv);
590     wstio = GvIOn(wgv);
591
592     if (IoIFP(rstio))
593         do_close(rgv,FALSE);
594     if (IoIFP(wstio))
595         do_close(wgv,FALSE);
596
597     if (PerlProc_pipe(fd) < 0)
598         goto badexit;
599     IoIFP(rstio) = PerlIO_fdopen(fd[0], "r"PIPE_OPEN_MODE);
600     IoOFP(wstio) = PerlIO_fdopen(fd[1], "w"PIPE_OPEN_MODE);
601     IoOFP(rstio) = IoIFP(rstio);
602     IoIFP(wstio) = IoOFP(wstio);
603     IoTYPE(rstio) = IoTYPE_RDONLY;
604     IoTYPE(wstio) = IoTYPE_WRONLY;
605     if (!IoIFP(rstio) || !IoOFP(wstio)) {
606         if (IoIFP(rstio)) PerlIO_close(IoIFP(rstio));
607         else PerlLIO_close(fd[0]);
608         if (IoOFP(wstio)) PerlIO_close(IoOFP(wstio));
609         else PerlLIO_close(fd[1]);
610         goto badexit;
611     }
612
613     sv_setsv(sv,&PL_sv_yes);
614     return;
615
616 badexit:
617     sv_setsv(sv,&PL_sv_undef);
618     return;
619 }
620 #endif
621
622 /* Backwards compatibility. */
623 int
624 Perl_init_i18nl14n(pTHX_ int printwarn)
625 {
626     return init_i18nl10n(printwarn);
627 }
628
629 /* XXX kept for BINCOMPAT only */
630 void
631 Perl_save_hints(pTHX)
632 {
633     Perl_croak(aTHX_ "internal error: obsolete function save_hints() called");
634 }
635
636 #if 0
637 OP *
638 Perl_ck_retarget(pTHX_ OP *o)
639 {
640     Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
641     /* STUB */
642     return o;
643 }
644 #endif
645
646 OP *
647 Perl_oopsCV(pTHX_ OP *o)
648 {
649     Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
650     /* STUB */
651     PERL_UNUSED_ARG(o);
652     NORETURN_FUNCTION_END;
653 }
654
655 PP(pp_padany)
656 {
657     DIE(aTHX_ "NOT IMPL LINE %d",__LINE__);
658 }
659
660 PP(pp_threadsv)
661 {
662     DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
663 }
664
665 PP(pp_mapstart)
666 {
667     DIE(aTHX_ "panic: mapstart");       /* uses grepstart */
668 }
669
670 /* These ops all have the same body as pp_null.  */
671 PP(pp_scalar)
672 {
673     return NORMAL;
674 }
675
676 PP(pp_regcmaybe)
677 {
678     return NORMAL;
679 }
680
681 PP(pp_lineseq)
682 {
683     return NORMAL;
684 }
685
686 PP(pp_scope)
687 {
688     return NORMAL;
689 }
690
691 /* Ops that are calls to do_kv.  */
692 PP(pp_values)
693 {
694     return do_kv();
695 }
696
697 PP(pp_keys)
698 {
699     return do_kv();
700 }
701
702 /* Ops that are simply calls to other ops.  */
703 PP(pp_dump)
704 {
705     return pp_goto();
706     /*NOTREACHED*/
707 }
708
709 PP(pp_dofile)
710 {
711     return pp_require();
712 }
713
714 PP(pp_dbmclose)
715 {
716     return pp_untie();
717 }
718
719 PP(pp_read)
720 {
721     return pp_sysread();
722 }
723
724 PP(pp_recv)
725 {
726     return pp_sysread();
727 }
728
729 PP(pp_seek)
730 {
731     return pp_sysseek();
732 }
733
734 PP(pp_fcntl)
735 {
736     return pp_ioctl();
737 }
738
739 PP(pp_gsockopt)
740 {
741     return pp_ssockopt();
742 }
743
744 PP(pp_getsockname)
745 {
746     return pp_getpeername();
747 }
748
749 PP(pp_lstat)
750 {
751     return pp_stat();
752 }
753
754 PP(pp_fteowned)
755 {
756     return pp_ftrowned();
757 }
758
759 PP(pp_ftbinary)
760 {
761     return pp_fttext();
762 }
763
764 PP(pp_localtime)
765 {
766     return pp_gmtime();
767 }
768
769 PP(pp_shmget)
770 {
771     return pp_semget();
772 }
773
774 PP(pp_shmctl)
775 {
776     return pp_semctl();
777 }
778
779 PP(pp_shmread)
780 {
781     return pp_shmwrite();
782 }
783
784 PP(pp_msgget)
785 {
786     return pp_semget();
787 }
788
789 PP(pp_msgctl)
790 {
791     return pp_semctl();
792 }
793
794 PP(pp_ghbyname)
795 {
796     return pp_ghostent();
797 }
798
799 PP(pp_ghbyaddr)
800 {
801     return pp_ghostent();
802 }
803
804 PP(pp_gnbyname)
805 {
806     return pp_gnetent();
807 }
808
809 PP(pp_gnbyaddr)
810 {
811     return pp_gnetent();
812 }
813
814 PP(pp_gpbyname)
815 {
816     return pp_gprotoent();
817 }
818
819 PP(pp_gpbynumber)
820 {
821     return pp_gprotoent();
822 }
823
824 PP(pp_gsbyname)
825 {
826     return pp_gservent();
827 }
828
829 PP(pp_gsbyport)
830 {
831     return pp_gservent();
832 }
833
834 PP(pp_gpwnam)
835 {
836     return pp_gpwent();
837 }
838
839 PP(pp_gpwuid)
840 {
841     return pp_gpwent();
842 }
843
844 PP(pp_ggrnam)
845 {
846     return pp_ggrent();
847 }
848
849 PP(pp_ggrgid)
850 {
851     return pp_ggrent();
852 }
853
854 U8 *
855 Perl_uvuni_to_utf8(pTHX_ U8 *d, UV uv)
856 {
857     return Perl_uvuni_to_utf8_flags(aTHX_ d, uv, 0);
858 }
859
860 bool
861 Perl_is_utf8_string_loc(pTHX_ const U8 *s, STRLEN len, const U8 **ep)
862 {
863     return is_utf8_string_loclen(s, len, ep, 0);
864 }
865
866 /*
867 =for apidoc sv_nolocking
868
869 Dummy routine which "locks" an SV when there is no locking module present.
870 Exists to avoid test for a NULL function pointer and because it could
871 potentially warn under some level of strict-ness.
872
873 "Superseded" by sv_nosharing().
874
875 =cut
876 */
877
878 void
879 Perl_sv_nolocking(pTHX_ SV *sv)
880 {
881     PERL_UNUSED_ARG(sv);
882 }
883
884
885 /*
886 =for apidoc sv_nounlocking
887
888 Dummy routine which "unlocks" an SV when there is no locking module present.
889 Exists to avoid test for a NULL function pointer and because it could
890 potentially warn under some level of strict-ness.
891
892 "Superseded" by sv_nosharing().
893
894 =cut
895 */
896
897 void
898 Perl_sv_nounlocking(pTHX_ SV *sv)
899 {
900     PERL_UNUSED_ARG(sv);
901 }
902
903 /*
904  * Local variables:
905  * c-indentation-style: bsd
906  * c-basic-offset: 4
907  * indent-tabs-mode: t
908  * End:
909  *
910  * ex: set ts=8 sts=4 sw=4 noet:
911  */