package wpa2_str;
our $wpa2_dir = ".";
#設定部はここまで-----------------------------------------

=head1 NAME

Wpa2_str - wpa2の補助

=head2 wpa2について

wpa2に付属のREADME.txtより引用させていただきます。

I<WPA2は「汝は人狼なりや?」続わかめてサーバ
(L<http://jinrou.dip.jp/~jinrou/>)用の個人勝率集計ソフトウェアです。>

作成者は☆ ◆LC7P44pfbgさんです。L<http://www.geocities.jp/lc7p44pfbg/index.html>にて入手できるようです。

=head2 Perlについて

プログラミング言語のひとつです。詳細は L<http://www.perl.com/>
もしくは L<http://ja.wikipedia.org/wiki/Perl> を参考にしてください。

=head1 概要

use Wpa2_str;

#活用例
$wpa2_dir='.'; #wpa2のディレクトリを設定
input_wpa2(); #デフォルトフォルダからwpa2データをメモリに入力
change_memory(); #メモリの内容を退避メモリのものと交換
input_wpa2('./ivd-1-43342'); #指定フォルダからwpa2データをメモリに入力
merge_memory(); #退避メモリの内容をメモリのものに加える
print_wpa2('./index_village_data_new'); #指定フォルダにwpa2形式でメモリの内容を出力

#コマンドラインから例えば…。

prompt% perl -Mwpa2_str -e "input_wpa2('index_village_data_new');change_memory();load_str('ivd-1-43451.str');merge_memory();print_wpa2();save_str('ivd-1-43472.str');"

prompt% perl -Mwpa2_str -e "load_str('ivd-1-43451.str');pickup_handle('^初日犠牲者$');print_wpa2();"

#その他
save_str('./1-43420.str'); #指定ファイルにstr形式でメモリの内容を保存
load_str('./1-43420.str'); #str形式の指定ファイルをメモリに読込
backup_memory(); #メモリの内容を退避メモリにコピー
Wpa2_str::help(); #このヘルプを表示…たぶん
Wpa2_str::print_time('now...'); #時刻表示

=head1 説明

wpa2の補助用Perlモジュールです。
活用例では2つのwpa2データをまとめています。

=over

=item $wpa2_dir

wpa2があるフォルダを指定します。デフォルト値は.です。

=cut
our ($start_time);
BEGIN{
our ($start_time) = (times)[0];
}
use strict;
use warnings;
use Storable qw(nstore_fd fd_retrieve);
use List::Util qw(max);
use Data::Dumper;
use Exporter ();
use Clone qw(clone);
our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
@ISA = qw(Exporter);
@EXPORT = qw(input_wpa2 print_wpa2 load_str save_str change_memory backup_memory merge_memory pickup_handle $wpa2_dir);
@EXPORT_OK = qw(help print_time version);
$VERSION = '1.12';
our %fn = (
'cfg' => 'wpa_configure.txt',
'pl' => 'wpa_players.txt',
'plr' => 'wpa_players_rev.txt',
'tt' => 'wpa_titles.txt',
'idx' => 'wpa_index.txt',
'vt' => 'wpa_votes.txt',
'cmd' => 'wpa_commands.txt',
'ivd' => 'index_village_data',
'str' => 'ivd.str'
);
$fn{'ivd'} = "$wpa2_dir/$fn{'ivd'}";
our ($id_m, $plr_m, $ivd_m, $id, $plr, $ivd, %change);

=pod

=item input_wpa2([dir])

dirをindex_village_dataフォルダとみなして中のwpa_~.txtファイルの内容をメモリに入力します。dirのデフォルト値は$wpa2_dir/index_village_dataです。

=cut

sub input_wpa2{
my($ivd_dir) = defined $_[0] ? $_[0] : $fn{ivd};
my($key);
for$key('pl','plr','tt','idx','vt','cmd'){
my ($fn) = "$ivd_dir/$fn{$key}";
&print_time("input wpa2-type $fn");
open F, "<$fn" or die "cannot open $fn";
scalar <F>;
if($key eq 'pl'){
&input_pl;
}elsif($key eq 'plr'){
&input_plr;
}else{
&input_ivd($key);
}
close F;
}
}

sub input_pl{
until(eof F){
(scalar <F>) =~ /^(.+)\t(.*)$/;
$id->{$2} = $1;
}
}

sub input_plr{
my ($f);
until(eof F){
$f = <F>;
$f =~ /^([^\t]+)\t(.*)$/;
$plr->[$1] = $2;
}
}

sub input_ivd{
my($key, $f, $v, $k) = $_[0];
my %tmp;
until(eof F){
$f = <F>;
$f =~ /^([^\t]+)\t(.*)$/;
push @{$tmp{$1}}, $2;
}
while(($k, $v) = each %tmp){
$ivd->{$k}->{$key} = $v;
}
}

=pod

=item print_wpa2([dir])

input_wpa2と逆の働きをします。

=cut

sub print_wpa2{
my($ivd_dir) = defined $_[0] ? $_[0] : $fn{ivd};
my @ivd = sort {$b <=> $a} keys %{$ivd};
my($key);
for$key('pl','plr','tt','idx','vt','cmd'){
my ($fn) = "$ivd_dir/$fn{$key}";
&print_time("print wpa2-type $fn");
open F, ">$fn" or die "cannot open $fn";
print F "version\t2.0\n";
if($key eq 'pl'){
&print_pl;
}elsif($key eq 'plr'){
&print_plr;
}else{
&print_ivd($key, \@ivd);
}
close F;
}
}

sub print_pl{
my($n);
foreach$n(sort {$id->{$a} <=> $id->{$b}} keys %{$id}){
print F "$id->{$n}\t$n\n";
}
}

sub print_plr{
my $max = $#{$plr};
my($i);
for($i=0; $i<=$max; $i++){
print F "$i\t$plr->[$i]\n" if defined $plr->[$i];
}
}

sub print_ivd{
my($k, $a_ivd, $i, $tmp, $line) = @_;
foreach$i(@{$a_ivd}){
$tmp = $ivd->{$i}->{$k};
for$line(@{$tmp}){
print F "$i\t$line\n";
}
}
}

=pod

=item load_str([file])

str形式のfileをメモリに読み込みます。str形式の利点はstorableモジュールがもたらす高速性であり、特に読み込み時にはその特色が顕著に現れることでしょう。fileのデフォルト値はivd.strです。

=cut

sub load_str{
my($fn) = defined $_[0] ? $_[0] : $fn{'str'};
&print_time("load str-type $fn");
open G, "<$fn" or die "cannot open $fn";
my($version) = fd_retrieve(\*G);
load_str_1() if $$version == 1;
close G;
}

sub load_str_1{
$id = fd_retrieve(\*G);
$plr = fd_retrieve(\*G);
$ivd = fd_retrieve(\*G);
}

=pod

=item save_str([file])

load_strと逆の働きをします。

=cut

sub save_str{
my($fn) = defined $_[0] ? $_[0] : $fn{'str'};
my($version) = '1';
&print_time("save str-type $fn");
open G, ">$fn" or die "cannot open $fn";
nstore_fd \$version, \*G;
nstore_fd $id, \*G;
nstore_fd $plr, \*G;
nstore_fd $ivd, \*G;
close G;
}

=pod

=item merge_memory()

退避用メモリの内容をメモリのものに加えます。先に小さいデータを読み込んでからchange_memoryを呼び出し、そして大きなデーターを読み込んだらmerge_memoryを呼んでください。退避用メモリの内容は破壊されます。


=cut

sub merge_memory{
&print_time("merge...");
&merge_new_id;
&merge_ivd;
}

sub merge_ivd{
print_time("merge: player's id in all data changing...");
my ($k, $line, @tmp);
foreach$k(keys %{$ivd_m}){
next if exists $ivd->{$k};
$ivd->{$k} = $ivd_m->{$k};
foreach$line(@{$ivd->{$k}->{idx}}){
# next unless exists $change{0+$line};
@tmp = split /\t/, $line;
$tmp[0] = $change{$tmp[0]};
$line = join "\t", @tmp;
}
}
}

sub merge_new_id{
&print_time("merge: new player's id computing...");
my ($new_id, $k, $v, $c, $n);
$new_id = (max values %{$id}) + 1;
foreach$k(keys %{$id_m}){
unless(exists $id->{$k}){
$id->{$k} = $new_id;
$new_id++;
}
$v = $id_m->{$k};
$c = $change{$v} = $id->{$k};
if(defined $plr->[$c]){
# print "/$plr->[$c]\n+$plr_m->[$v]\n" if $c;
$plr->[$c] = join "\t", $plr->[$c], (grep{
$plr->[$c] !~ /^$_(?!\d)/
and
$plr->[$c] !~ /\t$_(?!\d)/
}(split /\t/, $plr_m->[$v]));
# print "=$plr->[$c]\n\n" if $c;
}else{
$plr->[$c] = $plr_m->[$v];
}
# &print_time("$k");
}
}

=pod

=item change_memory()

メモリの内容と退避用メモリのものを交換します。主にmerge_memory関数のために呼び出されることでしょう。ちなみに退避用メモリにアクセスするのは*_memory関数だけです。

=cut

sub change_memory{
($id_m, $plr_m, $ivd_m, $id, $plr, $ivd) = ($id, $plr, $ivd, $id_m, $plr_m, $ivd_m);
}

=pod

=item backup_memory()

メモリの内容を退避用メモリにコピーします。

=cut

sub backup_memory{
($id_m, $plr_m, $ivd_m) = (clone($id), clone($plr), clone($ivd));
}


=pod

=item pickup_handle(handle pattern)

メモリ内容をハンドルパターンに合致するプレイヤー専用のものに絞ります。パターンはPerlの正規表現です。

=cut

sub pickup_handle{
my ($pattern) = (@_);
my ($k, %id_list, %v, %id_del);
print_time("pickup: player search...");
foreach$k(keys %{$id}){
if($k =~ /$pattern/o){
$id_list{$id->{$k}}=1;
print_time("find! $k");
}else{
# $plr->[$id->{$k}] = '';
}
}
print_time("pickup: village number search...");
foreach$k(keys %id_list){
foreach(split/\t/,$plr->[$k]){$v{$_}++;}
}
foreach$k(keys %{$ivd}){
delete $ivd->{$k} unless defined $v{$k};
}
foreach$k(0..$#{$plr}){
my $tmp = 0;
foreach(split/\t/, $plr->[$k]){
if(defined $v{$_}){
$tmp = 1;
last;
}
}
unless($tmp){
undef $plr->[$k];
$id_del{$k} = 1;
}
}
foreach$k(keys %{$id}){
if(defined $id_del{$id->{$k}}){
$plr->[$id->{$k}] = undef;
delete $id->{$k};
}else{
# print "$k\n" if $id_list{$id->{$k}};
next if $id_list{$id->{$k}};
$plr->[$id->{$k}] = join"\t" ,
grep{defined $v{$_}}
split /\t/,
$plr->[$id->{$k}];
}
}
}

=pod

=item help()

このモジュールのPODを表示する…はず。

=cut

sub help{
system 'perldoc', 'wpa2_str.pm';
}

=pod

=item print_time()

時間や時刻を表示します。表示形式は変更する可能性があります。

=cut

sub print_time{
printf STDERR "%2d:%02d:%02d#%.2fs#$_[0]\n", reverse ((times)[0], (localtime)[0..2]);
}

sub END{
print_time("end...");
}
return 1;
__END__

=pod

=back


=head1 お断り

使用は自己責任でよろしくお願いします。

=head1 将来の展望

wpa2_ppの機能を取り入れたい
良いスクリプトアップロード場所を見つけたい
PODの書き方をなんとかしたい
ログ出力先のコントロール関数追加
メモリの内容を絞り込む機能追加
wpa2.exeを呼び出せるように

=head1 履歴

=over

=item v1.12 2008/06/09 pickup_handleにwpa_players_rev.txtを絞る機能を加える

=item v1.11 2008/06/04 merge_new_id関数の高速化、List::MoreUtilsモジュールの不要化

=item v1.10 2008/06/04 pickup_handleの新設

=item v1.00 2008/05/30

=back

=head1 謝辞

wpa2の作成者☆ ◆LC7P44pfbgさん
続わかめて運営者のココアさん
ココアさんなどを支えるサブ運営者のみなさん
出会えたプレイヤーのみなさん

ありがとうございます。

=head1 連絡

2chの汝は人狼なりや関係スレッドにてwpa2_strの名前を出していただければ
検索で気づけるかも…です。

=cut

#wpa2_str---------------------------------------------end/
__END__
pod2html wpa2_str.pm --outfile wpa2_str.htm
最終更新:2008年06月09日 13:18