■ ボード一覧更新情報3

**まほら ★** · 2007/04/16(月) 08:05:04

このスレは2chボード一覧の更新に関する情報を扱います。
ボード一覧：http://menu.2ch.net/bbsmenu.html

また、一覧上のカテゴリの再編もここで検討を行います。
ただしbbspinkは除外、秘密基地で別途(ry。

発端および検討内容は以下をご覧ください。
質問・雑談スレ62＠運用情報板
http://qb5.2ch.net/operate/kako/1092/10927/1092708821.html（381-398）

前スレ
http://qb5.2ch.net/test/read.cgi/operate/1116229949/

**ひよこパーラー** · 2007/05/16(水) 18:34:12

### 設定
# 更新する掲示板一覧のファイル名・パス
@file = ('bbstable.html', 'bbsmenu.html');
#@file = ('faq.html', 'map.html', 'adv.html');
# バックアップの拡張子
$old = 'old';

### GETなら全て初期画面表示
if ( $ENV{'REQUEST_METHOD'} eq 'GET'){
print <<"owari";
Content-Type: text/html; charset=Shift_JIS

<html lang="ja">
<head>
<meta http-equiv="Content-Type" content="text/html; charset=Shift_JIS">
<title>掲示板一覧の更新</title>
</head>
<body>
<h1>掲示板一覧の更新</h1>
<p>指定された掲示板の移転を検出して、掲示板一覧を更新します。<br>
移転した板の<b>移転前の</b>URLを、1行に1つずつ書いてください。</p>
<p>対象ファイル：
owari
foreach ( @file ) { print " $_"}
print <<"owari";
</p>
<form method="POST" action="$ENV{'SCRIPT_NAME'}">
<textarea name="ita" cols="50" rows="20"></textarea><br>
<input type="submit" value="送信">
</form>
</body>
</html>
owari
exit;
}

print "Content-Type: text/plain; charset=Shift_JIS\n\n";
### 入力情報をもらう
# POSTだけ。GETは全て初期画面だから
$ENV{'CONTENT_LENGTH'} > 2048 and &end('でかい');
read(STDIN, $query, $ENV{'CONTENT_LENGTH'});
# デコ
foreach ( split(/&/, $query) ) {
my ($name, $value) = split(/=/);
$value =~ tr/+//d;
$value =~ s/%([0-9a-fA-F][0-9a-fA-F])/pack("C", hex($1))/eg;
$FORM{$name} = $value;
}
# 無い
$FORM{'ita'} or &end('入力して');

**動け動けウゴウゴ２ちゃんねる** · 2007/05/16(水) 18:35:21

### 入力内容を確認
@ita = split(/\r\n|\r|\n/, $FORM{'ita'});
foreach $ita ( @ita ) {
$ita !~ /^http:\/\/(?!www|info|headline|find|epg|movie)\w+\.(?:2ch\.net|bbspink\.com)\/\w+\/$/
and &end('板URLだけ書いて');
my $aru = 0;
foreach $data ( @filedata ) { $aru = grep(/\Q$ita/, @{$$data[1]}) and last; }
$aru or &end("$itaは板一覧に無い");
}
# ここまでで @ita は板一覧に載っている板URLだけだと確認された

### 移転先を探す
foreach $ita ( @ita ) {
print "$ita -> ";
my $res = &get($ita);
# GET失敗
unless ( $res->is_success ) {
print $res->status_line, "\n";
next;
}
# でかい
if ( $res->header('Content-Length') > 512 ){
print 'Content-Length: ',
$res->header('Content-Length'),
" たぶん現役\n";
next;
}
# 板URLを探す
my $iten;
my ($dom, $bbs) = $ita =~ m|^http://(\w+\.)(.+)$|;
if ( ($iten) = $res->content =~ m|(http://(?!\Q$dom\E)\w+\.\Q$bbs\E)| ) {
print "$iten @";
# 板一覧を変換
foreach $data ( @filedata ) {
if ( grep(s/\Q$ita/$iten/g, @{$$data[1]}) ) {
$$data[2] = 1;
print " $$data[0]";
}
}
print "\n";
# 移転先っぽいURLが無い
} else {
print "移転先不明\n";
next;
}
}

**ひよこパーラー** · 2007/05/16(水) 18:37:17

### ファイル更新
foreach $data ( @filedata ) {
if ( $$data[2] ) {
# バックアップ
print "unlink $$data[0].$old",
unlink("$$data[0].$old") ? "" : " 失敗", "\n",
"rename $$data[0] -> $$data[0].$old",
rename($$data[0], "$$data[0].$old") ? "" : " 失敗", "\n",
# ファイル保存
"open >$$data[0]",
open(FILE, ">$$data[0]") ? "" : " 失敗", "\n";
print FILE @{$$data[1]};
close FILE;
}
}

print 'おわり';
exit;

### 結果出力
sub end {
print @_;
exit;
}

### GET
use LWP::UserAgent;
sub get {
my $uri = $_[0];
my $ua = LWP::UserAgent->new;
$ua->timeout(5);
$ua->agent("$ENV{'SERVER_NAME'}$ENV{'SCRIPT_NAME'} ($ENV{'REMOTE_ADDR'})");
my $req = HTTP::Request->new(GET, $uri);
return $ua->simple_request($req);
}