フレームワーク (6) - lvalue で validation もしたい #

header_type というメソッドを実装していた時のこと。

 package CGI::Minimal::App;
 sub header_type :lvalue {
   my $self = shift;
   $self->{__HEADER_TYPE};
 }

これで

$self->header_type(‘redirect’);
$self->header_type = ‘redirect’;

どちらの書き方でも setter として動作し、$self->header_type は getter にもなる。が、header_type に set できる値は制限したいので、

 package CGI::Minimal::App;
 sub header_type :lvalue {
   my $self = shift;
   my $type = shift;
 
   die 'Invalid header type: '.$type
     unless ( $type eq 'header' or $type eq 'redirect' );
 
   $self->{__HEADER_TYPE} = $type;
 
   $self->{__HEADER_TYPE};
 }

というようなコードを書くと、

$self->header_type(‘dummy’);

はエラーになるが

$self->header_type = ‘dummy’;

はエラーにならない

lvalue の時も validation のロジックを通したいので、しばし思案。結果、tie を使うことにした。動いてるけど。。。もっとスマートな実装方法はないものか

 package CGI::Minimal::App;
 sub header_type :lvalue {
   my $self = shift;
   my $header_type = shift;
 
   # First use? Create new __HEADER_TYPE!
   $self->{__HEADER_TYPE} = 'header' unless exists $self->{__HEADER_TYPE};
 
   # tie getter and setter to CGI::Minima::App::Magic (to validate)
   tie $self->{__HEADER_TYPE}, 'CGI::Minimal::App::Magic', $self,
     sub {
       my $self = shift;
       $self->{__HEADER_TYPE};
     },
     sub {
       my $self = shift;
       my $value = shift;
 
       # check allowed header
       die 'Invalid header type: '.$value
         unless ( grep {$_ eq lc($value)} ('header', 'redirect', 'not_found', 'not_modified', 'none') );
       $self->{__HEADER_TYPE} = lc($value);
     };
 
   $self->{__HEADER_TYPE} = $header_type if defined $header_type;
   $self->{__HEADER_TYPE};
 }
 1;

 package CGI::Minimal::App::Magic;
 sub TIESCALAR {
   my $class = shift;
   my $self = shift;
   my $getter = shift;
   my $setter = shift;
 
   $class = ref $class || $class || __PACKAGE__;
   bless({obj => $self, getter => $getter, setter => $setter}, $class);
 }
 
 sub FETCH {
   my $self = shift;
   $self->{getter}->($self->{obj});
 }
 
 sub STORE {
   my $self = shift;
   my $value = shift;
 
   $self->{setter}->($self->{obj}, $value);
 }
 1;

参考
- Tie::Scalar
- perltie

フレームワーク (6) - lvalue で validation もしたい #

See Also