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_taint
  41
  42 Taint an SV. Use C<SvTAINTED_on> instead.
  43 =cut
  44 */
  45
  46 void
  47 Perl_sv_taint(pTHX_ SV *sv)
  48 {
  49     sv_magic((sv), Nullsv, PERL_MAGIC_taint, Nullch, 0);
  50 }
  51
  52 /* sv_2iv() is now a macro using Perl_sv_2iv_flags();
  53  * this function provided for binary compatibility only
  54  */
  55
  56 IV
  57 Perl_sv_2iv(pTHX_ register SV *sv)
  58 {
  59     return sv_2iv_flags(sv, SV_GMAGIC);
  60 }
  61
  62 /* sv_2uv() is now a macro using Perl_sv_2uv_flags();
  63  * this function provided for binary compatibility only
  64  */
  65
  66 UV
  67 Perl_sv_2uv(pTHX_ register SV *sv)
  68 {
  69     return sv_2uv_flags(sv, SV_GMAGIC);
  70 }
  71
  72 /* sv_2pv() is now a macro using Perl_sv_2pv_flags();
  73  * this function provided for binary compatibility only
  74  */
  75
  76 char *
  77 Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
  78 {
  79     return sv_2pv_flags(sv, lp, SV_GMAGIC);
  80 }
  81
  82
  83 /* sv_setsv() is now a macro using Perl_sv_setsv_flags();
  84  * this function provided for binary compatibility only
  85  */
  86
  87 void
  88 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
  89 {
  90     sv_setsv_flags(dstr, sstr, SV_GMAGIC);
  91 }
  92
  93 /* sv_catpvn() is now a macro using Perl_sv_catpvn_flags();
  94  * this function provided for binary compatibility only
  95  */
  96
  97 void
  98 Perl_sv_catpvn(pTHX_ SV *dsv, const char* sstr, STRLEN slen)
  99 {
 100     sv_catpvn_flags(dsv, sstr, slen, SV_GMAGIC);
 101 }
 102
 103 /* sv_catsv() is now a macro using Perl_sv_catsv_flags();
 104  * this function provided for binary compatibility only
 105  */
 106
 107 void
 108 Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
 109 {
 110     sv_catsv_flags(dstr, sstr, SV_GMAGIC);
 111 }
 112
 113 /* sv_pv() is now a macro using SvPV_nolen();
 114  * this function provided for binary compatibility only
 115  */
 116
 117 char *
 118 Perl_sv_pv(pTHX_ SV *sv)
 119 {
 120     if (SvPOK(sv))
 121         return SvPVX(sv);
 122
 123     return sv_2pv(sv, 0);
 124 }
 125
 126 /* sv_pvn_force() is now a macro using Perl_sv_pvn_force_flags();
 127  * this function provided for binary compatibility only
 128  */
 129
 130 char *
 131 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
 132 {
 133     return sv_pvn_force_flags(sv, lp, SV_GMAGIC);
 134 }
 135
 136 /* sv_pvbyte () is now a macro using Perl_sv_2pv_flags();
 137  * this function provided for binary compatibility only
 138  */
 139
 140 char *
 141 Perl_sv_pvbyte(pTHX_ SV *sv)
 142 {
 143     sv_utf8_downgrade(sv,0);
 144     return sv_pv(sv);
 145 }
 146
 147 /* sv_pvutf8 () is now a macro using Perl_sv_2pv_flags();
 148  * this function provided for binary compatibility only
 149  */
 150
 151 char *
 152 Perl_sv_pvutf8(pTHX_ SV *sv)
 153 {
 154     sv_utf8_upgrade(sv);
 155     return sv_pv(sv);
 156 }
 157
 158 /*
 159 =for apidoc A|U8 *|uvchr_to_utf8|U8 *d|UV uv
 160
 161 Adds the UTF-8 representation of the Native codepoint C<uv> to the end
 162 of the string C<d>; C<d> should be have at least C<UTF8_MAXBYTES+1> free
 163 bytes available. The return value is the pointer to the byte after the
 164 end of the new character. In other words,
 165
 166     d = uvchr_to_utf8(d, uv);
 167
 168 is the recommended wide native character-aware way of saying
 169
 170     *(d++) = uv;
 171
 172 =cut
 173 */
 174
 175 /* On ASCII machines this is normally a macro but we want a
 176    real function in case XS code wants it
 177 */
 178 #undef Perl_uvchr_to_utf8
 179 U8 *
 180 Perl_uvchr_to_utf8(pTHX_ U8 *d, UV uv)
 181 {
 182     return Perl_uvuni_to_utf8_flags(aTHX_ d, NATIVE_TO_UNI(uv), 0);
 183 }
 184
 185
 186 /*
 187 =for apidoc A|UV|utf8n_to_uvchr|U8 *s|STRLEN curlen|STRLEN *retlen|U32
 188 flags
 189
 190 Returns the native character value of the first character in the string
 191 C<s>
 192 which is assumed to be in UTF-8 encoding; C<retlen> will be set to the
 193 length, in bytes, of that character.
 194
 195 Allows length and flags to be passed to low level routine.
 196
 197 =cut
 198 */
 199 /* On ASCII machines this is normally a macro but we want
 200    a real function in case XS code wants it
 201 */
 202 #undef Perl_utf8n_to_uvchr
 203 UV
 204 Perl_utf8n_to_uvchr(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen,
 205 U32 flags)
 206 {
 207     const UV uv = Perl_utf8n_to_uvuni(aTHX_ s, curlen, retlen, flags);
 208     return UNI_TO_NATIVE(uv);
 209 }
 210 int
 211 Perl_fprintf_nocontext(PerlIO *stream, const char *format, ...)
 212 {
 213     dTHXs;
 214     va_list(arglist);
 215     va_start(arglist, format);
 216     return PerlIO_vprintf(stream, format, arglist);
 217 }
 218
 219 int
 220 Perl_printf_nocontext(const char *format, ...)
 221 {
 222     dTHX;
 223     va_list(arglist);
 224     va_start(arglist, format);
 225     return PerlIO_vprintf(PerlIO_stdout(), format, arglist);
 226 }
 227
 228 #if defined(HUGE_VAL) || (defined(USE_LONG_DOUBLE) && defined(HUGE_VALL))
 229 /*
 230  * This hack is to force load of "huge" support from libm.a
 231  * So it is in perl for (say) POSIX to use.
 232  * Needed for SunOS with Sun's 'acc' for example.
 233  */
 234 NV
 235 Perl_huge(void)
 236 {
 237 #   if defined(USE_LONG_DOUBLE) && defined(HUGE_VALL)
 238     return HUGE_VALL;
 239 #   endif
 240     return HUGE_VAL;
 241 }
 242 #endif
 243
 244 #ifndef USE_SFIO
 245 int
 246 perlsio_binmode(FILE *fp, int iotype, int mode)
 247 {
 248     /*
 249      * This used to be contents of do_binmode in doio.c
 250      */
 251 #ifdef DOSISH
 252 #  if defined(atarist) || defined(__MINT__)
 253     if (!fflush(fp)) {
 254         if (mode & O_BINARY)
 255             ((FILE *) fp)->_flag |= _IOBIN;
 256         else
 257             ((FILE *) fp)->_flag &= ~_IOBIN;
 258         return 1;
 259     }
 260     return 0;
 261 #  else
 262     dTHX;
 263 #ifdef NETWARE
 264     if (PerlLIO_setmode(fp, mode) != -1) {
 265 #else
 266     if (PerlLIO_setmode(fileno(fp), mode) != -1) {
 267 #endif
 268 #    if defined(WIN32) && defined(__BORLANDC__)
 269         /*
 270          * The translation mode of the stream is maintained independent
 271 of
 272          * the translation mode of the fd in the Borland RTL (heavy
 273          * digging through their runtime sources reveal).  User has to
 274 set
 275          * the mode explicitly for the stream (though they don't
 276 document
 277          * this anywhere). GSAR 97-5-24
 278          */
 279         fseek(fp, 0L, 0);
 280         if (mode & O_BINARY)
 281             fp->flags |= _F_BIN;
 282         else
 283             fp->flags &= ~_F_BIN;
 284 #    endif
 285         return 1;
 286     }
 287     else
 288         return 0;
 289 #  endif
 290 #else
 291 #  if defined(USEMYBINMODE)
 292     dTHX;
 293     if (my_binmode(fp, iotype, mode) != FALSE)
 294         return 1;
 295     else
 296         return 0;
 297 #  else
 298     PERL_UNUSED_ARG(fp);
 299     PERL_UNUSED_ARG(iotype);
 300     PERL_UNUSED_ARG(mode);
 301     return 1;
 302 #  endif
 303 #endif
 304 }
 305 #endif /* sfio */
 306
 307 /* compatibility with versions <= 5.003. */
 308 void
 309 Perl_gv_fullname(pTHX_ SV *sv, const GV *gv)
 310 {
 311     gv_fullname3(sv, gv, sv == (const SV*)gv ? "*" : "");
 312 }
 313
 314 /* compatibility with versions <= 5.003. */
 315 void
 316 Perl_gv_efullname(pTHX_ SV *sv, const GV *gv)
 317 {
 318     gv_efullname3(sv, gv, sv == (const SV*)gv ? "*" : "");
 319 }
 320
 321 void
 322 Perl_gv_fullname3(pTHX_ SV *sv, const GV *gv, const char *prefix)
 323 {
 324     gv_fullname4(sv, gv, prefix, TRUE);
 325 }
 326
 327 void
 328 Perl_gv_efullname3(pTHX_ SV *sv, const GV *gv, const char *prefix)
 329 {
 330     gv_efullname4(sv, gv, prefix, TRUE);
 331 }
 332
 333 AV *
 334 Perl_av_fake(pTHX_ register I32 size, register SV **strp)
 335 {
 336     register SV** ary;
 337     register AV * const av = (AV*)NEWSV(9,0);
 338
 339     sv_upgrade((SV *)av, SVt_PVAV);
 340     Newx(ary,size+1,SV*);
 341     AvALLOC(av) = ary;
 342     Copy(strp,ary,size,SV*);
 343     AvREIFY_only(av);
 344     SvPV_set(av, (char*)ary);
 345     AvFILLp(av) = size - 1;
 346     AvMAX(av) = size - 1;
 347     while (size--) {
 348         assert (*strp);
 349         SvTEMP_off(*strp);
 350         strp++;
 351     }
 352     return av;
 353 }
 354
 355 bool
 356 Perl_do_open9(pTHX_ GV *gv, register const char *name, I32 len, int
 357 as_raw,
 358               int rawmode, int rawperm, PerlIO *supplied_fp, SV *svs,
 359               I32 num_svs)
 360 {
 361     PERL_UNUSED_ARG(num_svs);
 362     return do_openn(gv, name, len, as_raw, rawmode, rawperm,
 363                     supplied_fp, &svs, 1);
 364 }
 365
 366 int
 367 Perl_do_binmode(pTHX_ PerlIO *fp, int iotype, int mode)
 368 {
 369  /* The old body of this is now in non-LAYER part of perlio.c
 370   * This is a stub for any XS code which might have been calling it.
 371   */
 372  const char *name = ":raw";
 373 #ifdef PERLIO_USING_CRLF
 374  if (!(mode & O_BINARY))
 375      name = ":crlf";
 376 #endif
 377  return PerlIO_binmode(aTHX_ fp, iotype, mode, name);
 378 }
 379
 380
 381 /*
 382  * Local variables:
 383  * c-indentation-style: bsd
 384  * c-basic-offset: 4
 385  * indent-tabs-mode: t
 386  * End:
 387  *
 388  * ex: set ts=8 sts=4 sw=4 noet:
 389  */