Tanpen.pm

• 付録
  • 今までのデータファイルを移行するスクリプト

短編の作者データ・作品データを扱うためのPerlモジュール。

おそらく運営者しか使わないものですが。

# Tanpen.pm
use strict;
package Tanpen;

my %Author;    # 作者データと作品データを格納するハッシュ
my @Turn;      # 各期の作品データを格納する配列
my %RealName;  # 別名から本名を返すハッシュ（別名があれば）

# データ構造作成

&_read_alias;
&_read_entries;

# 別名ファイルの読み込み

sub _read_alias {
    open(IN, "alias.txt") or die "alias list open fail!\n";
    while (<IN>) {
        next if (/^#/);
        chomp;
        my @name = split /\t/;
        foreach my $n (@name) {
            $RealName{$n} = $name[0];
        }
    }
    close IN;
}

# 全作品データファイルの読み込み

sub _read_entries {
    open(IN, "entries.txt") or die "entry list open fail!\n";
    while (<IN>) {
        next if (/^#/);
        chomp;
        my ($turn, $entry, $title, $author, $letters, $result, $pre, $fin, $mail, $url, $sitename) = split(/\t/);
        my $real = $RealName{$author} || $author;
    
        # {投稿名}の要素がなかったら作る
        unless ($Author{$author}) {
            # 更に{本名}の要素がなかったら新たに作る
            unless ($Author{$real}) {
                $Author{$real}->{id} = "$turn-$entry";
            }
            # {投稿名}と{本名}が違う場合は{本名}と同じ内容を指す
            if ($real ne $author) {
                $Author{$author} = $Author{$real};
            }
        }

        # メール、ウェブサイトは最新のものを設定
        $Author{$real}->{mail} = $mail;
        $Author{$real}->{url} = $url if ($url);
        $Author{$real}->{sitename} = $sitename if ($sitename);

        # 作品リストに作品データを追加
        my $work = {
            turn => $turn,
            entry => $entry,
            title => $title,
            author => $author,
            result => $result,
            letters => $letters,
            pre => $pre,
            fin => $fin,
        };
        my $workobj = Tanpen::Work->new($work);
        push @{$Author{$real}->{works}}, $workobj;
        $Turn[$turn - 1]->[$entry - 1] = $workobj;
    }
    close IN;
}

# 作者オブジェクトの作成とメソッドの定義

sub new {
    my $class = shift;
    bless \%Author, $class;
}

sub id {
    my ($self, $name) = @_;
    return $self->{$name}->{id};
}

sub mail {
    my ($self, $name) = @_;
    return $self->{$name}->{mail};
}

sub url {
    my ($self, $name) = @_;
    return ($self->{$name}->{url} || "");
}

sub sitename {
    my ($self, $name) = @_;
    return ($self->{$name}->{sitename} || "");
}

sub link_tag {
    my ($self, $name) = @_;
    return "" unless ($self->{$name}->{url});
    my $url = $self->{$name}->{url};
    my $sitename = $self->{$name}->{sitename} || $url;
    return qq{<a href="$url">$sitename</a>};

}

sub result_string {
    my ($self, $name) = @_;
    return join "", map $_->{result}, @{$self->{$name}->{works}};
}

sub work_list {
    my ($self, $name) = @_;
    return @{$self->{$name}->{works}};
}

sub has_alias {
    my ($self, $name) = @_;
    return ($RealName{$name}) ? 1 : 0;
}

sub real_name {
    my ($self, $name) = @_;
    return ($RealName{$name} || $name);
}

sub turn_list {
    return @Turn;
}

sub author_list {
    my $self = shift;
    my $include_alias = shift || 0;
    if ($include_alias) {
        return sort keys %Author
    } else {
        return grep {
            if (has_alias($self, $_)) {
                real_name($self, $_) eq $_;
            } else {
                1;
            }
        } sort keys %Author;
    }
}

1;

# 作品オブジェクト

package Tanpen::Work;

sub new {
    my $class = shift;
    my $ref = shift;
    bless {
        turn => $ref->{turn},
        entry => $ref->{entry},
        title => $ref->{title},
        author => $ref->{author},
        result => $ref->{result},
        letters => $ref->{letters},
        pre => $ref->{pre},
        fin => $ref->{fin},
    }, $class;
}

sub turn {
    my $self = shift;
    return $self->{turn};
}

sub entry {
    my $self = shift;
    return $self->{entry};
}

sub title {
    my $self = shift;
    return $self->{title};
}

sub author {
    my $self = shift;
    return $self->{author};
}

sub result {
    my $self = shift;
    return $self->{result};
}

sub letters {
    my $self = shift;
    return $self->{letters};
}

sub pre {
    my $self = shift;
    return $self->{pre};
}

sub fin {
    my $self = shift;
    return $self->{fin};
}

1;

付録

今までのデータファイルを移行するスクリプト

# alllist.txt -> entries.txt
use strict;
use Jcode;

while (<>) {
    chomp;
    #jcode(\$_);
    my($turn, $entry, $title, $realname, $author, $letters, $result, $pre, $fin, $mail, $url, $sitename) = split /\t/;
    $mail =~ s/&#64;/\@/;
    print join "\t", ($turn, $entry, $title, $author, $letters, $result, $pre, $fin, $mail, $url, $sitename);
    print "\n";
}