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