script/lib/suikawiki.pl

# -*- perl -*-
use strict;

package main;
our $VERSION = '2.'.do{my @r=(q$Revision: 1.4 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
binmode STDOUT; binmode STDIN;
use Fcntl;
require Yuki::YukiWikiCache;
require SuikaWiki::Name::Space;
require SuikaWiki::View;
require SuikaWiki::Plugin;
our %fmt;       ## formatter objects
our %embed_command = (
        form    => qr/\[\[\#form(?:\(([A-Za-z0-9-]+)\))?:'((?:[^'\\]|\\.)*)':'((?:[^'\\]|\\.)*)'(?::'((?:[^'\\]|\\.)*)')?\]\]/,
);
our ($modifier_dbtype,$url_cgi,%uri,%PathTo);
our (%PageName,$kanjicode,$lang);

my %form;
our %database;
our $database = bless {}, 'wiki::dummy';
our %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;
my $HAS_XML = SuikaWiki::Plugin->feature ('SuikaWiki::Markup::XML');
my $NS_XHTML1 = 'http://www.w3.org/1999/xhtml';

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';
  my $view_def = SuikaWiki::View->definition ($view);
  if (!$view_def->check ($o)) {
    print "Status: 406 Unsupported Media Type\n";
    $view = '-UnsupportedMediaType';
    $view_def = SuikaWiki::View->definition ($view);
  }
  my $media = $view_def->properties->{media};
  if ($view_def->properties->{xmedia} && $UA =~ /Gecko/) {
    $media = $view_def->properties->{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 ($view_def->as_string => $o, {formatter => $fmt{view}});
    print &code_convert (\$s => $kanjicode);
  } else {
    print $fmt{view}->replace ($view_def->as_string => $o, {formatter => $fmt{view}});
  }
}

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';
  my $view_def = SuikaWiki::View->definition ($option{-view});
  unless ($view_def->check ($o)) {
    print "Status: 406 Unsupported Media Type\n";
    $option{-view} = '-UnsupportedMediaType';
    $view_def = SuikaWiki::View->definition ($option{-view});
  }
  my $media = $view_def->properties->{media};
  if ($view_def->properties->{xmedia} && $UA =~ /Gecko/) {
    $media = $view_def->properties->{xmedia};
    $o->{media} = $media;
  }
  &print_header($option{-page}, -media => $media, o => $o, -goto => $option{-goto});
  print $fmt{view}->replace ($view_def->as_string => $o, {formatter => $fmt{view}});
}

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 =~ m!^application/(?:rdf|rss)\+xml$!) && ($UA =~ m#Gecko#);
        print qq{Content-Type: $type; charset=@{[&get_charset_name($kanjicode)]}\n};
    }
    #if ($main::ENV{HTTP_IF_MODIFIED_SINCE}) {
      ## TODO: IMS support
    #}
    
    ## TODO: more Vary: support
    print <<"EOD";
Vary: Negotiate,User-Agent,Accept-Language
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|&|&amp;|g;
    $s =~ s|<|&lt;|g;
    $s =~ s|>|&gt;|g;
    $s =~ s|"|&quot;|g;
    return $s;
}

sub unescape {
    my $s = shift;
    $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) = @_;
  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 ($option{-error_no_return}) {
    return undef;
  } elsif ($t =~ /HTML|xml/) {
    length $content ? '<pre>'.&escape($content).'</pre>' : '';
  } else {
    $content;
  }
}

{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') {
      if (lc ($main::ENV{CONTENT_TYPE}) eq 'application/x-www-form-urlencoded'
       || lc ($main::ENV{CONTENT_TYPE}) eq 'application/sgml-form-urlencoded') {
        read STDIN, $query, $main::ENV{CONTENT_LENGTH};
      } else {
        $form{mycmd} = '___unsupported_media_type___';
        $form{mypage} = $PageName{FrontPage};
        return;
      }
    }
    $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} = &code_convert (\$form{mypage}, $kanjicode);
    }
    $form{mypage} ||= $PageName{FrontPage};
    $form{mypage} =~ tr/\x00-\x1F\x7F//d;
    $form{mypage} = SuikaWiki::Name::Space::normalize_name ($form{mypage});
    $form{mycmd} ||= 'default';
    $form{mycmd} =~ tr/-/_/;

    # 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__|pi_)/, 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 =~ s/^[-=]*\s*\[\d+\]\s*//;
          $s =~ s/'''?//g;
          $s =~ s/\[[A-Z]+(?:\([^)]+\))?\[([^]]+)\](?:\s\[([^]]+)\])?\]/$1$2/g;
          $s =~ s/\[\[([^]]+)\]\]/$1/g;
        $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) = @_;
    return 0 unless SuikaWiki::Name::Space::validate_name ($page);
    return 0 if $page =~ /[\x00-\x20\[\]\x7F]/;
    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 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;
}

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);
            }
            $fmt{$t}->option (return_class => 'SuikaWiki::Markup::XML') if $HAS_XML;
        }
    }
}

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];
}

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 {$list{$b}<=>$list{$a}||$a cmp $b} 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/([^\x20-\x24\x26-\x7E])/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::dummy;
sub mtime (@) {undef}
sub meta (@) {undef}
sub Yuki::YukiWikiDB2::meta (@) {undef}

package main;
&SuikaWiki::Plugin::import_plugins ();
&main ();

=head1 NAME

lib/suikawiki.pl --- SuikaWiki transitional library

=head1 AUTHOR

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

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

Wakaba <w@suika.fam.cx>

=head1 LICENSE

Copyright AUTHORS 2000-2003

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

=cut

1; # $Date: 2003/04/29 10:41:07 $