IV, NV などを B モジュールで調べる

2011-02-13 心変わり

IV, NV などを B モジュールで調べる

makamaka さんが YAPC Asia 2010 にて発表した XSからPPへ - YAPC::Asia Tokyo 2010 に既に書いてあるんだけど、備忘録を兼ねて。

JSON にする際に違いが出てくる訳ですがまずは論より証拠。

$ perl -MJSON -e 'warn encode_json(+{ foo => 1, bar => "1", baz => 0 + "1" })'
{"bar":"1","baz":1,"foo":1} at -e line 1.

これらは IV なのか PV なのかばっちり判定してくれる訳ですね。API なんかのユースケースだとこの辺りを厳密にやらねばならないので、この辺りの制御はちゃんとやらないといかんのです。

その前に Devel::Peek で中を見てみると、

$ perl -MDevel::Peek -e 'my $i = "1"; Dump($i);'
SV = PV(0x10041040) at 0x10043be0
  REFCNT = 1
  FLAGS = (PADMY,POK,pPOK)
  PV = 0x10042020 "1"\0
  CUR = 1
  LEN = 4
$ perl -MDevel::Peek -e 'my $i = 1; Dump($i);'
SV = IV(0x10043be0) at 0x10043be0
  REFCNT = 1
  FLAGS = (PADMY,IOK,pIOK)
  IV = 1
$ perl -MDevel::Peek -e 'my $i = "1"; $i = 0 + $i; Dump($i);'
SV = PVIV(0x10062010) at 0x10043be0
  REFCNT = 1
  FLAGS = (PADMY,IOK,pIOK)
  IV = 1
  PV = 0x10042020 "1"\0
  CUR = 1
  LEN = 4

となり、一度 PV として初期化された変数も IV に変換すると PVIV になると。*1

B モジュールで B::SVp_IOK とか使えるってどこにも書いてない気がするんだけど気のせいだろうか。とりあえず sv.h で定義されている定数のうちその辺りは使えるみたいです。

B モジュールの svref_2object() によって B::SV オブジェクトにしつつ、そのオブジェクトメソッドである FLAGS を用いればどういう flag が立ってるか分かります。

即ちこんな感じでチェック出来ますよと。

#!/usr/bin/perl

use strict;
use warnings;
use B;
use Test::More;

sub iv_ok {
    my $sv = shift;
    return ( B::svref_2object( \$sv )->FLAGS & B::SVp_IOK ) ? 1 : 0;
}

sub nv_ok {
    my $sv = shift;
    return ( B::svref_2object( \$sv )->FLAGS & B::SVp_NOK ) ? 1 : 0;
}

subtest 'IV' => sub {
    my $sv1 = 1;

    is( iv_ok($sv1), 1, 'IV' );
    is( nv_ok($sv1), 0, 'not NV' );

    my $sv2 = "1";

    is( iv_ok($sv2), 0, 'not IV' );
    is( nv_ok($sv2), 0, 'not NV' );

    $sv2 = 0 + $sv2;

    is( iv_ok($sv2), 1, 'IV' );
    is( nv_ok($sv2), 0, 'not NV' );
    done_testing;
};

subtest 'NV' => sub {
    my $sv1 = 1.0;

    is( iv_ok($sv1), 0, 'not IV' );
    is( nv_ok($sv1), 1, 'NV' );

    my $sv2 = "1.0";

    is( iv_ok($sv2), 0, 'not IV' );
    is( nv_ok($sv2), 0, 'not NV' );

    $sv2 = 0 + $sv2;

    is( iv_ok($sv2), 0, 'not IV' );
    is( nv_ok($sv2), 1, 'NV' );
    done_testing;
};

done_testing;