suikawiki/script/wiki.cgi

#!/usr/bin/perl
## wiki.cgi - This is SuikaWiki, yet another WikiEngine

use strict;
use lib qw(./lib);
use CGI::Carp qw(fatalsToBrowser);
binmode STDOUT; binmode STDIN;
our $VERSION = do{my @r=(q$Revision: 1.50 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
require 'wikidata/suikawiki-config.ph'; ## site configuration script
require Yuki::YukiWikiCache;
use Fcntl;
our %fmt;       ## formatter objects
our %embed_command = (
        searched        => '^\[\[#searched:([^\]]+)\]\]$',
        form    => qr/\[\[\#form(?:\(([A-Za-z0-9-]+)\))?:'((?:[^'\\]|\\.)*)':'((?:[^'\\]|\\.)*)'(?::'((?:[^'\\]|\\.)*)')?\]\]/,
);
our ($modifier_dbtype,$url_cgi,%uri,%PathTo);
our (%PageName,$kanjicode,$lang,%ViewDefinition);

my %form;
our %database;
our $database = bless {}, 'wiki::dummy';
my %interwiki;
my %command_do = (
    default => \&do_view,
    adminchangepassword => \&do_adminchangepassword,
    write => \&do_write,
    searchform => \&do_searchform,
    comment => \&do_comment,
    RandomJump  => \&do_random_jump,
    wikiform    => \&do_wikiform,
);
our $UA = '';  ## User agent name
$| = 1;

sub main {
    $UA = $main::ENV{HTTP_USER_AGENT};
    &open_db;
    &init_form;
    if ($command_do{$form{mycmd}}) {
        &{$command_do{$form{mycmd}}};
    } else {
        &{$command_do{default}};
    }
    &close_db;
}

sub do_view {
  my $content = $database{$form{mypage}};
  my $lm = $database->mtime ($form{mypage});
  wiki::referer::add ($form{mypage}, $ENV{HTTP_REFERER});
  wiki::useragent::add ($ENV{HTTP_USER_AGENT});
  &load_formatter ('view');
    my $view = $form{mycmd};
    if ($view eq 'edit') {
      $view = 'adminedit' if $form{admin};
    } elsif ($view =~ /[^0-9A-Za-z]/) {
      $view = 'default'
    }
    if ($view eq 'default' || !$view) {
      ## BUG: this code is not strict
      if ($main::ENV{HTTP_COOKIE} =~ /SelectedMode=([0-9A-Za-z]+)/) {
        $view = $1;
      } else {
        $view = 'read';
      }
    }
  my ($magic, $content) = &SuikaWiki::Plugin::magic_and_content (undef, $content);
  $magic ||= '#?SuikaWiki/0.9';
  my $o = bless {param => \%form, page => $form{mypage}, toc => [],
                 magic => $magic, content => $content,
                 formatter => $fmt{view}, &_compatible_options ()}, 'SuikaWiki::Plugin';
  if (!ref $ViewDefinition{$view} || !&{$ViewDefinition{$view}->{check}} ($o)) {
    print "Status: 406 Unsupported Media Type\n";
    $view = '-UnsupportedMediaType';
  }
  my $media = $ViewDefinition{$view}->{media};
  if ($ViewDefinition{$view}->{xmedia} && $UA =~ /Gecko/) {
    $media = $ViewDefinition{$view}->{xmedia};
    $o->{media} = $media;
  } elsif ($UA =~ m#Mozilla/0\..+Windows#) {
    $kanjicode = 'shift_jis';
  }
    if ($magic =~ m!^\#\?SuikaWiki/0.9!) {
      &print_header ($form{mypage}, -last_modified => ($magic =~ /interactive="yes"/ ? time : $lm),
        -expires => ($magic =~ /interactive="yes"/ ? 1 : undef), o => $o,
        -media => $media, -magic => $magic,  content => $content);
    } else {
      &print_header($form{mypage}, -media => $media,
                                   -magic => $magic, -last_modified => $lm, o => $o);
    }
  if ($kanjicode ne 'euc') {
    my $s = $fmt{view}->replace ($ViewDefinition{$view}->{template} => $o);
    print &code_convert (\$s => $kanjicode);
  } else {
    print $fmt{view}->replace ($ViewDefinition{$view}->{template} => $o);
  }
}

sub _do_view_msg (%) {
  my %option = @_;
  &load_formatter ('view');
  my $o = bless {param => \%form, page => $option{-page}, toc => [], condition => \%option,
                 formatter => $fmt{view}, &_compatible_options ()}, 'SuikaWiki::Plugin';
  unless (&{$ViewDefinition{$option{-view}}->{check}} ($o)) {
    print "Status: 406 Unsupported Media Type\n";
    $option{-view} = '-UnsupportedMediaType';
  }
  my $media = $ViewDefinition{$option{-view}}->{media};
  if ($ViewDefinition{$option{-view}}->{xmedia} && $UA =~ /Gecko/) {
    $media = $ViewDefinition{$option{-view}}->{xmedia};
    $o->{media} = $media;
  }
  &print_header($option{-page}, -media => $media, o => $o, -goto => $option{-goto});
  print $fmt{view}->replace ($ViewDefinition{$option{-view}}->{template} => $o);
}

sub id_and_name ($) {
    my $name = shift;
    if ($UA =~ m#Mozilla/[12]\.|Microsoft Internet Explorer#) {
      qq{id="$name"><a name="$name"></a};
    } else {
        qq{id="$name"};
    }
}

sub do_adminchangepassword {
    if ($form{mynewpassword} ne $form{mynewpassword2}) {
        &_do_view_msg (-view => '-error', -page => $form{mypage},
                       error_message => &Resource ('Error:PasswordMismatch'));
        return;
    }
    my ($validpassword_crypt) = $database->meta (AdminPassword => $PageName{AdminSpecialPage});
    if ($validpassword_crypt) {
        if (not &valid_password($form{myoldpassword})) {
            &_do_view_msg (-view => '-error', -page => $form{mypage},
                           error_message => &Resource ('Error:PasswordIsIncorrect'));
            return;
        }
    }
    my ($sec, $min, $hour, $day, $mon, $year, $weekday) = localtime(time);
    my (@token) = ('0'..'9', 'A'..'Z', 'a'..'z');
    my $salt1 = $token[(time | $$) % scalar(@token)];
    my $salt2 = $token[($sec + $min*60 + $hour*60*60) % scalar(@token)];
    my $crypted = crypt($form{mynewpassword}, "$salt1$salt2");
    $database->meta (AdminPassword => $PageName{AdminSpecialPage} => $crypted);
    
    &_do_view_msg (-view => '-wrote', -page => $form{mypage});
}

sub valid_password ($) {
    my ($validpassword_crypt) = $database->meta (AdminPassword => $PageName{AdminSpecialPage});
    return crypt (shift, $validpassword_crypt) eq $validpassword_crypt ? 1 : 0;
}

sub do_write {
    if (&frozen_reject()) {
        return;
    }

    if (not &is_editable($form{mypage})) {
        &_do_view_msg (-view => '-error', -page => $form{mypage},
                       error_message => &Resource ('Error:ThisPageIsUneditable'));
        return;
    }

    ## Check confliction
    if ($form{myLastModified} ne $database->mtime ($form{mypage})) {
      &_do_view_msg (-view => '-conflict', -page => $form{mypage});
      return;
    }

    if ($form{mymsg}) {
        if ($form{mytouch} || !ref $database) {
          $database{$form{mypage}} = $form{mymsg};
        } else {
          $database->STORE ($form{mypage} => $form{mymsg}, -touch => 0);
        }
        $database->meta (IsFrozen => $form{mypage} => 0 + $form{myfrozen});
        my $fragment = '';
        $fragment .= qq(;after_edit_cmd=@{[&encode($form{after_edit_cmd})]}) if $form{after_edit_cmd};
        if ($form{__comment_anchor_index}) {
            $fragment .= qq(#anchor-$form{__comment_anchor_index});
        } elsif ($form{__wikiform_anchor_index}) {
            $fragment .= qq(#wikiform-$form{__wikiform_anchor_index});
        }
        &_do_view_msg (-view => '-wrote', -page => $form{mypage}, -goto => $url_cgi.'?mycmd='.&encode($form{after_edit_cmd}||'default').';mypage='.&encode($form{mypage}).qq(;x-param=@{[time.[0..9]->[rand 10]]}$fragment));
    } else {
        delete $database{$form{mypage}};
        &_do_view_msg (-view => '-deleted', -page => $form{mypage});
    }
}

sub _compatible_options () {
  (use_anchor_name => ($UA =~ m#Mozilla/[12]\.|Microsoft Internet Explorer# ? 1 : 0));
}

sub get_search_result ($;%) {
  my $word = lc shift;
  my $SearchResult = SuikaWiki::Plugin->cache ('search');
  my %option = @_;
  my @r;
  unless (defined $SearchResult->{$word}) {
    for my $page (keys %database) {
      next if !$option{-match_myself} && ($page eq $word);
      my $content = lc $database{$page};
      $content =~ s/^[^\x0A\x0D]+[\x0D\x0A]+//s;
      if (index (lc $page, $word) > -1) {
        my $c = $content =~ s/\Q$word\E//g;
        push @r, [$page, $c+20];
      } elsif (index ($word, lc $page) > -1) {
        my $c = $content =~ s/\Q$word\E//g;
        push @r, [$page, $c+10];
      } elsif (my $c = $content =~ s/\Q$word\E//g) {
        push @r, [$page, $c];
      }
    }
    @r = sort {$b->[1] <=> $a->[1] || $a->[0] cmp $b->[0]} @r;
    $SearchResult->{$word} = join "\x1E", map {$_->[0]."\x1F".$_->[1]} @r;
  } else {
    @r = map {[split /\x1F/, $_, 2]} split /\x1E/, $SearchResult->{$word};
  }
  #my $em = sub { my $s = shift; $s =~ s#(\Q$word\E)#<em>$1</em>#gi; $s };
  my $r = join "\n", map {qq(<li>[$_->[1]] <a href ="$url_cgi?@{[&encode($_->[0])]}" class="wiki">@{[&escape($_->[0])]}</a> <span class="wikipage-summary">@{[&escape(&get_subjectline($_->[0]))]}</span></li>)} @r;
  $r = qq|<ul class="search-result">$r</ul>| if $r;
  wantarray? ($r, scalar @r): $r;
}

sub do_random_jump {
  my @list = keys %database;
  my $name = &encode ($list[rand @list]);
  print "Location: $uri{wiki}?$name\n";
  print "\n";
}

sub print_header ($;%) {
    my ($page, %option) = @_;
    my @head;
    $option{o}->{-header}->{class} = &is_frozen($page) ? 'frozen' : '';
    $option{o}->{-header}->{class} .= " wiki-page-obsoleted" if $option{-magic} =~ /obsoleted="yes"/;
    if ($option{-goto}) {
      if ($UA =~ m#Opera|MSIE 2\.#) {
          ## WARNING: This code may output unsafe HTML document if
          ##          $option{-goto} is not clean.
          $option{-goto} =~ tr/;/&/ if $UA =~ m#Opera#;
          print qq{Refresh: 0; url=$option{-goto}\n};
          push @head, qq(<meta http-equiv="refresh" content="0; url=$option{-goto}">);
      } elsif ($UA =~ /Gecko/) {
          print qq{Refresh: 0; url="$option{-goto}"\n};
          push @head, qq(<meta http-equiv="refresh" content="0; url=&quot;@{[&escape($option{-goto})]}&quot;" />);
      } else {
          $option{-goto} =~ tr/;/&/ if $UA =~ m#Mozilla/[1-4]\.#;
          print qq{Refresh: 0; url="$option{-goto}"\n};
          push @head, qq(<meta http-equiv="refresh" content="0; url=&quot;@{[&escape($option{-goto})]}&quot;">);
      }
    }
    print qq{Last-Modified: @{[scalar gmtime $option{-last_modified}]}\n} if $option{-last_modified};
    if ($option{-expires} != -1) {
      if (defined $option{-expires}) {  ## TODO: Don't use asctime
        print qq{Expires: @{[scalar gmtime (time + $option{-expires})]}\n};
      } elsif ($option{-media}->{expires} != -1) {
        print qq{Expires: @{[scalar gmtime (time + $option{-media}->{expires})]}\n};
      }
    }
    if ($option{-media}->{charset} && $UA =~ m#Mozilla/[12]\.#) {
        my $ct = qq{$option{-media}->{type}; charset=@{[&get_charset_name($kanjicode,compatible=>1)]}};
        print qq{Content-Type: $ct\n};
        $option{o}->{-header}->{meta_ct} = qq{<meta http-equiv="content-type" content="$ct">\n};
    } elsif (!$option{-media}->{charset} || $UA =~ m#Infomosaic|Mozilla/0\.#) {
        print qq{Content-Type: $option{-media}->{type}\n};
        $option{o}->{-header}->{meta_ct} = qq{<meta http-equiv="content-type" content="$option{-media}->{type}; charset=@{[&get_charset_name($kanjicode,compatible=>1)]}">\n};
    } else {
        my $type = $option{-media}->{type};
        $type = 'application/xml' if $type eq 'application/rss+xml';
        print qq{Content-Type: $type; charset=@{[&get_charset_name($kanjicode)]}\n};
    }
    print <<"EOD";      ## TODO: 
Content-Language: $lang
Content-Style-Type: text/css

EOD
  $option{o}->{-header}->{links} = join "\n", (@head);
}

sub get_charset_name ($;%) {
    my ($charset, %option) = (lc shift, @_);
    if ($charset =~ 'euc') {
        $charset = $option{compatible} ? 'x-euc-jp' : 'euc-jp';
    } elsif ($charset =~ 'sjis' || $charset =~ 'shift') {
        $charset = $option{compatible} ? 'x-sjis' : 'shift_jis';
    } elsif ($charset =~ 'jis') {
        $charset = 'iso-2022-jp';
    }
    $charset;
}

sub escape {
    my $s = shift;
    $s =~ s|\x0D\x0A|\x0A|g;
    $s =~ s|&|&amp;|g;
    $s =~ s|<|&lt;|g;
    $s =~ s|>|&gt;|g;
    $s =~ s|"|&quot;|g;
    return $s;
}

sub unescape {
    my $s = shift;
    # $s =~ s|\n|\r\n|g;
    $s =~ s|&lt;|<|g;
    $s =~ s|&gt;|>|g;
    $s =~ s|&quot;|"|g;
    $s =~ s|&amp;|&|g;
    return $s;
}

sub convert_format ($$$;%) {
  my ($content, $d => $t, %option) = @_;
  &load_formatter ('format');
  my $f = SuikaWiki::Plugin->format_converter ($d => $t);
  if (ref $f) {
    $option{content} = $content;
    $option{from} = $d;
    $option{to} = $t;
    &$f ({}, bless (\%option, 'SuikaWiki::Plugin'));
  } elsif ($t =~ /HTML|xml/) {
    length $content ? '<pre>'.&escape($content).'</pre>' : '';
  } else {
    $content;
  }
}

sub text_to_html {
    my ($txt, %option) = @_;
    my $toc = $option{-toc} || (ref $option{toc} ? $option{toc} : []);
    my $tocnum = 0;
    
    ## Load constants
    my %const;
    if ($option{magic} =~ /import="([^"]+)"/) {
      for (split /\s*,\s*/, $1) {
        my $wp = $database{$_};
        if ($wp =~ m!^\#\?SuikaWikiConst/(?:0.9|1.0)!) {
          wiki::suikawikiconst::to_hash ($wp => \%const);
        }
      }
    }
    
    $txt =~ s{__&&([^&]+)&&__}{defined $const{$1}?$const{$1}:qq(__&&$1&&__)}ge;
    my (@txt) = split(/\n/, $txt);
    my (@saved, @result);
    unshift(@saved, "</p>");
    push(@result, "<p>");
    foreach (@txt) {
        chomp;
        if (/^\*\*\*\*\*([^\x0D\x0A]*)/) {
            push @$toc, [5, "i$tocnum" => ($1 || $tocnum)];
            push(@result, splice(@saved), qq(<h6 @{[&id_and_name("i$tocnum")]}>) . &inline($1, %option, const => \%const) . '</h6>');
            $tocnum++;
        } elsif (/^\*\*\*\*([^\x0D\x0A]*)/) {
            push @$toc, [4, "i$tocnum" => ($1 || $tocnum)];
            push(@result, splice(@saved), qq(<h5 @{[&id_and_name("i$tocnum")]}>) . &inline($1, %option, const => \%const) . '</h5>');
            $tocnum++;
        } elsif (/^\*\*\*([^\x0D\x0A]*)/) {
            push @$toc, [3, "i$tocnum" => ($1 || $tocnum)];
            push(@result, splice(@saved), qq(<h4 @{[&id_and_name("i$tocnum")]}>) . &inline($1, %option, const => \%const) . '</h4>');
            $tocnum++;
        } elsif (/^\*\*([^\x0D\x0A]*)/) {
        # if (/^\*\*(.*)/) {
        # Walrus mod (6) end
            push @$toc, [2, "i$tocnum" => ($1 || $tocnum)];
            push(@result, splice(@saved), qq(<h3 @{[&id_and_name("i$tocnum")]}>) . &inline($1, %option, const => \%const) . '</h3>');
            $tocnum++;
        } elsif (/^\*([^\x0D\x0A]*)/) {
            push @$toc, [1, "i$tocnum" => ($1 || $tocnum)];
            push(@result, splice(@saved), qq(<h2 @{[&id_and_name("i$tocnum")]}>) . &inline($1, %option, const => \%const) . '</h2>');
            $tocnum++;
        } elsif (/^(={1,6})(.*)/) {
            &back_push('ol', length($1), \@saved, \@result);
            push(@result, '<li>' . &inline($2, %option, const => \%const) . '</li>');
        } elsif (/^(-{1,6})(.*)/) {
          &back_push('ul', length($1), \@saved, \@result);
          my ($pf, $l) = ('', $2);
          if (!$main::_EMBEDED && $l =~ s/^\s*\[([0-9]+)\]//) {
            my $num = 0+$1;
            $pf = qq(<a name="anchor-$num" id="anchor-$num" class="anchor">[$num]</a>);
          }
          push(@result, '<li>' . $pf . &inline ($l, %option, const => \%const) . '</li>');
        } elsif (/^:([^:]+):(.*)/) {
            &back_push('dl', 1, \@saved, \@result);
            push(@result, '<dt>' . &inline($1, %option, const => \%const) . '</dt>', '<dd>' . &inline($2, %option, const => \%const) . '</dd>');
        } elsif (/^(?!>>\d)(>{1,5})(.*)/) {
            &back_push('blockquote', length($1), \@saved, \@result);
            push @result, "<p>";
            push(@result, &inline($2, %option, const => \%const));
            unshift @saved, "</p>";
        } elsif (/^\s*$/) {
            push(@result, splice(@saved));
            push(@result, "<p>");
            unshift(@saved, "</p>");
        } elsif (/^(\s+.*)$/) {
            &back_push('pre', 1, \@saved, \@result);
            push(@result, &inline($1, %option, const => \%const));
        } elsif (/^\,(.*?)[\x0D\x0A]*$/) {
            &back_push('table', 1, \@saved, \@result);
            #######
            # This part is taken from Mr. Ohzaki's Perl Memo and Makio Tsukamoto's WalWiki.
            # XXXXX
            my $tmp = "$1,";
            my @value = map {/^"(.*)"$/ ? scalar($_ = $1, s/""/"/g, $_) : $_} ($tmp =~ /("[^"]*(?:""[^"]*)*"|[^,]*),/g);
            my @align = map {(s/^\s+//) ? ((s/\s+$//) ? ' align="center"' : ' align="right"') : ''} @value;
            my @colspan = map {($_ eq '==') ? 0 : 1} @value;
            for (my $i = 0; $i < @value; $i++) {
                if ($colspan[$i]) {
                    while ($i + $colspan[$i] < @value and $value[$i + $colspan[$i]] eq '==') {
                        $colspan[$i]++;
                    }
                    $colspan[$i] = ($colspan[$i] > 1) ? sprintf(' colspan="%d"', $colspan[$i]) : '';
                    $value[$i] = sprintf('<td%s%s>%s</td>', $align[$i], $colspan[$i], &inline($value[$i], %option, const => \%const));
                } else {
                    $value[$i] = '';
                }
            }
            push(@result, join('', '<tr>', @value, '</tr>'));
            # XXXXX
            #######
        } elsif (/^\[(INS|DEL|PRE)\[\s*$/) {
            push @result, splice (@saved), '<'.lc($1).'>';
            unshift @saved, "</p>";
            push @result, "<p>";
        } elsif (/^\](INS|DEL|PRE)\]\s*$/) {
            push @result, splice (@saved), '</'.lc($1).'>';
        } elsif (/^\[([0-9]+)\](.*)$/ && !$main::_EMBEDED) {
          my $num = 0+$1;
          push @result, qq(<a name="anchor-$num" id="anchor-$num" class="anchor">[$num]</a>);
          push @result, &inline ($2, %option, const => \%const);
        } else {
            push(@result, &inline($_, %option, const => \%const));
        }
    }
    push(@result, splice(@saved));
    
    my $r = join("\n", @result);
    $r =~ s#<p>\x0D?\x0A</p>##g;
    $r =~ s#[\x0D\x0A]+</#</#g;
    $r =~ s#<pre>\x0D?\x0A#<pre>#g;
    $r;
}

sub back_push {
    my ($tag, $level, $savedref, $resultref, $attr) = @_;
    while (@$savedref > $level) {
        push(@$resultref, shift(@$savedref));
    }
    if ($savedref->[0] ne "</$tag>") {
        push(@$resultref, splice(@$savedref));
    }
    while (@$savedref < $level) {
        unshift(@$savedref, "</$tag>");
        push(@$resultref, "<$tag$attr>");
    }
}

sub inline ($;%) {
    my ($line, %option) = @_;
    $line = &escape($line);
    $line =~ s{$embed_command{form}}{&make_custom_form ($1, $2, $3, $4, \%option)}ge;
    $line =~ s{\[(INS|DEL|SUP|SUB|VAR|CODE|KBD|SAMP|DFN)(?:\(([A-Za-z0-9\x20-]+)\))?\[(.+?)\]\]}{<@{[lc $1]}@{[$2 ? qq( class="$2") : '']}>$3</@{[lc $1]}>}g;
    $line =~ s:\[(WEAK)\[(.+?)\]\]:<span class="@{[lc $1]}">$2</span>:g;
    $line =~ s:\[ABBR\[([^]]+)\] \[([^]]+)\]\]:<acronym title="$2">$1</acronym>:g;
    $line =~ s:\[RUBYB\[([^]]+)\] \[([^]]+)\] \[([^]]+)\]\]:<span class="ruby"><ruby class="rb"><rb>$1</rb><rp>(</rp><rt>$2</rt><rp>)</rp></ruby><span class="rp"> (</span><span class="rt-below">$3</span><span class="rp">) </span></span>:g;
    $line =~ s:\[RUBY\[([^]]+)\] \[([^]]+)\]\]:<ruby><rb>$1</rb><rp>(</rp><rt>$2</rt><rp>)</rp></ruby>:g;
    $line =~ s:\[RUBYB\[([^]]+)\] \[([^]]+)\]\]:<span class="ruby"><span class="rb">$1</span><span class="rp"> (</span><span class="rt-below">$2</span><span class="rp">) </span></span>:g;
    $line =~ s|'''([^']+)'''|<strong>$1</strong>|g;
    $line =~ s|''([^']+)''|<em>$1</em>|g;
    $line =~ s{
      (\[\[(\#\S+?)\]\])
      |\[\[([^[]+?)](?:&gt;&gt;([0-9]+))?]
      |&gt;&gt;([0-9]+)
      |&lt;([A-Za-z0-9%]+:(?:(?!&gt;).)+)&gt;
    }{
      my ($l, $page,$anchor, $anum, $uri) = ($1, $3,$4, 0+$5, $6);
      if ($l) {
        &embedded_to_html($1);
      } elsif (defined $page) {
        &make_wikilink ($page, anchor => 0+$anchor);
      } elsif ($anum) {
        qq(<a href="#anchor-$anum" class="wiki-anchor">&gt;&gt;$anum</a>);
      } elsif ($uri) {
        &make_urilink ($uri);
      }
    }gex;
    return $line;
}

sub make_wikilink ($%) {
  my ($ename, %option) = @_;
  my $name = &unescape ($ename);
  $option{latest} = $option{latest} ? qq(mycmd=default;x-param=@{[time.[0..9]->[rand 10]]};mypage=) : '';
  if ($database{$name}) {
    my $subject = &escape (&get_subjectline ($name, delimiter => ''));
    if ($option{anchor}) {
      return qq(<a title="$subject" href="$uri{wiki}?$option{latest}@{[&encode($name)]}#anchor-$option{anchor}" class="wiki">$ename&gt;&gt;$option{anchor}</a>);
    } else {
      return qq(<a title="$subject" href="$uri{wiki}?$option{latest}@{[&encode($name)]}" class="wiki">$ename</a>);
    }
  } else {
    return qq(<a title="@{[&Resource('JumpAndEditWikiPage',escape=>1)]}" href="$uri{wiki}?$option{latest}@{[&escape($name)]}" class="wiki not-exist">$ename<span class="mark">@{[&Resource('JumpAndEditWikiPageMark',escape=>1)]}</span></a>);
  }
}

sub make_urilink ($;%) {
  require URI;
  my $uri = shift;
  if ($uri =~ s/^IW://) {       ## InterWiki (not URI)
    $uri = &unescape ($uri);
    if ($uri =~ /^([^\x00-\x2F\x3A-\x40\x5B-\x60\x7B-\x7F]+|"(?:\\.|[^"\\])+"):([^\x00-\x2F\x3A-\x40\x5B-\x60\x7B-\x7F]+|"(?:\\.|[^"\\])+")$/) {
      my ($site, $name) = ($1, $2);
      for ($site, $name) {
        if (s/^"//) { s/"$//; s/\\(.)/$1/g }
      }
      &init_InterWikiName () unless $interwiki{'[[]]'};
      if ($interwiki{$site}) {
        &load_formatter ('interwiki');
        my $uri = &escape ($fmt{interwiki}->replace ($interwiki{$site} => {site => $site, name => $name}));
        $site = &escape ($site); $name = &escape ($name);
        qq(&lt;<a href="$uri" class="out-of-wiki interwiki" title="$name ($site); URI: &lt;$uri&gt;"><span class="interwiki-site">$site:</span><span class="interwiki-name">$name</span></a>&gt;);
      } else {
        qq(&lt;@{[&Resource('Error:UnknownInterWikiName=',escape=>1)]}@{[&escape ($site)]}&gt;);
      }
    } else {
      qq(&lt;@{[&Resource('Error:InvalidInterWiki=',escape=>1)]}@{[&escape($uri)]}&gt;);
    }
  } elsif ($uri =~ /^urn:/) {   ## URN
    my $uri2 = &escape (URI->new ('/uri-res/N2L?'.&unescape ($uri), 'http')->canonical);
    qq(&lt;<a href="$uri2" title="URI: &lt;$uri&gt; (via &lt;$uri2&gt;)" class="out-of-wiki urn">$uri</a>&gt;);
  } elsif ($uri =~ s/^MAIL://) {        ## mail address (not URI)
    my $uri2 = &escape (URI->new ('mailto:'.&unescape ($uri))->canonical);
    qq(&lt;<a href="$uri2" class="out-of-wiki mail">$uri</a>&gt;);
  } elsif ($uri =~ s/^IMG(?:\([^)]+\))?://) {   ## image (not URI itself)
    my $uri2 = &escape (URI->new (&unescape ($uri))->canonical);
    qq(<img src="$uri2" alt="" title="URI: &lt;$uri2&gt;" class="out-of-wiki">);
  } else {      ## misc. URI
    CGI::Carp::warningsToBrowser (0);
    my $uri2 = &escape (URI->new (&unescape ($uri))->canonical);
    CGI::Carp::warningsToBrowser (1);
    qq(&lt;<a href="$uri2" title="URI: &lt;$uri2&gt;" class="out-of-wiki">$uri</a>&gt;);
  }
}

{my %FormIndex;
sub make_custom_form ($$$$%) {
    my ($wfname, $definition, $template, $foption, $option) = @_;
    ## $template is currently not used in this procedure.
    #unless ($main::_EMBEDED) {
        $FormIndex{$option->{page}}++;
        if (length $definition) {
            my $param = bless {depth=>10}, 'SuikaWiki::Plugin';
            my $lastmodified = $database->mtime ($option->{page});
            &load_formatter (qw/form_input form_option/);
            $definition = &unescape ($definition);
            $definition =~ s/\\(.)/$1/g;
            $foption = &unescape ($foption);
            $foption =~ s/\\(.)/$1/g;
            $fmt{form_option}->replace ($foption, $param);
            $param->{output}->{form} = 1 unless defined $param->{output}->{form};
            $param->{output}->{form} = 0 if $main::_EMBEDED;
            $definition .= ' %submit;' if $definition !~ /%submit/ && !$param->{output}->{nosubmit} && $param->{output}->{form};
            $param->{output}->{page} ||= $option->{page};
            $param->{form_disabled} = 1 if $database->meta (IsFrozen => $option->{page});
            my $target_form = $param->{output}->{id};
            my $r = '';
            $r = <<EOH if $param->{output}->{form};
<form method="post" action="$url_cgi" id="wikiform-$FormIndex{$option->{page}}" class="wikiform">
  <input type="hidden" name="mycmd" value="@{[$param->{form_disabled}?'default':'wikiform']}" />
  <input type="hidden" name="mypage" value="@{[&escape($param->{output}->{page})]}" />
  <input type="hidden" name="myLastModified" value="$lastmodified" />
  <input type="hidden" name="mytouch" value="on" />
  <input type="hidden" name="@{[$target_form? qq(wikiform_targetform" value="@{[&escape($target_form)]}) : qq(wikiform_index" value="$FormIndex{$option->{page}})]}" />
EOH
            $r .= qq(<a name="wikiform-$FormIndex{$option->{page}}"></a>) if $UA =~ m#Mozilla/[12]\.#;
            $r .= $fmt{form_input}->replace ($definition, $param);
            $r .= "</form>\n" if $param->{output}->{form};
            $r;
       } else {  ## No input-interface WikiForm
         qq(<a id="wikiform-$FormIndex{$option->{page}}" name="wikiform-$FormIndex{$option->{page}}"><!-- #form --></a>);
       }
    #} else {
    #    qq(<ins class="wiki-error">@{[&Resource('Error:WikiForm:EmbedIsNotSupported',escape=>1)]}</ins>);
    #}
}}

sub init_form {
    ## TODO: Support multipart/form-data
    my $query = '';
    if (uc $main::ENV{REQUEST_METHOD} eq 'POST') {
      read STDIN, $query, $main::ENV{CONTENT_LENGTH};
    }
    $query .= ($query ? ';' : '') . $main::ENV{QUERY_STRING};
    if ($main::ENV{REQUEST_METHOD} ne 'POST' && $main::ENV{QUERY_STRING} && $main::ENV{QUERY_STRING} !~ /[&;=]/) {
      my $query = &decode($main::ENV{QUERY_STRING});
      $query = &code_convert(\$query, $kanjicode);
        $form{mypage} = $query;
        $form{mycmd} = 'default';
    } else {
      for (split /[;&]/, $query) {
        if (my ($n, $v) = split /=/, $_, 2) {
          for ($n, $v) {tr/+/ /; s/%([0-9A-Fa-f][0-9A-Fa-f])/pack 'C', hex $1/ge};
          $form{$n} = $v;
        }
      }
      unless (defined $form{mypage}) {
        $form{mypage} = $form{epage};
        $form{mypage} =~ s/([0-9A-F]{2})/ord hex $1/g;
      }
    }
    $form{mypage} ||= $PageName{FrontPage};
    $form{mypage} =~ tr/\x00-\x1F\x7F//d;
    $form{mycmd} ||= 'default';

    # mypreview_edit        -> do_edit, with preview.
    # mypreview_adminedit   -> do_adminedit, with preview.
    # mypreview_write       -> do_write, without preview.
    foreach (keys %form) {
        if (/^mypreview_(.*)$/) {
            $form{mycmd} = $1;
            $form{mypreview} = 1;
        }
    }

    # 
    # $form{mycmd} is frozen here.
    # 

    for (grep /^wikiform__/, keys %form) {
        $form{$_} = &code_convert (\$form{$_}, $kanjicode);
    }
    $form{mymsg} = &code_convert(\$form{mymsg}, $kanjicode);
    $form{myname} = &code_convert(\$form{myname}, $kanjicode);
}

sub get_subjectline {
    my ($page, %option) = @_;
    my $SubjectLine = SuikaWiki::Plugin->cache ('headline');
    unless (defined $SubjectLine->{$page}) {
      if (not &is_editable($page)) {
        $SubjectLine->{$page} = "";
      } else {
        $SubjectLine->{$page} = do {
          my $s=$database{$page};
          $s =~ s!^\#\?[^\x0A\x0D]+[\x0A\x0D]*!!s;
          $s =~ s/\x0D?\x0A.*//s;
        $s};
      }
    }
    if (length $SubjectLine->{$page}) {
      $option{delimiter} = defined $option{delimiter} ? $option{delimiter} : &Resource('Title-Summary Delimiter');
      $option{delimiter}.$SubjectLine->{$page}.$option{tail};
    } else {
      '';
    }
}

sub open_db {
    if ($modifier_dbtype eq 'dbmopen') {
        dbmopen(%database, $PathTo{WikiDataBase}, 0666) or die "(dbmopen) $PathTo{WikiDataBase}";
    } elsif ($modifier_dbtype eq 'AnyDBM_File') {
        eval q{use AnyDBM_File};
        tie(%database, "AnyDBM_File", $PathTo{WikiDataBase}, O_RDWR|O_CREAT, 0666) or die ("(tie AnyDBM_File) $PathTo{WikiDataBase}");
    } elsif ($modifier_dbtype eq 'Yuki::YukiWikiDB') {
        eval q{use Yuki::YukiWikiDB};
        tie(%database, "Yuki::YukiWikiDB", $PathTo{WikiDataBase}) or die ("(tie Yuki::YukiWikiDB) $PathTo{WikiDataBase}");
    } else {    ## Yuki::YukiWikiDB || Yuki::YukiWikiDBMeta
        eval qq{use $modifier_dbtype};
        $database = tie(%database, $modifier_dbtype => $PathTo{WikiDataBase}, -lock => 2, -backup => $wiki::diff::UseDiff) or die ("(tie $modifier_dbtype) $PathTo{WikiDataBase}");
    }
}

sub close_db {
    if ($modifier_dbtype eq 'dbmopen') {
        dbmclose(%database);
    } else {
        untie(%database);
    }
}

sub editform (@) {
  my %option = @_;
  my $frozen = &is_frozen ($option{page});
  $option{content} = $database{$option{page}} unless defined $option{content};
  $option{content} = $database{NewPageTemplate} unless length $option{content};
  $option{last_modified} = $database->mtime ($option{page}) unless defined $option{last_modified};
  my $f = '';
  my $magic = '';
  $magic = $1 if $option{content} =~ m/^([^\x0A\x0D]+)/s;
  
  my $selected = 'default';
  if ($form{after_edit_cmd}) {
    $selected = $form{after_edit_cmd};
  } elsif ($magic =~ /Const|Config|CSS/) {
    $selected = 'edit';
  }
  my $afteredit = <<EOH;
<select name="after_edit_cmd">
<option value="default" label="@{[&Resource('Edit:SaveAndDefault',escape=>1)]}"@{[$selected eq 'default' ? ' selected="selected"':'']}>@{[&Resource('Edit:SaveAndDefault',escape=>1)]}</option>
<option value="read" label="@{[&Resource('Edit:SaveAndView',escape=>1)]}"@{[$selected eq 'read' ? ' selected="selected"':'']}>@{[&Resource('Edit:SaveAndView',escape=>1)]}</option>
<option value="edit" label="@{[&Resource('Edit:SaveAndEdit',escape=>1)]}"@{[$selected eq 'edit' ? ' selected="selected"':'']}>@{[&Resource('Edit:SaveAndEdit',escape=>1)]}</option>
</select>
EOH
  $f .= <<"EOD";
<form action="$uri{wiki}" method="post">
    @{[ $option{conflict} ? '' : qq(<label><input type="submit" name="mypreview_write" value="@{[&Resource('Edit:Save',escape=>1)]}" /><kbd>S</kbd></label>) ]}
    @{[ $option{admin} ? qq(<label>@{[&Resource('Edit:Password=',escape=>1)]}<input type="password" name="mypassword" value="" size="10" /></label>) : "" ]} [@{[&get_new_anchor_index($option{content})]}]<br />
    <input type="hidden" name="myLastModified" value="$option{last_modified}" />
    <input type="hidden" name="mypage" value="@{[&escape($form{mypage})]}" />
    <textarea cols="@{[&Resource('Edit:Form:Cols')+0||80]}" rows="@{[&Resource('Edit:Form:Rows')+0||20]}" name="mymsg" tabindex="1">@{[&escape($option{content})]}</textarea><br />
@{[
    $option{admin} ?
    qq(
    <label><input type="radio" name="myfrozen" value="1" @{[$frozen ? qq(checked="checked") : ""]} />@{[&Resource('Edit:Freeze',escape=>1)]}</label>
    <label><input type="radio" name="myfrozen" value="0" @{[$frozen ? "" : qq(checked="checked")]} />@{[&Resource('Edit:DontFreeze',escape=>1)]}</label><br />)
    : ""
]}
@{[
    $option{conflict} ? "" :
    qq(
        <label><input type="checkbox" name="mytouch" value="on" checked="checked" />@{[&Resource('Edit:UpdateTimeStamp',escape=>1)]}</label><br />
        <label><input type="submit" name="mypreview_write" value="@{[&Resource('Edit:Save',escape=>1)]}" accesskey="S" /><kbd>S</kbd></label>
       $afteredit
    )
]}
</form>
EOD
    $f;
}

sub is_editable {
    my ($page) = @_;
    $page =~ /[\x00-\x20\x7F]/ ? 0 : 1;
}

sub decode {
    my ($s) = @_;
    $s =~ tr/+/ /;
    $s =~ s/%([A-Fa-f0-9][A-Fa-f0-9])/pack("C", hex($1))/eg;
    return $s;
}

sub encode {
  my $s = shift;
  $s =~ s/([^0-9A-Za-z_-])/sprintf '%%%02X', ord $1/ge;
  $s;
}

sub get_now {
    my ($sec, $min, $hour, $day, $mon, $year) = localtime(time);
    $year += 1900;
    $mon++;
    $mon = "0$mon" if $mon < 10;
    $day = "0$day" if $day < 10;
    $hour = "0$hour" if $hour < 10;
    $min = "0$min" if $min < 10;
    #$sec = "0$sec" if $sec < 10;
    return "$year-$mon-$day $hour:$min";
}

sub init_InterWikiName {
  my @content = split /\n/, $database{InterWikiName};
  for (@content) {
    if (/^([^#]\S*)\s+(\S[^\x0A\x0D]+)/) {
      $interwiki{$1} = $2;
    }
  }
  $interwiki{'[[]]'} = 1;       ## dummy
}

sub frozen_reject {
    my ($isfrozen) = $database->meta (IsFrozen => $form{mypage});
    my ($willbefrozen) = $form{myfrozen};
    if (not $isfrozen and not $willbefrozen) {
        # You need no check.
        return 0;
    } elsif (valid_password($form{mypassword})) {
        # You are admin.
        return 0;
    } else {
        &_do_view_msg (-view => '-error', -page => $form{mypage},
                       error_message => &Resource ('Error:PasswordIsIncorrect'));
        exit;
    }
}

sub is_frozen ($) { $database->meta (IsFrozen => $_[0]) ? 1 : 0 }

sub do_comment {
    my ($content) = $database{$form{mypage}};
    my $default_name;   ## this code is not strict.
    $default_name = $1 if $content =~ /default-name="([^"]+)"/;
    my $datestr = '[WEAK['.&get_now.']]';
    my $namestr = $form{myname} || $default_name || &Resource('WikiForm:WikiComment:DefaultName');
    ($namestr = '', $datestr = '') if $form{myname} eq 'nodate';
    if ($namestr =~ /^(?:>>)?[0-9]/) {
      $namestr = qq( ''$namestr'': );
    } elsif (length $namestr) {
      $namestr = qq( ''[[$namestr]]'': );
    }
    my $anchor = &get_new_anchor_index ($content);
    my $i = 1;  my $o = 0;
    $content =~ s{(\[\[\#r?comment\]\])}{
      my $embed = $1;
      if ($i == $form{comment_index}) {
        if ($embed ne '[[#rcomment]]') {
          $embed = "- [$anchor] $datestr$namestr$form{mymsg}\n$embed";  $o = 1;
        } else {
          $embed .= "\n- [$anchor] $datestr$namestr$form{mymsg}";  $o = 1;
        }
      }
      $i++; $embed;
    }ge;
    unless ($o) {
      $content = "#?SuikaWiki/0.9\n\n" unless $content;
      $content .= "\n" unless $content =~ /\n$/s;
      $content .= "- [$anchor] $datestr$namestr$form{mymsg}\n";
    }
    $form{__comment_anchor_index} = $anchor;
    if ($form{mymsg} || $form{myname}) {
        $form{mymsg} = $content;
        $form{mytouch} = 'on';
        &do_write;
    } else {    ## Don't write
        $form{mycmd} = 'default';
        &do_view;
    }
}

sub get_new_anchor_index ($) {
    my $content = shift;
    my $anchor = 0;
    $content =~ s/^(?:[-=]+\s*)?\[([0-9]+)\]/$anchor = $1 if $1 > $anchor; $&/mge;
    $anchor + 1;
}

my $CommentIndex = 0;
sub embedded_to_html {
    my ($embedded) = @_;
    if ($embedded eq '[[#comment]]' or $embedded eq '[[#rcomment]]') {
      unless ($main::_EMBEDED) {
        my $lastmodified = $database->mtime ($form{mypage});
        return <<"EOD";
<form action="$url_cgi" method="post" id="x-comment-@{[++$CommentIndex]}" class="comment"><p>
    <input type="hidden" name="mycmd" value="comment" />
    <input type="hidden" name="mypage" value="$form{mypage}" />
    <input type="hidden" name="myLastModified" value="$lastmodified" />
    <input type="hidden" name="mytouch" value="on" />
    <input type="hidden" name="comment_index" value="$CommentIndex" />
    @{[&Resource('WikiForm:WikiComment:Name=',escape=>1)]}
    <input type="text" name="myname" value="" size="10" class="comment-name" />
    <input type="text" name="mymsg" value="" size="60" class="comment-msg" />
    <input type="submit" value="@{[&Resource('WikiForm:Add',escape=>1)]}" title="@{[&Resource('WikiForm:AddLong',escape=>1)]}" class="comment-submit" />
</p></form>
EOD
     } else {
        return <<"EOD";
<del><form action="$url_cgi" method="get">
    <input type="hidden" name="mycmd" value="default" />
    <input type="hidden" name="mypage" value="$form{mypage}" />
    @{[&Resource('WikiForm:WikiComment:Name=',escape=>1)]}
    <input type="text" name="myname" value="" size="10" disabled="disabled" />
    <input type="text" name="mymsg" value="" size="60" disabled="disabled" />
</form></del>
EOD
    }
  } elsif ($embedded =~ /$embed_command{searched}/) {
    return get_search_result ($1, -match_myself => 1);
  } elsif ($embedded =~ /^\[\[\#embed:(.+)\]\]$/) {
    my ($name, $r) = ($1, '');
    if ($main::_EMBEDED != 1) {
      my ($cf, $content) = SuikaWiki::Plugin->magic_and_conten ($database{$name});
      $cf ||= '#?SuikaWiki/0.9';
      if ($cf =~ m!^#\?SuikaWiki/0.9(?:$|\s)!) {
        $main::_EMBEDED = 1;
        $r = &text_to_html ($content, magic => $cf, page => $name);
        $main::_EMBEDED = 0;
      } elsif (length $content) {
        $r = "<pre>@{[&escape ($content)]}</pre>";
      } else {
        $r = &text_to_html ("[INS[\n[[$name]]: @{[&Resource('Embed:PageNotFound')]}\n]INS]\n", magic => '#?SuikaWiki/0.9');
      }
    } else {    ## nested #EMBED
      $r = &text_to_html ("[INS[\n[[$name]]: @{[&Resource('Embed:Nested',escape=>1)]}\n]INS]\n", magic => '#?SuikaWiki/0.9');
    }
    return qq(<blockquote title="@{[&escape($name)]}" class="wiki-embed">$r<div class="cite-note">��<cite><a href="$url_cgi?@{[&encode($name)]}" class="wiki">@{[&escape($name)]}</a></cite>��</div></blockquote>);
  } elsif ($embedded =~ /^\[\[\#randomlink:(.+)\]\]$/) {
    return qq(<a href="$url_cgi?mycmd=RandomJump;x-param=@{[time.[0..9]->[rand 10]]}" class="wiki randomlink">$1</a>);
  } else {
    return $embedded;
  }
}

sub load_formatter (@) {
    for my $t (@_) {
        unless ($fmt{$t}) {
            require Message::Util::Formatter;
            $fmt{$t} = Message::Util::Formatter->new;
            for (@{$SuikaWiki::Plugin::List{'wiki'.$t}||[]}) {
                $_->load_formatter ($fmt{$t}, type => 'wiki'.$t);
            }
        }
    }
}

sub do_wikiform {
    my $content = $database{$form{mypage}};
    my $anchor = &get_new_anchor_index ($content);
    &load_formatter (qw/form_template form_option/);
    my $write = 0;
    my $i = 1;
    $content =~ s{$embed_command{form}}{
        my ($embed, $wfname, $template, $option) = ($&, $1, $3, $4);
        if (($wfname && $wfname eq $form{wikiform_targetform})
            || $i == $form{wikiform_index}) {
            $template =~ s/\\(.)/$1/g;
            $option =~ s/\\(.)/$1/g;
            my $param = bless {depth=>10}, 'SuikaWiki::Plugin';
            $param->{page} = $form{mypage};
            $param->{form_index} = $i;
            $param->{form_name} = $wfname;
            $param->{anchor_index} = $anchor;
            $param->{argv} = \%form;
            $param->{default_name} = $1 if $content =~ /default-name="([^"]+)"/;
            $param->{default_name} ||= &Resource('WikiForm:WikiComment:DefaultName');
            $fmt{form_option}->replace ($option, $param);
            my $t = 1;
            for (keys %{$param->{require}||{}}) {
                (undef $t, last) unless length $param->{argv}->{'wikiform__'.$_};
            }
            $t = $fmt{form_template}->replace ($template, $param) if $t;
            if (length $t) {
                if ($param->{output}->{reverse}) {
                    $embed .= "\n" . $t;
                } else {
                    $embed = $t . "\n" . $embed;
                }
                $write = 1;
                $form{__comment_anchor_index} = $anchor
                  if $param->{anchor_index_};  ## $anchor is used!
            }
            $form{__wikiform_anchor_index} = $i;
            undef $form{wikiform_targetform};  ## Make sure never to match
            undef $form{wikiform_index};       ## with WikiForm in rest of page!
        }
        $i++; $embed;
    }ge;
    unless ($write) {
      #$content = "#?SuikaWiki/0.9\n\n" unless $content;
      #$content .= "\n" unless $content =~ /\n$/s;
      #
    }
    if ($write) {
        $form{mymsg} = $content;
        $form{mytouch} = 'on';
        &do_write;
    } else {    ## Don't write!
        $form{mycmd} = 'default';
        &do_view;
    }
}

sub code_convert {
  require Jcode;
    my ($contentref, $code) = (shift, shift || $kanjicode);
    if    ($code =~ /euc/) { $code = 'euc' }
    elsif ($code =~ /iso/) { $code = 'jis' }
    elsif ($code =~ /shi/) { $code = 'sjis' }
    elsif ($code =~ /utf/) { $code = 'utf8' }
    $$contentref = Jcode->new ($contentref)->tr ("\xA3\xB0-\xA3\xB9\xA3\xC1-\xA3\xDA\xA3\xE1-\xA3\xFA\xA1\xF5\xA1\xA4\xA1\xA5\xA1\xA7\xA1\xA8\xA1\xA9\xA1\xAA\xA1\xAE\xA1\xB0\xA1\xB2\xA1\xBF\xA1\xC3\xA1\xCA\xA1\xCB\xA1\xCE\xA1\xCF\xA1\xD0\xA1\xD1\xA1\xDC\xA1\xF0\xA1\xF3\xA1\xF4\xA1\xF6\xA1\xF7\xA1\xE1\xA2\xAF\xA2\xB0\xA2\xB2\xA2\xB1\xA1\xE4\xA1\xE3\xA1\xC0\xA1\xA1" => q(0-9A-Za-z&,.:;?!`^_/|()[]{}+$%#*@='"~-><\ ))->$code;
    return $$contentref;
}

sub _rfc3339_date ($) {
  my @time = gmtime (shift);
  sprintf '%04d-%02d-%02dT%02d:%02d:%02d+00:00', $time[5]+1900,$time[4]+1,@time[3,2,1,0];
}

my %_Resource;
sub Resource ($;%) {
  my ($s, %o) = @_;
  unless (defined $_Resource{$s}) {
    $_Resource{$_[0]} = &wiki::resource::get ($s, $_Resource{__option});
  }
  $o{escape} ? &escape ($_Resource{$s}) : $_Resource{$s};
}

package wiki::referer;
sub add ($$) {
  my $page = shift;
  my $uri = shift;
  unless (ref $uri) {
    require URI;
    $uri = URI->new ($uri);
    ## Some schemes do not have query part.
    eval q{ $uri->query (undef) if $uri->query =~ /^[0-9]{6,8}$/ };
    $uri->fragment (undef);
  }
  $uri = $uri->canonical;
  return unless $uri;
  for my $regex (&get_dont_record) {
    return if $uri =~ /$regex/;
  }
  my %list = get ($page);
  $list{ $uri }++;
  set ($page, \%list);
}
sub get ($) { split /"/, $main::database->meta (Referer => $_[0]) }
sub set ($%) {
  my $page = shift;
  my $list = shift;
  $main::database->meta (Referer => $page => join '"', %$list);
}

sub get_dont_record () {
  map {s/\$/\\\$/g; s/\@/\\\@/g; $_}
  grep !/^#/,
  split /[\x0D\x0A]+/, $main::database{RefererDontRecord};
}
sub get_site_name () {
  my @lines = grep /[^#]/, split /[\x0D\x0A]+/, $main::database{RefererSiteName};
  my @item;
  for (@lines) {
    next if /^#/;
    my ($uri, $name) = split /\s+/, $_, 2;
    $uri =~ s/\$/\\\$/g;  $uri =~ s/\@/\\\@/g;  $uri =~ s/\//\\\//g;
    $name =~ s!([()/\\])!\\$1!g;  $name =~ s/\$([0-9]+)/).__decode (\${$1}).q(/g;
    push @item, [$uri, qq(q($name))];
  }
  @item;
}

sub list_html ($) {
  my $page = shift;
  my %list = get ($page);
  my $r = '';
  my @name = get_site_name;
  for my $uri (sort keys %list) {
    my $title;
    for my $item (@name) {
      if ($uri =~ /$item->[0]/) {
        $title = $uri;
        eval qq{\$title =~ s/^.*$item->[0].*\$/$item->[1]/e}
          or die $@ ;#. qq{\$title =~ s/^.*$item->[0].*\$/$item->[1]/e};
        last;
      }
    }
    my $euri = main::escape ($uri);
    if ($title) {
      $r .= qq(<li>[$list{$uri}] <a href="$euri" title="URI: &lt;$euri&gt;">@{[main::escape ($title)]}</a></li>\n);
    } else {
      $r .= qq(<li>[$list{$uri}] &lt;<a href="$euri">$euri</a>&gt;</li>\n);
    }
  }
  $r ? qq(<ul>$r</ul>\n) : '';
}

sub __decode ($) {
  my $s = shift;
  $s =~ tr/+/ /;
  $s =~ s/%([0-9A-Fa-f][0-9A-Fa-f])/chr hex $1/ge;
  main::code_convert (\$s);
}

package wiki::useragent;
our $UseLog;

sub add ($) {
  my $s = shift;
  return unless length $s;
  return unless $UseLog;
  $s =~ s/([\x00-\x08\x0A-\x1F\x25\x7F-\xFF])/sprintf '%%%02X', unpack 'C', $1/ge;
  my %ua;
  for (split /\n/, $main::database{$main::PageName{UserAgentList}}) {
    if (/^-\[(\d+)\] (.+)$/) {
      my ($t, $n) = ($1, $2);
      $n =~ tr/\x0A\x0D//d;
      $ua{$n} = $t;
    }
  }
  $ua{$s}++;
  my $s = qq(#?SuikaWiki/0.9\n);
  for (sort {$ua{$a} <=> $ua{$b}} keys %ua) {
    $s .= sprintf qq(-[%d] %s\n), $ua{$_}, $_;
  }
  $main::database->STORE ($main::PageName{UserAgentList} => $s, -touch => 0);
}

package wiki::suikawikiconst;

sub to_hash ($;$) {
  my $page = shift;
  my $h = shift || {};
  my $val;
  for my $line (split /\n/, $page) {
    next if $line =~ /^#/;
    $line =~ tr/\x0A\x0D//d;
    if ($val && $line =~ s/^\s+//) {
      $h->{$val} .= length $h->{$val} ? "\n" . $line : $line;
    } elsif ($line =~ /^(.+):/) {
      $val = $1; $h->{$val} = '';
    }
  }
  $h;
}

package wiki::dummy;
sub mtime (@) {undef}
sub meta (@) {undef}
sub Yuki::YukiWikiDB2::meta (@) {undef}

package SuikaWiki::Plugin;
  our ($plugin_directory, %List, %Index, %Cache);
  push @main::INC, $plugin_directory.'/../..';

sub escape ($$) { main::escape ($_[1]) }
sub unescape ($$) { main::unescape ($_[1]) }
sub encode ($$) { main::encode ($_[1]) }
sub decode ($$) { main::decode ($_[1]) }
sub __get_datetime ($) { main::get_now () }
sub resource ($$;%) { shift; &main::Resource (@_) }
sub uri ($$) { $main::uri{$_[1]} }
sub new_index ($$) { ++$Index{$_[1]} }
sub user_agent_names ($) { $main::UA }
sub magic_and_content ($$) {
  my ($magic, $page) = ('', $_[1]);
  $magic = $1 if $page =~ s!^((?:\#\?|/\*|<\?)[^\x02\x0A\x0D]+)[\x02\x0A\x0D]+!!s;
  ($magic, $page);
}
sub formatter ($$) {
  &main::load_formatter ($_[1]);
  $main::fmt{$_[1]};
}
sub format_converter ($$$) {
  &main::load_formatter ('format');
  $main::fmt{format}->{($_[1]=~/([A-Za-z0-9]\S+)/?$1:'SuikaWiki/0.9').'_to_'.$_[2]}
  || $main::fmt{format}->{($_[1]=~/([A-Za-z0-9](?:(?!\/)\S)+)/?$1:'SuikaWiki').'_to_'.$_[2]};
}
sub cache ($$) {
  my $name = $_[1];
  unless (ref $Cache{$name}) {
    my %cache;
    tie (%cache, 'Yuki::YukiWikiCache', -file => $main::PathTo{CachePrefix}.$name);
    $Cache{$name} = \%cache;
  }
  $Cache{$name};
}

sub regist ($@) {
    my $pack = shift;
    for (@_) {
        push @{$List{$_}}, $pack;
    }
}

sub import_plugins () {
    opendir PDIR, $plugin_directory;
    my @plugin = grep {s/\.pm$//} readdir (PDIR);
    closedir PDIR;
    for (@plugin) {
        eval qq{ use SuikaWiki::Plugin::$_ } unless /[^A-Za-z0-9_]/;
        push @{$List{_all}}, qq(SuikaWiki::Plugin::$_);
    }
}

&import_plugins ();

package wiki::conneg;

## BUG: this parser isn't strict.
sub get_accept_lang (;$) {
  my $alang = shift || $main::ENV{HTTP_ACCEPT_LANGUAGE};
  my %alang = (ja => 0.0002, en => 0.0001);
  if ($UA =~ m#Mozilla/0\.#) {
    $alang{ja} = 0.00001;
  }
  my $i = 0.1;
  for (split /\s*,\s*/, $alang) {
    tr/\x09\x0A\x0D\x20//d;
    if (/((?:(?!;q=).)+)(?:;q="?([0-9.]+)"?)?/) {
      my $l = lc $1; $l =~ tr/\x22\x5C//d;
      $alang{$l} = (defined $2 ? $2 : 1.000)*1000;
      $alang{$l} += $i unless $alang{$l} == 0;
      $i -= 0.001;
    }
  }
  \%alang;
}

package wiki::resource;

sub get ($;\%) {
  my ($resname, $option) = @_;
  $option->{accept_language} ||= &wiki::conneg::get_accept_lang ();
  $option->{resource} ||= {};
  my $v;
  for my $lang (sort {$option->{accept_language}->{$b} <=> $option->{accept_language}->{$a}} grep {$option->{accept_language}->{$_}!=0} keys %{$option->{accept_language}}) {
    while (length $lang) {
      unless ($option->{accept_language}->{defined $option->{accept_language}->{$lang} ? $lang : '*'} == 0) {
        $option->{resource}->{$lang} ||= &wiki::suikawikiconst::to_hash ($main::database{'WikiResource:'.$lang});
        $v = $option->{resource}->{$lang}->{$resname};
        last if defined $v;
      }
      $lang =~ s/[^+-]*$//; $lang =~ s/[+-]$//;
    }
    last if defined $v;
  }
  defined $v ? $v : $resname;
}

package main;
&main;
exit 0;

1;
__END__
=head1 NAME

wiki.cgi --- SuikaWiki: Yet yet another WikiEngine

=head1 SEE ALSO

<IW:SuikaWiki:SuikaWiki>

=head1 AUTHORS

Hiroshi Yuki <hyuki@hyuki.com> <http://www.hyuki.com/yukiwiki/>

Makio Tsukamoto <http://digit.que.ne.jp/>

Wakaba <w@suika.fam.cx>

=head1 LICENSE

Copyright (C) 2000-2003 AUTHORS

This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

=cut