tokuhirom's blog

Devel::MemProfile つくったけどオクラ入りにした話

B::Size2::Terse と Devel::Symdump を使ってメモリをプロファイルしようとしたんだけど、パッケージに紐づくやつしか見れないから、やっぱあんま意味ないなということでお蔵入り。

Devel::SizeMe 使えばいいんだけど、blead perl でうごかなかったり assertion failed になったりして謎すぎっから諦めた。(というか、パッチを送ったんだけど取り込まれないし困ってる)

package Devel::MemProfile;
use strict;
use warnings;
use utf8;
use 5.010_001;
use Devel::Symdump;
use B::Size2::Terse;

sub new {
    my $class = shift;

    my @packages = Devel::Symdump->rnew("main")->packages;
    my $size;

    for my $package ("main", @packages) {
        my($subs, $opcount, $opsize) = B::Size2::Terse::package_size($package);
        $size->{$package} = $opsize;
    }
    return bless $size, $class;
}

sub diff {
    my ($self, $after) = @_;
    $after ||= $self->new();

    my $diff = {};
    for my $pkg (keys %$after) {
        $diff->{$pkg} = $after->{$pkg} - ($self->{$pkg} || 0);
    }
    return $diff;
}

sub dump_diff {
    my ($self, $after, $opts) = @_;
    $after ||= $self->new();
    my $diff = $self->diff($after);
    $opts->{order} ||= 'diff';
    my $out = *STDERR || $opts->{out};

    my @pkgs = keys %$after;
    if ($opts->{order} eq 'after') {
        @pkgs = sort { $after->{$b} <=> $after->{$a}} @pkgs;
    } elsif ($opts->{order} eq 'diff') {
        @pkgs = sort { $diff->{$b} <=> $diff->{$a}} @pkgs;
    } else {
        die "Unknown sort order: '$opts->{order}'";
    }

    print STDERR sprintf(
        "%-32s %8s = %8s - %8s [KB]\n",
        'pkg', 'diff', 'after', 'before',
    );
    my $i = 0;
    for my $pkg (@pkgs) {
        if ($opts->{skip_zero} && $opts->{order} eq 'diff' && $diff->{$pkg} == 0) {
            last;
        }

        print STDERR sprintf(
            "%-32s %8d = %8d - %8d [KB]\n",
            _abbr($pkg, 32),
            $diff->{$pkg} / 1024,
            ($after->{$pkg}||0) / 1024,
            ($self->{$pkg}||0) / 1024,
        );
        $i++;
        last if defined($opts->{limit}) && $i >= $opts->{limit};
    }
}

sub dump {
    my ($self, $opts) = @_;
    my $out = *STDERR || $opts->{out};

    my @pkgs = keys %$self;
    @pkgs = sort { $self->{$b} <=> $self->{$a}} @pkgs;

    print STDERR sprintf(
        "%-32s %8s [KB]\n",
        'Pakcage', 'memory',
    );
    my $i = 0;
    for my $pkg (@pkgs) {
        print STDERR sprintf(
            "%-32s %8d [KB]\n",
            _abbr($pkg, 32),
            $self->{$pkg} / 1024,
        );
        $i++;
        last if defined($opts->{limit}) && $i >= $opts->{limit};
    }
}

sub _abbr {
    my ($pkg, $len) = @_;
    if (length($pkg) > $len) {
        if ($pkg =~ /\A(.*)::(.*?)\z/) {
            my ($prefix, $moniker) = ($1, $2);
            $prefix =~ s/([^:])([^:]+)/$1/g;
            return substr($prefix . "::" . $moniker, 0, $len);
        } else {
            return substr($pkg, 0, $len);
        }
    } else {
        return $pkg;
    }
}

1;
Created: 2014-04-10 12:49:16
Updated: 2014-04-10 12:49:16

How do I install Memcached::libmemcached on OSX.

http://qiita.com/xtetsuji/items/746da7791e2e0c01e890

Extract tar ball and cd to src/. And call ./README 1.0.18. Then, it downloads tar ball from bitbucket. After this, libmemcached still has a bug. Apply this patch.

diff --git a/src/libmemcached/clients/memflush.cc b/src/libmemcached/clients/memflush.cc
index 8bd0dbf..7641b88 100644
--- a/src/libmemcached/clients/memflush.cc
+++ b/src/libmemcached/clients/memflush.cc
@@ -39,7 +39,7 @@ int main(int argc, char *argv[])
 {
   options_parse(argc, argv);

-  if (opt_servers == false)
+  if (!opt_servers)
   {
     char *temp;

@@ -48,7 +48,7 @@ int main(int argc, char *argv[])
       opt_servers= strdup(temp);
     }

-    if (opt_servers == false)
+    if (!opt_servers)
     {
       std::cerr << "No Servers provided" << std::endl;
       exit(EXIT_FAILURE);

Then, you can use Memcached::libmemcached on OSX. (But, 1 test fails..)

(But, I don't suggest to use Memcached::libmemcached... I suggest to use Cache::Memcached::Fast!!!!!!!)

Created: 2014-04-06 18:51:53
Updated: 2014-04-06 18:51:53

Shipped scan-prereqs-cpanfile 1.00

scan-prereqs-cpanfile is using Perl::PrereqScanner::Lite instead of Perl::PrereqScanner now. This change makes scan-prereqs-cpanfile really fast.

The benchmark result is here: http://moznion.hatenadiary.com/entry/2014/03/21/231805

Created: 2014-04-03 08:06:33
Updated: 2014-04-03 08:06:33

Released Web::ChromeLogger

https://metacpan.org/pod/Web::ChromeLogger

Web::ChromeLogger is a ChromeLogger library for Perl5. Chrome Logger is a Google Chrome extension for debugging server side applications in the Chrome console.

Enjoy!

Created: 2014-03-28 20:36:22
Updated: 2014-03-28 20:36:22

Added experimental cookie_jar support in Furl

Hi,

I added experimental cookie_jar support in Furl.

You can use cookie_jar like following code:

use Furl;
use HTTP::CookieJar;

my $furl = Furl->new(cookie_jar => HTTP::CookieJar->new());
$furl->get('http://example.com/');
...

Enjoy!

Created: 2014-03-19 05:58:25
Updated: 2014-03-19 05:58:25

[perl] コントローラがどのテンプレを表示したかをテストする

Module::Spy をつかう。

my $render = spy_on('Text::Xslate', 'render');

# コントローラをよぶ
...;

my $tmpl = $render->calls_first->[1];
ok { $tmpl eq 'my/index.tt' };
Created: 2014-03-14 18:27:04
Updated: 2014-03-14 18:27:04

Re: 「切り捨て」に int() は使うべからず

http://blog.livedoor.jp/nipotan/archives/18935329.html

遅レスだけど、精度がいらなくて floor() になろうが ceil() になろうがどっちでもいいなって時には int() を別につかっても構わない。

floor() ceil() のどちらかによせたい時は floor() ceil() つかえばいい。

sprintf("%d", $n) は、意図がよくわからなくなるから、あんまつかわないほがいいとおもう。

Created: 2014-03-12 11:46:42
Updated: 2014-03-12 11:46:42

Module::Spy - Spy for Perl5

I released the new great Module::Spy. Repository is now on github.com/tokuhirom/Module-Spy.git.

I saw jasmine at few days ago. jasmine is very popular BDD testing framework for JavaScript. jasmine has the great interface for spy. A spy can stub any function and tracks calls to it and all arguments.

I'm using the local feature in the past days. Because it's good enough for me.

For example, following script works well.

use LWP::UserAgent;

my $called = 0;
no warnings 'redefine';
local *LWP::UserAgent::request = sub {
    $called++;
    HTTP::Response->new(200);
};
my $ua = LWP::UserAgent->new;
my $res = $ua->get('http://mixi.jp');
ok $called;

It works well... But the code is bit complicated.

When if you are using Module::Spy, you can write the code as following:

use LWP::UserAgent;
use Module::Spy;

my $spy = spy_on('LWP::UserAgent', 'request')->and_returns(
    HTTP::Response->new(200);
);
my $ua = LWP::UserAgent->new;
my $res = $ua->get('http://mixi.jp');
ok $spy->called_any;

The code is really readable!

And also, you can send spy for objects. It uses the Singleton class pattern.

my $ua = LWP::UserAgent->new;
my $spy = spy_on($ua, 'request')->and_returns(
    HTTP::Response->new(200);
);
my $res = $ua->get('http://mixi.jp');
ok $spy->called_any;

And so, Module::Spy restores the methods after $spy was gone!

Enjoy!

Created: 2014-03-08 06:05:19
Updated: 2014-03-08 06:05:19

MY_CXT_KEY is no longer used by current Perl5 implementation

We met a strange bug around XS. https://github.com/gfx/p5-Mouse/issues/18

This issue does not appear on recent Perl5 implementations.

... I find the difference between olders and recent implementation. Then I found a comment in the perl.h.

* 1. #define MY_CXT_KEY to a unique string, e.g.
*    "DynaLoader::_guts" XS_VERSION
*    XXX in the current implementation, this string is ignored.

Hmm...!!! The change is this: http://perl5.git.perl.org/perl.git/commitdiff/f16dd614412ea67a8eb64bb09a88fccdbd9db6b6?hp=85ce96a160e902929b94338ada20cf46b265d595

> git describe --all f16dd614412ea67a8eb64bb09a88fccdbd9db6b6
tags/perl-5.9.2-2002-gf16dd61

The change is applied on 5.10.0.

Then, if you are using MYCXTKEY, you need to test on 5.8.x explicitly(If you want to support old 5.8.x).

Created: 2014-02-26 14:09:50
Updated: 2014-02-26 14:09:50

Perl 5.19.9 で実装された signatures の構文をためしてみる

use 5.019009;
use autodie;

use feature 'signatures';
no warnings "experimental::signatures";

package Foo {
    sub new($class, $n) {
        bless {n=>$n}, $class;
    }
    sub bar($class, $a) {
        $a+3;
    }

    sub baz($self, $a) {
        $self->{n} * $a;
    }
}

sub add($left, $right) {
    return $left + $right;
}

say add(1,2);
say Foo->bar(4);
say Foo->new(5)->baz(4);

みたいな感じでつかえる。

【追記】

use 5.019009;

use feature 'signatures';
no warnings "experimental::signatures";

use B::Deparse;

sub add($left, $right) { $left + $right  }

my $deparse = B::Deparse->new("-p", "-sC");
say $deparse->coderef2text(\&add);

のようにすると、結果が以下のようになり、引数の処理はコードとして生成されていることがわかる。

{
    BEGIN {${^WARNING_BITS} = "\020\001\000\000\000P\004\000\000\000\000\000\000U\005"}
    use strict;
    use feature 'current_sub', 'evalbytes', 'fc', 'say', 'signatures', 'state', 'switch', 'unicode_strings', 'unicode_eval';
    no feature 'array_base';
    ((@_ <= 2) or die('Too many arguments for subroutine'));
    ((@_ >= 2) or die('Too few arguments for subroutine'));
    (my $left = $_[0]);
    (my $right = $_[1]);
    ();
    ($left + $right);
}

【追記】

なお、この種類のやつは prototype() 関数ではプロトタイプ宣言がとれません。

【追記】

19:41 xaicron____: signatures、deparse で (); って入るのがなぞ
19:42 tokuhirom: それないとこまるよ
19:42 xaicron____: そうなの?
19:42 tokuhirom: sub mattn { my $ossan=shift; }
19:42 tokuhirom: ってなったら
19:42 tokuhirom: $ossan の中身がそのままかえるじゃん
19:42 xaicron____: あーなる
19:42 tokuhirom: sub mattn($ossan) { } に mattn(3) ってして 3 がかえったらおかしい
19:43 xaicron____: こまる!
Created: 2014-02-24 19:44:18
Updated: 2014-02-24 19:44:18