Plack+CatalystでWebアプリ（とCLI）を作ってみる

catalyst MyApp::Web

script/myapp_create.pl PSGI
plackup -E product -R ./root -R ./lib -r script/myapp.psgi

my $session = Plack::Session->new($c->req->env);
$session->set('hoge', 'fuga'); #hogeというkeyでfugaという値をセット

別のサブルーチンで
$hoge = $session->get('hoge') #セッション毎に保存されたhogeの値がgetできる

package MyApp::Web::PSGI;
sub app {
        MyApp::Web->setup_engine('PSGI');
        my $app = sub { MyApp::Web->run(@_) };
        $app = builder {
                enable 'Session',
                        store => Plack::Session::Store::File->new(
                                dir => '/tmp/mysqpp_session/',
                        );
                enable 'Debug';
                $app;
        };

        return $app;
}

sub login :Local {
        my ($self, $c) = @_;

        my $session = Plack::Session->new($c->req->env);
        my $nt = Net::Twitter->new(traits => [qw/API::REST OAuth/], %{$c->config->{oauth}->{param}});
        my $url = $nt->get_authorization_url(callback => $c->config->{oauth}->{callbackurl});

        $session->set('token', $nt->request_token);
        $session->set('token_secret', $nt->request_token_secret);

        $c->response->redirect($url);
}

sub oauth_callback :Local {
        my ($self, $c) = @_;
        my $session = Plack::Session->new($c->req->env);

        my $token = $c->req->params->{oauth_token};
        my $verifier = $c->req->params->{oauth_verifier};

        my $nt = Net::Twitter->new(traits => [qw/API::REST OAuth/], %{$c->config->{oauth}->{param}});
        $nt->request_token($session->get('token'));
        $nt->request_token_secret($session->get('token_secret'));

        my ($access_token, $access_token_secret, $twitter_id, $screen_name)
                = $nt->request_access_token(token => $token, verifier => $verifier);

        # $access_tokenと$access_token_secretをMySQLに保存
}

package MyApp::CLI;
use strict;
use warnings;

use MyApp::Utils;

sub new {
        my $class = shift;
        my $self = {};
        $self->{config} = $class->setup_home;
        bless $self, $class;
        $self;
}

sub path_to {
        my ( $self, @path ) = @_;
        my $path = Path::Class::Dir->new( $self->{config}->{home}, @path );
        if ( -d $path ) { return $path }
        else { return Path::Class::File->new( $self->{config}->{home}, @path ) }
}

sub setup_home {
    my ( $class, $home ) = @_;

    if ( my $env = MyApp::Utils::env_value( $class, 'HOME' ) ) {
        $home = $env;
    }

    $home ||= MyApp::Utils::home($class);
    if ($home) {
        #I remember recently being scolded for assigning config values like this
#        $class->{config}->{home} ||= $home;
#        $class->{config}->{root} ||= Path::Class::Dir->new($home)->subdir('root');
        my $config;
        $config->{home} ||= $home;
        $config->{root} ||= Path::Class::Dir->new($home)->subdir('root');
        return $config;
    }
}
1;

package MyApp::CLI::ConfigLoader;

use strict;
use warnings;

use Config::Any;
use MRO::Compat;
use Data::Visitor::Callback;
#use Catalyst::Utils ();
use MyApp::Utils ();
use Path::Class;

use base qw(MyApp::CLI);

use parent qw(Class::Accessor::Fast);
__PACKAGE__->mk_accessors(qw(config));

sub new {
    my ($class, $config) = @_;
    my $self = $class->SUPER::new();
#    $self->config($config);
    while (my ($key, $value) = each %{$config}){
        $self->config->{$key} = $value;
    }

    my @files = $self->find_files;
    my $cfg   = Config::Any->load_files(
        {   files       => \@files,
            filter      => \&_fix_syntax,
            use_ext     => 1,
            driver_args => $self->config->{ 'CLI::ConfigLoader' }->{ driver }
                || {},
        }
    );
    # map the array of hashrefs to a simple hash
    my %configs = map { %$_ } @$cfg;

    # split the responses into normal and local cfg
    my $local_suffix = $self->get_config_local_suffix;
    my ( @main, @locals );
    for ( sort keys %configs ) {
        if ( m{$local_suffix\.}ms ) {
            push @locals, $_;
        }
        else {
            push @main, $_;
        }
    }

    # load all the normal cfgs, then the local cfgs last so they can override
    # normal cfgs
    $self->load_config( { $_ => $configs{ $_ } } ) for @main, @locals;

    $self->finalize_config;

#    $self->next::method( @_ );
    $self;
}
# 以下省略

package MyApp::CLI::Common;
use strict;
use warnings;

use MyApp::CLI::ConfigLoader;
use MyApp::Schema;

use base qw(MyApp::CLI);
use parent qw(Class::Accessor::Fast);
__PACKAGE__->mk_accessors(qw(config schema));

sub new {
        my $class = shift;
        my $self = $class->SUPER::new();
        $self->setup_config;
        $self;
}

sub setup_config {
        my $self = shift;
        $self->config(MyApp::CLI::ConfigLoader->new({
                'CLI::ConfigLoader' => {
                        file =>   $self->path_to('etc/conf/myapp'),
                },
        })->config);
}

sub schema {
        my $self = shift;
        $self->{schema} = MyApp::Schema->connect( $self->config->{'Model::DBIC'}{'connect_info'} );
        return $self->{schema};
}

1;

use MyApp::CLI::Common;

my $cli = MyApp::CLI::Common->new;
my $hoge = $cli->config->{'hoge'};

script/myapp_create.pl model DBIC DBIC::Schema MyApp::Schema create=static dbi:mysql:[db_name] [user] [pass]

package MyApp::API::APITest;
use strict;
use warnings;

sub new {
        my $class = shift;
        my $self = {};
        bless $self, $class;
        return $self;
}

sub init {
        my ($self, $schema) = @_;
        $self->{schema} = $schema;
        return $self;
}

sub get_hoge_data {
        my ($self, $value) = @_;

        my $hoge_data = $self->{schema}->resultset('HogeData');
        return $hoge_data->search({fuga => "$value"})->first->hoge;
}

1;

# CLIから使う
my $cli = MyApp::CLI::Common->new;
my $test = MyApp::API::APITest->new->init($cli->schema);
my $hoge_data = $test->get_hoge_data('hogehoge');

# Catalystから使う
my $hoge_data = $c->model('APITest')->init($c->model('DBIC')->schema)->get_hoge_data('hogehoge');

if (-f 'Makefile') {
    open (my $fh, '<', 'Makefile') or die "Could not open Makefile: $!";
    my $makefile = do { local $/; <$fh> };
    close $fh or die $!;

    $makefile =~ s/"-e" "(test_harness\(\$\(TEST_VERBOSE\), )/"-It\/lib" "-MTest::mysqld" "-e" "\\\$\$SIG{INT} = sub { CORE::exit(1) }; my \\\$\$m = Test::mysqld->new(mysql_install_db => '\/usr\/bin\/mysql_install_db', mysqld => '\/usr\/sbin\/mysqld', my_cnf => { 'skip-networking' => '' },); \\\$\$ENV{TEST_DSN} = \\\$\$m->dsn(); $1't\/lib', /;

    open (my $fh, '>', 'Makefile') or die "Could not open Makefile: $!";
    print $fh $makefile;
    close $fh or die $!;
}

package MyApp::Test;
use strict;
use warnings;

use Test::mysqld;
use MyApp::Schema;

sub new {
        my $class = shift;
        my $self = {};
        bless $self, $class;
        $self;
}

sub schema {
        my ($self, $dsn) = @_;

        $dsn = $ENV{TEST_DSN} unless($dsn);
        my $deploy = 0;
        if(!$dsn){
                my $mysqld = Test::mysqld->new(
                        mysql_install_db => '/usr/bin/mysql_install_db',
                        mysqld => '/usr/sbin/mysqld',
                        my_cnf => { 'skip-networking' => '' },
                ) or return "Could not start mysqld: $Test::mysqld::errstr";
                $self->{mysql} = $mysqld;
                $dsn = $mysqld->dsn;
                $deploy = 1;
                $ENV{TEST_DSN} = $dsn;
        }

        my $schema = MyApp::Schema->connect($dsn);
        if($deploy){
                $self->deploy;
        }
        return $schema;
}


sub deploy {
        my $self = shift;
        $self->schema->deploy;
}

sub init_data {
        my ($self, $data) = @_;

        $data = $self->_test_data unless($data);
        my $schema = $self->schema;

        while (my($table, $lows) = each %{$data}){
                my $rs = $schema->resultset($table);
                $rs->create($_) for (@{$lows});
        }
}

sub _test_data {
        return {
                HogeData => [
                        {
                                hoge_id => 1,
                                hoge => 'fuga',
                        },
                ],
        };
}

1;

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

use Test::More;
use MyApp::Test;

my $deploy;
$deploy = 1 if($ENV{TEST_DSN});
my $test = MyApp::Test->new;
$test->deploy if($deploy);
my $schema = $test->schema;
$test->init_data;

is $schema->resultset('HogeData')->search({hoge_id => 1})->first->hoge, 'fuga';

done_testing;