universal.c

   1 /*    universal.c
   2  *
   3  *    Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
   4  *    2005, 2006, 2007, 2008 by Larry Wall and others
   5  *
   6  *    You may distribute under the terms of either the GNU General Public
   7  *    License or the Artistic License, as specified in the README file.
   8  *
   9  */
  10
  11 /*
  12  * '"The roots of those mountains must be roots indeed; there must be
  13  *   great secrets buried there which have not been discovered since the
  14  *   beginning."'                   --Gandalf, relating Gollum's history
  15  *
  16  *     [p.54 of _The Lord of the Rings_, I/ii: "The Shadow of the Past"]
  17  */
  18
  19 /* This file contains the code that implements the functions in Perl's
  20  * UNIVERSAL package, such as UNIVERSAL->can().
  21  *
  22  * It is also used to store XS functions that need to be present in
  23  * miniperl for a lack of a better place to put them. It might be
  24  * clever to move them to separate XS files which would then be pulled
  25  * in by some to-be-written build process.
  26  */
  27
  28 #include "EXTERN.h"
  29 #define PERL_IN_UNIVERSAL_C
  30 #include "perl.h"
  31
  32 #ifdef USE_PERLIO
  33 #include "perliol.h" /* For the PERLIO_F_XXX */
  34 #endif
  35
  36 /*
  37  * Contributed by Graham Barr  <Graham.Barr@tiuk.ti.com>
  38  * The main guts of traverse_isa was actually copied from gv_fetchmeth
  39  */
  40
  41 STATIC bool
  42 S_isa_lookup(pTHX_ HV *stash, const char * const name, STRLEN len, U32 flags)
  43 {
  44     dVAR;
  45     const struct mro_meta *const meta = HvMROMETA(stash);
  46     HV *isa = meta->isa;
  47     const HV *our_stash;
  48
  49     PERL_ARGS_ASSERT_ISA_LOOKUP;
  50
  51     if (!isa) {
  52         (void)mro_get_linear_isa(stash);
  53         isa = meta->isa;
  54     }
  55
  56     if (hv_common(isa, NULL, name, len, ( flags & SVf_UTF8 ? HVhek_UTF8 : 0),
  57                   HV_FETCH_ISEXISTS, NULL, 0)) {
  58         /* Direct name lookup worked.  */
  59         return TRUE;
  60     }
  61
  62     /* A stash/class can go by many names (ie. User == main::User), so
  63        we use the HvENAME in the stash itself, which is canonical, falling
  64        back to HvNAME if necessary.  */
  65     our_stash = gv_stashpvn(name, len, flags);
  66
  67     if (our_stash) {
  68         HEK *canon_name = HvENAME_HEK(our_stash);
  69         if (!canon_name) canon_name = HvNAME_HEK(our_stash);
  70
  71         if (hv_common(isa, NULL, HEK_KEY(canon_name), HEK_LEN(canon_name),
  72                       HEK_FLAGS(canon_name),
  73                       HV_FETCH_ISEXISTS, NULL, HEK_HASH(canon_name))) {
  74             return TRUE;
  75         }
  76     }
  77
  78     return FALSE;
  79 }
  80
  81 /*
  82 =head1 SV Manipulation Functions
  83
  84 =for apidoc sv_derived_from_pvn
  85
  86 Returns a boolean indicating whether the SV is derived from the specified class
  87 I<at the C level>.  To check derivation at the Perl level, call C<isa()> as a
  88 normal Perl method.
  89
  90 Currently, the only significant value for C<flags> is SVf_UTF8.
  91
  92 =cut
  93
  94 =for apidoc sv_derived_from_sv
  95
  96 Exactly like L</sv_derived_from_pvn>, but takes the name string in the form
  97 of an SV instead of a string/length pair.
  98
  99 =cut
 100
 101 */
 102
 103 bool
 104 Perl_sv_derived_from_sv(pTHX_ SV *sv, SV *namesv, U32 flags)
 105 {
 106     char *namepv;
 107     STRLEN namelen;
 108     PERL_ARGS_ASSERT_SV_DERIVED_FROM_SV;
 109     namepv = SvPV(namesv, namelen);
 110     if (SvUTF8(namesv))
 111        flags |= SVf_UTF8;
 112     return sv_derived_from_pvn(sv, namepv, namelen, flags);
 113 }
 114
 115 /*
 116 =for apidoc sv_derived_from
 117
 118 Exactly like L</sv_derived_from_pv>, but doesn't take a C<flags> parameter.
 119
 120 =cut
 121 */
 122
 123 bool
 124 Perl_sv_derived_from(pTHX_ SV *sv, const char *const name)
 125 {
 126     PERL_ARGS_ASSERT_SV_DERIVED_FROM;
 127     return sv_derived_from_pvn(sv, name, strlen(name), 0);
 128 }
 129
 130 /*
 131 =for apidoc sv_derived_from_pv
 132
 133 Exactly like L</sv_derived_from_pvn>, but takes a nul-terminated string
 134 instead of a string/length pair.
 135
 136 =cut
 137 */
 138
 139
 140 bool
 141 Perl_sv_derived_from_pv(pTHX_ SV *sv, const char *const name, U32 flags)
 142 {
 143     PERL_ARGS_ASSERT_SV_DERIVED_FROM_PV;
 144     return sv_derived_from_pvn(sv, name, strlen(name), flags);
 145 }
 146
 147 bool
 148 Perl_sv_derived_from_pvn(pTHX_ SV *sv, const char *const name, const STRLEN len, U32 flags)
 149 {
 150     dVAR;
 151     HV *stash;
 152
 153     PERL_ARGS_ASSERT_SV_DERIVED_FROM_PVN;
 154
 155     SvGETMAGIC(sv);
 156
 157     if (SvROK(sv)) { /* hugdo: */
 158         const char *type;
 159         sv = SvRV(sv);
 160         type = sv_reftype(sv,0);
 161         if (type && strEQ(type,name))
 162             return TRUE;
 163         stash = SvOBJECT(sv) ? SvSTASH(sv) : NULL;
 164     }
 165     else {
 166         stash = gv_stashsv(sv, 0);
 167     }
 168
 169     return stash ? isa_lookup(stash, name, len, flags) : FALSE;
 170 }
 171
 172 /*
 173 =for apidoc sv_does_sv
 174
 175 Returns a boolean indicating whether the SV performs a specific, named role.
 176 The SV can be a Perl object or the name of a Perl class.
 177
 178 =cut
 179 */
 180
 181 #include "XSUB.h"
 182
 183 bool
 184 Perl_sv_does_sv(pTHX_ SV *sv, SV *namesv, U32 flags)
 185 {
 186     SV *classname;
 187     bool does_it;
 188     SV *methodname;
 189     dSP;
 190
 191     PERL_ARGS_ASSERT_SV_DOES_SV;
 192     PERL_UNUSED_ARG(flags);
 193
 194     ENTER;
 195     SAVETMPS;
 196
 197     SvGETMAGIC(sv);
 198
 199     if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
 200             || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv)))) {
 201         LEAVE;
 202         return FALSE;
 203     }
 204
 205     if (sv_isobject(sv)) {
 206         classname = sv_ref(NULL,SvRV(sv),TRUE);
 207     } else {
 208         classname = sv;
 209     }
 210
 211     if (sv_eq(classname, namesv)) {
 212         LEAVE;
 213         return TRUE;
 214     }
 215
 216     PUSHMARK(SP);
 217     EXTEND(SP, 2);
 218     PUSHs(sv);
 219     PUSHs(namesv);
 220     PUTBACK;
 221
 222     methodname = newSVpvs_flags("isa", SVs_TEMP);
 223     /* ugly hack: use the SvSCREAM flag so S_method_common
 224      * can figure out we're calling DOES() and not isa(),
 225      * and report eventual errors correctly. --rgs */
 226     SvSCREAM_on(methodname);
 227     call_sv(methodname, G_SCALAR | G_METHOD);
 228     SPAGAIN;
 229
 230     does_it = SvTRUE( TOPs );
 231     FREETMPS;
 232     LEAVE;
 233
 234     return does_it;
 235 }
 236
 237 /*
 238 =for apidoc sv_does
 239
 240 Like L</sv_does_pv>, but doesn't take a C<flags> parameter.
 241
 242 =cut
 243 */
 244
 245 bool
 246 Perl_sv_does(pTHX_ SV *sv, const char *const name)
 247 {
 248     PERL_ARGS_ASSERT_SV_DOES;
 249     return sv_does_sv(sv, newSVpvn_flags(name, strlen(name), SVs_TEMP), 0);
 250 }
 251
 252 /*
 253 =for apidoc sv_does_pv
 254
 255 Like L</sv_does_sv>, but takes a nul-terminated string instead of an SV.
 256
 257 =cut
 258 */
 259
 260
 261 bool
 262 Perl_sv_does_pv(pTHX_ SV *sv, const char *const name, U32 flags)
 263 {
 264     PERL_ARGS_ASSERT_SV_DOES_PV;
 265     return sv_does_sv(sv, newSVpvn_flags(name, strlen(name), SVs_TEMP | flags), flags);
 266 }
 267
 268 /*
 269 =for apidoc sv_does_pvn
 270
 271 Like L</sv_does_sv>, but takes a string/length pair instead of an SV.
 272
 273 =cut
 274 */
 275
 276 bool
 277 Perl_sv_does_pvn(pTHX_ SV *sv, const char *const name, const STRLEN len, U32 flags)
 278 {
 279     PERL_ARGS_ASSERT_SV_DOES_PVN;
 280
 281     return sv_does_sv(sv, newSVpvn_flags(name, len, flags | SVs_TEMP), flags);
 282 }
 283
 284 /*
 285 =for apidoc croak_xs_usage
 286
 287 A specialised variant of C<croak()> for emitting the usage message for xsubs
 288
 289     croak_xs_usage(cv, "eee_yow");
 290
 291 works out the package name and subroutine name from C<cv>, and then calls
 292 C<croak()>. Hence if C<cv> is C<&ouch::awk>, it would call C<croak> as:
 293
 294     Perl_croak(aTHX_ "Usage: %"SVf"::%"SVf"(%s)", "ouch" "awk", "eee_yow");
 295
 296 =cut
 297 */
 298
 299 void
 300 Perl_croak_xs_usage(pTHX_ const CV *const cv, const char *const params)
 301 {
 302     const GV *const gv = CvGV(cv);
 303
 304     PERL_ARGS_ASSERT_CROAK_XS_USAGE;
 305
 306     if (gv) {
 307         const HV *const stash = GvSTASH(gv);
 308
 309         if (HvNAME_get(stash))
 310             Perl_croak(aTHX_ "Usage: %"HEKf"::%"HEKf"(%s)",
 311                                 HEKfARG(HvNAME_HEK(stash)),
 312                                 HEKfARG(GvNAME_HEK(gv)),
 313                                 params);
 314         else
 315             Perl_croak(aTHX_ "Usage: %"HEKf"(%s)",
 316                                 HEKfARG(GvNAME_HEK(gv)), params);
 317     } else {
 318         /* Pants. I don't think that it should be possible to get here. */
 319         Perl_croak(aTHX_ "Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params);
 320     }
 321 }
 322
 323 XS(XS_UNIVERSAL_isa)
 324 {
 325     dVAR;
 326     dXSARGS;
 327
 328     if (items != 2)
 329         croak_xs_usage(cv, "reference, kind");
 330     else {
 331         SV * const sv = ST(0);
 332
 333         SvGETMAGIC(sv);
 334
 335         if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
 336                     || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
 337             XSRETURN_UNDEF;
 338
 339         ST(0) = boolSV(sv_derived_from_sv(sv, ST(1), 0));
 340         XSRETURN(1);
 341     }
 342 }
 343
 344 XS(XS_UNIVERSAL_can)
 345 {
 346     dVAR;
 347     dXSARGS;
 348     SV   *sv;
 349     SV   *rv;
 350     HV   *pkg = NULL;
 351
 352     if (items != 2)
 353         croak_xs_usage(cv, "object-ref, method");
 354
 355     sv = ST(0);
 356
 357     SvGETMAGIC(sv);
 358
 359     if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
 360                 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
 361         XSRETURN_UNDEF;
 362
 363     rv = &PL_sv_undef;
 364
 365     if (SvROK(sv)) {
 366         sv = MUTABLE_SV(SvRV(sv));
 367         if (SvOBJECT(sv))
 368             pkg = SvSTASH(sv);
 369     }
 370     else {
 371         pkg = gv_stashsv(sv, 0);
 372     }
 373
 374     if (pkg) {
 375         GV * const gv = gv_fetchmethod_sv_flags(pkg, ST(1), 0);
 376         if (gv && isGV(gv))
 377             rv = sv_2mortal(newRV(MUTABLE_SV(GvCV(gv))));
 378     }
 379
 380     ST(0) = rv;
 381     XSRETURN(1);
 382 }
 383
 384 XS(XS_UNIVERSAL_DOES)
 385 {
 386     dVAR;
 387     dXSARGS;
 388     PERL_UNUSED_ARG(cv);
 389
 390     if (items != 2)
 391         Perl_croak(aTHX_ "Usage: invocant->DOES(kind)");
 392     else {
 393         SV * const sv = ST(0);
 394         if (sv_does_sv( sv, ST(1), 0 ))
 395             XSRETURN_YES;
 396
 397         XSRETURN_NO;
 398     }
 399 }
 400
 401 XS(XS_UNIVERSAL_VERSION)
 402 {
 403     dVAR;
 404     dXSARGS;
 405     HV *pkg;
 406     GV **gvp;
 407     GV *gv;
 408     SV *sv;
 409     SV *ret;
 410     const char *undef;
 411     PERL_UNUSED_ARG(cv);
 412
 413     if (SvROK(ST(0))) {
 414         sv = MUTABLE_SV(SvRV(ST(0)));
 415         if (!SvOBJECT(sv))
 416             Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
 417         pkg = SvSTASH(sv);
 418     }
 419     else {
 420         pkg = gv_stashsv(ST(0), 0);
 421     }
 422
 423     gvp = pkg ? (GV**)hv_fetchs(pkg, "VERSION", FALSE) : NULL;
 424
 425     if (gvp && isGV(gv = *gvp) && (sv = GvSV(gv)) && SvOK(sv)) {
 426         ret = sv_newmortal();
 427         sv_setsv(ret, sv);
 428         undef = NULL;
 429     }
 430     else {
 431         sv = ret = &PL_sv_undef;
 432         undef = "(undef)";
 433     }
 434
 435     if (items > 1) {
 436         SV *req = ST(1);
 437
 438         if (undef) {
 439             if (pkg) {
 440                 const HEK * const name = HvNAME_HEK(pkg);
 441                 Perl_croak(aTHX_
 442                            "%"HEKf" does not define $%"HEKf
 443                            "::VERSION--version check failed",
 444                            HEKfARG(name), HEKfARG(name));
 445             } else {
 446                 Perl_croak(aTHX_
 447                              "%"SVf" defines neither package nor VERSION--version check failed",
 448                              SVfARG(ST(0)) );
 449              }
 450         }
 451
 452         if ( !sv_derived_from(sv, "version"))
 453             upg_version(sv, FALSE);
 454
 455         if ( !sv_derived_from(req, "version")) {
 456             /* req may very well be R/O, so create a new object */
 457             req = sv_2mortal( new_version(req) );
 458         }
 459
 460         if ( vcmp( req, sv ) > 0 ) {
 461             if ( hv_exists(MUTABLE_HV(SvRV(req)), "qv", 2 ) ) {
 462                 Perl_croak(aTHX_ "%"HEKf" version %"SVf" required--"
 463                        "this is only version %"SVf"",
 464                        HEKfARG(HvNAME_HEK(pkg)),
 465                        SVfARG(sv_2mortal(vnormal(req))),
 466                        SVfARG(sv_2mortal(vnormal(sv))));
 467             } else {
 468                 Perl_croak(aTHX_ "%"HEKf" version %"SVf" required--"
 469                        "this is only version %"SVf,
 470                        HEKfARG(HvNAME_HEK(pkg)),
 471                        SVfARG(sv_2mortal(vstringify(req))),
 472                        SVfARG(sv_2mortal(vstringify(sv))));
 473             }
 474         }
 475
 476     }
 477
 478     ST(0) = ret;
 479
 480     XSRETURN(1);
 481 }
 482
 483 XS(XS_version_new)
 484 {
 485     dVAR;
 486     dXSARGS;
 487     if (items > 3)
 488         croak_xs_usage(cv, "class, version");
 489     SP -= items;
 490     {
 491         SV *vs = ST(1);
 492         SV *rv;
 493         STRLEN len;
 494         const char *classname;
 495         U32 flags;
 496         if ( sv_isobject(ST(0)) ) { /* get the class if called as an object method */
 497             const HV * stash = SvSTASH(SvRV(ST(0)));
 498             classname = HvNAME(stash);
 499             len       = HvNAMELEN(stash);
 500             flags     = HvNAMEUTF8(stash) ? SVf_UTF8 : 0;
 501         }
 502         else {
 503             classname = SvPV(ST(0), len);
 504             flags     = SvUTF8(ST(0));
 505         }
 506
 507         if ( items == 1 || ! SvOK(vs) ) { /* no param or explicit undef */
 508             /* create empty object */
 509             vs = sv_newmortal();
 510             sv_setpvs(vs, "0");
 511         }
 512         else if ( items == 3 ) {
 513             vs = sv_newmortal();
 514             Perl_sv_setpvf(aTHX_ vs,"v%s",SvPV_nolen_const(ST(2)));
 515         }
 516
 517         rv = new_version(vs);
 518         if ( strnNE(classname,"version", len) ) /* inherited new() */
 519             sv_bless(rv, gv_stashpvn(classname, len, GV_ADD | flags));
 520
 521         mPUSHs(rv);
 522         PUTBACK;
 523         return;
 524     }
 525 }
 526
 527 XS(XS_version_stringify)
 528 {
 529      dVAR;
 530      dXSARGS;
 531      if (items < 1)
 532          croak_xs_usage(cv, "lobj, ...");
 533      SP -= items;
 534      {
 535           SV *  lobj = ST(0);
 536
 537           if (sv_derived_from(lobj, "version") && SvROK(lobj)) {
 538                lobj = SvRV(lobj);
 539           }
 540           else
 541                Perl_croak(aTHX_ "lobj is not of type version");
 542
 543           mPUSHs(vstringify(lobj));
 544
 545           PUTBACK;
 546           return;
 547      }
 548 }
 549
 550 XS(XS_version_numify)
 551 {
 552      dVAR;
 553      dXSARGS;
 554      if (items < 1)
 555          croak_xs_usage(cv, "lobj, ...");
 556      SP -= items;
 557      {
 558           SV *  lobj = ST(0);
 559
 560           if (sv_derived_from(lobj, "version") && SvROK(lobj)) {
 561                lobj = SvRV(lobj);
 562           }
 563           else
 564                Perl_croak(aTHX_ "lobj is not of type version");
 565
 566           mPUSHs(vnumify(lobj));
 567
 568           PUTBACK;
 569           return;
 570      }
 571 }
 572
 573 XS(XS_version_normal)
 574 {
 575      dVAR;
 576      dXSARGS;
 577      if (items < 1)
 578          croak_xs_usage(cv, "lobj, ...");
 579      SP -= items;
 580      {
 581           SV *  lobj = ST(0);
 582
 583           if (sv_derived_from(lobj, "version") && SvROK(lobj)) {
 584                lobj = SvRV(lobj);
 585           }
 586           else
 587                Perl_croak(aTHX_ "lobj is not of type version");
 588
 589           mPUSHs(vnormal(lobj));
 590
 591           PUTBACK;
 592           return;
 593      }
 594 }
 595
 596 XS(XS_version_vcmp)
 597 {
 598      dVAR;
 599      dXSARGS;
 600      if (items < 1)
 601          croak_xs_usage(cv, "lobj, ...");
 602      SP -= items;
 603      {
 604           SV *  lobj = ST(0);
 605
 606           if (sv_derived_from(lobj, "version") && SvROK(lobj)) {
 607                lobj = SvRV(lobj);
 608           }
 609           else
 610                Perl_croak(aTHX_ "lobj is not of type version");
 611
 612           {
 613                SV       *rs;
 614                SV       *rvs;
 615                SV * robj = ST(1);
 616                const IV  swap = (IV)SvIV(ST(2));
 617
 618                if ( ! sv_derived_from(robj, "version") )
 619                {
 620                     robj = new_version(SvOK(robj) ? robj : newSVpvs_flags("0", SVs_TEMP));
 621                     sv_2mortal(robj);
 622                }
 623                rvs = SvRV(robj);
 624
 625                if ( swap )
 626                {
 627                     rs = newSViv(vcmp(rvs,lobj));
 628                }
 629                else
 630                {
 631                     rs = newSViv(vcmp(lobj,rvs));
 632                }
 633
 634                mPUSHs(rs);
 635           }
 636
 637           PUTBACK;
 638           return;
 639      }
 640 }
 641
 642 XS(XS_version_boolean)
 643 {
 644     dVAR;
 645     dXSARGS;
 646     if (items < 1)
 647         croak_xs_usage(cv, "lobj, ...");
 648     SP -= items;
 649     if (sv_derived_from(ST(0), "version") && SvROK(ST(0))) {
 650         SV * const lobj = SvRV(ST(0));
 651         SV * const rs = newSViv( vcmp(lobj,new_version(newSVpvs("0"))) );
 652         mPUSHs(rs);
 653         PUTBACK;
 654         return;
 655     }
 656     else
 657         Perl_croak(aTHX_ "lobj is not of type version");
 658 }
 659
 660 XS(XS_version_noop)
 661 {
 662     dVAR;
 663     dXSARGS;
 664     if (items < 1)
 665         croak_xs_usage(cv, "lobj, ...");
 666     if (sv_derived_from(ST(0), "version") && SvROK(ST(0)))
 667         Perl_croak(aTHX_ "operation not supported with version object");
 668     else
 669         Perl_croak(aTHX_ "lobj is not of type version");
 670 #ifndef HASATTRIBUTE_NORETURN
 671     XSRETURN_EMPTY;
 672 #endif
 673 }
 674
 675 XS(XS_version_is_alpha)
 676 {
 677     dVAR;
 678     dXSARGS;
 679     if (items != 1)
 680         croak_xs_usage(cv, "lobj");
 681     SP -= items;
 682     if (sv_derived_from(ST(0), "version") && SvROK(ST(0))) {
 683         SV * const lobj = ST(0);
 684         if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "alpha", 5 ) )
 685             XSRETURN_YES;
 686         else
 687             XSRETURN_NO;
 688         PUTBACK;
 689         return;
 690     }
 691     else
 692         Perl_croak(aTHX_ "lobj is not of type version");
 693 }
 694
 695 XS(XS_version_qv)
 696 {
 697     dVAR;
 698     dXSARGS;
 699     PERL_UNUSED_ARG(cv);
 700     SP -= items;
 701     {
 702         SV * ver = ST(0);
 703         SV * rv;
 704         STRLEN len = 0;
 705         const char * classname = "";
 706         U32 flags = 0;
 707         if ( items == 2 && SvOK(ST(1)) ) {
 708             ver = ST(1);
 709             if ( sv_isobject(ST(0)) ) { /* class called as an object method */
 710                 const HV * stash = SvSTASH(SvRV(ST(0)));
 711                 classname = HvNAME(stash);
 712                 len       = HvNAMELEN(stash);
 713                 flags     = HvNAMEUTF8(stash) ? SVf_UTF8 : 0;
 714             }
 715             else {
 716                classname = SvPV(ST(0), len);
 717                 flags     = SvUTF8(ST(0));
 718             }
 719         }
 720         if ( !SvVOK(ver) ) { /* not already a v-string */
 721             rv = sv_newmortal();
 722             sv_setsv(rv,ver); /* make a duplicate */
 723             upg_version(rv, TRUE);
 724         } else {
 725             rv = sv_2mortal(new_version(ver));
 726         }
 727         if ( items == 2
 728                 && strnNE(classname,"version", len) ) { /* inherited new() */
 729             sv_bless(rv, gv_stashpvn(classname, len, GV_ADD | flags));
 730         }
 731         PUSHs(rv);
 732     }
 733     PUTBACK;
 734     return;
 735 }
 736
 737 XS(XS_version_is_qv)
 738 {
 739     dVAR;
 740     dXSARGS;
 741     if (items != 1)
 742         croak_xs_usage(cv, "lobj");
 743     SP -= items;
 744     if (sv_derived_from(ST(0), "version") && SvROK(ST(0))) {
 745         SV * const lobj = ST(0);
 746         if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "qv", 2 ) )
 747             XSRETURN_YES;
 748         else
 749             XSRETURN_NO;
 750         PUTBACK;
 751         return;
 752     }
 753     else
 754         Perl_croak(aTHX_ "lobj is not of type version");
 755 }
 756
 757 XS(XS_utf8_is_utf8)
 758 {
 759      dVAR;
 760      dXSARGS;
 761      if (items != 1)
 762          croak_xs_usage(cv, "sv");
 763      else {
 764         SV * const sv = ST(0);
 765         SvGETMAGIC(sv);
 766             if (SvUTF8(sv))
 767                 XSRETURN_YES;
 768             else
 769                 XSRETURN_NO;
 770      }
 771      XSRETURN_EMPTY;
 772 }
 773
 774 XS(XS_utf8_valid)
 775 {
 776      dVAR;
 777      dXSARGS;
 778      if (items != 1)
 779          croak_xs_usage(cv, "sv");
 780     else {
 781         SV * const sv = ST(0);
 782         STRLEN len;
 783         const char * const s = SvPV_const(sv,len);
 784         if (!SvUTF8(sv) || is_utf8_string((const U8*)s,len))
 785             XSRETURN_YES;
 786         else
 787             XSRETURN_NO;
 788     }
 789      XSRETURN_EMPTY;
 790 }
 791
 792 XS(XS_utf8_encode)
 793 {
 794     dVAR;
 795     dXSARGS;
 796     if (items != 1)
 797         croak_xs_usage(cv, "sv");
 798     sv_utf8_encode(ST(0));
 799     XSRETURN_EMPTY;
 800 }
 801
 802 XS(XS_utf8_decode)
 803 {
 804     dVAR;
 805     dXSARGS;
 806     if (items != 1)
 807         croak_xs_usage(cv, "sv");
 808     else {
 809         SV * const sv = ST(0);
 810         bool RETVAL;
 811         if (SvIsCOW(sv)) sv_force_normal(sv);
 812         RETVAL = sv_utf8_decode(sv);
 813         ST(0) = boolSV(RETVAL);
 814     }
 815     XSRETURN(1);
 816 }
 817
 818 XS(XS_utf8_upgrade)
 819 {
 820     dVAR;
 821     dXSARGS;
 822     if (items != 1)
 823         croak_xs_usage(cv, "sv");
 824     else {
 825         SV * const sv = ST(0);
 826         STRLEN  RETVAL;
 827         dXSTARG;
 828
 829         RETVAL = sv_utf8_upgrade(sv);
 830         XSprePUSH; PUSHi((IV)RETVAL);
 831     }
 832     XSRETURN(1);
 833 }
 834
 835 XS(XS_utf8_downgrade)
 836 {
 837     dVAR;
 838     dXSARGS;
 839     if (items < 1 || items > 2)
 840         croak_xs_usage(cv, "sv, failok=0");
 841     else {
 842         SV * const sv = ST(0);
 843         const bool failok = (items < 2) ? 0 : (int)SvIV(ST(1));
 844         const bool RETVAL = sv_utf8_downgrade(sv, failok);
 845
 846         ST(0) = boolSV(RETVAL);
 847     }
 848     XSRETURN(1);
 849 }
 850
 851 XS(XS_utf8_native_to_unicode)
 852 {
 853  dVAR;
 854  dXSARGS;
 855  const UV uv = SvUV(ST(0));
 856
 857  if (items > 1)
 858      croak_xs_usage(cv, "sv");
 859
 860  ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
 861  XSRETURN(1);
 862 }
 863
 864 XS(XS_utf8_unicode_to_native)
 865 {
 866  dVAR;
 867  dXSARGS;
 868  const UV uv = SvUV(ST(0));
 869
 870  if (items > 1)
 871      croak_xs_usage(cv, "sv");
 872
 873  ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
 874  XSRETURN(1);
 875 }
 876
 877 XS(XS_Internals_SvREADONLY)     /* This is dangerous stuff. */
 878 {
 879     dVAR;
 880     dXSARGS;
 881     SV * const svz = ST(0);
 882     SV * sv;
 883     PERL_UNUSED_ARG(cv);
 884
 885     /* [perl #77776] - called as &foo() not foo() */
 886     if (!SvROK(svz))
 887         croak_xs_usage(cv, "SCALAR[, ON]");
 888
 889     sv = SvRV(svz);
 890
 891     if (items == 1) {
 892          if (SvREADONLY(sv) && !SvIsCOW(sv))
 893              XSRETURN_YES;
 894          else
 895              XSRETURN_NO;
 896     }
 897     else if (items == 2) {
 898         if (SvTRUE(ST(1))) {
 899             if (SvIsCOW(sv)) sv_force_normal(sv);
 900             SvREADONLY_on(sv);
 901             XSRETURN_YES;
 902         }
 903         else {
 904             /* I hope you really know what you are doing. */
 905             if (!SvIsCOW(sv)) SvREADONLY_off(sv);
 906             XSRETURN_NO;
 907         }
 908     }
 909     XSRETURN_UNDEF; /* Can't happen. */
 910 }
 911
 912 XS(XS_Internals_SvREFCNT)       /* This is dangerous stuff. */
 913 {
 914     dVAR;
 915     dXSARGS;
 916     SV * const svz = ST(0);
 917     SV * sv;
 918     PERL_UNUSED_ARG(cv);
 919
 920     /* [perl #77776] - called as &foo() not foo() */
 921     if (!SvROK(svz))
 922         croak_xs_usage(cv, "SCALAR[, REFCOUNT]");
 923
 924     sv = SvRV(svz);
 925
 926     if (items == 1)
 927          XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
 928     else if (items == 2) {
 929          /* I hope you really know what you are doing. */
 930          SvREFCNT(sv) = SvIV(ST(1));
 931          XSRETURN_IV(SvREFCNT(sv));
 932     }
 933     XSRETURN_UNDEF; /* Can't happen. */
 934 }
 935
 936 XS(XS_Internals_hv_clear_placehold)
 937 {
 938     dVAR;
 939     dXSARGS;
 940
 941     if (items != 1 || !SvROK(ST(0)))
 942         croak_xs_usage(cv, "hv");
 943     else {
 944         HV * const hv = MUTABLE_HV(SvRV(ST(0)));
 945         hv_clear_placeholders(hv);
 946         XSRETURN(0);
 947     }
 948 }
 949
 950 XS(XS_PerlIO_get_layers)
 951 {
 952     dVAR;
 953     dXSARGS;
 954     if (items < 1 || items % 2 == 0)
 955         croak_xs_usage(cv, "filehandle[,args]");
 956 #ifdef USE_PERLIO
 957     {
 958         SV *    sv;
 959         GV *    gv;
 960         IO *    io;
 961         bool    input = TRUE;
 962         bool    details = FALSE;
 963
 964         if (items > 1) {
 965              SV * const *svp;
 966              for (svp = MARK + 2; svp <= SP; svp += 2) {
 967                   SV * const * const varp = svp;
 968                   SV * const * const valp = svp + 1;
 969                   STRLEN klen;
 970                   const char * const key = SvPV_const(*varp, klen);
 971
 972                   switch (*key) {
 973                   case 'i':
 974                        if (klen == 5 && memEQ(key, "input", 5)) {
 975                             input = SvTRUE(*valp);
 976                             break;
 977                        }
 978                        goto fail;
 979                   case 'o':
 980                        if (klen == 6 && memEQ(key, "output", 6)) {
 981                             input = !SvTRUE(*valp);
 982                             break;
 983                        }
 984                        goto fail;
 985                   case 'd':
 986                        if (klen == 7 && memEQ(key, "details", 7)) {
 987                             details = SvTRUE(*valp);
 988                             break;
 989                        }
 990                        goto fail;
 991                   default:
 992                   fail:
 993                        Perl_croak(aTHX_
 994                                   "get_layers: unknown argument '%s'",
 995                                   key);
 996                   }
 997              }
 998
 999              SP -= (items - 1);
1000         }
1001
1002         sv = POPs;
1003         gv = MUTABLE_GV(sv);
1004
1005         if (!isGV(sv)) {
1006              if (SvROK(sv) && isGV(SvRV(sv)))
1007                   gv = MUTABLE_GV(SvRV(sv));
1008              else if (SvPOKp(sv))
1009                   gv = gv_fetchsv(sv, 0, SVt_PVIO);
1010         }
1011
1012         if (gv && (io = GvIO(gv))) {
1013              AV* const av = PerlIO_get_layers(aTHX_ input ?
1014                                         IoIFP(io) : IoOFP(io));
1015              I32 i;
1016              const I32 last = av_len(av);
1017              I32 nitem = 0;
1018
1019              for (i = last; i >= 0; i -= 3) {
1020                   SV * const * const namsvp = av_fetch(av, i - 2, FALSE);
1021                   SV * const * const argsvp = av_fetch(av, i - 1, FALSE);
1022                   SV * const * const flgsvp = av_fetch(av, i,     FALSE);
1023
1024                   const bool namok = namsvp && *namsvp && SvPOK(*namsvp);
1025                   const bool argok = argsvp && *argsvp && SvPOK(*argsvp);
1026                   const bool flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
1027
1028                   if (details) {
1029                       /* Indents of 5? Yuck.  */
1030                       /* We know that PerlIO_get_layers creates a new SV for
1031                          the name and flags, so we can just take a reference
1032                          and "steal" it when we free the AV below.  */
1033                        XPUSHs(namok
1034                               ? sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp))
1035                               : &PL_sv_undef);
1036                        XPUSHs(argok
1037                               ? newSVpvn_flags(SvPVX_const(*argsvp),
1038                                                SvCUR(*argsvp),
1039                                                (SvUTF8(*argsvp) ? SVf_UTF8 : 0)
1040                                                | SVs_TEMP)
1041                               : &PL_sv_undef);
1042                        XPUSHs(flgok
1043                               ? sv_2mortal(SvREFCNT_inc_simple_NN(*flgsvp))
1044                               : &PL_sv_undef);
1045                        nitem += 3;
1046                   }
1047                   else {
1048                        if (namok && argok)
1049                             XPUSHs(sv_2mortal(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
1050                                                  SVfARG(*namsvp),
1051                                                  SVfARG(*argsvp))));
1052                        else if (namok)
1053                            XPUSHs(sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp)));
1054                        else
1055                             XPUSHs(&PL_sv_undef);
1056                        nitem++;
1057                        if (flgok) {
1058                             const IV flags = SvIVX(*flgsvp);
1059
1060                             if (flags & PERLIO_F_UTF8) {
1061                                  XPUSHs(newSVpvs_flags("utf8", SVs_TEMP));
1062                                  nitem++;
1063                             }
1064                        }
1065                   }
1066              }
1067
1068              SvREFCNT_dec(av);
1069
1070              XSRETURN(nitem);
1071         }
1072     }
1073 #endif
1074
1075     XSRETURN(0);
1076 }
1077
1078 XS(XS_Internals_hash_seed)
1079 {
1080     dVAR;
1081     /* Using dXSARGS would also have dITEM and dSP,
1082      * which define 2 unused local variables.  */
1083     dAXMARK;
1084     PERL_UNUSED_ARG(cv);
1085     PERL_UNUSED_VAR(mark);
1086     XSRETURN_UV(PERL_HASH_SEED);
1087 }
1088
1089 XS(XS_Internals_rehash_seed)
1090 {
1091     dVAR;
1092     /* Using dXSARGS would also have dITEM and dSP,
1093      * which define 2 unused local variables.  */
1094     dAXMARK;
1095     PERL_UNUSED_ARG(cv);
1096     PERL_UNUSED_VAR(mark);
1097     XSRETURN_UV(PL_rehash_seed);
1098 }
1099
1100 XS(XS_Internals_HvREHASH)       /* Subject to change  */
1101 {
1102     dVAR;
1103     dXSARGS;
1104     PERL_UNUSED_ARG(cv);
1105     if (SvROK(ST(0))) {
1106         const HV * const hv = (const HV *) SvRV(ST(0));
1107         if (items == 1 && SvTYPE(hv) == SVt_PVHV) {
1108             if (HvREHASH(hv))
1109                 XSRETURN_YES;
1110             else
1111                 XSRETURN_NO;
1112         }
1113     }
1114     Perl_croak(aTHX_ "Internals::HvREHASH $hashref");
1115 }
1116
1117 XS(XS_re_is_regexp)
1118 {
1119     dVAR;
1120     dXSARGS;
1121     PERL_UNUSED_VAR(cv);
1122
1123     if (items != 1)
1124         croak_xs_usage(cv, "sv");
1125
1126     if (SvRXOK(ST(0))) {
1127         XSRETURN_YES;
1128     } else {
1129         XSRETURN_NO;
1130     }
1131 }
1132
1133 XS(XS_re_regnames_count)
1134 {
1135     REGEXP *rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1136     SV * ret;
1137     dVAR;
1138     dXSARGS;
1139
1140     if (items != 0)
1141         croak_xs_usage(cv, "");
1142
1143     SP -= items;
1144     PUTBACK;
1145
1146     if (!rx)
1147         XSRETURN_UNDEF;
1148
1149     ret = CALLREG_NAMED_BUFF_COUNT(rx);
1150
1151     SPAGAIN;
1152     PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
1153     XSRETURN(1);
1154 }
1155
1156 XS(XS_re_regname)
1157 {
1158     dVAR;
1159     dXSARGS;
1160     REGEXP * rx;
1161     U32 flags;
1162     SV * ret;
1163
1164     if (items < 1 || items > 2)
1165         croak_xs_usage(cv, "name[, all ]");
1166
1167     SP -= items;
1168     PUTBACK;
1169
1170     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1171
1172     if (!rx)
1173         XSRETURN_UNDEF;
1174
1175     if (items == 2 && SvTRUE(ST(1))) {
1176         flags = RXapif_ALL;
1177     } else {
1178         flags = RXapif_ONE;
1179     }
1180     ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(0), (flags | RXapif_REGNAME));
1181
1182     SPAGAIN;
1183     PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
1184     XSRETURN(1);
1185 }
1186
1187
1188 XS(XS_re_regnames)
1189 {
1190     dVAR;
1191     dXSARGS;
1192     REGEXP * rx;
1193     U32 flags;
1194     SV *ret;
1195     AV *av;
1196     I32 length;
1197     I32 i;
1198     SV **entry;
1199
1200     if (items > 1)
1201         croak_xs_usage(cv, "[all]");
1202
1203     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1204
1205     if (!rx)
1206         XSRETURN_UNDEF;
1207
1208     if (items == 1 && SvTRUE(ST(0))) {
1209         flags = RXapif_ALL;
1210     } else {
1211         flags = RXapif_ONE;
1212     }
1213
1214     SP -= items;
1215     PUTBACK;
1216
1217     ret = CALLREG_NAMED_BUFF_ALL(rx, (flags | RXapif_REGNAMES));
1218
1219     SPAGAIN;
1220
1221     if (!ret)
1222         XSRETURN_UNDEF;
1223
1224     av = MUTABLE_AV(SvRV(ret));
1225     length = av_len(av);
1226
1227     for (i = 0; i <= length; i++) {
1228         entry = av_fetch(av, i, FALSE);
1229
1230         if (!entry)
1231             Perl_croak(aTHX_ "NULL array element in re::regnames()");
1232
1233         mXPUSHs(SvREFCNT_inc_simple_NN(*entry));
1234     }
1235
1236     SvREFCNT_dec(ret);
1237
1238     PUTBACK;
1239     return;
1240 }
1241
1242 XS(XS_re_regexp_pattern)
1243 {
1244     dVAR;
1245     dXSARGS;
1246     REGEXP *re;
1247
1248     if (items != 1)
1249         croak_xs_usage(cv, "sv");
1250
1251     SP -= items;
1252
1253     /*
1254        Checks if a reference is a regex or not. If the parameter is
1255        not a ref, or is not the result of a qr// then returns false
1256        in scalar context and an empty list in list context.
1257        Otherwise in list context it returns the pattern and the
1258        modifiers, in scalar context it returns the pattern just as it
1259        would if the qr// was stringified normally, regardless as
1260        to the class of the variable and any stringification overloads
1261        on the object.
1262     */
1263
1264     if ((re = SvRX(ST(0)))) /* assign deliberate */
1265     {
1266         /* Houston, we have a regex! */
1267         SV *pattern;
1268
1269         if ( GIMME_V == G_ARRAY ) {
1270             STRLEN left = 0;
1271             char reflags[sizeof(INT_PAT_MODS) + MAX_CHARSET_NAME_LENGTH];
1272             const char *fptr;
1273             char ch;
1274             U16 match_flags;
1275
1276             /*
1277                we are in list context so stringify
1278                the modifiers that apply. We ignore "negative
1279                modifiers" in this scenario, and the default character set
1280             */
1281
1282             if (get_regex_charset(RX_EXTFLAGS(re)) != REGEX_DEPENDS_CHARSET) {
1283                 STRLEN len;
1284                 const char* const name = get_regex_charset_name(RX_EXTFLAGS(re),
1285                                                                 &len);
1286                 Copy(name, reflags + left, len, char);
1287                 left += len;
1288             }
1289             fptr = INT_PAT_MODS;
1290             match_flags = (U16)((RX_EXTFLAGS(re) & RXf_PMf_COMPILETIME)
1291                                     >> RXf_PMf_STD_PMMOD_SHIFT);
1292
1293             while((ch = *fptr++)) {
1294                 if(match_flags & 1) {
1295                     reflags[left++] = ch;
1296                 }
1297                 match_flags >>= 1;
1298             }
1299
1300             pattern = newSVpvn_flags(RX_PRECOMP(re),RX_PRELEN(re),
1301                                      (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
1302
1303             /* return the pattern and the modifiers */
1304             XPUSHs(pattern);
1305             XPUSHs(newSVpvn_flags(reflags, left, SVs_TEMP));
1306             XSRETURN(2);
1307         } else {
1308             /* Scalar, so use the string that Perl would return */
1309             /* return the pattern in (?msix:..) format */
1310 #if PERL_VERSION >= 11
1311             pattern = sv_2mortal(newSVsv(MUTABLE_SV(re)));
1312 #else
1313             pattern = newSVpvn_flags(RX_WRAPPED(re), RX_WRAPLEN(re),
1314                                      (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
1315 #endif
1316             XPUSHs(pattern);
1317             XSRETURN(1);
1318         }
1319     } else {
1320         /* It ain't a regexp folks */
1321         if ( GIMME_V == G_ARRAY ) {
1322             /* return the empty list */
1323             XSRETURN_UNDEF;
1324         } else {
1325             /* Because of the (?:..) wrapping involved in a
1326                stringified pattern it is impossible to get a
1327                result for a real regexp that would evaluate to
1328                false. Therefore we can return PL_sv_no to signify
1329                that the object is not a regex, this means that one
1330                can say
1331
1332                  if (regex($might_be_a_regex) eq '(?:foo)') { }
1333
1334                and not worry about undefined values.
1335             */
1336             XSRETURN_NO;
1337         }
1338     }
1339     /* NOT-REACHED */
1340 }
1341
1342 struct xsub_details {
1343     const char *name;
1344     XSUBADDR_t xsub;
1345     const char *proto;
1346 };
1347
1348 struct xsub_details details[] = {
1349     {"UNIVERSAL::isa", XS_UNIVERSAL_isa, NULL},
1350     {"UNIVERSAL::can", XS_UNIVERSAL_can, NULL},
1351     {"UNIVERSAL::DOES", XS_UNIVERSAL_DOES, NULL},
1352     {"UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, NULL},
1353     {"version::()", XS_version_noop, NULL},
1354     {"version::new", XS_version_new, NULL},
1355     {"version::parse", XS_version_new, NULL},
1356     {"version::(\"\"", XS_version_stringify, NULL},
1357     {"version::stringify", XS_version_stringify, NULL},
1358     {"version::(0+", XS_version_numify, NULL},
1359     {"version::numify", XS_version_numify, NULL},
1360     {"version::normal", XS_version_normal, NULL},
1361     {"version::(cmp", XS_version_vcmp, NULL},
1362     {"version::(<=>", XS_version_vcmp, NULL},
1363     {"version::vcmp", XS_version_vcmp, NULL},
1364     {"version::(bool", XS_version_boolean, NULL},
1365     {"version::boolean", XS_version_boolean, NULL},
1366     {"version::(nomethod", XS_version_noop, NULL},
1367     {"version::noop", XS_version_noop, NULL},
1368     {"version::is_alpha", XS_version_is_alpha, NULL},
1369     {"version::qv", XS_version_qv, NULL},
1370     {"version::declare", XS_version_qv, NULL},
1371     {"version::is_qv", XS_version_is_qv, NULL},
1372     {"utf8::is_utf8", XS_utf8_is_utf8, NULL},
1373     {"utf8::valid", XS_utf8_valid, NULL},
1374     {"utf8::encode", XS_utf8_encode, NULL},
1375     {"utf8::decode", XS_utf8_decode, NULL},
1376     {"utf8::upgrade", XS_utf8_upgrade, NULL},
1377     {"utf8::downgrade", XS_utf8_downgrade, NULL},
1378     {"utf8::native_to_unicode", XS_utf8_native_to_unicode, NULL},
1379     {"utf8::unicode_to_native", XS_utf8_unicode_to_native, NULL},
1380     {"Internals::SvREADONLY", XS_Internals_SvREADONLY, "\\[$%@];$"},
1381     {"Internals::SvREFCNT", XS_Internals_SvREFCNT, "\\[$%@];$"},
1382     {"Internals::hv_clear_placeholders", XS_Internals_hv_clear_placehold, "\\%"},
1383     {"PerlIO::get_layers", XS_PerlIO_get_layers, "*;@"},
1384     {"Internals::hash_seed", XS_Internals_hash_seed, ""},
1385     {"Internals::rehash_seed", XS_Internals_rehash_seed, ""},
1386     {"Internals::HvREHASH", XS_Internals_HvREHASH, "\\%"},
1387     {"re::is_regexp", XS_re_is_regexp, "$"},
1388     {"re::regname", XS_re_regname, ";$$"},
1389     {"re::regnames", XS_re_regnames, ";$"},
1390     {"re::regnames_count", XS_re_regnames_count, ""},
1391     {"re::regexp_pattern", XS_re_regexp_pattern, "$"},
1392 };
1393
1394 void
1395 Perl_boot_core_UNIVERSAL(pTHX)
1396 {
1397     dVAR;
1398     static const char file[] = __FILE__;
1399     struct xsub_details *xsub = details;
1400     const struct xsub_details *end
1401         = details + sizeof(details) / sizeof(details[0]);
1402
1403     do {
1404         newXS_flags(xsub->name, xsub->xsub, file, xsub->proto, 0);
1405     } while (++xsub < end);
1406
1407     /* register the overloading (type 'A') magic */
1408     PL_amagic_generation++;
1409
1410     /* Providing a Regexp::DESTROY fixes #21347. See test in t/op/ref.t  */
1411     {
1412         CV * const cv =
1413             newCONSTSUB(get_hv("Regexp::", GV_ADD), "DESTROY", NULL);
1414         Safefree(CvFILE(cv));
1415         CvFILE(cv) = (char *)file;
1416         CvDYNFILE_off(cv);
1417     }
1418 }
1419
1420 /*
1421  * Local variables:
1422  * c-indentation-style: bsd
1423  * c-basic-offset: 4
1424  * indent-tabs-mode: t
1425  * End:
1426  *
1427  * ex: set ts=8 sts=4 sw=4 noet:
1428  */