CGI::Application

昔書いたCGI::Applicationのプログラムの一部です。途中で開発を止めちゃったので、ちゃんと動かないかも。 CGI::Applicationは低機能ですが、その分全体の把握が簡単です。 CGI::Applicationを使う時の参考になるかな?

基本構造

CGI::Applicationはディスパッチャー程度しか提供しないので、コントローラやモデルの構造は自己流です。ま、よくある一般的な構造にしてあります。

  • htdocs/dispatch.cgi フロントコントローラ
  • config/config.pl 設定ファイル
  • lib/C.pm 基底コントローラクラス
  • lib/C/Inquiry.pm Inquiryコントローラクラス
  • lib/M.pm 基底モデルクラス
  • lib/M/Account.pm Account関連モデルクラス
  • template/inquiry/index.tt HTMLテンプレートファイル(Inquiryのindexアクション用)

ソースコード

htdocs/dispatch.cgi

#!/usr/bin/perl
# ==============================================================================
#  フロントコントローラ
# ==============================================================================
use strict;
use warnings;
use FindBin qw($Bin);
use Cwd 'abs_path';
use lib (
    "$Bin/../../admin_app/lib",
);
use CGI::Carp qw(carpout);
use CGI::Application::Dispatch;

# ログファイル書き出し
umask 000;
open my $log, '>>', "$Bin/../../admin_app/logs/cgi_log" or die $!;
carpout($log);

# URL修正
chdir $Bin;
my $www = abs_path;
$ENV{PATH_INFO} =~ s/^$www//g if defined $ENV{PATH_INFO};

# アプリケーション実行
CGI::Application::Dispatch->dispatch(
    prefix  => 'C',
    default => 'Index',
    debug   => 1,
);
close $log;
exit;

config/config.pl

#!/usr/bin/perl

$CFG{site_name} = 'portal';
$CFG{base_url} = 'http://example.com';
$CFG{db} = {
    dsn => 'DBI:mysql:database=mydb;host=localhost;',
    user => 'db_user',
    passwd => 'db_pass',
};
$CFG{debug} = 1;

\%CFG;

lib/C.pm

# ==============================================================================
# コントローラ
# ==============================================================================
package C;

use strict;
use warnings;
use base 'CGI::Application';
use FindBin qw/$Bin/;
use CGI::Application::Plugin::Forward;
use CGI::Application::Plugin::Redirect;
use CGI::Application::Plugin::BrowserDetect;
use CGI::Application::Plugin::TT;
use CGI::Application::Plugin::LogDispatch;
use CGI::Application::Plugin::Session;
use CGI::Application::Plugin::FillInForm (qw/fill_form/);
use CGI::Application::Plugin::ConfigAuto (qw/cfg cfg_file/);
use CGI::Application::Plugin::MessageStack;
use CGI::Application::Plugin::Authentication;
use CGI::Application::Plugin::Authorization;
#use CGI::Application::Plugin::DebugScreen;
use CGI::Application::Plugin::DBH (qw/dbh_config dbh/);
use M::Account;
use Data::Dumper;

sub cgiapp_init {
    my $self = shift;
    $ENV{CGI_APP_DEBUG} = 1;
    # コンフィグファイル読み込み
    $self->cfg_file("$Bin/../../admin_app/config/config.pl");
    # DB接続
    my $db_config = $self->cfg('db');
    $self->dbh_config( $db_config->{dsn}, $db_config->{user},
        $db_config->{passwd},
        { RaiseError => 1, AutoCommit => 1, PrintError => 0 } );
    # Template Toolkit 初期化
    $self->tt_config(
        TEMPLATE_OPTIONS => { INCLUDE_PATH => "$Bin/../../admin_app/template" } );
    # セッション設定
    $self->session_config(
        DEFAULT_EXPIRY => '+1w',
        COOKIE_PARAMS  => { -expires => '+24h' },
        SEND_COOKIE    => 1,
    );
    # MessageStack 設定
    $self->capms_config( -automatic_clearing => 1, );
    # デバッグログ設定
    $self->log_config(
        LOG_DISPATCH_MODULES => [
            {
                module         => 'Log::Dispatch::File',
                name           => 'debug',
                filename       => "$Bin/../../admin_app/logs/debug_log",
                min_level      => 'debug',
                stderr         => 1,
                append_newline => 1,
            },
        ]
    );
    # Authentication 設定
    my $url = $self->query->url( -base => 1 );
    my $account = $self->model('M::Account');
    $self->authen->config(
        DRIVER => [
            'Generic',
            sub {
                my ( $login_id, $passwd ) = @_;
                my $info = $account->check_passwd( $login_id, $passwd );
                if ($info) {
                    return $info || 'N/A';
                }
                else {
                    $self->push_message(-message => 'ログインエラー:ユーザーID・パスワードを確認して下さい。');
                    $self->redirect("$url/admin/login");
                    return;
                }
              }
        ],
        STORE          => 'Session',
        CREDENTIALS    => [ 'authn_login_id', 'authn_passwd' ],
        LOGIN_URL      => "$url/admin/login",
        POST_LOGIN_URL => "$url/admin/regular-id",
    );
    # Authorization 設定
    $self->authz->config( DRIVER => [ 'Generic', sub {
        my ( $user_info, $group) = @_;
        return $user_info->{$group} ? 1 : 0;
        
    } ],
        FORBIDDEN_RUNMODE => 'forbidden',
        #FORBIDDEN_URL => "$url/login",
    );
    # 共通 run mode の設定
    $self->run_modes([qw/forbidden/]);
}

sub cgiapp_prerun {
    my $self      = shift;
    $self->header_add( -type => 'text/html; charset=UTF-8' );
}

sub cgiapp_postrun {
    my $self       = shift;
    my $output_ref = shift;
}

sub forbidden {
    my $self = shift;
    $self->push_message(
        -message => '権限がありません。権限のあるアカウントでログインし直してください。',
    );
    my $url = $self->query->url( -base => 1 );
    $self->redirect("$url/admin/login");
}

# ------------------------------------------------------------------------------
# モデルクラスオブジェクト呼び出し
# ------------------------------------------------------------------------------
sub model {
    my $self  = shift;
    my $model = shift;
    my $obj = eval { $model->new( dbh => $self->dbh, cfg => { $self->cfg } ) };
    die $@ if $@;
    return $obj;
}

1;

lib/M.pm

package M;
use strict;
use warnings;
use Data::Dumper;

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

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

1;

lib/C/Inquiry.pm

package C::Inquiry;
use strict;
use warnings;
use base 'C';

sub setup {
    my $self = shift;
    $self->start_mode('index');
    $self->run_modes([qw/
        index
        confirm
        finish
    /]);
}

sub index {
    my $self = shift;
    # テンプレートを呼び出す
    return $self->tt_process('inquiry/index.tt');
}

sub confirm {
    my $self = shift;
    # フォームパラメータから取り出し
    my $name = $self->query->param('name');
    my $age = $self->query->param('age');
    # セッションに入れる
    $self->session->param('name',$name);
    $self->session->param('age',$age);
    # テンプレートを呼び出し、名前と年齢を差し込む
    return $self->tt_process('inquiry/confirm.tt', { name => $name, age => $age });
}

sub finish {
    my $self = shift;
    # セッションから取り出し
    my $name = $self->session->param('name');
    # テンプレートを呼び出し、名前を差し込む
    return $self->tt_process('inquiry/finish.tt', { name => $name });
}

1;

lib/M/Account.pm

# ==============================================================================
# アカウントモデル
# ==============================================================================
package M::Account;
use strict;
use warnings;
use base 'M';
use Data::Dumper;

# ------------------------------------------------------------------------------
# 一覧取得
# ------------------------------------------------------------------------------
sub get_list {
    my $self = shift;
    my $ref = $self->dbh->selectall_arrayref(
        "SELECT *, 
            CASE department WHEN 1 THEN 'SALES' WHEN 2 THEN 'TECH' WHEN 3 THEN 'BACKOFFICE' ELSE 'N/A' END AS department_desc
         FROM account ORDER BY account_id",
        { Columns => {} }
    );
    return @$ref;
}

# ------------------------------------------------------------------------------
# 一覧取得2
# 一覧をハッシュで取得する
# ------------------------------------------------------------------------------
sub get_list2 {
    my $self = shift;
    my @list = $self->get_list;
    my %result;
    foreach my $tmp (@list) {
        # ハッシュのキーにアカウントIDを含める
        my $aid = $tmp->{account_id};
        $result{"login_id_$aid"}          = $tmp->{login_id};
        $result{"passwd_$aid"}            = $tmp->{passwd};
        $result{"name_$aid"}              = $tmp->{name};
        $result{"department_$aid"}        = $tmp->{department};
        $result{"temp_id_manage_$aid"}    = $tmp->{temp_id_manage};
        $result{"regular_id_manage_$aid"} = $tmp->{regular_id_manage};
        $result{"bbs_manage_$aid"}        = $tmp->{bbs_manage};
        $result{"account_manage_$aid"}    = $tmp->{account_manage};
    }
    return %result;
}

# ------------------------------------------------------------------------------
# 追加
# ------------------------------------------------------------------------------
sub add {
    my $self = shift;
    my %data = %{shift()};
    my $sql = sprintf(
        "INSERT INTO account ( %s, update_date )\n VALUES ( %s, now() )",
        join( ', ', keys %data ),
        join( ', ', map { '?' } keys %data )
    );
    eval {
        $self->dbh->do($sql,{},values %data);
    };
    die "DB ERR: $@\n$sql\n", Dumper \%data if $@;
}

# ------------------------------------------------------------------------------
# 削除
# ------------------------------------------------------------------------------
sub delete {
    my $self = shift;
    my $account_id = shift;
    my $sql = "DELETE FROM account WHERE account_id = ?";
    eval {
        $self->dbh->do( $sql, {}, ($account_id) );
    };
    die "DB ERR: $@\n$sql\n", $account_id if $@;
}

# ------------------------------------------------------------------------------
# 更新
# ------------------------------------------------------------------------------
sub update {
    my $self = shift;
    my %data = %{shift()};
    my $account_id = $data{account_id};
    delete $data{account_id};
    my $sql = sprintf( "UPDATE account SET %s WHERE account_id = ?",
        join( ', ', ( map { $_ . ' = ?' } keys %data ) ) );
    eval { $self->dbh->do( $sql, {}, ( values %data, $account_id ) ); };
    die "DB ERR: $@\n$sql\n", Dumper \%data if $@;
}

# ------------------------------------------------------------------------------
# パスワードチェック
# ------------------------------------------------------------------------------
sub check_passwd {
    my $self = shift;
    my ( $login_id, $passwd ) = @_;
    my $ref = $self->dbh->selectrow_hashref(
        'SELECT * FROM account WHERE login_id = ? AND passwd = ?',
        {},
        ( $login_id, $passwd )
    );
    return $ref;
}

# ------------------------------------------------------------------------------
# ログインIDが存在しているか
# ------------------------------------------------------------------------------
sub login_id_exists {
    my $self     = shift;
    my $login_id = shift;
    my $ref = $self->dbh->selectrow_arrayref(
        'SELECT COUNT(*) FROM account WHERE login_id = ? ',
        {},
        ( $login_id )
    );
    return $ref->[0];
    
}

1;

template/inquiry/index.tt

<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">
<html>
<head>
<meta http-equiv="Content-Type" content="text/html; charset=utf-8">
<title>管理画面</title>
<link href="/admin/css/base.css" rel="stylesheet" type="text/css">
</head>
<body>
<div>
<div id="main">
<!--ヘッダー-->
[% INCLUDE 'common/header.tt' %]
<!--/ヘッダー-->
<!--メインコンテンツ-->
<form action="/admin/inquiry/confirm" method="post">
名前:<input name="name" type="text"><br>
年齢:<input name="age" type="text"><br>
<input type="submit" value="確認する" style="height:1.5em;font-size:small">
</form>
<!--/メインコンテンツ-->
<!--フッター-->
[% INCLUDE 'common/footer.tt' %]
<!--/フッター-->
</div>
</div>
</body>
</html>

トップ   編集 凍結 差分 バックアップ 添付 複製 名前変更 リロード   新規 一覧 単語検索 最終更新   ヘルプ   最終更新のRSS

Last-modified: 2010-01-20 (水) 20:28:47 (3247d)