#/*
# *  Copyright 2007 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: Interface.pm 734 2007-06-01 13:33:31Z hikarin $
#

package Img0ch::Request::Interface;

use strict;

sub init {
    my ( $iRequest, $iConfig, $ip, $now, $e ) = @_;
    my ( $system_path, $token_type ) = ( '', '' );

    if ($iConfig) {
        $system_path            = $iConfig->get('SystemPath');
        $token_type             = $iConfig->get('SignatureType');
        $iRequest->{__app_path} = $iConfig->get('CGIServer')
            || join( '/', $iConfig->get('Server'), 'test' );
    }
    $iRequest->{__now}    = $now;
    $iRequest->{__msec}   = int( rand(99999) );
    $iRequest->{__ip}     = $ip;
    $iRequest->{__ip_int} = pack 'C4', ( split '\.', $ip );
    $iRequest->{__agent}  = $iRequest->detect_agent($system_path);
    $iRequest->{__sign}   = __PACKAGE__->signature( $e, $token_type );

    {
        my $bbs = $iRequest->param('bbs') || '';
        $bbs =~ /\A([\w\-]+)\z/xms;
        $iRequest->{__bbs} = $1 || ''
    }
    {
        my $key = $iRequest->param('key') || $now;
        $key =~ /\A(\d\d\d\d\d\d\d\d\d\d?)\z/xms;
        $iRequest->{__key} = $1 || ''
    }
    return;
}

sub signature {
    my ( $iRequest, $module_type, $token_type ) = @_;
    my $formats = {
        'Product' => 'img0ch',
        'Major'   => 'img0ch(%s)/%d',
        'Minor'   => 'img0ch(%s)/%d.%d',
        'Full'    => 'img0ch(%s)/%d.%d.%s',
        'Debug'   => 'img0ch(%s)/%d.%d.%s SVN.REV:%d',
    };
    my $format = $formats->{ $token_type || 'Minor' };
    return sprintf( $format,
        $module_type,
        split( '\.', Img0ch::Kernel->VERSION(), 3 ),
        Img0ch::Kernel->revision() );
}

sub param_int {
    my ( $iRequest, $param ) = @_;
    if (wantarray) {
        my @params = $iRequest->param($param);
        @params = map { Img0ch::Kernel::intval($_) } @params;
    }
    else {
        Img0ch::Kernel::intval( $iRequest->param($param) );
    }
}

sub param_multibyte {
    my ( $iRequest, $param, $charset, $unescape ) = @_;
    my $value = $iRequest->param( $param, $unescape ) || '';

    require Unicode::Japanese;
    my $unijp = $iRequest->{__unijp} ||= Unicode::Japanese->new('');
    my $icode = $unijp->getcode($value);
    if ( $icode ne $charset and $icode ne 'unknown' ) {
        $unijp->set( $value, $icode );
        return $unijp->conv($charset);
    }
    else {
        return $value;
    }
}

sub upload {
    my ( $iRequest, $path ) = @_;
    my $temp = $iRequest->tempfile();
    require File::Copy;
    if ( !File::Copy::copy( $temp, $path ) ) {
        my $file = !-e $temp ? $temp : $path;
        Img0ch::Kernel->throw_io_exception($file);
    }
    $iRequest->{__file} = $path;
    1;
}

sub tempfile {
    my ($iRequest) = @_;
    my $tmp = $iRequest->{__tmp};
    $tmp or die 'No file was uploaded', "\n";
    return $tmp;
}

sub filename {
    my ( $iRequest, $key ) = @_;
    my $filename = $iRequest->{__file};
    $filename =~ tr/\0'"<>&//d;
    $filename;
}

sub get_json {
    my ( $iRequest, $data ) = @_;
    if ( ref($iRequest) and !$iRequest->{__load_json_module} ) {
        eval "use JSON::XS qw(); 1"
            or require Data::JavaScript::Anon;
        $iRequest->{__load_json_module} = 1;
    }
    return exists $INC{'JSON/XS.pm'}
        ? \JSON::XS::to_json($data)
        : \Data::JavaScript::Anon->anon_dump($data);
}

# from URI::Escape
my %escapes;
for ( 0 .. 255 ) {
    $escapes{ chr $_ } = sprintf( '%%%02X', $_ );
}

sub escape_uri {
    my ( $iClass, $data ) = @_;
    if ( ref $data ) {
        $$data =~ s/([^A-Za-z0-9\-_.!~*'()])/$escapes{$1}/gxmse;
        return;
    }
    else {
        $data =~ s/([^A-Za-z0-9\-_.!~*'()])/$escapes{$1}/gxmse;
        return $data;
    }
}

sub get_app_uri { $_[0]->{__app_path} || '' }

sub get_app_uri2 {
    my ( $iClass, $iConfig ) = @_;
    return $iConfig->get('CGIServer')
        || join( '/', $iConfig->get('Server'), 'test' );
}

sub get_remote_host {
    return gethostbyaddr( $_[0]->{__ip_int}, 2 ) || $_[0]->{__ip};
}

sub get_device_id {
    my ( $iRequest, $agent ) = @_;
    my $ag = Img0ch::Maple::intval( $agent || $iRequest->{__agent} );
    $ag > 6 and return '';
    my $id = [
        sub {''},
        sub {
            my $agent = $_[0]->get_header('user-agent');
            return $1 if $agent =~ m{/ser(\w{11})\z}xms;
            return $1 if $agent =~ /;ser(\w{15});/xms;
            '';
        },
        sub {
            my $agent  = $_[0]->get_header('user-agent');
            my $serial = '';
            if (   $agent =~ m{\AVodafone/}xms
                or $agent =~ m{\ASoftBank/}xms )
            {
                $serial = [ split '/', $agent ]->[4] || '';
            }
            else {
                $serial = [ split '/', $agent ]->[3] || '';
            }
            $serial =~ s/\ASN//xms or return '';
            $serial =~ s/\s\w*\z//xms;
            $serial;
        },
        sub {
            my $serial = $_[0]->get_header('x-up-subno');
            $serial =~ tr/_/-/;
            $serial =~ /\A(\d{14}-\w\w)/xms ? $1 : '';
        },
        sub {''},
        sub { $_[0]->get_header('x-subscriber-id') },
        sub {
            my $agent = $_[0]->get_header('user-agent');
            $agent =~ /ibisBrowser;.+;\s*(\w+)/xms;
            $1 || '',;
        },
    ]->[$ag]->($iRequest);
    return $id;
}

sub is_mobile_device {
    my ( $iRequest, $agent ) = @_;
    return Img0ch::Maple::intval( $agent || $iRequest->{__agent} ) > 0
        ? 1
        : 0;
}

sub detect_agent {
    my ( $iRequest, $path ) = @_;
    my $host    = $iRequest->{__ip};
    my $iConfig = Img0ch::Config->new();
    my $ini     = ( $path || '' ) . '/CIDR-mobile-jp.ini';

    -r $ini or return 0;
    $iConfig->load($ini);

    my @docomo   = keys %{ $iConfig->get('docomo.*') };
    my @vodafone = keys %{ $iConfig->get('vodafone.*') };
    my @au       = keys %{ $iConfig->get('ezweb.*') };
    my @willcom  = keys %{ $iConfig->get('willcom.*') };
    my @jig      = keys %{ $iConfig->get('jig.*') };
    my @ibis     = keys %{ $iConfig->get('ibis.*') };
    my $ret      = eval {
        require Net::IP::Match::XS;
        Net::IP::Match::XS::match_ip( $host, @docomo )   and return 1;
        Net::IP::Match::XS::match_ip( $host, @vodafone ) and return 2;
        Net::IP::Match::XS::match_ip( $host, @au )       and return 3;
        Net::IP::Match::XS::match_ip( $host, @willcom )  and return 4;
        Net::IP::Match::XS::match_ip( $host, @jig )      and return 5;
        Net::IP::Match::XS::match_ip( $host, @ibis )     and return 6;
        return 0;
    };
    return $ret unless $@;

    require Net::CIDR::Lite;
    Net::CIDR::Lite->new(@docomo)->find($host)   and return 1;
    Net::CIDR::Lite->new(@vodafone)->find($host) and return 2;
    Net::CIDR::Lite->new(@au)->find($host)       and return 3;
    Net::CIDR::Lite->new(@willcom)->find($host)  and return 4;
    Net::CIDR::Lite->new(@jig)->find($host)      and return 5;
    Net::CIDR::Lite->new(@ibis)->find($host)     and return 6;
    0;
}

sub agent { $_[0]->{__agent} || 0 }

sub bbs { $_[0]->{__bbs} }

sub fh { $_[0]->{__fh} || undef }

sub fsize { $_[0]->{__fsize} || 0 }

sub ip { $_[0]->{__ip} || '0.0.0.0' }

sub ip_int { $_[0]->{__ip_int} }

sub key { $_[0]->{__key} }

sub msec { $_[0]->{__msec} }

sub now { $_[0]->{__now} || time() }

1;
__END__

=head1 NAME

Img0ch::RequestIF - Img0ch::*::Requestの継承元となる基本クラス

=head1 SYNOPSYS

  use base qw(Img0ch::RequestIF);
  # internal use only

=head1 DESCRIPTION

Img0ch::*::Requestで必ず継承されるクラスです。
このクラスは内部でのみ利用されます。

=head2 init

=over 4

=item Arguments

$iConfig, $ip, $time, $engineType

=item Return Value

none

=back

初期化を行います。
このクラスを継承したクラスのオブジェクトから呼び出す必要があります。

=head2 param_int

=over 4

=item Arguments

$param

=item Return Value

@all_param_keys (array context),
$param_value (scalar context)

=back

param()メソッドと働きは同じですが、スカラーコンテキストで返す値が数値であることが保証されます。
返す値に文字列が含まれていた場合は0に変換されます。

=head2 param_multibyte

=over 4

=item Arguments

$param, $charset

=item Return Value

$param_value (scalar context)

=back

param()メソッドと働きは同じですが、$charsetに指定された文字エンコーディングに変換されます。
変換にはI<Unicode::Japanese>が用いられます。

=head2 upload

=over 4

=item Arguments

$path

=item Return Value

1

=back

アップロードされたファイルを指定されたI<$path>に保存します。
保存に失敗した場合は例外が発行されます。

=head2 get_app_uri

=over 4

=item Arguments

none

=item Return Value

$path_to_applications

=back

アプリケーションを格納するURLを返します。

=head2 get_app_uri2

=over 4

=item Arguments

$iConfig

=item Return Value

$path_to_applications

=back

クラスメソッドとして呼び出す点以外I<get_app_uri()>と同じ

=head2 get_json

=over 4

=item Arguments

$data

=item Return Value

$reference_to_json_string

=back

データ構造をJSONに変換します。利用可能な場合はI<JSON::Syck>、
それ以外の場合にはI<Data::JavaScript::Anon>が利用されます。

=head2 get_remote_host

=over 4

=item Arguments

none

=item Return Value

$remote_host_or_ip

=back

IPアドレスをホスト名に変換します。変換できない場合IPアドレスが返されます。

=head2 get_device_id

=over 4

=item Arguments

$agent?

=item Return Value

$device_id

=back

端末のIDを取得します。取得できない場合はナルストリングが返されます。

=head2 is_mobile_device

=over 4

=item Arguments

none

=item Return Value

true(mobileDevice) or false

=back

投稿元の端末が携帯またはそれに準じるものであるかを調べます。

=head2 detect_agent

=over 4

=item Arguments

none

=item Return Value

$number_of_agent_enum

=back

オブジェクトに保存されているIPアドレスから書き込み端末のキャリアを特定します。
利用可能な場合にI<Net::IP::Match::XS>、それ以外の場合は
I<Net::CIDR::Lite>が利用されます。
$number_of_agent_enumは以下の通りになっています。

=over 4

=item 0

下記以外のキャリア

=item 1

DoCoMo

=item 2

softbank mobile
(Vodafone, J-Phone)

=item 3

au

=item 4

willcom

=item 5

jig browser

=item 6

ibis browser

=back

=head2 agent

=over 4

=item Arguments

none

=item Return Value

$number_of_agent_enum

=back

detect_agent()から返される数値を返します。

=head2 bbs

=over 4

=item Arguments

none

=item Return Value

$dir_or_id_to_bbs

=back

掲示板のディレクトリ名(またはID)を返します。

=head2 fh

=over 4

=item Arguments

none

=item Return Value

$file_handle_to_uploaded_file

=back

アップロードされたファイルハンドルを返します。

=head2 fsize

=over 4

=item Arguments

none

=item Return Value

$size_of_uploaded_file

=back

アップロードされたファイルの大きさを返します。

=head2 ip

=over 4

=item Arguments

none

=item Return Value

$ip_address_human_readable

=back

*.*.*.*形式のIPアドレスを返します。

=head2 ip_int

=over 4

=item Arguments

none

=item Return Value

$ip_address_hex_binary

=back

16進数で表されたバイナリ形式のIPアドレスを返します。
gethostbyaddr()関数に直接利用することが出来ます。

=head2 key

=over 4

=item Arguments

none

=item Return Value

$thread_key

=back

9桁または10桁のスレッドキーを返します。

=head2 now

=over 4

=item Arguments

none

=item Return Value

$current_time_stamp

=back

1970年1月1日からの経過秒数(エポック秒)を返します。

=head1 AUTHOR

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

=cut
