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

Mooseのprivate, protected.

菊川レイがギャーギャーうるさくて不愉快なNizahです、こんちわ 追記: 続き書いた。 Moose でアクセス制御 その2 - Nizah Blog 今更Mooseでも使ってみるかと思ったんだけど

package Foo;
use Moose;
has hoge => (is => 'ro');
sub test {
my $self = shift;
$self->hoge('bar');
}

こんなん書いて怒られた

あー、そういう事 ro にすると同一packageからでもダメなのね うーん、read onlyにしたいけど、package内からは普通にアクセサ使いたいなぁ あ、privateとかprotectedとかって修飾子ある? ……ないっすね。 どれ、やってみるか

package Parent;
use Moose;
use Data::Dumper;
no warnings;
has 'pub' => (is => 'rw', default => 'parent');
has 'pro' => (is => 'rw', default => 'parent');
has 'pri' => (is => 'rw', default => 'parent');
around  'pri' => sub {
my $orig = shift;
my $self = shift;
my $count =0;
my ($name,$isclass);
my $class = __PACKAGE__;
unless(@_){
return $self->$orig();
}else{
while($name = (caller($count++))[3]){
if($name =~ /^$class:/){
my $caller = (caller($count++))[3];
$isclass = 1 if($caller =~ /^$class:/);
last;
}
}
if( $isclass ){
return $self->$orig(@_);
}else{
warn "! private method $name called";
return $self->$orig();
}
}
};
around 'pro' => sub {
my $orig = shift;
my $self = shift;
my $count =0;
my ($name,$ischild);
my $class = __PACKAGE__;
unless(@_){
return $self->$orig();
}else{
while($name = (caller($count++))[3]){
if($name =~ /^$class:/){
my $cls = (caller($count))[0];
my $caller = (caller($count))[3];
$caller  =~ s/::\w+$//;
$ischild = 1 if( eval { $caller->isa($class) });
last;
}
}
if( $ischild ){
return $self->$orig(@_);
}else{
warn "! protected method $name called";
return $self->$orig();
}
}
};
sub test {
my $self = shift;
$self->pub('parent_modified');
$self->pro('parent_modified');
$self->pri('parent_modified');
}
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 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 $/,$/;
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'),$/;

どうかな?

$ perl test.pl
parent class====================
default--------------------
public:     parent
protected:  parent
private:    parent
change from inner--------------------
public:     parent_modified
protected:  parent_modified
private:    parent_modified
change from outer--------------------
public:     main
! protected method Parent::pro called at moose.pl line 64.
protected:  parent_modified
! private method Parent::pri called at moose.pl line 34.
private:    parent_modified
child class====================
default--------------------
public:     parent
protected:  parent
private:    parent
change from parent--------------------
public:     parent_modified
protected:  parent_modified
private:    parent_modified
! private method Parent::pri called at moose.pl line 34.
change from child--------------------
public:     child_modified
protected:  child_modified
private:    parent_modified
change from outer--------------------
public:     main
! protected method Parent::pro called at moose.pl line 64.
protected:  child_modified
! private method Parent::pri called at moose.pl line 34.
private:    parent_modified

お、出来たっぽい。 aroundで囲って、同一 packageか(private)、あるいはサブクラスか(protected) 判断するだけ でも、なんかMooseのラッパとか色々経由しているみたいだから 直前のcallerじゃなくて、Parent:: なサブルーチンが呼ばれるまで遡らなきゃいけない この変は、ちゃんとやればもっと上手く出来そうなので、それはそれで放置 多分3行くらいで書けるんだろう で、だ 毎回こんな事したくないので、もっと楽に出来ないかなーと思ってやってみた

package AccessControl;
use Moose;
use Moose::Exporter;
Moose::Exporter->setup_import_methods(
with_caller => [qw( private protected)],
);
sub private(@) {
my $class = shift;
Moose::Util::add_method_modifier($class, 'around', [@_,_private($class)]);
}
sub protected(@) {
my $class = shift;
Moose::Util::add_method_modifier($class, 'around', [@_,_protected($class)]);
}
sub _private{
my $class = shift;
return sub {
my $orig = shift;
my $self = shift;
my $count =0;
my ($name,$isclass);
unless(@_){
return $self->$orig();
}else{
while($name = (caller($count++))[3]){
if($name =~ /^$class:/){
my $caller = (caller($count++))[3];
last unless $caller;
$isclass = 1 if($caller =~ /^$class:/);
last;
}
}
if( $isclass ){
return $self->$orig(@_);
}else{
warn "! private method $name called";
return $self->$orig();
}
}
};
}
sub _protected{
my $class = shift;
return sub {
my $orig = shift;
my $self = shift;
my $count =0;
my ($name,$ischild);
unless(@_){
return $self->$orig();
}else{
while($name = (caller($count++))[3]){
if($name =~ /^$class:/){
my $caller = (caller($count))[3];
last unless $caller;
$caller  =~ s/::\w+$//;
$ischild = 1 if( eval { $caller->isa($class) });
last;
}
}
if( $ischild ){
return $self->$orig(@_);
}else{
warn "! private method $name called";
return $self->$orig();
}
}
};
}
1;

こんな感じ? private と protectedの中身同じなの、一緒に出来るけれど そもそもここの部分はもっと簡単に出来そうなので放置 んで、使ってみると

package Parent;
use Moose;
use Data::Dumper;
use AccessControl;
no warnings;
has 'pub' => (is => 'rw', default => 'parent');
has 'pro' => (is => 'rw', default => 'parent');
has 'pri' => (is => 'rw', default => 'parent');
private 'pri';
protected 'pro';
# 以下略

うわ、出来たΣ(゜Д゜)簡単すぎる 本当は

has 'pub' => (is => 'rw', default => 'parent');
has 'pro' => (is => 'rw', default => 'parent', access => 'protected');
has 'pri' => (is => 'rw', default => 'parent', access => 'private');

とかやりたいんだけど、Attribute追加してごちゃごちゃするのは良く分からんかった とりあえず、callerとかその辺がイマイチよく分かんないので 続・初めてのPerlを読み返すとしますか 続・初めてのPerl 改訂版 あと、dan kogai が絶賛してたのでコレ注文した 404 Blog Not Found:$job->done('well'); # 書評 - モダンPerl入門 モダンPerl入門 (CodeZine BOOKS) こないだユウリンドウで気になったけど、タイトルがダサいからスルーしちゃったんだよね 後、Mooseは重いからMOPしないならMouse使えという話