diff -urN tiarra-20030731/ChangeLog tiarra-20030804/ChangeLog --- tiarra-20030731/ChangeLog 2003-07-31 18:29:13.000000000 +0900 +++ tiarra-20030804/ChangeLog 2003-08-06 10:12:36.000000000 +0900 @@ -1,3 +1,33 @@ +2003-08-04 phonohawk + + * makedoc: + 追加。このスクリプトはdoc-src下のファイルとmodule下のモジュール、 + main下のモジュールを読み、tdoc形式で書かれたドキュメントを認識し、 + sample.confおよびdoc下のhtmlドキュメントを生成する。 + tdocについてはdoc-src/READMEを参照。 + 尚、各モジュールへのtdocの記述が完了していない為、 + 完全なsample.confは生成出来ない。完了するまではsample.confでなく + sample.conf.tmpに書き出す。 + + * doc-src/README: 追加。tdocについての説明。 + + * doc-src/conf-main.tdoc: 追加。generalやnetworksのドキュメント。 + + * doc-src/contents.html: 追加。htmlドキュメントのテンプレート。 + + * doc-src/module-group.tdoc: 追加。モジュールの分類情報。 + + * doc-src/module-toc.html: 追加。モジュールの目次のhtmlテンプレート。 + + * doc-src/sample.conf.in: 追加。sample.confのテンプレート。 + + * main/Template.pm: 追加。テンプレートを扱うクラス。 + + * main/TiarraDoc.pm: 追加。tdocパーサ。 + + * module/System/PrivTranslator.pm + * module/User/Ignore.pm: tdoc追加。 + 2003-07-31 Topia * 全般: @@ -750,7 +780,7 @@ * これ以前のログは書いていません。 -# Id: $Id: ChangeLog,v 1.95 2003/07/31 07:34:12 topia Exp $ -# Author: $Author: topia $ -# Date: $Date: 2003/07/31 07:34:12 $ -# Revision: $Revision: 1.95 $ +# Id: $Id: ChangeLog,v 1.96 2003/08/04 09:29:21 admin Exp $ +# Author: $Author: admin $ +# Date: $Date: 2003/08/04 09:29:21 $ +# Revision: $Revision: 1.96 $ diff -urN tiarra-20030731/main/Template.pm tiarra-20030804/main/Template.pm --- tiarra-20030731/main/Template.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20030804/main/Template.pm 2003-08-06 10:12:36.000000000 +0900 @@ -0,0 +1,185 @@ +# ----------------------------------------------------------------------------- +# $Id: Template.pm,v 1.1 2003/08/04 09:29:20 admin Exp $ +# ----------------------------------------------------------------------------- +package Template; +use strict; +use warnings; +use Unicode::Japanese; +use Symbol; +use Carp; +use UNIVERSAL; +our $AUTOLOAD; + +sub new { + # $fpath: テンプレートとして使用するファイル + # $strip_empty_line (省略可能): やの直後の改行を削除するかどうか。 + my ($class,$fpath,$strip_empty_line) = @_; + my $this = { + original => undef, # リーフをに置換した中身。 + current => undef, # <&foo>を置換した後のもの。 + leaves => {}, # {名前 => Template} + parent => undef, # これがトップレベルでなければ、親(Template)。 + leafname => undef, # これがトップレベルでなければ、リーフ名。 + }; + bless $this,$class; + + local $/ = undef; + my $fh = gensym; + open($fh,'<',$fpath) or croak "couldn't open file $fpath"; + my $source = <$fh>; + close($fh); + ungensym($fh); + + # やの直後が改行コードなら、それを消す。 + # その改行コードから始まるスペースまたはタブも、インデントと見做して消す。 + if ($strip_empty_line) { + $source =~ s/(|)\x0d?\x0a[ \t]*/$1/g; + } + + $this->_load($source); + $this; +} + +sub reset { + my $this = shift; + $this->{current} = $this->{original}; + $this; +} + +sub expand { + # $t->expand({foo => '---' , bar => '+++'}); + # もしくは + # $t->expand(foo => '---' , bar => '+++'); + + # このメソッドは、キー内に現われたアンダースコアを + # ハイフンにフォールバックする事が出来ます。 + # つまり、<&foo-bar>というタグを、キー名"foo_bar"で指定する事が出来ます。 + my $this = shift; + my $hash = do { + if (@_ == 1 && UNIVERSAL::isa($_[0],'HASH')) { + $_[0]; + } + elsif (@_ % 2 == 0) { + my %h = @_; + \%h; + } + else { + croak "Illegal argument for Template->expand"; + } + }; + while (my ($key,$value) = each %$hash) { + # $key,$value共にスカラー値でなければならない。 + # リファならエラー。 + if (!defined $value) { + croak "Values must not be undef; key: $key"; + } + if (ref($key) ne '') { + croak "Keys and values must be scalar values: $key"; + } + if (ref($value) ne '') { + croak "Keys and values must be scalar values: $value"; + } + + if ($this->{current} !~ s/<\&\Q$key\E>/$value/g) { + # 無い。アンダースコアをハイフンに変えてみる。 + (my $tred_key = $key) =~ tr/_/-/; + if ($this->{current} !~ s/<\&\Q$tred_key\E>/$value/g) { + # そのようなキーは存在しなかった。警告。 + carp "No <\&$key> are in template, or you have replaced it already."; + } + } + } + $this; +} + +sub add { + my $this = shift; + + # 引数があればexpandする。 + if (@_ > 0) { + eval { + $this->expand(@_); + }; if ($@) { + croak $@; + } + } + + # 親が存在しなければcroak。 + if (!defined $this->{parent}) { + croak "This template doesn't have its parent."; + } + + # 親のの直前に、このリーフを挿入。 + my $str = $this->str; + $this->{parent}{current} =~ s/({leafname}\E>)/$str$1/g; + + # リセット + $this->reset; + + $this; +} + +sub str { + my $this = shift; + my $result = $this->{current}; + + # 未置換の<&foo>があればそれを消してcarp。 + while ($result =~ s/<\&(.+?)>//) { + carp "Unexpanded tag: <\&$1>"; + } + + # を消す。 + $result =~ s///g; + + $result; +} + +sub leaf { + my ($this,$leafname) = @_; + $this->{leaves}{$leafname}; +} + +sub AUTOLOAD { + my $this = shift; + (my $leafname = $AUTOLOAD) =~ s/.+?:://g; + + # アンダースコアはハイフンに置換。 + $leafname =~ tr/_/-/; + $this->{leaves}{$leafname}; +} + +sub _new_leaf { + my ($class,$parent,$leafname,$source) = @_; + my $this = { + original => undef, + current => undef, + leaves => {}, + parent => $parent, + leafname => $leafname, + }; + bless $this,$class; + + $this->_load($source); +} + +sub _load { + my ($this,$source) = @_; + + # ... をに置換しつつ、そのリーフを保存。 + while ($source =~ s/(.+?)//s) { + my ($leafname,$source) = ($1,$2); + + if (defined $this->{leaves}{$leafname}) { + # 既にこのリーフが定義されていたらcroak。 + croak "duplicated leaves in template: $leafname"; + } + else { + $this->{leaves}{$leafname} = Template->_new_leaf($this,$leafname,$source); + } + } + $this->{original} = $this->{current} = $source; + + $this; +} + +1; diff -urN tiarra-20030731/main/TiarraDoc.pm tiarra-20030804/main/TiarraDoc.pm --- tiarra-20030731/main/TiarraDoc.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20030804/main/TiarraDoc.pm 2003-08-06 10:12:37.000000000 +0900 @@ -0,0 +1,388 @@ +# ------------------------------------------------------------------------ +# $Id: TiarraDoc.pm,v 1.1 2003/08/04 09:29:20 admin Exp $ +# ------------------------------------------------------------------------ +# tiarra-docのパーサとトランスレータ群。 +# ------------------------------------------------------------------------ +use strict; +use warnings; +use Unicode::Japanese; +use IO::File; + +package DocParser; +use Carp; + +sub new { + my ($class,$fpath) = @_; + my $this = { + fpath => $fpath, + + docs => undef, # {パッケージ名 => DocPod} + }; + bless $this,$class; +} + +sub makeconf { + # confのブロックを生成する。 + # 戻り値: ([ブロック名,info,ブロック(文字列)],...) + # スカラーコンテクストで呼ぶとcroak。 + croak "You can't call DocParser->makeconf directly."; +} + +sub makehtml { + croak "You can't call DocParser->makehtml directly."; +} + +sub getdoc { + # パッケージ名を省略すると、要素が一つであればそれを返し、 + # 複数あればcroakする。一つも無ければundefを返す。 + my ($this,$pkg_name) = @_; + + if (!defined $this->{docs}) { + $this->{docs} = {}; + my @dummy = $this->_parse_docpod; + } + + if (defined $pkg_name) { + $this->{docs}{$pkg_name}; + } + else { + my @keys = keys %{$this->{docs}}; + if (@keys == 0) { + undef; + } + elsif (@keys == 1) { + $this->{docs}{$keys[0]}; + } + else { + croak "You can't ommit \$pkg_name if there's multiple poddocs."; + } + } +} + +sub _parse_docpod { + # tiarraドキュメント形式のpodを探してヘッダをパースして返す。 + # 同一パッケージにドキュメントが二つ以上あったらdie。 + # スカラーコンテクストで呼ばれたらcroak。 + # 戻り値の形式: (DocPod,DocPod,...) + croak "Don't call DocParser->_parse_docpod in scalar context." if !wantarray; + my $this = shift; + my @pods = $this->_parse_pod; + my $header_re = qr/^\s*(.+?)\s*:\s*(.+)$/; + + my @result; + my $new_doc = sub { + my ($pkg_name,$header,$remaining) = @_; + # 既にこのパッケージのドキュメントが用意されていないか？ + foreach (@result) { + if ($_->pkg_name eq $pkg_name) { + die "$pkg_name has multiple documents.\n"; + } + } + + my $docpod = DocPod->new($pkg_name,$header,$remaining); + push @result,$docpod; + $this->{docs}{$pkg_name} = $docpod; + }; + + foreach my $pod (@pods) { + my @lines = split /\x0a/,$pod->[1]; + if (@lines == 0) { + next; # これはドキュメントでない。 + } + elsif ($lines[0] =~ m/$header_re/) { + # ヘッダの終わりまでをパースする。 + my $header = {}; + my $remaining_start = @lines; + foreach (my $i = 0; $i < @lines; $i++) { + if ($lines[$i] =~ m/$header_re/) { + $header->{$1} = $2; + } + else { + # ここでヘッダ終わり。 + $remaining_start = $i; + last; + } + } + + # 全ての行について、先頭と末尾の空白を消去する。 + (my $remaining = join "\n",map { + s/^\s*|\s*$//g; + $_; + } @lines[$remaining_start .. (@lines-1)]) =~ s/^\s*|\s*$//g; + $new_doc->($pod->[0],$header,$remaining); + } + } + + @result; +} + +sub _parse_pod { + # =podと=cutに囲まれた範囲を返す。 + # 戻り値: ([パッケージ名,pod範囲],[パッケージ名,pod範囲],...) + # スカラーコンテクストで呼ばれたらcroak。 + croak "Don't call DocParser->_parse_pod in scalar context." if !wantarray; + my $this = shift; + my @lines = split /\x0d?\x0a/,$this->_get_content; + + my @result; + my $search_start_pos = 0; + my $pkg_name; + while (1) { + # =podを探す + my $found_pod_line; + for (my $i = $search_start_pos; $i < @lines; $i++) { + if ($lines[$i] =~ m/^\s*=pod\s*$/) { + $found_pod_line = $i; + last; + } + elsif ($lines[$i] =~ m/\s*package\s+(.+?);/) { + $pkg_name = $1; + } + } + + if (defined $found_pod_line) { + # あった。次は=cutを探す。 + my $found_cut_line; + for (my $i = $found_pod_line+1; $i < @lines; $i++) { + if ($lines[$i] =~ m/^\s*=cut\s*$/) { + $found_cut_line = $i; + last; + } + } + if (defined $found_cut_line) { + # あった。ここまで=pod & =cut。 + push @result,[ + $pkg_name, + join("\n",@lines[$found_pod_line+1 .. $found_cut_line-1]) + ]; + $search_start_pos = $found_cut_line+1; + } + else { + # 無い。エラー。 + die "$this->{fpath} has unbalanced =pod and =cut\n"; + } + } + else { + # 無い。ここで終わり。 + last; + } + } + + @result; +} + +sub _get_content { + # ファイルの中身をutf8で返す。 + my $this = shift; + + my $fh = IO::File->new($this->{fpath},'r'); + if (!defined $fh) { + die "Couldn't open file $this->{fpath}.\n"; + } + local $/ = undef; + my $content = <$fh>; + $fh->close; + + my $code = $this->_getcode($content); + if ($code eq 'unknown') { + die "Couldn't determine the charset of $this->{fpath}.\n"; + } + + Unicode::Japanese->new($content,$code)->utf8; +} + +sub _getcode { + # 文字コードを判別する。 + my ($this,$content) = @_; + my $unijp = Unicode::Japanese->new; + + if ((my $code = $unijp->getcode($content)) ne 'unknown') { + # 判別できたら、これを返す。 + $code; + } + else { + # それぞれの行についてgetcodeを実行し、多数決を取る。 + my $total_for_each = {}; + foreach (split /[\r\n]/,$content) { + if ((my $c = $unijp->getcode($_)) ne 'unknown') { + $total_for_each->{$c} = ($total_for_each->{$c} || 0) + 1; + } + } + + my @rank = sort { + $b <=> $a; + } values %$total_for_each; + if (@rank == 0) { + # 全部unknownだった! + # 仕方無いのでunknownを返す。 + 'unknown'; + } + elsif (@rank == 1) { + # 候補が一つだけ。これを返す。 + $rank[0]; + } + else { + # 候補のトップがasciiだったら、二番目のものを返す。 + # そうでなければトップを返す。 + if ($rank[0] eq 'ascii') { + $rank[1]; + } + else { + $rank[0]; + } + } + } +} + +package DocParser::Module; +use base qw/DocParser/; +use Carp; + +sub new { + my $class = shift; + $class->SUPER::new(@_); +} + +sub makeconf { + my $this = shift; + my $indent_level = shift || 2; + croak "Don't call DocParser->makeconf in scalar context." if !wantarray; + + map { + my $pod = $_; + my $conf = eval { + $this->_makeconf($pod,$indent_level); + }; if ($@) { + die $pod->pkg_name.": $@"; + } + [$pod->pkg_name,$pod->header->{info},$conf]; + } $this->_parse_docpod; +} + +sub _makeconf { + my ($this,$pod,$indent_level) = @_; + my $result = ''; + + # defaultヘッダに応じて+か-かを設定する。 + # 但しno-switchが定義されていて真であれば、それをしない。 + if ($pod->header->{'no-switch'}) { + $result .= $pod->pkg_name." {\n"; + } + else { + my $enabled = $pod->header->{default}; + if (defined $enabled) { + my $switch = {on => '+' , off => '-'}->{$enabled}; + if (defined $switch) { + $result .= $switch; + } + else { + die "Its `default' header is invalid: $enabled\n"; + } + } + else { + die "It doesn't have `default' header.\n"; + } + $result .= ' '.$pod->pkg_name." {\n"; + } + + + # infoヘッダの内容を出力。無ければエラー。 + # ただしinfo-is-omittedが定義されていて真であれば出力しない。 + my $indent = ' ' x $indent_level; + my $info = $pod->header->{info}; + if (defined $info) { + if (!$pod->header->{'info-is-omitted'}) { + $result .= "$indent# $info\n\n"; + } + } + else { + die "It doesn't have `info' header.\n"; + } + + # ルール: + # '#'で始まる行はそのまま出力。 + # 空行もそのまま出力。 + # key:value形式になっている部分もそのまま出力するが、 + # そのkeyの頭に'-'が付いていたら、それをコメントアウト。 + my @lines = split /\n/,$pod->content; + for (my $i = 0; $i < @lines; $i++) { + my $line = $lines[$i]; + + my $error = sub { + my $errstr = shift; + + # 前後5行と共にエラー行を示す。 + my $region_lines = 5; + my $begin = $i - $region_lines; + if ($begin < 0) { + $begin = 0; + } + my $end = $i + $region_lines; + if ($end >= @lines) { + $end = @lines-1; + } + my $list = join '',map { + if ($_ == $i) { + "=> |$lines[$_]\n"; + } + else { + " |$lines[$_]\n"; + } + } ($begin .. $end); + + die "$errstr\n$list"; + }; + + $result .= $indent . do { + if ($line eq '') { + ''; + } + elsif ($line =~ m/^\s*#/) { + (my $stripped = $line) =~ s/^\s*//; + $stripped; + } + elsif ($line =~ m/^(.+?)\s*:\s*(.+)$/) { + my ($key,$value) = ($1,$2); + if ($key =~ s/^-//) { + "#$key: $value"; + } + else { + "$key: $value"; + } + } + else { + $error->('illegal line'); + } + } . "\n"; + } + + $result . '}'; +} + +package DocPod; +our $AUTOLOAD; + +sub new { + my ($class,$pkg_name,$header,$content) = @_; + my $this = { + pkg_name => $pkg_name, + header => $header, + content => $content, + }; + bless $this,$class; +} + +sub AUTOLOAD { + my ($this,$arg) = @_; + (my $key = $AUTOLOAD) =~ s/.+?:://g; + + my $val = $this->{$key}; + if (defined $arg && ref($val) eq 'HASH') { + $val->{$arg}; + } + else { + $val; + } +} + +1; diff -urN tiarra-20030731/module/System/PrivTranslator.pm tiarra-20030804/module/System/PrivTranslator.pm --- tiarra-20030731/module/System/PrivTranslator.pm 2003-07-31 18:29:15.000000000 +0900 +++ tiarra-20030804/module/System/PrivTranslator.pm 2003-08-06 10:12:38.000000000 +0900 @@ -1,5 +1,5 @@ # ----------------------------------------------------------------------------- -# $Id: PrivTranslator.pm,v 1.1 2003/01/28 09:16:33 admin Exp $ +# $Id: PrivTranslator.pm,v 1.2 2003/08/04 09:29:20 admin Exp $ # ----------------------------------------------------------------------------- package System::PrivTranslator; use strict; @@ -24,3 +24,10 @@ } 1; +=pod +info: クライアントからの個人的なprivが相手に届かなくなる現象を回避する。 +default: off + +# このモジュールは個人宛てのprivmsgの送信者のnickにネットワーク名を付加します。 +# 設定項目はありません。 +=cut diff -urN tiarra-20030731/module/User/Ignore.pm tiarra-20030804/module/User/Ignore.pm --- tiarra-20030731/module/User/Ignore.pm 2003-07-31 18:29:15.000000000 +0900 +++ tiarra-20030804/module/User/Ignore.pm 2003-08-06 10:12:38.000000000 +0900 @@ -1,5 +1,5 @@ # ----------------------------------------------------------------------------- -# $Id: Ignore.pm,v 1.2 2003/01/21 09:07:14 admin Exp $ +# $Id: Ignore.pm,v 1.3 2003/08/04 09:29:20 admin Exp $ # ----------------------------------------------------------------------------- package User::Ignore; use strict; @@ -29,3 +29,14 @@ } 1; +=pod +info: 指定された人間からのPRIVMSGやNOTICEを破棄してクライアントへ送らないようにするモジュール。 +default: off + +# 対象となるコマンドのマスク。省略時には"privmsg,notice"が設定されている。 +# ただしprivmsgとnotice以外を破棄してしまうと、(Tiarraは平気でも)クライアントが混乱する。 +command: privmsg,notice + +# maskは複数定義可能。定義された順番でマッチングが行なわれます。 +mask: sample!*@*.sample.net +=cut diff -urN tiarra-20030731/sample.conf tiarra-20030804/sample.conf --- tiarra-20030731/sample.conf 2003-07-31 18:29:13.000000000 +0900 +++ tiarra-20030804/sample.conf 2003-08-06 10:12:36.000000000 +0900 @@ -1,6 +1,6 @@ # -*- tiarra-conf -*- # ----------------------------------------------------------------------------- -# $Id: sample.conf,v 1.55 2003/07/31 07:34:13 topia Exp $ +# $Id: sample.conf,v 1.56 2003/08/04 09:29:21 admin Exp $ # ----------------------------------------------------------------------------- # tiarra.conf サンプル # @@ -963,7 +963,7 @@ # 指定された人間からのPRIVMSGやNOTICEを破棄してクライアントへ送らないようにするモジュール。 # 対象となるコマンドのマスク。省略時には"privmsg,notice"が設定されている。 - # ただしprivmsgとnotice以外を破棄してしまうと、(Tiarraは平気でも)クライアントが混乱する事は間違い無い。 + # ただしprivmsgとnotice以外を破棄してしまうと、(Tiarraは平気でも)クライアントが混乱する。 command: privmsg,notice # maskは複数定義可能。定義された順番でマッチングが行なわれます。