This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
3c92a423f6281aba894c304140fccf91ef62149e
[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 /*
410 =for apidoc A|U8 *|uvchr_to_utf8|U8 *d|UV uv
411
412 Adds the UTF-8 representation of the Native codepoint C<uv> to the end
413 of the string C<d>; C<d> should be have at least C<UTF8_MAXBYTES+1> free
414 bytes available. The return value is the pointer to the byte after the
415 end of the new character. In other words,
416
417     d = uvchr_to_utf8(d, uv);
418
419 is 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
430 U8 *
431 Perl_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 
439 flags
440
441 Returns the native character value of the first character in the string 
442 C<s>
443 which is assumed to be in UTF-8 encoding; C<retlen> will be set to the
444 length, in bytes, of that character.
445
446 Allows 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
454 UV
455 Perl_utf8n_to_uvchr(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen, 
456 U32 flags)
457 {
458     const UV uv = Perl_utf8n_to_uvuni(aTHX_ s, curlen, retlen, flags);
459     return UNI_TO_NATIVE(uv);
460 }
461 int
462 Perl_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
470 int
471 Perl_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  */
485 NV
486 Perl_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
496 int
497 perlsio_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 
522 of
523          * the translation mode of the fd in the Borland RTL (heavy
524          * digging through their runtime sources reveal).  User has to 
525 set
526          * the mode explicitly for the stream (though they don't 
527 document
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
558 /* compatibility with versions <= 5.003. */
559 void
560 Perl_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. */
566 void
567 Perl_gv_efullname(pTHX_ SV *sv, const GV *gv)
568 {
569     gv_efullname3(sv, gv, sv == (const SV*)gv ? "*" : "");
570 }
571
572 void
573 Perl_gv_fullname3(pTHX_ SV *sv, const GV *gv, const char *prefix)
574 {
575     gv_fullname4(sv, gv, prefix, TRUE);
576 }
577
578 void
579 Perl_gv_efullname3(pTHX_ SV *sv, const GV *gv, const char *prefix)
580 {
581     gv_efullname4(sv, gv, prefix, TRUE);
582 }
583
584 AV *
585 Perl_av_fake(pTHX_ register I32 size, register SV **strp)
586 {
587     register SV** ary;
588     register AV * const av = (AV*)NEWSV(9,0);
589
590     sv_upgrade((SV *)av, SVt_PVAV);
591     Newx(ary,size+1,SV*);
592     AvALLOC(av) = ary;
593     Copy(strp,ary,size,SV*);
594     AvREIFY_only(av);
595     SvPV_set(av, (char*)ary);
596     AvFILLp(av) = size - 1;
597     AvMAX(av) = size - 1;
598     while (size--) {
599         assert (*strp);
600         SvTEMP_off(*strp);
601         strp++;
602     }
603     return av;
604 }
605
606 bool
607 Perl_do_open(pTHX_ GV *gv, register const char *name, I32 len, int as_raw,
608              int rawmode, int rawperm, PerlIO *supplied_fp)
609 {
610     return do_openn(gv, name, len, as_raw, rawmode, rawperm,
611                     supplied_fp, (SV **) NULL, 0);
612 }
613
614 bool
615 Perl_do_open9(pTHX_ GV *gv, register const char *name, I32 len, int 
616 as_raw,
617               int rawmode, int rawperm, PerlIO *supplied_fp, SV *svs,
618               I32 num_svs)
619 {
620     PERL_UNUSED_ARG(num_svs);
621     return do_openn(gv, name, len, as_raw, rawmode, rawperm,
622                     supplied_fp, &svs, 1);
623 }
624
625 int
626 Perl_do_binmode(pTHX_ PerlIO *fp, int iotype, int mode)
627 {
628  /* The old body of this is now in non-LAYER part of perlio.c
629   * This is a stub for any XS code which might have been calling it.
630   */
631  const char *name = ":raw";
632 #ifdef PERLIO_USING_CRLF
633  if (!(mode & O_BINARY))
634      name = ":crlf";
635 #endif
636  return PerlIO_binmode(aTHX_ fp, iotype, mode, name);
637 }
638
639 #ifndef OS2
640 bool
641 Perl_do_aexec(pTHX_ SV *really, register SV **mark, register SV **sp)
642 {
643     return do_aexec5(really, mark, sp, 0, 0);
644 }
645 #endif
646
647 #ifdef PERL_DEFAULT_DO_EXEC3_IMPLEMENTATION
648 bool
649 Perl_do_exec(pTHX_ const char *cmd)
650 {
651     return do_exec3(cmd,0,0);
652 }
653 #endif
654
655 #ifdef HAS_PIPE
656 void
657 Perl_do_pipe(pTHX_ SV *sv, GV *rgv, GV *wgv)
658 {
659     register IO *rstio;
660     register IO *wstio;
661     int fd[2];
662
663     if (!rgv)
664         goto badexit;
665     if (!wgv)
666         goto badexit;
667
668     rstio = GvIOn(rgv);
669     wstio = GvIOn(wgv);
670
671     if (IoIFP(rstio))
672         do_close(rgv,FALSE);
673     if (IoIFP(wstio))
674         do_close(wgv,FALSE);
675
676     if (PerlProc_pipe(fd) < 0)
677         goto badexit;
678     IoIFP(rstio) = PerlIO_fdopen(fd[0], "r"PIPE_OPEN_MODE);
679     IoOFP(wstio) = PerlIO_fdopen(fd[1], "w"PIPE_OPEN_MODE);
680     IoOFP(rstio) = IoIFP(rstio);
681     IoIFP(wstio) = IoOFP(wstio);
682     IoTYPE(rstio) = IoTYPE_RDONLY;
683     IoTYPE(wstio) = IoTYPE_WRONLY;
684     if (!IoIFP(rstio) || !IoOFP(wstio)) {
685         if (IoIFP(rstio)) PerlIO_close(IoIFP(rstio));
686         else PerlLIO_close(fd[0]);
687         if (IoOFP(wstio)) PerlIO_close(IoOFP(wstio));
688         else PerlLIO_close(fd[1]);
689         goto badexit;
690     }
691
692     sv_setsv(sv,&PL_sv_yes);
693     return;
694
695 badexit:
696     sv_setsv(sv,&PL_sv_undef);
697     return;
698 }
699 #endif
700
701 /*
702  * Local variables:
703  * c-indentation-style: bsd
704  * c-basic-offset: 4
705  * indent-tabs-mode: t
706  * End:
707  *
708  * ex: set ts=8 sts=4 sw=4 noet:
709  */