読者です 読者をやめる 読者になる 読者になる

Moose でアクセス制御 その2

こんちは、実家から以下略シリーズ ヽ(´ー`)ノ 今日はカニグラタン Mooseのprivate, protected. - Nizah Blog これの続きをやってみた

Moose の traits がすばらしすぎるの件 - TokuLog 改めB日記 この辺を参考に、traits を使ってみる。

package AccessTrait;
use Moose::Role;
use Data::Dumper;
use List::MoreUtils qw(any);
has 'access' => (is => 'ro');
has 'access_label' => (is => 'ro', isa => 'Str');
has 'read_public' => (is => 'ro', isa => 'Int');
after 'install_accessors' => sub {
my $self = shift;
my $class = $self->associated_class->{package};
my $label  = $self->access_label;
my ($rp,$code);
$rp = $self->read_public;
if(ref $self->access eq 'CODE'){
$label = "acl" unless $label;
$code = $self->access;
}elsif(ref $self->access eq 'ARRAY'){
$label = "friend" unless $label;
$code = sub { defined $_[1] and any { $_ eq $_[1]} @{$self->access} };
}elsif($self->access eq 'public'){
# do nothing.
}elsif($self->access eq 'protected'){
$label = "protected" unless $label;
$code = sub { defined $_[1] and $_[1]  =~ s/::.*$//; eval{$_[1]->isa($_[0])}};
}elsif($self->access eq 'private'){
$label = "private" unless $label;
$code = sub { defined $_[1] and $_[1] =~ /${_[0]}::((?!::).)+/};
}
if($code){
Moose::Util::add_method_modifier($class, 'around', [$self->accessor, _acl_call($label,$class,$rp,$code)]);
}
};
sub _acl_call {
my $aclname = shift;
my $class = shift;
my $read_public = shift;
my $cmp = shift;
return sub {
my $orig = shift;
my $self = shift;
if($read_public and not @_){
return $self->$orig();
}else{
my ($name,$caller) = _get_caller($class,$self);
return $self->$orig(@_) if $cmp->($class,$caller,@_) ;
warn "$aclname field $name accessed";
}
return ($read_public) ? $self->$orig() : undef;
}
}
sub _get_caller {
my $class = shift;
my $self = shift;
my ($name,$count);
while($name = (caller($count++))[3]){
if($name =~ /^${class}::((?!::).)+/){
return (wantarray) ?
($name, (caller($count))[3]) :
(caller($count))[3] ;
}
}
return undef;
}
1;

やってる事は基本的に同じ。 やっぱり、callerの取得が何だかなぁな感じ MOPとかその辺で美味しい仕組みが用意されてそうなのでとりあえず放置 使ってみる。

package Parent;
use Moose;
use Data::Dumper;
no warnings;
has 'pub' => (
is => 'rw', default => 'parent',
traits => [qw/AccessTrait/], access => 'public',
);
has 'pro' => (
is => 'rw', default => 'parent',
traits => [qw/AccessTrait/], access => 'protected', read_public => 1,
);
has 'pri' => (
is => 'rw', default => 'parent',
traits => [qw/AccessTrait/], access => 'private', read_public => 1,
);
has 'true_pri' => (
is => 'rw', default => 'parent',
traits => [qw/AccessTrait/], access => 'private',
);
has 'fri' => (
is => 'rw', default => 'parent',
traits => [qw/AccessTrait/], access => [qw(Neighbor::friend Foo::Bar)],
access_label => 'friend', read_public => 1,
);
has 'acl' => (
is => 'rw', default => 'parent',
traits => [qw/AccessTrait/], access =>  sub {
my $class = shift; my $caller = shift; my $arg = shift; not $arg%2; },
access_label => 'even_number_only', read_public => 1,
);
sub test {
my $self = shift;
$self->pub('parent_modified');
$self->pro('parent_modified');
$self->pri('parent_modified');
}
# 続く

traits => がちょっと面倒なものの(classの方にぶち込めるっぽい) has と一緒に定義できる。 基本的に access => 'private'|'protected' で良いんだけど ついでなので、 public (実はNOP)、 ARRAYREF (friend,指定したメソッドからはOK)、 CODE(もう、なんでもあり) とかも受けるようにしてみた。 昨日のコードは、readonly ならアクセス修飾関係無しにアクセス出来た。 「おぉ、それってprivateじゃないじゃん」と間抜けに今日気付いたので read_public オプションとか付けてみた。 read/write 別にアクセス指定するほどでもないし、そんな複雑だったらCODEでやれみたいな。 pub (public), pro(protected), pri(private) は、read_public な感じ tru_pri は、readもちゃんとprivate fri は、リストで呼び出し可能なサブルーチンを定義。 C++のfriend ってロクに使ったことないからコレで良いのか知らん acl は、true/false を返すコードリファレンスを指定して、呼び出し可能かどうかを決めさせる。 ここでの例は偶数の指定のみ可能な感じ 続きのテストコード

# 続き
package Child;
use Moose;
extends 'Parent';
sub test_child {
my $self = shift;
$self->pub('child_modified');
$self->pro('child_modified');
$self->pri('child_modified');
}
package Neighbor;
sub friend {
my $p = new Parent;
print "change from friend","-"x20,$/;
print "public:     ",$p->pub('neighbor_modified'),$/;
print "protected:  ",$p->pro('neighbor_modified'),$/;
print "private:    ",$p->pri('neighbor_modified'),$/;
print "friend:     ",$p->fri('neighbor_modified'),$/;
print $/,$/;
}
sub not_friend {
my $p = new Parent;
print "change from not friend","-"x20,$/;
print "public:     ",$p->pub('neighbor_modified'),$/;
print "protected:  ",$p->pro('neighbor_modified'),$/;
print "private:    ",$p->pri('neighbor_modified'),$/;
print "friend:     ",$p->fri('neighbor_modified'),$/;
print $/,$/;
}
package main;
use FileHandle;
STDERR->autoflush(1);
STDOUT->autoflush(1);
my $p = Parent->new();
print "parent class","="x20,$/;
print "default","-"x20,$/;
print "public:     ",$p->pub,$/;
print "protected:  ",$p->pro,$/;
print "private:    ",$p->pri,$/;
print $/,$/;
$p->test();
print "change from inner","-"x20,$/;
print "public:     ",$p->pub,$/;
print "protected:  ",$p->pro,$/;
print "private:    ",$p->pri,$/;
print $/,$/;
print "change from outer","-"x20,$/;
print "public:     ",$p->pub('main'),$/;
print "protected:  ",$p->pro('main'),$/;
print "private:    ",$p->pri('main'),$/;
print "truly private:    ",$p->true_pri('main'),$/;
print $/,$/;
my $c = Child->new();
print "child class","="x20,$/;
print "default","-"x20,$/;
print "public:     ",$c->pub,$/;
print "protected:  ",$c->pro,$/;
print "private:    ",$c->pri,$/;
print $/,$/;
$c->test();
print "change from parent","-"x20,$/;
print "public:     ",$c->pub,$/;
print "protected:  ",$c->pro,$/;
print "private:    ",$c->pri,$/;
print $/,$/;
$c->test_child();
print "change from child","-"x20,$/;
print "public:     ",$c->pub,$/;
print "protected:  ",$c->pro,$/;
print "private:    ",$c->pri,$/;
print $/,$/;
print "change from outer","-"x20,$/;
print "public:     ",$c->pub('main'),$/;
print "protected:  ",$c->pro('main'),$/;
print "private:    ",$c->pri('main'),$/;
print $/,$/;
Neighbor::friend();
Neighbor::not_friend();
print "change acl method","-"x20,$/;
print "acl(2):     ",$c->acl(2),$/;
print "acl(3):     ",$c->acl(3),$/;
print "acl(4):     ",$c->acl(4),$/;
print "acl(5):     ",$c->acl(5),$/;
print $/,$/;

昨日と同じなので、friとaclのとこだけ載せておこう

change from friend--------------------
public:     neighbor_modified
protected field Parent::pro accessed at AccessTrait.pm line 55.
protected:  parent
private field Parent::pri accessed at AccessTrait.pm line 55.
private:    parent
friend:     neighbor_modified
change from not friend--------------------
public:     neighbor_modified
protected field Parent::pro accessed at AccessTrait.pm line 55.
protected:  parent
private field Parent::pri accessed at AccessTrait.pm line 55.
private:    parent
friend field Parent::fri accessed at AccessTrait.pm line 55.
friend:     parent
change acl method--------------------
acl(2):     2
even_number_only field Parent::acl accessed at AccessTrait.pm line 55.
acl(3):     2
acl(4):     4
even_number_only field Parent::acl accessed at AccessTrait.pm line 55.
acl(5):     4

しかし、メンバだけじゃなくメソッドもアクセス制御しようと思ったら 昨日やったみたいに

private 'foo', 'bar';

とかの方が使いやすいかもしれないなぁ とりあえずモダンPerl来たのでそれ読む モダンPerl入門 (CodeZine BOOKS)