#/*
# *  Copyright 2007-2008 hkrn <hikarin@users.sourceforge.jp>
# *
# *  Licensed under the Apache License, Version 2.0 (the "License");
# *  you may not use this file except in compliance with the License.
# *  You may obtain a copy of the License at
# *
# *      http://www.apache.org/licenses/LICENSE-2.0
# *
# *  Unless required by applicable law or agreed to in writing, software
# *  distributed under the License is distributed on an "AS IS" BASIS,
# *  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
# *  See the License for the specific language governing permissions and
# *  limitations under the License.
# */
#
# $Id: Maple.pm 1756 2008-07-17 12:42:48Z hikarin $
#

package Img0ch::Maple;

use strict;
use Fcntl qw(:DEFAULT :flock);

$Img0ch::Maple::RCS_ID  = '$Id: Maple.pm 1756 2008-07-17 12:42:48Z hikarin $';
$Img0ch::Maple::VERSION = '2.1.26';
$Img0ch::Maple::revision = do {
    my @rv = $Img0ch::Maple::RCS_ID =~ /(\d+)/xms;
    $rv[0];
};

sub new {
    my ( $iClass, $iConfig ) = @_;
    my $class = 'Img0ch::Maple::'
        . $iClass->get_repos_type( $iConfig->get('RepositoryType') );
    defined &{"${class}::new"} or $iClass->load_module($class);
    $ENV{TZ} ||= $iConfig->get('TimeZone') || 'JST-9';

    bless {
        __flockf =>
            ( $iConfig->get('io.should_lock') ? LOCK_EX : LOCK_EX | LOCK_NB ),
        __cache   => {},
        __config  => $iConfig,
        __noflock => $iConfig->get('io.no_flock'),
        __repos   => $class,
    }, $iClass;
}

sub DESTROY { }

sub get_read_file_handle {
    my ( $iMaple, $path ) = @_;

    -e $path or return;
    sysopen my $fh, $path, O_RDONLY or $iMaple->throw_io_exception($path);
    $iMaple->{__noflock}
        or flock $fh, LOCK_SH
        or $iMaple->throw_io_exception($path);

    return $fh;
}

sub get_write_file_handle {
    my ( $iMaple, $path, $umask ) = @_;
    my $flag = -e $path ? O_WRONLY | O_CREAT : O_WRONLY | O_EXCL | O_CREAT;
    $umask ||= 0666;

    sysopen my $fh, $path, $flag, $umask
        or $iMaple->throw_io_exception($path);
    $iMaple->{__noflock}
        or flock $fh, $iMaple->{__flockf}
        or $iMaple->throw_io_exception($path);
    truncate $fh, 0 or $iMaple->throw_io_exception($path);

    return $fh;
}

sub load_module {
    my ( $iClass, $module ) = @_;
    $module =~ s{::}{/}gxms;
    $module .= '.pm';
    return require $module;
}

my $unijp_charset_alias = {
    'sjis'        => 'sjis',
    'shiftjis'    => 'sjis',
    'cp932'       => 'sjis',
    'windows31j'  => 'sjis',
    'macjapanese' => 'sjis',
    'eucjp'       => 'euc-jp',
    'ujis'        => 'euc-jp',
    'eucjpwin'    => 'euc-jp',
    'eucjpms'     => 'euc-jp',
    'jis'         => 'jis',
    '7bitjis'     => 'jis',
    'iso2022jp'   => 'jis',
    'utf8'        => 'utf8',
    'ascii'       => 'ascii',
    'iso88591'    => 'ascii',
    'usascii'     => 'ascii',
    'latin1'      => 'ascii',
};

sub get_encoding {
    my ( $iKernel, $to_unijp ) = @_;
    my $charset = $iKernel->{__config}->get('DefaultCharset') || 'Shift_JIS';

    if ($to_unijp) {
        $charset =~ tr/\-\_//d;
        $charset = $unijp_charset_alias->{ lc $charset } || 'sjis';
    }

    return $charset;
}

sub get_encoded_str {
    my ( $iKernel, $str, $to, $from ) = @_;
    $str or return '';

    defined $Unicode::Japanese::VERSION or require Unicode::Japanese;
    my $unijp = $iKernel->{__unijp} ||= Unicode::Japanese->new();

    $to ||= '';
    $to =~ tr/\-\_//d;
    $to = $unijp_charset_alias->{$to} || $iKernel->get_encoding(1);
    if ( !$from ) {
        my $name = $unijp->getcode($str);
        $name eq $to and return $str;
        $from = $name;
    }

    $from ||= '';
    $from =~ tr/\-\_//d;
    $from = $unijp_charset_alias->{$from} || $from;
    $unijp->set( $str, $from );

    return $unijp->conv($to);
}

sub get_config { $_[0]->{__config} }

sub escape_html_entities {
    my ($str) = @_;
    $str ||= '';
    $str =~ s/&/&amp;/gxms;
    $str =~ s/"/&quot;/gxms;    # "
    $str =~ s/'/&#39;/gxms;     # '
    $str =~ s/</&lt;/gxms;
    $str =~ s/>/&gt;/gxms;
    $str =~ tr/\0//d;
    $str;
}

sub throw_io_exception {
    my ( $iMaple, $path, $surpress ) = @_;
    my $iConfig = $iMaple->{__config};
    my $base    = $iConfig->get('BBSPath');
    my $shell   = $iConfig->get('ShellPath');

    if (   $path =~ m{\A\.\./}xms
        or $base  =~ m{\A\.\./}xms
        or $shell =~ m{\A\.\./}xms )
    {
        defined $Cwd::VERSION or require Cwd;
        $path  = Cwd::realpath($path);
        $base  = Cwd::realpath($base);
        $shell = Cwd::realpath($shell);
    }

    $path =~ s/\A$base//xms;
    $path =~ s/\A$shell//xms;

    die 'img0ch I/O Exception at ', $path, ' :', $!, "\n",
        _trace()->as_string(), "\n";
}

sub throw_exception {
    my ( $iClass, @err ) = @_;
    die @err, "\n", _trace()->as_string(), "\n";
}

sub intval {
    my ($str) = @_;
    $str ||= '';
    $str =~ /\A(\d+)\z/xms or return 0;
    $1 + 0;
}

sub revision {$Img0ch::Maple::revision}

sub get_repos {
    my ( $iMaple, $path ) = @_;
    my $iRepos = $iMaple->{__repos}->new( $iMaple, $path );
    $iRepos->load();
    return $iRepos;
}

*get_repos_nocache = \&get_repos;

sub get_repos_path {
    my ( $iMaple, $path ) = @_;
    my $iConfig = $iMaple->get_config();
    my $ext = $iConfig->get('RepositoryFileExtension') || 'rps';
    return $iConfig->get('RepositoryRoot') . '/' . $path . '.' . $ext;
}

sub start_transaction {
    my ($iMaple) = @_;
    return;
}

sub commit_transaction {
    my ($iMaple) = @_;
    return;
}

sub rollback_transaction {
    my ($iMaple) = @_;
    return;
}

sub create_repository_subdirs {
    my ( $time, $filename, $iObject, $truncate ) = @_;

    $time or return '';
    my ( undef, undef, undef, $day, $month, $year ) = localtime($time);

    $year  += 1900;
    $month += 1;
    my $repos_file_path
        = $iObject->get_repos_path( join '/', $year, $month, $day, $time,
        $filename );
    my $repos_file_dir = $repos_file_path;
    $repos_file_dir =~ s{/$filename\.\w+\z}{}xms;
    if ($truncate) {
        $repos_file_dir  =~ s{/$time\z}{}xms;
        $repos_file_path =~ s{/$time/($filename\.\w+)\z}{/$1}xms;
    }

    if ( !-d $repos_file_dir ) {
        defined $File::Path::VERSION or require File::Path;
        my $iKernel
            = $iObject->isa('Img0ch::BBS')
            ? $iObject->get_kernel()
            : $iObject;
        File::Path::mkpath($repos_file_dir)
            or $iKernel->throw_io_exception($repos_file_dir);
    }

    return $repos_file_path;
}

my $repository_type = {
    'Archive'    => 'Archive',
    'BDB'        => 'BDB',
    'BerkeleyDB' => 'BDB',
    'CDB'        => 'CDB',
    'CDB_File'   => 'CDB',
    'Compressed' => 'Archive',
    'DBMDeep'    => 'DD',
    'DD'         => 'DD',
    'Depot'      => 'Qdepot',
    'FlatFile'   => 'Simple',
    'QDBM'       => 'Qdepot',
    'Qdepot'     => 'Qdepot',
    'Qvilla'     => 'Qvilla',
    'Simple'     => 'Simple',
    'Storable'   => 'Storable',
    'Villa'      => 'Qvilla',
};

sub get_repos_type { $repository_type->{ $_[1] } || 'Simple' }

my $module_by_script = {
    'bbs.cgi'         => 'Img0ch::App::BBS',
    'img0ch-note.cgi' => 'Img0ch::App::Note',
    'img0ch-sf.cgi'   => 'Img0ch::App::Search::File',
    'img0ch-st.cgi'   => 'Img0ch::App::Search::Text',
    'img0ch-ufm.cgi'  => 'Img0ch::App::UFM',
    'm.cgi'           => 'Img0ch::App::MailPost',
    'oekaki.cgi'      => 'Img0ch::Compat::App::Oekaki',
    'r.cgi'           => 'Img0ch::App::Mobile',
    'read.cgi'        => 'Img0ch::App::Read',
    'zeromin2.cgi'    => 'Zeromin2::App',
};

sub get_application_modules { [ values %{$module_by_script} ] }

sub get_module_by_script { $module_by_script->{ $_[1] } || '' }

sub load_application_modules {
    map { __PACKAGE__->load_module($_) } values %{$module_by_script};
    return;
}

sub _trace {
    require Devel::StackTrace;
    return Devel::StackTrace->new(
        ignore_package => [
            'main',                        'Img0ch::CGI::BootStrap',
            'Img0ch::Kernel',              'Img0ch::ModPerl::BootStrap',
            'Img0ch::ModPerl2::BootStrap', __PACKAGE__,
        ],
    );
}

package Img0ch::Kernel;

use strict;
use base qw(Img0ch::Maple);

sub VERSION { Img0ch::Maple->VERSION() }

*escape_html_entities = \&Img0ch::Maple::escape_html_entities;
*intval               = \&Img0ch::Maple::intval;
*revision             = \&Img0ch::Maple::revision;

1;
__END__

=head1 NAME

Img0ch::Maple - ほとんどのオブジェクトに利用される重要な基底クラス

=head1 SYNOPSYS

  use Img0ch::Maple

  my $iKernel = Img0ch::Maple->new($iConfig);
  my $iKernel = Img0ch::Kernel->new($iConfig);

  open my $fh, '<', 'test.txt'
  or $iKernel->throw_io_exception('test.txt');
  print {$fh} 'This is a test'
  or $iKernel->throw_io_exception('test.txt');
  close $fh or $iKernel->throw_io_exception('test.txt');

  my $int = Img0ch::Kernel::intval('0');
  my $escaped = Img0ch::Kernel::escape_html_entities('<html>');

=head1 DESCRIPTION

ほとんどのクラスで利用される中心クラスです。Img0ch::Mapleとして呼び出す必要がありますが、
Img0ch::Kernelとして扱うことが出来ます。

=head2 new

=over 4

=item Arguments

$iConfig

=item Return Value

$iMaple (Img0ch::Maple itself)

=back

I<Img0ch::Maple>(I<Img0ch::Kernel>)のオブジェクトを作成します。

=head2 get_config

=over 4

=item Arguments

none

=item Return Value

$iConfig

=back

I<Img0ch::Config>のオブジェクトを返します。

=head2 get_encoding

=over 4

=item Arguments

$return_as_unicode_japanese_charset

=item Return Value

$charset

=back

現在の文字列エンコーディング(I<DefaultCharset>)を返します。
I<DefaultCharset>が指定されていなければShift_JISを、
$return_as_unicode_japanese_charsetが設定されていれば
sjisを返します。

=head2 get_encoded_str

=over 4

=item Arguments

$string_to_encode, $to_charset, $from_charset

=item Return Value

$encoded_string

=back

I<$string_to_encode>からエンコードセットI<$to_charset>に
変換した文字列を返します。
I<$from_charset>が指定されていなければI<$string_to_encode>から
エンコードセットの自動判定を行います。I<$to_charset>が指定されていなければ
I<get_encoding()>から現在のエンコードセットを求め、それに変換します。
I<$from_charset>とI<$to_charset>が同一の場合はI<$string_to_encode>
そのものを返します。

=head2 escape_html_entities

=over 4

=item Arguments

$string

=item Return Value

$escape_html_entities

=back

HTMLのタグまたは記号として扱われる特殊文字を無効化または削除します。
無効化または削除される特殊文字は以下の通りです。

=over 4

=item <

-> &lt;

=item >

-> &gt;

=item &

-> &amp;

=item "

-> &quot;

=item '

-> &#39;

=item \0

-> (remove)

=back

=head2 throw_io_exception

=over 4

=item Arguments

$path

=item Return Value

none

=back

I/O操作に関する例外を発行し、コールトレースを表示させてプログラムを終了させます。
このとき$pathにI<BBSPath>、またはI<ShellPath>が含まれている場合はその部分を削除します。

=head2 throw_exception

=over 4

=item Arguments

$error_message

=item Return Value

none

=back

I<$error_message>とコールトレースを出力してプログラムを終了させます。

=head2 intval

=over 4

=item Arguments

$string

=item Return Value

$number

=back

文字列を強制的に数値に変換します。文字列が全て数字の場合は
その値を返し、文字が含まれている場合は0を返します。

=head2 get_application_modules

=over 4

=item Arguments

none

=item Return Value

$array_reference_of_all_application_modules

=back

Img0ch::App::*のモジュールのパッケージ名を配列リファレンスとして返します。

=head2 get_module_by_script

=over 4

=item Arguments

$cgi_script_name

=item Return Value

$application_module_name

=back

I<$cgi_script_name>から対応するアプリケーションモジュールのパッケージ名を返します。

=head2 load_application_modules

=over 4

=item Arguments

none

=item Return Value

none

=back

Img0ch::App::*のモジュールを全て読み込みます。

=head2 get_read_file_handle

=over 4

=item Arguments

$file_path

=item Return Value

$file_handle

=back

I<$file_path>を読み込み専用で開き、そのファイルハンドルを返します。
ファイルが存在し無い場合はI<undef>を返します。
I/Oエラーが発生すると例外を発行します。

=head2 get_write_file_handle

=over 4

=item Arguments

$file_path, $umask_value

=item Return Value

$file_handle

=back

I<$file_path>を書き込み専用で開き、そのファイルハンドルを返します。
I<$umask_value>が存在する場合はumask値を設定します。
I/Oエラーが発生すると例外を発行します。

=head2 get_repos

=over 4

=item Arguments

$path_to_repository

=item Return Value

$iRepos (Img0ch::Maple::*)

=back

レポジトリを読み込み、レポジトリのオブジェクトを返します。
この関数はバージョンが2.1.x-3.xでのみ使用可能です。

=head2 get_repos_path

=over 4

=item Arguments

$path

=item Return Value

$path_to_repository

=back

断片的なパスからレポジトリのパスを作成します。
この関数はバージョンが2.1.x-3.xでのみ使用可能です。

=head2 get_repos_type

=over 4

=item Arguments

$type

=item Return Value

$repository_type

=back

I<RepositoryType>からモジュールを読み込めるようにする値を返します。
一致する値が存在しない場合I<Simple(Img0ch::Maple::Simple)>を返します。
この関数はバージョンが2.1.x-3.xでのみ使用可能です。

=head2 create_repository_subdirs

=over 4

=item Arguments

$time, $filename, $iBBS_or_$iKernel

=item Return Value

none

=back

$timeに基づいてレポジトリのサブディレクトリを作成します。

=head1 AUTHOR

hkrn E<lt>hikarin@users.sourceforge.jpE<gt>

=cut
