#---------------------------------------------- # Multi-TALK "HEARTS" (c)1998-2001 ASKN (朝日薫) # http://www.hinocatv.ne.jp/~askn/ #---------------------------------------------- $BBS{SOFTWERE} = "Multi-TALK HEARTS"; $BBS{RELEASE} = "0.1.23"; $GZIP = "/usr/bin/gzip -6"; =copyleft= This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. http://www.gnu.org/copyleft/gpl.txt 本プログラムはフリー・ソフトウェアです。あなたは Free Software Foundation が公表した GNU 一般公有使用許諾の「バージョン２」或 いはそれ以降の各バージョンの中から何れかを選択し、そのバージョ ンが定める条項に従って本プログラムを再頒布または変更することが できます。 本プログラムは有用とは思いますが、頒布にあたっては、市場性及び 特定目的適合性についての暗黙の保証を含めて、いかなる保証も行な いません。詳細については GNU一般公有使用許諾書をお読みください。 =cut= #---------------------------------------------- $PRT_HEAD = "Content-type: text/html\nPragma: no-cache\nExpires: 0\n\n"; $main::PRT_MODE && return; select STDOUT; $| = 1; close STDERR; open STDERR, ">&STDOUT"; @MTX::SNK{'　','〜','＜','＞','＆','”'} = ('　','〜','<','>','&','"'); $SIG{ALRM} = sub{die"[TIMEOUT]\n"}; eval "alarm $alarm"; $SIG{__DIE__} = sub{&$PRT_MODE($_[0])}; $PRT_MODE = \&prt_mode; $PRT_NEXT = \&prt_plain; $MAIL_KEYCHECK = $SYNC_COOKIE = $c = sub{undef}; %SUBMIT = ( 'post' => \&postcheck, # ボタンエントリー 'post.x' => \&postcheck, 'preview' => \&preview, 'preview.x' => \&preview, 'replace' => \&replace, 'replace.x' => \&replace, 'search' => \&search, 'search.x' => \&search, 'tree_move' => \&tree_move, 'undo' => \&undo, 'undo.x' => \&undo, 'delete' => \&delete, 'delete.x' => \&delete, 'correct' => \&correct, 'correct.x' => \&correct, 'my_menu' => \&my_menu, 'my_menu.x' => \&my_menu, 'perm' => \&permutation, 'perm.x' => \&permutation, 'about' => $c, 'about.x' => $c, 'append' => $c, 'append.x' => $c, 'edit' => $c, 'edit.x' => $c, 'form' => $c, 'form.x' => $c, 'help' => $c, 'help.x' => $c, 'index' => $c, 'index.x' => $c, 'kill' => $c, 'kill.x' => $c, 'login' => $c, 'login.x' => $c, 'main' => $c, 'main.x' => $c, 'menu' => $c, 'menu.x' => $c, 'navi' => $c, 'navi.x' => $c, 'note' => $c, 'note.x' => $c, 'open' => $c, 'open.x' => $c, 'ress' => $c, 'ress.x' => $c, 'scan' => $c, 'scan.x' => $c); $BBS{CGI_NAME} = $cgi; $ENV{SERVER_NAME} = "localhost" if $ENV{REMOTE_ADDR} eq "127.0.0.1"; $ENV{SERVER_NAME} = $ENV{SERVER_ADDR} if $ENV{SERVER_ADDR} =~ /^(10|192)\./; ($BBS{CGI_URL} = "http://$ENV{SERVER_NAME}$ENV{SCRIPT_NAME}") =~ s/([^:])\.*\/+/$1\//g; ($BBS{CGI_DIR} = $BBS{CGI_URL}) =~ s/^(.*\/).*$/$1/g; $BBS{CGI_ID} = &MTX::aenc($c = &MTX::strnum($BBS{CGI_URL}), 26); $procid = &MTX::aenc($c ^ $^T ^ ($$ << 8), 26); $cookie = newcookie MTX $BBS{CGI_ID}; $form = newform MTX; $dml = new DML; $BBS{C_DML} = &DML::pathchk($cookie -> cell("dml")); @BBS{INCODE,CHARSET,QUERY_CHKSUM,DML_FILE} = ($MTX::JCODE,$MTX::CHARSET,$MTX::QUERYCHKSUM,$dml_file); unless($c = &DML::pathchk($form -> cell("dml"))){ ($d, $_) = split /&/, $ENV{QUERY_STRING}, 2; $c = &DML::pathchk(&MTX::qdec($d)) if $d ne '' && $d !~ /=/; } (!$dml_only && ( ($c && $dml -> load($BBS{DML} = $c)) || (($d = &DML::pathchk($ARGV[0])) && $dml -> load($BBS{DML} = $d)) || ($BBS{C_DML} && $dml -> load($BBS{DML} = $BBS{C_DML}))) || ($dml -> load($BBS{DML} = $dml_file))) || &$PRT_MODE("[DML nofile]\n"); local $icon_set = newselset main; local $color_set = newselset main; local $select_set = newselset main; local $symbol_set = newselset main; $BBS{DML_ID} = &MTX::aenc(&MTX::strnum($BBS{DML}), 26); $cookie2 = newcookie MTX $BBS{DML_ID}; ($LOGMARK = $BBS{SOFTWERE}) =~ s/[^\w]/_/g; @BBS{APPEND_NOTES,VIEW_NOTES,ADD_LINES,SEARCH_COUNT,OLDLOG_PATH,USER_AGENT,REMOTE_INFO} = (15, 15, 0, 0, $oldlog_path, &MTX::charline($ENV{HTTP_USER_AGENT}), &MTX::getproxyinfo); $BBS{C_UID} = $procuid = ($cookie -> cell("uid")) || $procid; if(($password = $form -> cell("password")) && $password eq $admin_pass){ $BBS{ADMIN_MODE} = 1; $BBS{PASSWORD} = $form -> cell("password"); $BBS{APPEND_NOTES} = $max_note; } if($procuid ne 'no'){ @BBS{C_CODE,COUNT,ICON,LINK,MAIL,NAME,C_FMAIL,C_PASS,SYMBOL,C_SYNC,C_GZIP} = $cookie -> cell(qw/code count icon link mail name fmail pass symbol sync gzip/); @BBS{C_SORT,OPTIM,OPTIM1,OPTIM2,OPTIM3,OPTIM4,COLOR,SELECT} = $cookie2 -> cell(qw/sort optim optim1 optim2 optim3 optim4 color select/); $BBS{THREAD_SORT} = $BBS{C_SORT}; $BBS{GZIP} = $BBS{C_GZIP}; $BBS{COOKIE} = " checked"; }else{ $procuid = $procid; } $BBS{GZIP} = $form -> cell("gzip") if($form -> def("gzip")); if($c = $form -> cell("code")){ &chkcharcode($c); }elsif($BBS{C_CODE}){ &chkcharcode($BBS{C_CODE})} @BBS{ARTICLE,ID,MOVE,INAME,OPT,OPT1,OPT2,OPT3,OPT4,PAGE,WORD,SYNC} = $form -> cell(qw/article id move name opt opt1 opt2 opt3 opt4 page word sync/); @BBS{PAGE,MOVE} = (&numinstr($BBS{PAGE}),&numinstr($BBS{MOVE})); $BBS{THREAD} = int($form -> cell('thread')); $BBS{COUNT} += 0; $BBS{INAME} = $BBS{INAME} || $BBS{NAME}; $BBS{INAME} =~ s/(\(|（).*(\)|）)|[#!+?*]//g; $BBS{INAME} = substr $BBS{INAME}, 0, $c if ($c = &MTX::indexj($BBS{INAME}, '＠')) >= 0; $BBS{INAME} = substr $BBS{INAME}, 0, $c if ($c = &MTX::indexj($BBS{INAME}, '@')) >= 0; $dml -> entget(BBS, \&bbs_get); $dml -> entput(BBS, \&bbs_put); $dml -> entmac(BBS, \&bbs_block); $dml -> run(sub{goto $PRT_MODE}); &$PRT_MODE($PRT_TEXT) if $PRT_TEXT; &$PRT_MODE("[Empty STDOUT]") if $PRT_HEAD; # STDOUT 出力周り sub prt_sjis{ my $p = $_[0]; $MTX::CHARCODE eq 'euc' && &MTX::euc2sjis(\$p); print $p; } sub prt_phone{ my $p = $_[0]; $MTX::CHARCODE eq 'euc' && &MTX::euc2sjis(\$p); print &MTX::snarrk(\$p); } sub prt_euc{ my $p = $_[0]; $MTX::CHARCODE eq 'sjis' && &MTX::sjis2euc(\$p); print &MTX::widek(\$p); } sub prt_jis{ my $p = $_[0]; $MTX::CHARCODE eq 'sjis' && &MTX::sjis2euc(\$p); print &MTX::euc2jis(\$p); } sub prt_plain{print $_[0]} sub prt_mode{ return if $_[0] eq ''; my($i, $j, $k); $i = $PRT_TEXT; $i .= $PRT_HEAD if $_[0] !~ /^[\w\-]+:/i; $i .= $_[0]; $PRT_HEAD = $PRT_TEXT = undef; my($j, $k) = split /\n\n+/, $i, 2; if($k eq ''){ $PRT_TEXT = $i; return; }else{ if($GZIP && $BBS{GZIP} && $ENV{HTTP_ACCEPT_ENCODING} =~ /(x-)?gzip/){ print "Content-encoding: ${&}\n${j}\n\n"; open STDOUT, "|${GZIP} -c"; }else{ print "$j\n\n"; } &$PRT_NEXT($k); $PRT_MODE = $PRT_NEXT; } } sub chkcharcode{ $BBS{CHARCODE} = lc $_[0]; if($BBS{CHARCODE} eq 'sjis'){ $PRT_NEXT = \&prt_sjis; $BBS{CHARSET} = 'Shift_JIS'; }elsif($BBS{CHARCODE} eq 'phone'){ $PRT_NEXT = \&prt_phone; $BBS{CHARSET} = 'Shift_JIS'; }elsif($BBS{CHARCODE} eq 'euc'){ $PRT_NEXT = \&prt_euc; $BBS{CHARSET} = 'x-euc'; }elsif($BBS{CHARCODE} eq 'jis'){ $PRT_NEXT = \&prt_jis; $BBS{CHARSET} = 'iso-2022-jp'; }else{ $PRT_NEXT = \&prt_plain; $BBS{CHARSET} = $MTX::CHARSET} $PRT_MODE = $PRT_NEXT if $PRT_MODE ne \&prt_mode; } # DMLマクロエントリー sub bbs_get{ my($a, $b) = @_; my($d, $e, $f, %v); $v{BTIMES} = sub{eval'sprintf"%.3f",(times)[0]-$btimes'if$]>5.004}; $v{LTIME} = sub{$HEAD[2]}; $v{MODE} = sub{&loginit unless $BBS{MODE};$BBS{MODE}}; $v{ICON_ALT} = sub{$icon_set->getselalt(&DML::envget($f))}; $v{ICON_DEF} = sub{$icon_set->getseldef(&DML::envget($f))}; $v{ICON_USE} = sub{$icon_set->getseluse}; $v{SYMBOL_ALT} = sub{$symbol_set->getselalt(&DML::envget($f))}; $v{SYMBOL_DEF} = sub{$symbol_set->getseldef(&DML::envget($f))}; $v{SYMBOL_USE} = sub{$symbol_set->getseluse}; $v{DML_LIST} = sub{ unless($BBS{DML_LIST}){ for $f (sort glob("*.dml")){ local *L; if(open L, $f){ read L, $e, 256, 0; $BBS{DML_LIST} .= "$f,$1\n" if $e =~ //i; close L; } } } $BBS{DML_LIST}; }; $v{CHANGE} = sub{ push(@chenges, "black") unless @chenges; $e = int((time - &DML::envget($f)) / (($BBS{CHANGE_TIME} || 1) * 3600)); $chenges[($e < 0) ? 0 : (($e > $#chenges) ? $#chenges : $e)]; }; $v{FORM_T} = sub{ $e = $f ? &DML::envget($f) : 0; $f = $form -> plaincell($e ? "t$e" : "text"); $f =~ s/<(\/text[^>]+>)/<$1/gi; $f; }; $v{FORM_S} = sub{ $e = $f ? &DML::envget($f) : 0; $form -> cell($e ? "s$e" : "subject"); }; $v{THREAD_DEF} = sub{ $THREAD{int($d eq '' ? $BBS{THREAD} : &DML::envget($f))} ? 1 : undef; }; $v{ARTICLE_DEF} = sub{ $NOTES{$d eq '' ? $BBS{ARTICLE} : &DML::envget($f)} ? 1 : undef; }; $v{THREAD_INPAGE} = sub{ $e = int($d eq '' ? ($BBS{ARTICLE} || $BBS{THREAD}) : &DML::envget($f)); for($f = 0; $f < @PAGES; $f++){ for $d(split /\n/, $PAGES[$f]){ return($f + 1) if $d eq $e; } } 1; }; $v{SEQUENTIAL_INPAGE} = sub{ $e = $d eq '' ? ($BBS{ARTICLE} || $BBS{THREAD}) : &DML::envget($f); for($f = 0; $f < @SEQUENTIAL; $f++){ for $d(split /\n/, $SEQUENTIAL[$f]){ return($f + 1) if $d eq $e; } } 1; }; $v{OLDLOG_FILES} = sub{ $BBS{$b} || do{ my(@f, $i); for($i = $HEAD[1]; $i > 0; $i--){ push(@f, $i) if -s sprintf("${oldlog_path}${oldlog_file}", $i); } $BBS{$b} = join "\n", &rsort(@f) } }; ($b, $d, $f) = $b =~ /^(\w+)(:([\w:]*))?$/; goto &$e if $e = $v{$b}; $BBS{$b}; } sub bbs_put{ my($a, $b, $c) = @_; my($d, $e, $f, $g, %v); $d = sub{$BBS{$b}=$c}; @v{ APPEND_NOTES, ARTICLE, CGI_URL, CHANGE_TIME, DEPTH_LIMIT, FILE_UPLOAD, ID, OPT, OPT1, OPT2, OPT3, OPT4, PAGE, POST_FLASHING, POST_RESS, POST_SIGNUP, POST_SUBJECT, THREAD_SORT, VIEW_NOTES, SKIP_KILLNOTE, USER_CORRECT, ICON, COLOR, SYMBOL, SELECT, POST_CHATMODE, OPTIM, DML, GZIP, FREE_DOWNLOAD, DIRECT_SUBMIT, NAME, LINK} = ($d) x 33; $v{THREAD} = sub{$BBS{$b}=int$c}; $v{CHANGES} = sub{ $BBS{$b} = $c; @chenges = (); for $e (split /\n/, $c){ push @chenges, $& if $e =~ /^(#?[0-9A-F]{6}|[A-Z]+)/i; } }; $v{CHARCODE} = sub{&chkcharcode($c)}; $v{ICONS} = sub{$BBS{ICON_LIST} = $icon_set -> selset($BBS{$b} = $c, $BBS{INAME})}; $v{COLORS} = sub{$BBS{COLOR_LIST} = $color_set -> selset($BBS{$b} = $c, $BBS{INAME})}; $v{SELECTS} = sub{$BBS{SELECT_LIST} = $select_set -> selset($BBS{$b} = $c, $BBS{INAME})}; $v{SYMBOLS} = sub{$BBS{SYMBOL_LIST} = $symbol_set -> selset($BBS{$b} = $c, $BBS{INAME})}; ($b, $d, $f) = $b =~ /^(\w+)(:([\w:]*))?$/; &$d() if $d = $v{$b}; } sub bbs_block{ # BBSマクロの実行 my($a, $b, @BLK) = @_; my($c, $d, $e, $f, $g, @c, %v, @v, $v); @v = qw/COLOR COUNT FMAIL FILE ICON LINK MAIL NAME REMOTE_INFO SELECT SERIAL STATUS SUBJECT SYMBOL TEXT TIME UID UNDO USER_AGENT/; $v = join "|", @v; $v{THREAD_LIST} = sub{ $g = @PAGES if ($g = int($d eq '' ? $BBS{PAGE} : &DML::envget($f))) > @PAGES; $g = $g < 1 ? 1 : $g; $BBS{THREAD} = undef; for $c (split /\n/, $PAGES[$g - 1]){ ($BBS{THREAD} = $c) || next; &DML::runobj(@BLK); } }; $v{SEQUENTIAL} = sub{ $g = @PAGES if ($g = int($d eq '' ? $BBS{PAGE} : &DML::envget($f))) > @PAGES; $g = $g < 1 ? 1 : $g; $BBS{ARTICLE} = undef; unless(@SEQUENTIAL){ for $a(@PAGES){ for $b(split/\n/, $a){ for $f(split/\n/, $THREAD{$b}){ push(@c, "$1.$f") if $NOTES{$f} =~ /^SERIAL:(\d+)/m; } } } @c = &rsort(@c); $c = scalar @c; $d = scalar(@PAGES) || 1; $b = $d = int($c / $d) + ($c != 0); $SEQUENTIAL[0] = ''; for $c(@c){ $c =~ /^\d+\.([\d\.]+)$/; $SEQUENTIAL[$#SEQUENTIAL] .= "$1\n"; if(--$d == 0){ push @SEQUENTIAL, ""; $d = $b; } } } for $c (split /\n/, $SEQUENTIAL[$g - 1]){ ($BBS{ARTICLE} = $c) || next; &DML::runobj(@BLK); } }; $v{OLDLOG_MAKE} = sub{ @oldlog_make = @BLK }; $v{OLDLOG_THREAD_LIST} = sub{ local @BBS{THREAD,APPEND_NOTES,ADMIN_MODE} = (); for $c (split /\n/, $BBS{OLDLOG_THREAD}){ ($BBS{THREAD} = $c) || next; &DML::runobj(@BLK); } }; $v{THREAD} = sub{ $BBS{_} = 0; @BBS{INDENT,ARTICLE,DEPTH,THREAD_NOTES,APPENDED_OK} = (); (@c = split /\n/, $THREAD{int($d eq '' ? $BBS{THREAD} : &DML::envget($f))}) || return; $BBS{THREAD_NOTES} = scalar @c; $BBS{APPENDED_OK} = $BBS{OLDLOG_MAKE} ? 0 : ($BBS{ADMIN_MODE} || $BBS{THREAD_NOTES} < $BBS{APPEND_NOTES}); for $c (&maketree(@c)){ local @BBS{@v} = (); @BBS{INDENT,ARTICLE,DEPTH} = split /,/, $c; $d = $NOTES{$BBS{ARTICLE}} || next; study $d; $BBS{$1} = $2 while $d =~ /^($v):(.+)/gm; $BBS{MAIL} = undef if !$BBS{ADMIN_MODE} && $BBS{FMAIL}; $BBS{UNDO} = split /,/, $BBS{STATUS}; if($BBS{STATUS} =~ /^D/){ $BBS{SUBJECT} = 'DELETE'; @BBS{FILE,LINK,MAIL,NAME,TEXT} = (undef) x 5 if !$BBS{ADMIN_MODE}; } $BBS{_}++; &DML::runobj(@BLK); } }; $v{ARTICLE} = sub{ $BBS{_} = 0; ($d = $NOTES{$e = ($d eq '' ? $BBS{ARTICLE} : &DML::envget($f))}) || return; local @BBS{@v} = (); local $BBS{ARTICLE} = $e; @c = split /\n/, $THREAD{int $e}; $BBS{THREAD_NOTES} = scalar @c; $BBS{APPENDED_OK} = $BBS{OLDLOG_MAKE} ? 0 : ($BBS{ADMIN_MODE} || $BBS{THREAD_NOTES} < $BBS{APPEND_NOTES}); study $d; $BBS{$1} = $2 while $d =~ /^($v):(.+)/gm; $BBS{MAIL} = undef if !$BBS{ADMIN_MODE} && $BBS{FMAIL}; $BBS{UNDO} = split /,/, $BBS{STATUS}; if($BBS{STATUS} =~ /^D/){ $BBS{SUBJECT} = 'DELETE'; @BBS{FILE,LINK,MAIL,NAME,TEXT} = (undef) x 5 if !$BBS{ADMIN_MODE}; } $BBS{_}++; &DML::runobj(@BLK); }; ($b, $d, $f) = $b =~ /^(\w+)(:([\w:]*))?$/; &$e() if $e = $v{$b}; } # 選択リストメソッド sub newselset{ my $c = shift; my(%a, %b, @c, @d, %e); my @a = (\%a, \%b, \@c, \@d, \%e); my $x = \@a; bless $x, $c; return $x; } sub selset{ my $x = shift; my $f = shift; my $n = shift; my($a, $b, $c, $d, $e) = @$x; my($m, $l, %v, %w, $y, $z); undef %$a; undef %$b; undef @$c; undef @$d; undef %$e; $v{E} = sub{$$b{$y}=$_[0]if$_[0]}; $v{'#'} = sub{$$a{$2}.="$y\n";&{$v{E}}($2)}; $v{'!'} = sub{$$a{$2}.="$y\n";$l.="$2,$y,$z\n"unless$w{$2}++;&{$v{E}}($2)}; $v{'+'} = sub{push@$c,$y;goto$v{'!'}}; $v{'?'} = sub{push@$c,$y;&{$v{E}}($2)}; $v{'*'} = sub{push(@$d,$y)if$2 eq $n}; for $m (split /\n/, $f){ ($x, $y, $z) = split /,/, $m, 3; $x || next; $$e{$y}++; $x = "+$x" if ord($x) != 35; &{$v{$1}} while $x =~ /([!?+#\*])([^!?+#\*]+)/g; } $l; } sub getselset{ my $x = shift; my $n = shift; my($a, $b, $c, $d, $e) = @$x; my($f, $g, @g); (&MTX::rand(1)) x &MTX::rand(4); if(($g = $$a{$n}) ne ''){ chomp $g; @g = split /\n/, $g; $f = $g[&MTX::rand(scalar @g)]; }elsif(scalar @$d){ $f = $$d[&MTX::rand(scalar @$d)]; }else{ $f = $$c[&MTX::rand(scalar @$c)]; } $f; } sub getselalt{ my $x = shift; my $n = shift; my($a, $b, $c, $d, $e) = @$x; $$b{$n}; } sub getseldef{ my $x = shift; my $n = shift; my($a, $b, $c, $d, $e) = @$x; $$e{$n}; } sub getseluse{ my $x = shift; my($a, $b, $c, $d, $e) = @$x; join "\n", @$d; } # 補助ルーチン sub maketree{ my @c = @_; my($c, $d, $e, $f, @d, @e); for $c (@c){ @e = split /\./, $c; if(($e = scalar @e - 1) == 0){ push @d, ",$c,0"; next; } $e = $BBS{DEPTH_LIMIT} if $BBS{DEPTH_LIMIT} && $BBS{DEPTH_LIMIT} < $e; push @d, ('　' x ($e - 1) . "└,$c,$e"); $e = $e * 2 - 2; for($f = $#d - 1; $f > 0; $f--){ $g = substr $d[$f], $e, 2; if($g eq '　'){ substr($d[$f], $e, 2) = '│'; next; }elsif($g eq '└'){ substr($d[$f], $e, 2) = '├'; } last; } } @d; } sub datestr{ my @t = localtime $_[0]; $t[4] ++; $t[5] += 1900; sprintf "$t[5]/$t[4]/$t[3](%s) %2.2d:%2.2d:%2.2d", (qw/Sun Mon Tue Wed Thu Fri Sat/)[$t[6]], $t[2], $t[1], $t[0]; } sub readform{ @BBS{S_COOKIE,COLOR,ICON,LINK,MAIL,NAME,SELECT,SYMBOL,OPTIM} = $form -> cell(qw/cookie color icon link mail name select symbol optim/); $BBS{LINK} = "" if $BBS{LINK} eq "http://"; $BBS{LINK} = "mailto:$BBS{LINK}" if $BBS{LINK} =~ /^[\w\-\.]+\@([\w\-]+\.)+[A-Z]{2,4}$/i; } sub numinstr{ $_[0] =~ /\d+/ ? $& : 0; } sub rsort{ local($a, $b); sort { $b <=> $a } @_; } sub remarkinfo{ $LOG =~ s/^<\w+,\w+,\d.+>$/<$LOGMARK,$MTX::CHARCODE,$HEAD[0],$HEAD[1],$^T,$MTX::QUERYCHKSUM,$BBS{REMOTE_INFO}>/m; $reflesh++; } sub imgchk{ my $data = $_[0]; my $offset; if($data =~ /^\xFF\xD8\xFF\xE0(..)JFIF/s){ pos $data = $offset = unpack("n", $1) + 4; while($data =~ /(.)(.)(..)(.)(..)(..)/gs){ $1 ne "\xFF" && last; my $m = ord $2; my $d = unpack("n", $3); my $f = ord $4; return sprintf(",%d,%d", unpack("n", $6), unpack("n", $5)) if $m >= 0xC0 && $m <= 0xCF && $f == 8; pos $data = ($offset += $d + 2); } }elsif($data =~ /^.PNG.{12}(.{4})(.{4})/s){ return sprintf(",%d,%d", unpack("N", $1), unpack("N", $2)); }elsif($data =~ /^GIF8[79]a(..)(..)/s){ return sprintf(",%d,%d", unpack("S", $1), unpack("S", $2)); } } sub file_upload{ $BBS{FILE_UPLOAD} || return; $file_limit || return; my($n, $m, $e, $f, $d, $s, $t) = @_; $e = $form -> cell($n) || return; ($f) = $e =~ /[\\\/]([\w_\-\.]+)$/; $f =~ s/[\.\/]+$//; $s = length($d = $MTX::FB{$e}); if($f eq "" || $s == 0){ $BBS{RESULT} .= "$m,E_ILG_FILE\n"; return undef; }elsif($s > $file_limit){ $BBS{RESULT} .= "$m,E_FILE_SIZE\n"; return undef; } $t = $MTX::FT{$e}; $i = "\nFILE:$f,$s,$t" . imgchk($d); $BBS{RESULT} .= "$m,OK_FILE_UPLOAD\n"; $i . "\nfile:" . &MTX::benc($d); } # ログイン sub loginit{ my($c, $d, $e, $f, $g, $h, @c); local($reflesh); $BBS{MODE} = "MAIN"; open LOG, "+<$log_file"; do{ local $SIG{__DIE__} = IGNORE; eval 'flock LOG, 2'; }; read LOG, $LOG, (-s $log_file); seek(LOG, 0, 0); if($LOG =~ /<\w+,$MTX::CHARCODE,([^>\n]+)>/i){ @HEAD = split /,/, $1, 5; unshift @HEAD, 0 if $HEAD[3] =~ /\./; }else{ $LOG = "<$LOGMARK,$MTX::CHARCODE,0,0>\n"; @HEAD = (0, 0); } $c = &$MAIL_KEYCHECK(1); if(length($ENV{PATH_INFO}) > 4){ $BBS{MODE} = "FILE_DOWNLOAD"; $ENV{PATH_INFO} =~ s/[\.\/]+$//; @c = split /\//, $ENV{PATH_INFO}; ($num, $file) = @c[$#c-1, $#c]; $m = quotemeta $num; $f = quotemeta $file; ($log) = $LOG =~ /^<$m>((\n\w+:.*)*)/m; ($s, $z) = $log =~ /^FILE:$f,(\d+),([\w\-\/]+)/m; $c = undef if $BBS{FREE_DOWNLOAD}; if($c){ $BBS{MAIL} = $form -> cell("mail"); $BBS{PASS} = $form -> cell("pass"); $c = &$MAIL_KEYCHECK(2); } if($s && $z && !$c){ study $log; ($d) = $log =~ /^file:(.+)/m; ($c) = $log =~ /^TIME:(\d+)/m; ($f) = $log =~ /^STATUS:.._(\d+)/m; $e = &MTX::expires($c < $f ? $f : $c); print "Content-type: $z\nContent-length: $s\nLast-Modified: $e\n\n"; binmode STDOUT; print &MTX::bdec($d) if $ENV{REQUEST_METHOD} ne "HEAD"; exit(0); }elsif($c){ $BBS{FILE_DOWNLOAD} = $file if $num; $BBS{RESULT} .= "$num,E_MAIL_AUTH\n"; }else{ $BBS{FILE_DOWNLOAD} = $file if $num; $BBS{RESULT} .= "$num,E_NO_FILE\n"; return; } } $oldlog = (($DML::ES{RELOAD} || $DML::ES{DML}) ne $dml_file) ? 0 : 1; %NOTES = %THREAD = @PAGES = (); $BBS{ALL} = $oldlog_mark = $c = $d = 0; $PAGES[0] = ''; while($LOG =~ /^<((\d+\.)*\d+)>((\n\w+:.*)*)/gm){ ++$c; ++$BBS{ALL}; if($2 eq ''){ if($BBS{ALL} > $max_note && $oldlog){ unless($oldlog_mark){ $oldlog_mark = pos($LOG) - length($&); push @PAGES, ''; } }elsif($c > $BBS{VIEW_NOTES}){ push @PAGES, ''; $c = 0; } $PAGES[$#PAGES] .= "$1\n"; $THREAD{$e = $1} = ''; } $THREAD{$e} .= "$1\n"; $NOTES{$1} = $3; } $BBS{SERIAL_NUM} = $HEAD[0]; $BBS{OLDLOG_NUM} = $HEAD[1]; $BBS{OLDLOG_THREAD} = pop @PAGES if $oldlog_mark; $BBS{PAGE} = @PAGES if $BBS{PAGE} > @PAGES; $BBS{PAGES} = @PAGES; $BBS{PAGE} = $BBS{PAGE} < 1 ? 1 : $BBS{PAGE}; for $c (@PAGES){ $BBS{PAGE_LIST} .= ++$d. "\n"; } if($oldlog_path && $BBS{OLDLOG_THREAD} && @oldlog_make){ local(*DATA, $data, $save); my($f, $s, $hd); $hd = $HEAD[1] || 1; $f = sprintf "${oldlog_path}${oldlog_file}", $hd; if(($s = -s $f) > $oldlog_limit){ $hd++; $f = sprintf "${oldlog_path}${oldlog_file}", $hd; } if(open DATA, "+<$f"){ local $SIG{__DIE__} = IGNORE; eval 'flock DATA, 2'; $data = join '', ; seek(DATA, 0, 0); }else{ open(DATA, ">$f"); } $BBS{OLDLOG_NEXT} = $hd - 1 if $hd > 1; $BBS{OLDLOG_NUM} = $hd; local($BBS{CHARSET}, $BBS{CHARCODE}, $BBS{ADMIN_MODE}, $BBS{FILE_UPLOAD}); local($PRT_MODE, $PRT_TEXT, $PRT_NEXT); &chkcharcode($MTX::CHARCODE); @BBS{ADMIN_MODE,FILE_UPLOAD} = (); $BBS{OLDLOG_MAKE} = 1; if($data){ $save = &DML::envout2($data); }else{ $oldlog_make[1] = sub{$save .= $_[0]}; &DML::runobj(@oldlog_make); } $BBS{OLDLOG_MAKE} = undef; if($BBS{CHARCODE} eq 'phone'){ &MTX::snarrk(\$save); }elsif($BBS{CHARCODE} eq 'euc'){ &MTX::widek(\$save); } print DATA $save; close DATA; $HEAD[1] = $hd if(-s $f) > 0; $LOG = substr $LOG, 0, $oldlog_mark; $LOG =~ s/,\d+,\d+/,$HEAD[0],$HEAD[1]/; $reflesh++; } $BBS{APPEND_NOTES} = $max_note if $BBS{ADMIN_MODE}; if($BBS{DIRECT_SUBMIT} && ($c = $form -> arraydef("^($BBS{DIRECT_SUBMIT})(\\d+\\.)*\\d+(\.[xyXY])?\$", 1)) =~ /^($BBS{DIRECT_SUBMIT})((\d+\.)*\d+)(\.[xyXY])?$/){ $d = $SUBMIT{$1}; @id = ($BBS{ID} = $2); $BBS{SUBMIT} = $c; $BBS{MODE} = uc $1; $BBS{MODE} =~ s/^(\w+).*$/$1/; &$d() if $d; }else{ @id = $form -> arraycell("id"); $BBS{ID_LIST} = join "\n", @id; @chk = $form -> arraycell("chk"); $BBS{CHK_LIST} = join "\n", @chk; for $c ($form -> deflist){ if($d = $SUBMIT{$c}){ $BBS{MODE} = uc $c; $BBS{MODE} =~ s/^(\w+).*$/$1/; $BBS{SUBMIT} = $form -> cell($c); &$d(); last; } } } if($reflesh && $BBS{MODE} ne 'PREVIEW'){ print LOG $LOG; local $SIG{__DIE__} = IGNORE; eval 'truncate(LOG, tell LOG)'; if($BBS{POST_FLASHING}){ $h = @PAGES; %NOTES = %THREAD = @PAGES = (); pos $LOG = $BBS{ALL} = $c = $d = 0; $PAGES[0] = ''; study $LOG; while($LOG =~ /^<((\d+\.)*\d+)>((\n\w+:.*)*)/gm){ ++$c; ++$BBS{ALL}; if($2 eq ''){ if($c > $BBS{VIEW_NOTES}){ push @PAGES, ''; $c = 0; } $PAGES[$#PAGES] .= "$1\n"; $THREAD{$e = $1} = ''; } $THREAD{$e} .= "$1\n"; $NOTES{$1} = $3; } pop @PAGES while @PAGES > $h; } } close LOG; undef $LOG; $BBS{LINK} = "http://" if $BBS{LINK} eq ''; if($BBS{THREAD_SORT}){ local($a, $b); my(%SORT, @SORT, @i); $h = @PAGES; $c = $d = 0; for $a(@PAGES){ for $b(split/\n/, $a){ for $f(split/\n/, $THREAD{$b}){ ($g) = $NOTES{$f} =~ /^SERIAL:(\d+)/m; $SORT{$b} = $g if $SORT{$b} < $g; } } } @PAGES = (); $PAGES[0] = ''; push(@SORT, "$g.$f") while ($f, $g) = each %SORT; for $e (&rsort(@SORT)){ ($e) = $e =~ /\.(\d+)/; $c += scalar(split /\n/, $THREAD{$e}); $PAGES[$#PAGES] .= "$e\n"; if($c > $BBS{VIEW_NOTES}){ push @PAGES, ''; $c = 0; } } while(@PAGES > $h){ $c = pop @PAGES; $PAGES[$#PAGES] .= $c; } $BBS{PAGE_LIST} = undef; for $c (@PAGES){ $BBS{PAGE_LIST} .= ++$d. "\n"; } } } sub preview{ &postcheck; $reflesh = undef; $BBS{MODE} = "PREVIEW"; } # 投稿処理 sub postcheck{ my($c, $d, $f, $i, $j, $m, $n, $date, $num, $top, $sup); my($son, $ton, $subj, $text, $rsubj, $rtext); &readform; $ton++ if &MTX::strchk($text = $form -> htmlcell("text")); $son++ if &MTX::strchk($subj = $form -> cell("subject")); $BBS{RESULT} .= "0,E_NO_METHOD\n" if $ENV{REQUEST_METHOD} ne "POST"; $BBS{RESULT} .= "0,E_POST_DUBLE\n" if $HEAD[3] == $MTX::QUERYCHKSUM; $BBS{RESULT} .= "0,E_POST_WAIT\n" if ($HEAD[2] + $post_wait > $^T) && ($HEAD[4] eq $BBS{REMOTE_INFO}); $BBS{RESULT} .= "0,E_NO_NAME\n" unless &MTX::strchk($BBS{NAME}); $d = &$MAIL_KEYCHECK(0); $BBS{RESULT} .= $c = $d unless $BBS{ADMIN_MODE}; $BBS{RESULT} .= "0,E_ILG_MAIL\n" if $c eq '' && $BBS{MAIL} && $BBS{MAIL} !~ /^[\w\-\.]+\@([\w\-]+\.)+[A-Z]{2,4}$/i; $BBS{RESULT} .= "0,E_LONG_LINE\n" if length(join "", $subj, @BBS{LINK,MAIL,NAME}) > $line_limit; return if $BBS{RESULT}; $date = &datestr($^T); $note = "TIME:$^T\nDATE:$date\nUSER_AGENT:$BBS{USER_AGENT}\nREMOTE_INFO:$BBS{REMOTE_INFO}\nNAME:$BBS{NAME}\nUID:$procuid"; $note .= "\nLINK:$BBS{LINK}" if $BBS{LINK}; $note .= "\nMAIL:$BBS{MAIL}" if $BBS{MAIL}; $note .= "\nFMAIL:$BBS{C_FMAIL}" if $BBS{C_FMAIL}; $note .= "\nCOLOR:$c" if $c = $color_set -> getselset($BBS{COLOR}); $note .= "\nSELECT:$c" if $c = $select_set -> getselset($BBS{SELECT}); study $LOG; $f = $DML::ES{HEADLINE} || 40; for $c (reverse $form -> arraydef('^t(\d+\.)*\d+$')){ &MTX::strchk($rtext = $form -> htmlcell($c)) || next; ($num, $top) = $c =~ /((\d+)(\.\d+)*)/; chomp($d = $THREAD{$top}); if(!$d){ $BBS{RESULT} .= "$num,E_NO_THREAD\n"; }elsif(scalar(split /\n/, $d) >= $BBS{APPEND_NOTES}){ $BBS{RESULT} .= $sup = "$num,E_NO_APPEND\n"; }elsif($form -> length($c) > $note_limit){ $BBS{RESULT} .= $sup = "$num,E_LONG_SIZE\n"; }else{ $rsubj = &MTX::headline($form -> cell("s$num"), $f, "...") || &MTX::headline($rtext, $f, "...") || "(none)"; my $n = 0; do{ $n++; $m = "${num}.$n" } while $NOTES{$m} ne ''; $c = quotemeta $num; $LOG =~ s/^<\/$c>$/ $HEAD[0]++; $i = "<$m>\nSERIAL:$HEAD[0]\n" . $note; $i .= "\nCOUNT:" . ++$BBS{COUNT}; $i .= "\nICON:$c" if $c = $icon_set -> getselset($BBS{ICON}); $i .= "\nSYMBOL:$c" if $c = $symbol_set -> getselset($BBS{SYMBOL}); $i .= &file_upload("f$num", $m); $i."\nSUBJECT:$rsubj\nTEXT:$rtext\n<\/$m>\n".$& /em; $BBS{RESULT} .= "$m,OK_APPENDED\n"; $BBS{ADD_LINES} ++; } } $top = $n = 0; if($BBS{POST_SIGNUP} && @chk == 1 && $BBS{ADD_LINES} == 0 && $ton && $son == 0){ ($num, $top) = $chk[0] =~ /((\d+)(\.\d+)*)/; chomp($d = $THREAD{$top}); if(!$d){ $BBS{RESULT} .= "$num,E_NO_THREAD\n"; }elsif(scalar(split /\n/, $d) >= $BBS{APPEND_NOTES}){ $BBS{RESULT} .= $sup = "$num,E_NO_APPEND\n"; }elsif($form -> length("text") > $note_limit){ $BBS{RESULT} .= $sup = "$num,E_LONG_SIZE\n"; }else{ $rsubj = &MTX::headline($text, $f, "...") || "(none)"; do{ $n++; $m = "${num}.$n" } while $NOTES{$m} ne ''; $c = quotemeta $num; $LOG =~ s/^<\/$c>$/ $HEAD[0]++; $i = "<$m>\nSERIAL:$HEAD[0]\n" . $note; $i .= "\nCOUNT:" . ++$BBS{COUNT}; $i .= "\nICON:$c" if $c = $icon_set -> getselset($BBS{ICON}); $i .= "\nSYMBOL:$c" if $c = $symbol_set -> getselset($BBS{SYMBOL}); $i .= &file_upload("file", $m); $i . "\nSUBJECT:$rsubj\nTEXT:$text\n<\/$m>\n" . $& /em; $BBS{RESULT} .= "$m,OK_APPENDED\n"; $BBS{ADD_LINES} ++; } } if(!$top){ if($BBS{POST_CHATMODE}){ $rsubj = &MTX::headline($subj, $f, "..."); $ton++ if $text.$rsubj ne ''; }else{ $rsubj = &MTX::headline($subj, $f, "...") || &MTX::headline($text, $f, "...") || "(none)" } if(!$ton){ $BBS{RESULT} .= "0,E_NO_TEXT\n" if $BBS{ADD_LINES} == 0; }elsif($BBS{POST_SUBJECT} && !$son){ $BBS{RESULT} .= "0,E_NO_SUBJECT\n"; }elsif($BBS{APPEND_NOTES} <= 0){ $BBS{RESULT} .= $sup = "0,E_NO_NEWPOST\n"; }elsif($form -> length("text") > $note_limit){ $BBS{RESULT} .= $sup = "0,E_LONG_SIZE\n"; }else{ $BBS{ARTICLE} = int $PAGES[0]; $BBS{ARTICLE} ++; $LOG =~ s/\n/ $HEAD[0]++; $i = "\n<$BBS{ARTICLE}>\nSERIAL:$HEAD[0]\n" . $note; $i .= "\nCOUNT:" . ++$BBS{COUNT}; $i .= "\nICON:$c" if $c = $icon_set -> getselset($BBS{ICON}); $i .= "\nSYMBOL:$c" if $c = $symbol_set -> getselset($BBS{SYMBOL}); $i .= &file_upload("file", $BBS{ARTICLE}); $i."\nSUBJECT:$rsubj\nTEXT:$text\n<\/$BBS{ARTICLE}>\n" /es; $BBS{ADD_LINES} ++; $BBS{RESULT} .= $sup = "$BBS{ARTICLE},OK_NEWPOST\n"; } } if($BBS{ADD_LINES}){ &remarkinfo; &presscookie; }elsif($sup eq '' && $BBS{POST_RESS} && @chk > 0){ $BBS{MODE} = "RESS"; } } # その他の submit 処理 sub presscookie{ my($c, $d, $e); $e = &MTX::expires($^T + $cookie_time * 86400); if($BBS{S_COOKIE}){ &$SYNC_COOKIE(1); $cookie = newquery MTX; $cookie -> setcell("uid", $procuid); $cookie -> setcell("name", $BBS{NAME}); $cookie -> setcell("link", $BBS{LINK}); $cookie -> setcell("mail", $BBS{MAIL}); $cookie -> setcell("icon", $BBS{ICON}); $cookie -> setcell("count", $BBS{COUNT}); $cookie -> setcell("symbol", $BBS{SYMBOL}); $cookie -> setcell("code", $BBS{C_CODE}); $cookie -> setcell("dml", $BBS{C_DML}); $cookie -> setcell("sync", $BBS{C_SYNC}); $cookie -> setcell("fmail", $BBS{C_FMAIL}); $cookie -> setcell("gzip", $BBS{C_GZIP}); $cookie -> setcell("pass", $BBS{MAIL_AUTH} ? $BBS{PASS} : $BBS{C_PASS}); $cookie2 = newquery MTX; $cookie2 -> setcell("sort", $BBS{C_SORT}); $cookie2 -> setcell("optim", $BBS{OPTIM}); $cookie2 -> setcell("optim1", $BBS{OPTIM1}); $cookie2 -> setcell("optim2", $BBS{OPTIM2}); $cookie2 -> setcell("optim3", $BBS{OPTIM3}); $cookie2 -> setcell("optim4", $BBS{OPTIM4}); $cookie2 -> setcell("color", $BBS{COLOR}); $cookie2 -> setcell("select", $BBS{SELECT}); $c = $cookie -> mkcookie($BBS{CGI_ID}); $d = $cookie2 -> mkcookie($BBS{DML_ID}); $BBS{COOKIES} = "$c;EXPIRES=$e"; $BBS{COOKIE2} = "$d;EXPIRES=$e"; $PRT_TEXT .= "Set-Cookie:$BBS{COOKIES}\nSet-Cookie:$BBS{COOKIE2}\n"; }elsif($BBS{C_UID} ne "no"){ &$SYNC_COOKIE(0); $BBS{COOKIES} = "$BBS{CGI_ID}=uid:no;EXPIRES=$e"; $BBS{COOKIE2} = "$BBS{DML_ID}=;EXPIRES=" . &MTX::expires($^T + 3); $PRT_TEXT .= "Set-Cookie:$BBS{COOKIES}\nSet-Cookie:$BBS{COOKIE2}\n"; } } sub my_menu{ my($c, $d); for $c (COLOR,ICON,LINK,MAIL,NAME,OPTIM){ $BBS{$c} = $d if ($d = $form -> cell($c)) ne ''; } $BBS{LINK} = "" if $BBS{LINK} eq "http://"; $BBS{LINK} = "mailto:$BBS{LINK}" if $BBS{LINK} =~ /^[\w\-\.]+\@([\w\-]+\.)+[A-Z]{2,4}$/i; } sub replace{ my $c; &readform; $BBS{RESULT} .= "0,E_NO_METHOD\n" if $ENV{REQUEST_METHOD} ne "POST"; $BBS{RESULT} .= "0,E_NO_NAME\n" if $BBS{S_COOKIE} && !&MTX::strchk($BBS{NAME}); $BBS{RESULT} .= ($c = &$MAIL_KEYCHECK(0)) if $BBS{S_COOKIE}; $BBS{RESULT} && return; @BBS{C_CODE,C_DML,C_SORT,OPTIM,OPTIM1,OPTIM2,OPTIM3,OPTIM4} = $form -> cell(qw/c_code c_dml c_sort optim optim1 optim2 optim3 optim4/); $BBS{C_FMAIL} = ($form -> cell("c_fmail") ne '') ? " checked" : undef; $BBS{C_SYNC} = ($form -> cell("c_sync") && !$c) ? 1 : 0; $BBS{C_GZIP} = ($form -> cell("c_gzip") && !$c) ? 1 : 0; &presscookie; $BBS{RESULT} .= "0,OK_REPLACE\n"; } sub search{ return if $BBS{WORD} eq ''; my($c, $d, $e, @c, @d, @e, %d, $z); $d = join '', @PAGES; $e .= $THREAD{$1} while $d =~ /(\d+)/g; @e = split "\n", $e; %d = @d = (); if($BBS{WORD} =~ /^(\d+)$/ && $1 < 100){ # 未読検索(単純日数) $c = $1 + 1; while(--$c >= 0){ &datestr($^T - $c * 86400) =~ /^([^\s]+)/; $BBS{SEARCH_DATE} = $BBS{SEARCH_DATE} || $1; push @c, quotemeta $1; } $d = join "|", @c; map{ if($NOTES{$_} !~ /^STATUS:D/m){ $NOTES{$_} =~ /^DATE:($d)/mo && push(@d, $_) } } @e; }elsif($BBS{WORD} ne ''){ for $c (split /\x20+/, $BBS{WORD}){ push(@c, quotemeta $c) if $c ne ''; } map{ if($NOTES{$_} !~ /^STATUS:D/m){ $d = $e = undef; $d .= $2 while $NOTES{$_} =~ /^(NAME|SUBJECT|TEXT|DATE):(.*)/gm; for $c (@c){ $d =~ /$c/i && $e++; } push(@d, $_) if @c == $e; } } @e; } if($BBS{SEARCH_COUNT} = @d){ for $d (@d){ $d{int $d} .= "$d,"; } $BBS{SEARCH_RESULT} = join "\n", @d{&rsort(keys %d)}; $BBS{SEARCH_RESULT} =~ s/,$//gm; } } sub permutation{ my($c, $d, $e, $f, $g, $m); $BBS{RESULT} .= "0,E_NO_METHOD\n" if $ENV{REQUEST_METHOD} ne "POST"; $BBS{RESULT} .= "0,E_NO_ADMIN\n" unless $BBS{ADMIN_MODE}; $BBS{RESULT} && return; for $c (@id){ $e = 0; if(($d = $NOTES{$c}) && $d =~ /^SERIAL:(\d+)$/m){ $f = $g = $1; for(;;){ $f++; if($LOG =~ /^<((\d+\.)*\d+)>\nSERIAL:${f}$/m){ $m = quotemeta $1; next if ($d = $NOTES{$m}) && $d =~ /^STATUS:D/m; $LOG =~ s/^SERIAL:${f}$/SERIAL:----/m; $LOG =~ s/^SERIAL:${g}$/SERIAL:${f}/m; $LOG =~ s/^SERIAL:----$/SERIAL:${g}/m; $e++; } last; } } $BBS{RESULT} .= $e ? ($reflesh++, "$c,OK_PERM\n") : "$c,E_NO_PERM\n"; } } sub delete{ my($c, $d, $e, $m); $BBS{RESULT} .= "0,E_NO_METHOD\n" if $ENV{REQUEST_METHOD} ne "POST"; $BBS{RESULT} .= "0,E_NO_ADMIN\n" unless $BBS{ADMIN_MODE}; $BBS{RESULT} && return; for $c (@id){ $e = 0; $m = quotemeta $c; if(($d = $NOTES{$c}) && $d !~ /^STATUS:D/m){ $LOG =~ s/^<$m>((\n\w+:.*)*)/ $d = $&; if($d =~ s|\nSTATUS:([^\n]*)|\nSTATUS:DA_$^T,$1|){ $e++ }else{ $d .= "\nSTATUS:DA_$^T"; $e++; } $d; /em; } $BBS{RESULT} .= $e ? ($reflesh++, "$c,OK_DELETED\n") : "$c,E_NO_DELETED\n"; } } sub tree_move{ $BBS{RESULT} .= "0,E_NO_METHOD\n" if $ENV{REQUEST_METHOD} ne "POST"; $BBS{RESULT} .= "0,E_NO_ADMIN\n" unless $BBS{ADMIN_MODE}; $BBS{RESULT} && return; my($src, $dst, $m, $n, $tree, $chk, $tmp, $flg); $src = $form -> cell("src_tree"); $dst = $form -> cell("dst_tree"); $flg = $form -> cell("chk_tree"); $flg = undef if $src !~ /\./; $m = quotemeta $src; $n = quotemeta $dst; study $LOG; while($m ne $n && $LOG =~ s/\n<$m>\n.*\n<\/$m>\n/\n/s){ $tree = $&; if($LOG =~ /\n<$n>(\n.*)\n<\/$n>\n/s){ $tmp = $1; $chk = 0; $chk = $1 while $tmp =~ /\n<\/$n\.(\d+)>/g; $chk ++; $tree =~ s/(\n<\/?)$m(\.|>)/$1$dst\.$chk$2/g; $reflesh++ if $LOG =~ s/\n<\/$n>/$tree<\/$dst>/s; }else{ ($n) = $LOG =~ /^<(\d+)>/m; $dst = ++$n; $tree =~ s/(\n<\/?)$m(\.|>)/$1$n$2/g; $reflesh++ if $LOG =~ s/\n(<\d+>)/$tree$1/; } last unless($flg && $m =~ s/\.(\d+)$/".".($1 + 1)/e); } $BBS{RESULT} .= $reflesh ? "$src,OK_TREE_MOVED\n" : "$src,E_NO_TREE_MOVED\n"; } sub correct{ &readform; local $err; my($c, $d, $m, $n); $m = quotemeta($c = $BBS{ID}); $d = $NOTES{$c}; $BBS{RESULT} .= "$c,E_NO_METHOD\n" if $ENV{REQUEST_METHOD} ne "POST"; if(!$BBS{ADMIN_MODE} && $BBS{USER_CORRECT}){ $BBS{RESULT} .= &$MAIL_KEYCHECK(0); $n = "CU_$^T"; $d =~ /^MAIL:(.*)/m; $BBS{RESULT} .= "$c,E_ILG_OWNER\n" if $1 ne $BBS{MAIL}; $BBS{RESULT} .= "$c,E_ILG_ADMIN\n" if $d =~ /^STATUS:.A/m; }else{ $BBS{RESULT} .= "$c,E_NO_ADMIN\n" unless $BBS{ADMIN_MODE}; $n = "CA_$^T"; } $BBS{RESULT} && return; $LOG =~ s/\n<$m>((\n\w+:[^\n]*)*)/&correctsub($&, $c, $n)/e if $d && $d !~ /^STATUS:D/m; $BBS{RESULT} .= $err ? ($reflesh++, "$c,OK_CORRECT\n") : "$c,E_NO_CORRECT\n"; } sub correctsub{ my($s, $m, $n) = @_; my($c, $d, $f, $x, $y, $z, %x); my($name, $link, $mail, $text, $subj); $text = $form -> htmlcell("text"); $subj = $form -> cell("subject"); return $s if $form -> length("text") > $note_limit; return $s unless &MTX::strchk($BBS{NAME}); return $s if $BBS{MAIL} && $BBS{MAIL} !~ /^[\w\-\.]+\@([\w\-]+\.)+[A-Z]{2,4}$/is; return $s if length(join "", $subj, @BBS{LINK,MAIL,NAME}) > $line_limit; $f = $DML::ES{HEADLINE} || 40; if($BBS{POST_CHATMODE}){ $subj = &MTX::headline($subj, $f, "..."); return $s if($text.$subj eq ''); }else{ return $s unless &MTX::strchk($text); $subj = &MTX::headline($subj, $f, "...") || &MTX::headline($text, $f, "...") || "(none)"; } if($form -> def("file_remove")){ $BBS{RESULT} .= "$m,OK_FILE_REMOVE\n"; $err++; $s =~ s/\nfile:([^\n]*)//gis; }else{ if($form -> def("file") && ($x = &file_upload("file", $m))){ $s =~ s/\nfile:([^\n]*)//gis; $s .= $x; $err++; } } $s =~ s/\nSTATUS:([^\n]*)/$d = $1;undef/es; for $c (qw/NAME LINK MAIL COLOR SELECT ICON SYMBOL SUBJECT TEXT/){ $s =~ s/\n$c:[^\n]*/$x{$c} = $&;undef/es; } $x = "\nNAME:$BBS{NAME}"; $x .= "\nLINK:$BBS{LINK}" if $BBS{LINK}; $x .= "\nMAIL:$BBS{MAIL}" if $BBS{MAIL}; $x .= $BBS{ICON} eq '.' ? $x{ICON} : (($c = $icon_set -> getselset($BBS{ICON})) ? "\nICON:$c" : undef); $x .= $BBS{COLOR} eq '.' ? $x{COLOR} : (($c=$color_set ->getselset($BBS{COLOR}))? "\nCOLOR:$c": undef); $x .= $BBS{SELECT} eq '.' ? $x{SELECT}:(($c=$select_set->getselset($BBS{SELECT}))?"\nSELECT:$c":undef); $x .= $BBS{SYMBOL} eq '.' ? $x{SYMBOL}:(($c=$symbol_set->getselset($BBS{SYMBOL}))?"\nSYMBOL:$c":undef); $x .= "\nSUBJECT:$subj\nTEXT:$text"; if($x ne ($y = "$x{NAME}$x{LINK}$x{MAIL}$x{ICON}$x{COLOR}$x{SELECT}$x{SYMBOL}$x{SUBJECT}$x{TEXT}")){ $d = ",".$d if $d; $err++; $s . $x ."\nSTATUS:$n=" .&MTX::brenc($y, $x) .$d; }else{ $s . $x ."\nSTATUS:$d"; } } sub undo{ $BBS{RESULT} .= "0,E_NO_METHOD\n" if $ENV{REQUEST_METHOD} ne "POST"; $BBS{RESULT} .= "0,E_NO_ADMIN\n" unless $BBS{ADMIN_MODE}; $BBS{RESULT} && return; study $LOG; for $c (@id){ $e = 0; $m = quotemeta $c; ($d = $NOTES{$c}) || next; if($d =~ /^STATUS:D/m){ $LOG =~ s/\n<$m>((\n\w+:[^\n]*)*)/ $d = $&; $e++ if $d =~ s|\nSTATUS:D\w*,?([^\n]*)|$1 ? "\nSTATUS:$1" : ""|es; $d /es; }elsif($d =~ /^STATUS:\w+=/m){ $LOG =~ s/(\n<$m>)((\n\w+:[^\n]*)*)/$1.&undosub($2)/es; } $BBS{RESULT} .= $e ? ($reflesh++, "$c,OK_UNDO\n") : "$c,E_NO_UNDO\n"; } } sub undosub{ my($s) = @_; my($c, $d, $x, $y); my($name, $link, $mail, $text, $subj); $s =~ s/\nSTATUS:\w+=([^,\n]+),?([^\n]*)/$y = $1; $d = $2;undef/es; $d = "\nSTATUS:".$d if $d; for $c (qw/NAME LINK MAIL COLOR SELECT ICON SYMBOL SUBJECT TEXT/){ $s =~ s/\n$c:[^\n]*/$x .= $&;undef/es; } $e++; $s .&MTX::brdec($y, $x) .$d; } 1; __END__