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