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 compatibility reasons, though, we
  20  * 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 /* sv_2iv() is now a macro using Perl_sv_2iv_flags();
  40  * this function provided for binary compatibility only
  41  */
  42
  43 IV
  44 Perl_sv_2iv(pTHX_ register SV *sv)
  45 {
  46     return sv_2iv_flags(sv, SV_GMAGIC);
  47 }
  48
  49 /* sv_2uv() is now a macro using Perl_sv_2uv_flags();
  50  * this function provided for binary compatibility only
  51  */
  52
  53 UV
  54 Perl_sv_2uv(pTHX_ register SV *sv)
  55 {
  56     return sv_2uv_flags(sv, SV_GMAGIC);
  57 }
  58
  59 /* sv_2pv() is now a macro using Perl_sv_2pv_flags();
  60  * this function provided for binary compatibility only
  61  */
  62
  63 char *
  64 Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
  65 {
  66     return sv_2pv_flags(sv, lp, SV_GMAGIC);
  67 }
  68
  69
  70 /* sv_setsv() is now a macro using Perl_sv_setsv_flags();
  71  * this function provided for binary compatibility only
  72  */
  73
  74 void
  75 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
  76 {
  77     sv_setsv_flags(dstr, sstr, SV_GMAGIC);
  78 }
  79
  80 /* sv_catpvn() is now a macro using Perl_sv_catpvn_flags();
  81  * this function provided for binary compatibility only
  82  */
  83
  84 void
  85 Perl_sv_catpvn(pTHX_ SV *dsv, const char* sstr, STRLEN slen)
  86 {
  87     sv_catpvn_flags(dsv, sstr, slen, SV_GMAGIC);
  88 }
  89
  90 /* sv_catsv() is now a macro using Perl_sv_catsv_flags();
  91  * this function provided for binary compatibility only
  92  */
  93
  94 void
  95 Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
  96 {
  97     sv_catsv_flags(dstr, sstr, SV_GMAGIC);
  98 }
  99
 100 /* sv_pv() is now a macro using SvPV_nolen();
 101  * this function provided for binary compatibility only
 102  */
 103
 104 char *
 105 Perl_sv_pv(pTHX_ SV *sv)
 106 {
 107     if (SvPOK(sv))
 108         return SvPVX(sv);
 109
 110     return sv_2pv(sv, 0);
 111 }
 112
 113 /* sv_pvn_force() is now a macro using Perl_sv_pvn_force_flags();
 114  * this function provided for binary compatibility only
 115  */
 116
 117 char *
 118 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
 119 {
 120     return sv_pvn_force_flags(sv, lp, SV_GMAGIC);
 121 }
 122
 123 /* sv_pvbyte () is now a macro using Perl_sv_2pv_flags();
 124  * this function provided for binary compatibility only
 125  */
 126
 127 char *
 128 Perl_sv_pvbyte(pTHX_ SV *sv)
 129 {
 130     sv_utf8_downgrade(sv,0);
 131     return sv_pv(sv);
 132 }
 133
 134 /* sv_pvutf8 () is now a macro using Perl_sv_2pv_flags();
 135  * this function provided for binary compatibility only
 136  */
 137
 138 char *
 139 Perl_sv_pvutf8(pTHX_ SV *sv)
 140 {
 141     sv_utf8_upgrade(sv);
 142     return sv_pv(sv);
 143 }
 144
 145 /*
 146 =for apidoc A|U8 *|uvchr_to_utf8|U8 *d|UV uv
 147
 148 Adds the UTF-8 representation of the Native codepoint C<uv> to the end
 149 of the string C<d>; C<d> should be have at least C<UTF8_MAXBYTES+1> free
 150 bytes available. The return value is the pointer to the byte after the
 151 end of the new character. In other words,
 152
 153     d = uvchr_to_utf8(d, uv);
 154
 155 is the recommended wide native character-aware way of saying
 156
 157     *(d++) = uv;
 158
 159 =cut
 160 */
 161
 162 /* On ASCII machines this is normally a macro but we want a
 163    real function in case XS code wants it
 164 */
 165 #undef Perl_uvchr_to_utf8
 166 U8 *
 167 Perl_uvchr_to_utf8(pTHX_ U8 *d, UV uv)
 168 {
 169     return Perl_uvuni_to_utf8_flags(aTHX_ d, NATIVE_TO_UNI(uv), 0);
 170 }
 171
 172
 173 /*
 174 =for apidoc A|UV|utf8n_to_uvchr|U8 *s|STRLEN curlen|STRLEN *retlen|U32
 175 flags
 176
 177 Returns the native character value of the first character in the string
 178 C<s>
 179 which is assumed to be in UTF-8 encoding; C<retlen> will be set to the
 180 length, in bytes, of that character.
 181
 182 Allows length and flags to be passed to low level routine.
 183
 184 =cut
 185 */
 186 /* On ASCII machines this is normally a macro but we want
 187    a real function in case XS code wants it
 188 */
 189 #undef Perl_utf8n_to_uvchr
 190 UV
 191 Perl_utf8n_to_uvchr(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen,
 192 U32 flags)
 193 {
 194     const UV uv = Perl_utf8n_to_uvuni(aTHX_ s, curlen, retlen, flags);
 195     return UNI_TO_NATIVE(uv);
 196 }
 197 int
 198 Perl_fprintf_nocontext(PerlIO *stream, const char *format, ...)
 199 {
 200     dTHXs;
 201     va_list(arglist);
 202     va_start(arglist, format);
 203     return PerlIO_vprintf(stream, format, arglist);
 204 }
 205
 206 int
 207 Perl_printf_nocontext(const char *format, ...)
 208 {
 209     dTHX;
 210     va_list(arglist);
 211     va_start(arglist, format);
 212     return PerlIO_vprintf(PerlIO_stdout(), format, arglist);
 213 }
 214
 215 #if defined(HUGE_VAL) || (defined(USE_LONG_DOUBLE) && defined(HUGE_VALL))
 216 /*
 217  * This hack is to force load of "huge" support from libm.a
 218  * So it is in perl for (say) POSIX to use.
 219  * Needed for SunOS with Sun's 'acc' for example.
 220  */
 221 NV
 222 Perl_huge(void)
 223 {
 224 #   if defined(USE_LONG_DOUBLE) && defined(HUGE_VALL)
 225     return HUGE_VALL;
 226 #   endif
 227     return HUGE_VAL;
 228 }
 229 #endif
 230
 231 #ifndef USE_SFIO
 232 int
 233 perlsio_binmode(FILE *fp, int iotype, int mode)
 234 {
 235     /*
 236      * This used to be contents of do_binmode in doio.c
 237      */
 238 #ifdef DOSISH
 239 #  if defined(atarist) || defined(__MINT__)
 240     if (!fflush(fp)) {
 241         if (mode & O_BINARY)
 242             ((FILE *) fp)->_flag |= _IOBIN;
 243         else
 244             ((FILE *) fp)->_flag &= ~_IOBIN;
 245         return 1;
 246     }
 247     return 0;
 248 #  else
 249     dTHX;
 250 #ifdef NETWARE
 251     if (PerlLIO_setmode(fp, mode) != -1) {
 252 #else
 253     if (PerlLIO_setmode(fileno(fp), mode) != -1) {
 254 #endif
 255 #    if defined(WIN32) && defined(__BORLANDC__)
 256         /*
 257          * The translation mode of the stream is maintained independent
 258 of
 259          * the translation mode of the fd in the Borland RTL (heavy
 260          * digging through their runtime sources reveal).  User has to
 261 set
 262          * the mode explicitly for the stream (though they don't
 263 document
 264          * this anywhere). GSAR 97-5-24
 265          */
 266         fseek(fp, 0L, 0);
 267         if (mode & O_BINARY)
 268             fp->flags |= _F_BIN;
 269         else
 270             fp->flags &= ~_F_BIN;
 271 #    endif
 272         return 1;
 273     }
 274     else
 275         return 0;
 276 #  endif
 277 #else
 278 #  if defined(USEMYBINMODE)
 279     dTHX;
 280     if (my_binmode(fp, iotype, mode) != FALSE)
 281         return 1;
 282     else
 283         return 0;
 284 #  else
 285     PERL_UNUSED_ARG(fp);
 286     PERL_UNUSED_ARG(iotype);
 287     PERL_UNUSED_ARG(mode);
 288     return 1;
 289 #  endif
 290 #endif
 291 }
 292 #endif /* sfio */
 293
 294 /*
 295  * Local variables:
 296  * c-indentation-style: bsd
 297  * c-basic-offset: 4
 298  * indent-tabs-mode: t
 299  * End:
 300  *
 301  * ex: set ts=8 sts=4 sw=4 noet:
 302  */