#!/usr/bin/perl
# ↑
# Perl5 へのパス
#
# Ir-i-BBS   -  module of mail post
# ---------------------------------
#   Copyright (c) 1999 by Irao Computer System, All rights reserved.
#
# 設置構成 < >内はパーミッション(suexec のない場合)
# /cgi-bin/
#     |--ir-post.pl   <-rwxr-xr-x> : 投稿モジュール
# 履歴
# 13, Mar, 2000 v1.00
# 15, Mar, 2000 v1.01
# 15, Mar, 2000 v1.02
#
#   受信メールで投稿を受理するモジュール
my $rcsid = q$Id: ir-post.pl/v1.02 2000/03/15 irao Exp $;

local $version = ($rcsid =~ m|/v([\d.a-z]+)|)? ("version " . $1) : 'unknown';
local $v_short = ($rcsid =~ m|/v([\d.]+)|)? $1 : 'unknown';
my $copyright =
        "Copyright (c) 1999-2000 by Irao Computer System  All rights reserved.";

$0 =~ /(.*)\/(.*)$/;
if ($1 ne "") {
  $cur_dir = $1 . "/";
} else {
  $cur_dir = "./";
}
#
# ここまで変更厳禁

## ここから設定
#
# jcode.pl へのパス
require $cur_dir . './jcode.pl';
# mimer.pl へのパス
require $cur_dir . './mimer.pl';

# データファイルのパス設定
$bbs_data_file = $cur_dir . './data/ir-i-bbs.dat';
$bbs_init_file = $cur_dir . './data/ir-i-bbs.ini';

# 受信メールの最大バイト数
$email_max = 102400;
# From欄
$email_from = '(投稿用メールアドレス)';
# Sender欄
$email_sender = '';
# Reply-To欄
$email_replyto = '';
# メールサーバーの妥当性をチェックするか？
$check_mail_server = 1;
# メールサーバー名（第３レベルまで）
# 妥当性をチェックするが、個別のメールサーバーについて
# チェックしない場合は「auto」
$mail_server = 'phone.ne.jp';
# X-Mailer: 欄の値（正規表現）
# 空欄にするとチェックしません
$mailer_name = 'Astel Mozio Mail';
# ファイル作成時のパーミッション
$permit_on_create = 0666;
# １頁に表示される最大記事数
$page_max = 5;
# i-mode の絵文字を変換表示するか？
$imchr_title = 1;
# 変換スクリプトのパス（このスクリプトからの相対パス）
$ir_i_def_pl = './ir-i-def.pl';
#
## ここまで設定

$ir_i_def_pl = $cur_dir . $ir_i_def_pl;
local ($regist_max, $mail, @mail, @header);
local ($from, $replyto, $subject, $messageid, $received, $mailer);
local ($err, @smtpsrv, $mailsrv, $mid, @mid, $srv, $srvip, $srvnm);
my ($err1, $err2);

$regist_max = 600;
$sendmail = "/usr/bin/sendmail";
$title = '掲示板';
$bbs_url = '';
$email_admin = '';
&load_init();

read(STDIN, $mail, $email_max);
&jcode'convert(*mail, 'sjis', '', 'z');
@mail = split("\n", $mail);
@header = &purse_header();
($from, $replyto, $subject, $messageid, $received, $mailer) = @header;

$err1 = "そのアドレスからは投稿できません.";
$err2 = "不正なメールの可能性があります. 投稿できません.";

# メールサーバーのチェック
if ($check_mail_server) {
    @smtpsrv = split('@', $from);
    $mailsrv = @smtpsrv[1];
    &error($err1) if (($mailsrv ne $mail_server) && ($mail_server ne 'auto'));
    $mid = $messageid;
    $mid =~ s/[<>]//g;
    @mid = split('@',$mid);
    $srv = @mid[1];
    &error($err2) if ($srv !~ /$mailsrv$/i);
    &error($err2) if ($received !~ /$mailsrv$/i);
    $srvip = ($mailsrv eq 'phone.ne.jp')? @mid[2] : @mid[1];
    $srvnm = @mid[1];
    &error($err2) if (($received !~ /$srvip/) || ($received !~ /$srvnm/));
    if ($mailer_name) {
        &error($err2) if ($mailer !~ /$mailer_name/i);
    }
}
$from = $replyto if ($replyto ne "");
&post($from, $subject, @mail);
exit();

sub view {
    my ($opt) = @_;

    &file_lock("$bbs_data_file");
    &make_new() unless (-e "$bbs_data_file");
    open FHI, "$bbs_data_file" || &error_unlock_dat("ファイルが開けません");
    @mes = <FHI>;
    close FHI;
    &file_unlock("$bbs_data_file");
    if ($#mes < 0) {
        $message = '記事がありません.';
    } else {
        require $ir_i_def_pl if ($imchr_title);
        if ($opt) {
            if ($opt =~ /^([0-9]+)$/) {
                $start = 0;
                $end = $1 - 1 + $start;
                $end = $#mes if ($#mes < $1 - 1 + $start);
            } elsif ($opt =~ /^([0-9]+)[^0-9]([0-9]+)$/) {
                $start = ($1 > $2)? $2 : $1;
                $end = ($1 > $2)? $1: $2;
                $start--;
                $end--;
                $start = 0 if ($start < 0);
                $end = 0 if ($end < 0);
                $start = $#mes if ($#mes < $start - 1);
                $end = $#mes if ($#mes < $end - 1);
            } elsif ($opt =~ /^all$/i) {
                my ($i, $all, $now);
                $all = $#mes + 1;
                for ($i = 0; $i <= $#mes; $i++) {
                    my ($subject, $name, $mail, $web, $msg, $date, $host,
                        $addr, $agent, $pass, $unkey) = split("\t", $mes[$i]);
                    $subject = &conv_imchr($subject);
                    $name = &conv_imchr($name);
                    $now = $i + 1;
                    $message .= <<"EOM";
\[$now/$all\]$name
$subject
-----
EOM
                }
                $message .= <<"EOM";

----------
$title
$bbs_url
EOM
                $subj = '投稿一覧';
                &send_mail($from, $email_from, $email_sender, "",
                                                    $subj, $message);
                exit;
            } else {
                $message = '引数が正しくありません. [$opt]';
                &error($message);
            }
        } else {
            $start = 0;
            $end = $page_max - 1 + $start;
            $end = $#mes if ($#mes < $page_max - 1 + $start);
        }
        $message = "";
        foreach ($start .. $end) {
            my ($subject, $name, $mail, $web, $msg, $date, $host,
                    $addr, $agent, $pass, $unkey) = split("\t", $mes[$_]);
            $date = &conv_date($date);
  
            $msg = &conv_imchr($msg);
            $subject = &conv_imchr($subject);
            $name = &conv_imchr($name);

            $message .= <<"EOM";
$date $url
$subject
$name
$msg
-----
EOM
        }
        $message .= ($start + 1) . '～' . ($end + 1) . '件／全' .
                                                ($#mes + 1) . '件';
    }
    $message .= <<"EOM";

----------
$title
$bbs_url
EOM
    $subject = '投稿表示';
    &send_mail($from, $email_from, $email_sender, "", $subject, $message);
    exit;
}


sub conv_imchr {
    ($_) = @_;

    s/\&#(63[5-9]\d\d)(;|)/&code_to_char($1)/eg;
    s/\&#x(f[89][\da-f][\da-f])(;|)/&code_to_char($1)/ige;
    s/([\x81-\x9f\xe0-\xef][\x40-\x7e\x80-\xfc]|\xf8[\x40-\x4f\x9e-\xff]|\xf9[\x40-\xb0])/&im_char($1)/eg;
    return ($_);
}


sub im_char {
    my ($arg) = @_;
    my ($retc, $ret);

    return ($arg) unless ($arg =~ /(\xf8[\x40-\x4f\x9e-\xff]|\xf9[\x40-\xb0])/);
    my ($arg1, $arg2) = unpack "CC", $arg;
    $ret = sprintf "%02x%02x", $arg1, $arg2;
    
    ($retc = $ret) =~ tr/a-f/A-F/;
    if (($imchr_title) && (exists $imchr_explain{$retc})) {
        $retc = "&amp;#x" . $ret . ";[" . $imchr_explain{$retc} . "]";
    } else {
        $retc = "絵文字:&amp;#x" . $ret . ";";
    }
    
    return ($retc);
}

sub code_to_char {
    my ($arg) = @_;
    $arg = hex $arg if ($arg =~ /^[a-fA-F]/);
    return ('&#' . $arg . ';') unless ((($arg >= 63552) && ($arg <= 63567))
                                    || (($arg >= 63646) && ($arg <= 63743))
                                    || (($arg >= 63808) && ($arg <= 63920)));
    return (chr ($arg >> 8) . chr ($arg & 0xff));
}

sub conv_date {
    my ($date) = @_;
    $date =~ s/<d>(.*)<w>/<d>\($1\) /;
    $date =~ s/<wd>//;
    $date =~ s/(\d+)<y>(\d+)<mo>(\d+)<d>/$1年$2月$3日/;
    $date =~ s/(\d+)<h>(\d+)<mi>/$1時$2分/;
    return ($date);
}

sub post {
    local ($from, $subj, @mail) = @_;
    local ($webp, $name, $mesg, $pass, $host, $addr);
    local ($agnt, $ukey, $date, $cryp);
    local ($errmsg) = "データファイルが開けません.";

    $webp = "";
    $name = (split('@', $from))[0];
    my (@new);
    if ($mail[0] =~ /^#(view|title(s|))/i) {
        $opt = $1 if ($mail[0] =~ /^#view\s*(.*)\s*$/i);
        $opt = 'all' if ($mail[0] =~ /^#title.*$/i);
        &view($opt);
    }
    foreach $_ (@mail) {
        last if ((/^#(end|exit|quit)$/i) || (/^-/));
        push @new, $_;
    }
    @mail = @new;
    $mesg = join("<br>", @mail);
    $pass = &make_unique_pass();
    $ukey = &make_unique_key();
    $date = &get_date();
    $host = ($srvnm)? $srvnm : "localhost";
    $addr = ($srvip)? $srvip : "127.0.0.1";
    $addr =~ tr/0-9.//cd;
    $agnt = "Ir-Mail-Post/$v_short";
    &jcode'convert(*mesg,"sjis");
    &jcode'h2z_sjis(*mesg);
    &jcode'convert(*subj,"sjis");
    &jcode'h2z_sjis(*subj);
    &jcode'convert(*name,"sjis");
    &jcode'h2z_sjis(*name);
    $mail = &zen_to_han($from);
    $webp = &zen_to_han($webp);
    $cryp = &encode_pass($pass);
    $mesg =~ s/\n/<br>/g;
    my $mes = <<"EOMSG";
$subj\t$name\t$mail\t$webp\t$mesg\t$date\t$host\t$addr\t$agnt\t$cryp\t$ukey
EOMSG
    &file_lock("$bbs_data_file");
    &make_new() unless (-e "$bbs_data_file");
    open (FHI, "$bbs_data_file") || &error_unlock_dat($errmsg);
    my $i = 0;
    my @new = "";
    foreach(<FHI>) {
        last unless ($i < $regist_max);
        $i++;
        push @new, $_;
    }
    close(FHI);
    if (!&check_double_post($new[1], $mes)) {

        unshift @new, $mes;
        open (FHO, "> $bbs_data_file") || &error_unlock_dat($errmsg);
        print FHO @new;
        close(FHO);
        &file_unlock("$bbs_data_file");
        $subject = "投稿完了!";
        $message = <<"EOM";
投稿を受理しました。
削除パスワードは$passです。削除／修正時に必要になります。
投稿した覚えがない場合は $email_admin に連絡してください。
----------
$title
$bbs_url
EOM
        &send_mail($from, $email_from, $email_sender, "", $subject, $message);
    } else {
        &error_unlock_dat("投稿内容が同一です. 二重投稿はできません.");
    }
}

sub check_double_post {

    my ($prev, $post) = @_;
    @prev_array = split("\t", $prev);
    @post_array = split("\t", $post);
    $prev_array[5] = "";
    $post_array[5] = "";
    $prev_array[9] = "";
    $post_array[9] = "";
    $prev_array[10] = "";
    $post_array[10] = "";
    return (join(',', @prev_array) eq join(',', @post_array));
}

sub error_unlock_dat {
    my ($string) = @_;
    &error($string, "$bbs_data_file");
}

sub error {
    my ($str, $filename) = @_;
    $str .= <<"EOES";

----------
$title
$bbs_url
EOES
    &send_mail($from, $email_from, $email_sender, "", "エラー!", $str);
    unlink $filename . ".lock"
        if ((defined $filename) && (-e "$filename.lock"));
    exit;
}

sub zen_to_han {
    local($_) = @_;
    &jcode'tr(*_, "！”＃＄％＆’（）＊＋，－．／", "!\"#\$%&'()*+,\-.\/");
    &jcode'tr(*_, "：；＜＝＞？＠", ":;<=>?@");
    &jcode'tr(*_, "［￥］＾＿｀", "[\\]^_`");
    &jcode'tr(*_, "｛｜｝～", "{|}~");

    my ($srccode) = &jcode'getcode(*_);
    unless ($srccode =~ /^(binary|\s*)$/) {
        local ($range) = "０-９Ａ-Ｚａ-ｚ";
        &jcode'convert(*_, "euc", $srccode);
        &jcode'convert(*range, "euc");
        &jcode'tr(*_, $range, "0-9A-Za-z");
        &jcode'convert(*_, $srccode, "euc");
    }

    &jcode'tr(*_, "　", " ");
    return ($_);

}

sub encode_pass {
    my ($arg) = @_;
    my @saltset = ('a'..'z','A'..'Z','0'..'9','.','/');
    my $ssize = $#saltset + 1;
    my $now = time;
    my ($p1, $p2) = unpack("C2", $now);
    my $seed = time ^ ($$ + ($$ << 15));
    my $work = int($now / (60*60*24*7)) + $p1 + $p2 - 8 + $seed;
    my $nsalt = $saltset[$work % $ssize] . $saltset[$seed % $ssize];
    return(crypt($arg, $nsalt));
}

sub file_lock {
    my ($file) = @_;
    my ($lock) = $file . ".lock";
    my ($del_sec) = 30;
    my ($lock_timeout) = $del_sec / (60 * 60 * 24);
    my ($retry) = 30;
    my ($can_symlink) = (eval { symlink("",""); }, $@ eq "");
    my ($error_message) = 'ただ今混雑しています. 後ほどもう一度お試しください.';

    if((-M "$lock") > $lock_timeout) {
        unlink $lock;
    }

    if($can_symlink) {
        while (not symlink $file, $lock){
            if (--$retry <= 0){
                &error($error_message);
            }
            sleep 2;
        }
    } else {
        $count = 0;
        while(-f "$lock") {
            $count++;
            if ($count >= $retry) {
                &error($error_message);
            }
            sleep 2;
        }
        open(LOCK,">$lock");
        close(LOCK);
    }
    return;
}

sub file_unlock {
    my ($file) = @_;
    my ($lock) = $file . ".lock";

    unlink $lock || &error("ロック解除ができません, $lock");
    return;
}

sub make_new {
    open  FOH, "> $bbs_data_file"
        || &error_unlock_dat("データファイルが開けません.");
    print FOH "";
    close FOH;
    chmod $permit_on_create, "$bbs_data_file";
}

sub make_unique_key {
    my @saltset = ('a' .. 'z', 'A' .. 'Z', '0' .. '9');
    my $ssize = $#saltset + 1;
    my $now = time;
    my ($p1, $p2) = unpack("C2", $now);
    my $seed = $now ^ ($$ + ($$ << 15));
    my $work = int($now / (60 * 60 * 24 * 7)) + $p1 + $p2 - 8 + $seed;
    my $nsalt = $saltset[$work % $ssize] . $saltset[$seed % $ssize];
    $nsalt .= (($work ^ $$) % 1000 + ($seed % 100));
    my $unique = 0;
    while($now > 0) {
      $unique = (($unique << 8) + ($now % 10)) % 931193;
      $now = int($now / 10);
    }
    $nsalt .= $unique;
    return ($nsalt);
}

sub get_date {
    $ENV{'TZ'} = "JST-9";
    my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time);

    $mon++;
    $wday = ('日','月','火','水','木','金','土')[$wday];
    $year += 1900 if ($year < 1900);

    my $date = sprintf("%04d<y>%02d<mo>%02d<d>%s<w>%02d<h>%02d<mi>",
                            $year, $mon, $mday, $wday, $hour, $min);
    return ($date);
}

sub purse_header {
    my($line, $header, @header, $item, $value, %hdr, @ctype, $k);
    my($from, $replyto, $subject, $contenttype);
    my($messageid, $received, $mailer);
    while (@mail) {
        $line = shift(@mail);
        $header .= "$line\n";
        last if($line =~ /^$/);
    }
    $header =~ s/\n\s+/ /g;
    @header = split("\n", $header);
    foreach $data (@header) {
        ($item, $value) = split(':', $data, 2);
        $item =~ tr/A-Z/a-z/;
        $value =~ s/^\s+//;
        $value =~ s/\s+$//;
        $hdr{$item} = $value;
    }
    foreach $k (keys(%hdr)) {
        if ($k eq "from") {
            $from = &get_adr($hdr{$k});
        } elsif ($k eq "reply-to") {
            $replyto = &get_adr($hdr{$k});
        } elsif ($k eq "subject") {
            $subject = &mimedecode($hdr{$k}, "euc");
        } elsif ($k eq "message-id") {
            $messageid = $hdr{$k};
        } elsif ($k eq "x-mailer") {
            $mailer = $hdr{$k};
        } elsif ($k eq "content-type") {
            $hdr{$k} =~ s/ //g;
            @ctype = split(";", $hdr{$k});
            $contenttype = $ctype[0];
            $contenttype =~ tr/A-Z/a-z/;
            exit() if ($contenttype ne "text/plain")
        } elsif ($k eq "received") {
            if ($hdr{$k} =~ /from (\S+) by (\S+)/i) {
                $received = "$1 $2";
            } elsif ($hdr{$k} =~ /by (\S+)/i) {
                $received = "$1";
            }
        }
    }
    return($from, $replyto, $subject, $messageid, $received, $mailer);
}


sub get_adr {
    my($value) = @_;
    my($adr, @adr, $line);

    $value =~ s/\((.*)\)//g;
    $value =~ s/"([^"]*)"//g;
    @adr = split(',', $value);
    foreach $adr(@adr) {
        if($adr =~ /</) {
            $adr =~ /<(.*)>/;
            $line .= $1 . ',';
        } else {
            $line .= $adr . ",";
        }
    }
    $line =~ s/\s+//g;
    chop($line);
    return($line);
}

sub load_init {
    my ($file) = $bbs_init_file;
    my (@text, %ini);
    my ($line, $ini_variable, $ini_lvalue, $ini_rvalue, $ini_split);
    my ($home);

    return 0 unless (-e $file);
    
    open(FILE, $file) || &error('設定ファイルが開けません.');
    
    while ($line = <FILE>) {
        chomp($line);
        if ((!($line =~ /^#/)) && (!($line =~ /^\s*$/))) {
            push(@text, $line);
        }
    }
    close(FILE);
    
    return 0 if (join("", @text) =~ /^\s*$/);
    
    while (@text) {
        $line = shift(@text);
        if ($line =~ /^\[(.*)\]/) {
            $ini_variable = $1;
            if ($1 eq "head_lines") {
                $nextline = shift(@text);
                my ($cnt, @hl);
                while (!($nextline =~ /^\[/)) {
                    $hl[$cnt++] = $nextline;
                    $nextline = shift(@text);
                }
                $headlines = join("", @hl);
                unshift(@text, $nextline);
            } elsif ($text[0] !~ /^\[(.*)\]/) {
                $ini{$ini_variable} = shift(@text);
            }
        }
    }
    $regist_max = $ini{'regist_max'} if (exists $ini{'regist_max'});
    $sendmail = $ini{'sendmail'} if (exists $ini{'sendmail'});
    $title = $ini{'title'} if (exists $ini{'title'});
    $bbs_url = $ini{'bbs_url'} if (exists $ini{'bbs_url'});
    $email_admin = $ini{'email_admin'} if (exists $ini{'email_admin'});

}

sub make_unique_pass {
    my @saltset = ('A' .. 'Z');
    my $ssize = $#saltset + 1;
    my $now = time;
    my ($p1, $p2) = unpack("C2", $now);
    my $seed = $now ^ ($$ + ($$ << 15));
    my $work = int($now / (60 * 60 * 24 * 7)) + $p1 + $p2 - 8 + $seed;
    my $nsalt = $saltset[$work % $ssize] . $saltset[$seed % $ssize];
    my $seed1 = $now ^ ($$ - ($$ << 15));
    $nsalt .= $saltset[$seed1 % $ssize];
    $nsalt .= (($work ^ $$) % 1000 + ($seed % 100));
    my $unique = 0;
    while($now > 0) {
      $unique = (($unique << 8) + ($now % 10)) % 931193;
      $now = int($now / 10);
    }
    $nsalt .= $unique;
    $nsalt = substr($nsalt, 0, 8);
    return ($nsalt);
}


sub send_mail {
    local ($to, $from, $sender, $replyto, $subject, $message) = @_;
    open MOH, "| $sendmail $to" || return;
    print MOH "To: $to\n";
    print MOH "From: $from\n";
    print MOH "Sender: $sender\n" if ($sender !~ /^\s*$/);
    print MOH "Reply-To: $replyto\n" if ($replyto !~ /^\s*$/);
    &jcode'convert(*subject, "jis");
    print MOH "Subject: $subject\n";
    print MOH "X-Mailer: Ir-i-BBS Mail-Post $version\n";
    print MOH "Content-Transfer-Encoding: 7bit\n";
    print MOH 'Content-Type: text/plain; charset=iso-2022-jp' . "\n\n";
    local ($_) = $message;
    s/<br>/\n/gi;
    s/&lt;/</g;
    s/&gt;/>/g;
    s/&quot;/\"/g;
    s/&amp;/\&/g;
    s/[ \t]+/ /g;
    s/\n /\n/g;
    s/ \n/\n/g;
    s/\n+/\n/g;
    s/^\s+//;
    s/\s+$//;
    &jcode'convert(*_, 'jis');
    print MOH "$_\n";
    close MOH;
    return;
}

