2011-05-23

bookmark.el でブックマーク名を自動入力

Emacs

bookmark.el の使いづらいところと言えば、ブックマーク名を自分で入れなきゃらないところ。ブックマーク名を自動で入れればかなり便利になるんじゃないかと考え、「ファイル名:行数:関数名」と自動でブックマーク名を入れることにした。

which-functionというので、今いる関数の名前がわかるらしいので、これを利用する。

以下のような関数を定義し、

(require 'which-func)
(defun my-get-bookmark-name ()
  (interactive)
  (message "%s:%s:%s"
            (buffer-name)
            (line-number-at-pos (point)) (or (which-function) "")))

以下のhoge()で M-x my-get-bookmark-nameを実行すると

#include <stdio.h>
void hoge(void)
{
    return;
}

int main(int argc, char *argv[])
{
    hoge();
    return 0;
}

エコーバッファに「foo.c:4:hoge」と表示された。

これを使って関数を辿っていくのにどんどんブックマークをつけていったら、ブックマークが多くなって収集がつかなってきた。そこでブックマークの先頭に"!"が付いている場合は、次回起動時に読み込まないようにした。つまり、先頭に"!"とついているブックマークはテンポラリとする。

2011-05-26 オリジナルのbookmark.elに手を入れないと動かいなことがわかった。残念。

(require 'bookmark)

;; ブックマーク名を "!バッファ名:行数:関数名" にする。
;; オリジナルの bookmark-buffer-name 関数を上書き。
;; 後述するように、起動時に先頭が"!"となっているブックマークを削除することに注
;; 意。ブックマークを起動時に削除したくない場合は、ブックマーク登録時にミニバッ
;; ファで C-u を押して"!"を削除してから登録するか、 C-x r l で一覧表示して r を
;; 押して先頭の"!"を削除して登録しなおす。
(require 'which-func)
(defun bookmark-buffer-name ()
  (cond
   ((string-equal mode-name "Info") Info-current-node)
   ((and (boundp 'dired-directory) dired-directory)
    (format "%s" (buffer-name)))
   (t
    (format "!%s:%s:%s"
            (buffer-name)
            (line-number-at-pos (point)) (or (which-function) "")))))

;; 起動時に先頭が"!"となっているブックマークを削除する。 bookmark-default-file
;; を変更しているときは、事前に bookmark-default-file を設定しておく必要あり。
(require 'cl)
(bookmark-maybe-load-default-file)
(setq bookmark-alist
      (remove-if
       (lambda (x) (string-match "^!" (car x)) ) bookmark-alist))
(bookmark-save)

;; ブックマーク名に関数名を入れたことにより、ブックマーク名が長くなりがちなので、
;; 表示を伸ばす
(setq bookmark-bmenu-file-column 60)

;; オリジナルのbookmark-setに以下の変更を加える
;; elcファイルがあるときはバイトコンパイル必要なことに注意
;; diff -c bookmark.el bookmark.el.20110526-1635~ 
;; *** bookmark.el 2011-05-26 16:37:45.970516200 +0900
;; --- bookmark.el.20110526-1635~  2009-08-09 21:37:28.001000000 +0900
;; ***************
;; *** 761,769 ****
;;     (setq bookmark-yank-point (point))
;;     (setq bookmark-current-buffer (current-buffer))
;;
;; ! ;;   (let* ((default (or bookmark-current-bookmark
;; ! ;;                       (bookmark-buffer-name)))
;; !   (let* ((default (bookmark-buffer-name))
;;      (str
;;       (or name
;;                 (read-from-minibuffer
;; --- 761,768 ----
;;     (setq bookmark-yank-point (point))
;;     (setq bookmark-current-buffer (current-buffer))
;;
;; !   (let* ((default (or bookmark-current-bookmark
;; !                       (bookmark-buffer-name)))
;;      (str
;;       (or name
;;                 (read-from-minibu
;;                 ffer

補足

bm.el というのもあるそう。

2011-05-16

Coro で Thread-Specific Storage パターン

Perl Design Pattern Coro

増補改訂版 Java言語で学ぶデザインパターン入門マルチスレッド編を参考に Coro で Thread-Specific Storage パターンを実装。Thread-Specific Storage パターンは、スレッドごとのコインロッカー。

スレッドがコインロッカーを初めて使うときは、そのスレッド用のコインロッカーが作られる
2回目から、既に作られたコインロッカーを使う
スレッドごとにコインロッカーが作られる

下の図だとスレッドが一個しかないけど、2つあればclien1-object1、client2-object2のような関係になる。

スレッドに名前を付けて、コインロッカーの門番である proxy に見せると専用のコインロッカーが割り当たるイメージ。Javaだとスレッドに名前を付ける標準の方法があるみたいだけど、Coroだとよくわからんな。

#!/usr/bin/perl
use strict;
use warnings;

package Client;
use Coro;
use Coro::Select ();
use Scalar::Util qw(refaddr);

our %coro_name = ();

sub new {
    my ( $class, %args ) = @_;
    my %defaults = ( name => 'no name' );
    %args = ( %defaults, %args );
    bless \%args, $class;
}

sub run {
    my $self = shift;
    my $coro = async {
        do {
            print $self->{name}, " BEGIN\n";
            my $id = refaddr($Coro::current);
            $Client::coro_name{$id} = $self->{name};
            for my $count ( 1 .. 10 ) {
                Log->println( "i = " . $count );

                # sleep 100 milli second
                Coro::Select::select( undef, undef, undef, 0.1 );
            }
            Log->close();
            print $self->{name}, " END\n";
        };
    };
    return $coro;
}

package TSLog;

sub new {
    my ( $class, %args ) = @_;
    my %defaults = ( filename => "no_name" );
    %args = ( %defaults, %args );

    my $file = $args{filename};
    open my $fh, '>', $file or die "$!:$file";
    %args = ( fh => $fh );
    bless \%args, $class;
}

sub println {
    my $self = shift;
    my $str  = shift;
    print { $self->{fh} } $str, $/;
}

sub close {
    my $self = shift;
    $self->println("==== End of log ====");
    close $self->{fh} or die "$!:" . $self->{filename};
}

package Log;
use Coro;
use Scalar::Util qw(refaddr);

our %_ts_log_list = ();

sub println {
    my $class = shift;
    my $str   = shift;
    $class->get_TSLog()->println($str);
}

sub close {
    my $class = shift;
    $class->get_TSLog()->close();
}

sub get_TSLog {
    my $class = shift;

    my $id   = refaddr($Coro::current);
    my $name = $Client::coro_name{$id};
    if ( !exists $_ts_log_list{$name} ) {
        $_ts_log_list{$name} = TSLog->new( filename => "${name}.txt" );
    }
    return $_ts_log_list{$name};
}

package main;

my $coro_alice = Client->new( name => "Alice" )->run();
my $coro_bobby = Client->new( name => "Bobby" )->run();
my $coro_chris = Client->new( name => "Chris" )->run();

$coro_alice->join();
$coro_bobby->join();
$coro_chris->join();

出力

$ perl -w ThreadSpecificStorage.pl
Alice BEGIN
Bobby BEGIN
Chris BEGIN
Alice END
Bobby END
Chris END
# Alice.txt, Bobby.txt. Chris.txtが作られる

pic ファイル

.PS

copy "sequence.pic";

boxwid = 1.3;

# Define the objects
object(CL,":client");
object(P,":proxy");
object(C,":collection");
placeholder_object(O);
step();

# Message sequences
active(CL);

message(CL,P,"request");
active(P);

message(P,C,"get_object");
active(C);
rmessage(C,P,"(null)");
inactive(C);

create_message(P,O,":Object");
rmessage(O,P,"(object)");

message(P,C,"set_object");
active(C);
rmessage(C,P,"");
inactive(C);

message(P,O,"request");
active(O);
rmessage(O,P,"");
inactive(O);

rmessage(P,CL,"");
inactive(P);

step();

message(CL,P,"request");
active(P);

message(P,C,"get_object");
active(C);
rmessage(C,P,"(object)");
inactive(C);

message(P,O,"request");
active(O);
rmessage(O,P,"");
inactive(O);

rmessage(P,CL,"");
inactive(P);

complete(CL);
complete(P);
complete(C);
complete(O);

.PE

参考

増補改訂版 Java言語で学ぶデザインパターン入門マルチスレッド編

作者: 結城浩
出版社/メーカー: ソフトバンククリエイティブ
発売日: 2006/03/21
メディア: 大型本
購入: 15人クリック: 287回
この商品を含むブログ (206件) を見る

2011-04-17

Coro で Two-Phase Termination パターン

Perl Design Pattern Coro

増補改訂版 Java言語で学ぶデザインパターン入門マルチスレッド編を参考に Coro で Two-Phase Termination パターンを実装。

Two-Phase Termination パターンは別スレッドに止まれと命令して、別スレッドに終了処理させる。終了処理が終ってスレッドが終了するのを待つ。

#!/usr/bin/perl
use strict;
use warnings;

package Countup;
use Coro;
use Coro::Timer;
use Error qw(:try);

sub new {
    my ( $class, %args ) = @_;
    $args{counter} = 0;
    $args{shutdown_requested} = 0;
    bless \%args, $class;
}

sub shutdown_request {
    my $self = shift;
    my $coro = shift;
    $self->{shutdown_requested} = 1;
    $coro->throw("Shutdown Request");
}

sub is_shutdown_requested {
    my $self = shift;
    return $self->{shutdown_requested};
}

sub start {
    my $self = shift;
    try {
        while (!$self->is_shutdown_requested()) {
            $self->do_work();
        }
    }
    catch Error with {
        my $e = shift;
        print qq{catch "}, $e->text, qq{"\n};
    }
    finally {
        $self->do_shutdown();
    };
}

sub do_work {
    my $self = shift;
    $self->{counter}++;
    print "do_work : counter = ", $self->{counter}, $/;
    Coro::Timer::sleep(1);
}

sub do_shutdown {
    my $self = shift;
    $self->{counter}++;
    print "do_shutdown\n";
}

package main;
use Coro;
use Coro::Timer;

print "main : BEGIN\n";
my $countup;
my $coro = async {
    $countup = Countup->new();
    $countup->start();
};

Coro::Timer::sleep(3);

print "main : shutdown_request\n";
$countup->shutdown_request($coro);
$coro->join();
print "main : END\n";

出力

$ perl -w TwoPhaseTermination.pl
main : BEGIN
do_work : counter = 1
do_work : counter = 2
do_work : counter = 3
main : shutdown_request
catch "Shutdown Request"
do_shutdown
main : END

pic ファイル

.PS

copy "sequence.pic";

boxwid = 1.3;

# Define the objects
object(M,":main");
placeholder_object(T);
step();

# Message sequences
active(M);
create_message(M,T,":countup");
message(M,T,"start");
active(T);
rmessage(T,M,"");

message(T,T,"is_shutdown_requested");
active(T);
step();
inactive(T);
comment(T,C,down 0.5 left 0.5,wid 0.75 ht 0.25 "false");

message(T,T,"do_work");
active(T);
step();
inactive(T);

message(T,T,"is_shutdown_requested");
active(T);
step();
inactive(T);
connect_to_comment(T,C);

message(T,T,"do_work");
active(T);
step();
inactive(T);

message(M,T,"shutdown_request");
rmessage(T,M,"");

message(M,T,"join");
comment(M,C,up 0.5 left 0.25,wid 1.25 ht 0.25 "waiting for finish");

message(T,T,"is_shutdown_requested");
active(T);
step();
inactive(T);
comment(T,C,down 0.5 left 0.5,wid 0.75 ht 0.25 "true");

message(T,T,"do_shutdown");
active(T);
step();
inactive(T);

rmessage(T,M,"");
delete(T);

complete(M);

.PE

参考

増補改訂版 Java言語で学ぶデザインパターン入門マルチスレッド編

作者: 結城浩
出版社/メーカー: ソフトバンククリエイティブ
発売日: 2006/03/21
メディア: 大型本
購入: 15人クリック: 287回
この商品を含むブログ (206件) を見る

2011-04-10

Coro で Future パターン

Perl Design Pattern Coro

増補改訂版 Java言語で学ぶデザインパターン入門マルチスレッド編を参考に Coro で Future パターンを実装。

Future パターンは別スレッドに仕事を投げて、戻りにID (引き換え券)を貰う。あとで引き換え券を渡して結果を確認する。

#!/usr/bin/perl
use strict;
use warnings;

package Host;
use Coro;

sub new {
    my ( $class, %args ) = @_;
    bless bless \%args, $class;
}

sub request {
    my $self        = shift;
    my @args        = @_;
    my $future_data = FutureData->new();
    my $coro        = async {
        do {
            my $real_data = RealData->new(@args);
            $future_data->set_real_data($real_data);
        };
    };
    return $future_data;
}

package FutureData;
use Coro;
use Coro::Signal;

sub new {
    my ( $class, %args ) = @_;
    $args{real_data} = undef;
    $args{ready}     = 0;
    $args{signal}    = Coro::Signal->new();
    bless \%args, $class;
}

sub set_real_data {
    my $self      = shift;
    my $guard     = $self->_get_guard();
    my $real_data = shift;

    if ( $self->{ready} ) {
        return;
    }

    $self->{real_data} = $real_data;
    $self->{ready}     = 1;
    $self->{signal}->broadcast();
}

sub get_content {
    my $self  = shift;
    my $guard = $self->_get_guard();

    while ( $self->{ready} == 0 ) {
        $self->{signal}->wait();
    }
    return $self->{real_data}->get_content();
}

sub _get_guard {
    my $self = shift;
    my $name = ( caller 1 )[3];
    $name =~ s/.*:://;
    $name .= '_sem';

    if ( !exists( $self->{$name} ) ) {
        $self->{$name} = Coro::Semaphore->new;
    }
    else {
        my $class = ref $self->{$name};
        if ( $class ne 'Coro::Semaphore' ) {
            die "$name is not Coro::Semaphore";
        }
    }

    return $self->{$name}->guard();
}

package RealData;
use Coro;
use Coro::Select ();

sub new {
    my ( $class, %args ) = @_;
    my %defaults = ( count => '3', char => 'A' );
    %args = ( %defaults, %args );

    my $buffer = q{};
    for my $count ( 1 .. $args{count} ) {
        $buffer .= $args{char};

        # sleep 100 milli second
        Coro::Select::select( undef, undef, undef, 0.1 );
    }
    $args{content} = $buffer;
    bless \%args, $class;
}

sub get_content {
    my $self = shift;
    return $self->{content};
}

package main;
use Coro;
use Coro::Timer;

my $host  = Host->new();
my $data1 = $host->request( count => 10, char => 'A' );
my $data2 = $host->request( count => 20, char => 'B' );
my $data3 = $host->request( count => 30, char => 'C' );
Coro::Timer::sleep(2);
print "data1 = ", $data1->get_content(), $/;
print "data2 = ", $data2->get_content(), $/;
print "data3 = ", $data3->get_content(), $/;

出力

$ perl -w Future.pl
data1 = AAAAAAAAAA
data2 = BBBBBBBBBBBBBBBBBBBB
data3 = CCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

pic ファイル

.PS

copy "sequence.pic";

boxwid = 1.3;

# Define the objects
object(M,":main");
placeholder_object(H);
placeholder_object(T);
placeholder_object(F);
placeholder_object(R);
step();

# Message sequences
active(M);

create_message(M,H,":host");
message(M,H,"request");
active(H);
create_message(H,F,":future_data");
create_message(H,T,":coro");
rmessage(H,M,"");

active(T);
create_message(T,R,":real_data");
active(R);
rmessage(R,T);
inactive(R);

message(T,F,"set_real_data");
active(F);
rmessage(F,T);
inactive(F);

step();
inactive(T);
delete(T);

message(M,F,"get_content");
active(F);
message(F,R,"get_content");
active(R);
rmessage(R,F,"");
inactive(R);
rmessage(F,M,"");
inactive(F);


complete(M);
complete(H);
complete(T);
complete(F);
complete(R);

.PE

参考

増補改訂版 Java言語で学ぶデザインパターン入門マルチスレッド編

作者: 結城浩
出版社/メーカー: ソフトバンククリエイティブ
発売日: 2006/03/21
メディア: 大型本
購入: 15人クリック: 287回
この商品を含むブログ (206件) を見る

2011-04-03

Coro で Worker-Thread パターン

Perl Design Pattern Coro

増補改訂版 Java言語で学ぶデザインパターン入門マルチスレッド編を参考に Coro で Worker-Thread パターンを実装。

Worker-Thread パターンはワーカースレッドが依頼を待ち、依頼が来たら処理する。

#!/usr/bin/perl
use strict;
use warnings;

package Client;
use Coro;
use Coro::Timer;

sub new {
    my ( $class, %args ) = @_;
    bless \%args, $class;
}

sub run {
    my $self = shift;
    my $coro = async {
        do {
            for my $count ( 1 .. $self->{num_of_request} ) {
                print $self->{name}, " request $count\n";
                my $text = $self->{name} . "'s request $count";
                my $request = Request->new( request => $text );
                $self->{channel}->put_request($request);
                Coro::Timer::sleep( int(rand(3)) );
            }
        };
    };
    return $coro;
}

package Worker;
use Coro;

sub new {
    my ( $class, %args ) = @_;
    bless \%args, $class;
}

sub run {
    my $self = shift;
    my $coro = async {
        do {
            while (1) {
                my $request = $self->{channel}->take_request();
                print $self->{name}, qq{ execute "}, $request->get_request_name(), qq{"\n};
                $request->execute();
            }
        };
    };
    return $coro;
}

package Request;
use Coro;
use Coro::Timer;

sub new {
    my ( $class, %args ) = @_;
    my %defaults = ( request => 'request' );
    %args = ( %defaults, %args );
    bless \%args, $class;
}

sub execute {
    my $self = shift;

    Coro::Timer::sleep(1);
}

sub get_request_name {
    my $self = shift;

    return $self->{request};
}

package Channel;
use Coro;
use Coro::Semaphore;
use Coro::Signal;

sub new {
    my ( $class, %args ) = @_;
    my %defaults = ( max_request => 10, num_of_thread => 3 );
    %args = ( %defaults, %args );
    $args{signal}  = Coro::Signal->new;
    $args{queue}   = [];
    $args{workers} = [];
    $args{coros}   = [];

    my $self = bless \%args, $class;
    for my $count ( 1 .. $args{num_of_thread} ) {
        push @{ $args{workers} }, Worker->new( name => "worker-$count", channel => $self );
    }

    return $self;
}

sub start_workers {
    my $self = shift;
    for my $worker ( @{ $self->{workers} } ) {
        push @{ $self->{coros} }, $worker->run();
    }
}

sub stop_workers {
    my $self = shift;
    for my $coro ( @{ $self->{coros} } ) {
        $coro->cancel();
    }
}

sub put_request {
    my $self  = shift;
    my $guard = $self->_get_guard();

    if ( $self->{max_request} <= scalar( @{ $self->{queue} } ) ) {
        warn "no space in queue";
        return;
    }
    push @{ $self->{queue} }, $_[0];
    $self->{signal}->broadcast();
}

sub take_request {
    my $self  = shift;
    my $guard = $self->_get_guard();

    while ( scalar( @{ $self->{queue} } ) == 0 ) {
        $self->{signal}->wait();
    }
    return shift @{ $self->{queue} };
}

sub _get_guard {
    my $self = shift;
    my $name = ( caller 1 )[3];
    $name =~ s/.*:://;
    $name .= '_sem';

    if ( !exists( $self->{$name}) ) {
        $self->{$name} = Coro::Semaphore->new;
    }
    else {
        my $class = ref $self->{$name};
        if ( $class ne 'Coro::Semaphore' ) {
            die "$name is not Coro::Semaphore";
        }
    }

    return $self->{$name}->guard();
}

package main;
use Coro;
use Coro::Timer;

my $channel = Channel->new( max_request => 50, num_of_thread => 2 );
$channel->start_workers();

my $client1 = Client->new( name => 'Alice', num_of_request => 3, channel => $channel );
my $client2 = Client->new( name => 'Bobby', num_of_request => 5, channel => $channel );
my $client3 = Client->new( name => 'Chris', num_of_request => 7, channel => $channel );

my $client1_coro = $client1->run();
my $client2_coro = $client2->run();
my $client3_coro = $client3->run();

$client1_coro->join();
$client2_coro->join();
$client3_coro->join();

Coro::Timer::sleep(2);
$channel->stop_workers();

出力

Alice request 1
Bobby request 1
Chris request 1
worker-1 execute "Alice's request 1"
worker-2 execute "Bobby's request 1"
Bobby request 2
worker-2 execute "Chris's request 1"
worker-1 execute "Bobby's request 2"
Chris request 2
Bobby request 3
Bobby request 4
Alice request 2
worker-2 execute "Chris's request 2"
Chris request 3
worker-1 execute "Bobby's request 3"
Chris request 4
Chris request 5
Chris request 6
Alice request 3
worker-2 execute "Bobby's request 4"
worker-1 execute "Alice's request 2"
Bobby request 5
worker-1 execute "Chris's request 3"
worker-2 execute "Chris's request 4"
Chris request 7
worker-2 execute "Chris's request 5"
worker-1 execute "Chris's request 6"
worker-2 execute "Alice's request 3"
worker-1 execute "Bobby's request 5"
worker-2 execute "Chris's request 7"

pic ファイル

.PS

copy "sequence.pic";

boxwid = 1.3;

# Define the objects
object(CL,":client");
placeholder_object(R);
object(CH,":channel");
object(W,":worker");
step();

# Message sequences
active(CL);
active(CH);
active(W);

create_message(CL,R,":request");

message(W,CH,"take_request");
message(CL,CH,"put_request");
rmessage(CH,CL);
rmessage(CH,W);

message(W,R,"execute");
active(R);
step();
rmessage(R,W,"");
inactive(R);

step();
complete(CL);
complete(R);
complete(CH);
complete(W);

.PE

参考

増補改訂版 Java言語で学ぶデザインパターン入門マルチスレッド編

作者: 結城浩
出版社/メーカー: ソフトバンククリエイティブ
発売日: 2006/03/21
メディア: 大型本
購入: 15人クリック: 287回
この商品を含むブログ (206件) を見る

2011-03-07

Coro で Thread-Per-Message パターン

Perl Design Pattern Coro

増補改訂版 Java言語で学ぶデザインパターン入門マルチスレッド編を参考に Coro で Thread-Per-Message パターンを実装。

Thread-Per-Message パターンはメッセージを送ると新しく一つのスレッドが割り当てられて、そのスレッドが処理を行なう。

#!/usr/bin/perl
use strict;
use warnings;

package Host;
use Coro;

sub new {
    my ( $class, %args ) = @_;
    $args{helper} = Helper->new();
    $args{coros}  = [];
    bless \%args, $class;
}

sub request {
    my $self    = shift;
    my $content = shift;
    print "request $content\n";
    my $coro = async {
        do {
            $self->{helper}->handle($content);
        };
    };
    push @{ $self->{coros} }, $coro;
}

sub wait_all {
    my $self = shift;
    for my $coro ( @{ $self->{coros} } ) {
        $coro->join();
    }
}

package Helper;
use Coro;
use Coro::Timer;

sub new {
    my ( $class, %args ) = @_;
    bless \%args, $class;
}

sub handle {
    my $self    = shift;
    my $content = shift;

    print "working $content...\n";
    Coro::Timer::sleep(1);
    print "done $content...\n";
}

package main;
use Coro;

print "start main\n";
my $host = Host->new();
$host->request("work1");
$host->request("work2");
print "end main\n";

$host->wait_all();

出力

start main
request work1
request work2
end main
working work1...
working work2...
done work2...
done work1...

pic ファイル

.PS

copy "sequence.pic";

boxwid = 1.3;

# Define the objects
object(M,":main");
placeholder_object(HOST);
placeholder_object(T1);
placeholder_object(T2);
placeholder_object(HELPER);
step();

# Message sequences
active(M);

create_message(M,HOST,":host");
active(HOST);

create_message(HOST,HELPER,":helper");
active(HELPER);


message(M,HOST,"request");
create_message(HOST,T1,":coro1");
begin_frame(T1,F,"On other coro");
rmessage(HOST,M,"");
active(T1);
message(T1,HELPER,"handle");
rmessage(HELPER,T1);
delete(T1);
step();
end_frame(HELPER,F);

message(M,HOST,"request");
create_message(HOST,T2,":coro2");
begin_frame(T2,F,"On other coro");
rmessage(HOST,M,"");
complete(M);
active(T2);
message(T2,HELPER,"handle");
rmessage(HELPER,T2);
delete(T2);
step();
end_frame(HELPER,F);

complete(HOST);
complete(HELPER);

.PE

参考

増補改訂版 Java言語で学ぶデザインパターン入門マルチスレッド編

作者: 結城浩
出版社/メーカー: ソフトバンククリエイティブ
発売日: 2006/03/21
メディア: 大型本
購入: 15人クリック: 287回
この商品を含むブログ (206件) を見る

2011-03-04

Coro で Read-Write Lock パターン

Perl Design Pattern Coro

増補改訂版 Java言語で学ぶデザインパターン入門マルチスレッド編を参考に Coro で Read-Write Lock パターンを実装。

Read-Write Lockは、

スレッドが読んている間は、別のスレッドも読める
スレッドが書いている間は、別のスレッドは読めない
スレッドが読んている間は、別のスレッドは書けない
スレッドが書いている間は、別のスレッドは書けない

#!/usr/bin/perl
use strict;
use warnings;

package Reader;
use Coro;

sub new {
    my ( $class, %args ) = @_;
    my %defaults = ( name => 'Reader' );
    %args = ( %defaults, %args );
    bless \%args, $class;
}

sub run {
    my $self = shift;
    my $coro = async {
        do {
            my $name  = $self->{name};
            my $board = $self->{board};
            my $type  = $self->{type};
            print "$name : read $type data\n";
            my $content = $board->read( type => $type );
            print "$name : done $type data($content)\n";
        };
    };
    return $coro;
}

package Writer;
use Coro;

sub new {
    my ( $class, %args ) = @_;
    my %defaults = ( name => 'Writer' );
    %args = ( %defaults, %args );
    bless \%args, $class;
}

sub run {
    my $self    = shift;
    my $content = shift;
    my $coro    = async {
        do {
            my $name  = $self->{name};
            my $board = $self->{board};
            my $type  = $self->{type};
            print "$name : write $type data($content)\n";
            $board->write( type => $type, content => $content );
            print "$name : done $type data\n";
        };
    };
    return $coro;
}

package Locker;
use Coro;
use Coro::Semaphore;
use Coro::Timer;

sub new {
    my ( $class, %args ) = @_;
    $args{reading_readers} = 0;
    $args{waiting_writers} = 0;
    $args{writing_writers} = 0;
    $args{prefer_writer}   = 1;
    $args{signal}          = Coro::Signal->new;
    bless \%args, $class;
}

sub read_lock {
    my $self  = shift;
    my $guard = $self->_get_guard();

    while (( $self->{writing_writers} > 0 )
        || ( $self->{prefer_writer} && ( $self->{waiting_writers} > 0 ) ) )
    {
        $self->{signal}->wait();
    }
    $self->{reading_readers}++;
}

sub read_unlock {
    my $self  = shift;
    my $guard = $self->_get_guard();

    $self->{reading_readers}--;
    $self->{prefer_writer} = 1;
    $self->{signal}->broadcast();
}

sub write_lock {
    my $self  = shift;
    my $guard = $self->_get_guard();

    $self->{waiting_writers}++;
    while (( $self->{reading_readers} > 0 )
        || ( $self->{writing_writers} > 0 ) )
    {
        $self->{signal}->wait();
    }
    $self->{waiting_writers}--;
    $self->{writing_writers}++;
}

sub write_unlock {
    my $self  = shift;
    my $guard = $self->_get_guard();

    $self->{writing_writers}--;
    $self->{prefer_writer} = 0;
    $self->{signal}->broadcast();
}

sub _get_guard {
    my $self = shift;
    my $name = ( caller 1 )[3];
    $name =~ s/.*:://;
    $name .= '_sem';
    if ( !exists $self->{$name} ) {
        $self->{$name} = Coro::Semaphore->new;
    }
    else {
        my $class = ref $self->{$name};
        if ( $class ne 'Coro::Semaphore' ) {
            die "$name is not Coro::Semaphore";
        }
    }

    return $self->{$name}->guard();
}

package Board;
use Coro;
use Coro::Timer;

sub new {
    my ( $class, %args ) = @_;
    my %defaults = ( heavy => 'heavy data0', light => 'light data0' );
    %args = ( %defaults, %args );
    $args{locker} = Locker->new();
    bless \%args, $class;
}

sub read {
    my $self = shift;

    $self->{locker}->read_lock();
    my $content = $self->do_read(@_);
    $self->{locker}->read_unlock();
    return $content;
}

sub do_read {
    my $self = shift;
    my %args = @_;
    my $type = $args{type};

    if ( $type eq 'heavy' ) {
        Coro::Timer::sleep(1);
    }
    return $self->{$type};

}

sub write {
    my $self = shift;

    $self->{locker}->write_lock();
    $self->do_write(@_);
    $self->{locker}->write_unlock();
}

sub do_write {
    my $self    = shift;
    my %args    = @_;
    my $type    = $args{type};
    my $content = $args{content};

    if ( $type eq 'heavy' ) {
        Coro::Timer::sleep(1);
    }
    $self->{$type} = $content;
}

package main;
use Coro;

read_on_read();
read_on_write();
write_on_read();
write_on_write();

sub read_on_read {
    print "--- read_on_read\n";
    my $board = Board->new();
    my $reader1
        = Reader->new( name => 'reader1', type => 'heavy', board => $board );
    my $reader2
        = Reader->new( name => 'reader2', type => 'light', board => $board );

    my $reader1_coro = $reader1->run();
    my $reader2_coro = $reader2->run();

    $reader1_coro->join();
    $reader2_coro->join();
    print "\n";
}

sub read_on_write {
    print "--- read_on_write\n";
    my $board = Board->new();
    my $writer
        = Writer->new( name => 'writer', type => 'heavy', board => $board );
    my $reader
        = Reader->new( name => 'reader', type => 'light', board => $board );

    my $writer_coro = $writer->run('heavy data1');
    my $reader_coro = $reader->run();

    $writer_coro->join();
    $reader_coro->join();
    print "\n";
}

sub write_on_read {
    print "--- read_on_write\n";
    my $board = Board->new();
    my $reader
        = Reader->new( name => 'reader', type => 'heavy', board => $board );
    my $writer
        = Writer->new( name => 'writer', type => 'light', board => $board );

    my $reader_coro = $reader->run();
    my $writer_coro = $writer->run('light data1');

    $reader_coro->join();
    $writer_coro->join();
    print "\n";
}

sub write_on_write {
    print "--- write_on_write\n";
    my $board = Board->new();
    my $writer1
        = Writer->new( name => 'writer1', type => 'heavy', board => $board );
    my $writer2
        = Writer->new( name => 'writer2', type => 'light', board => $board );

    my $writer1_coro = $writer1->run('heavy data1');
    my $writer2_coro = $writer2->run('light data1');

    $writer1_coro->join();
    $writer2_coro->join();
    print "\n";
}

出力

--- read_on_read
reader1 : read heavy data
reader2 : read light data
reader2 : done light data(light data0)
reader1 : done heavy data(heavy data0)

--- read_on_write
writer : write heavy data(heavy data1)
reader : read light data
writer : done heavy data
reader : done light data(light data0)

--- read_on_write
reader : read heavy data
writer : write light data(light data1)
reader : done heavy data(heavy data0)
writer : done light data

--- write_on_write
writer1 : write heavy data(heavy data1)
writer2 : write light data(light data1)
writer1 : done heavy data
writer2 : done light data

参考

増補改訂版 Java言語で学ぶデザインパターン入門マルチスレッド編

作者: 結城浩
出版社/メーカー: ソフトバンククリエイティブ
発売日: 2006/03/21
メディア: 大型本
購入: 15人クリック: 287回
この商品を含むブログ (206件) を見る