script/lib/suikawiki.pl

use strict;
package main;
binmode STDOUT; binmode STDIN;
our $WIKI;
require SuikaWiki::Plugin;
our %embed_command = ( # Map, main
        form    => qr/\[\[\#form(?:\(([A-Za-z0-9-]+)\))?:'((?:[^'\\]|\\.)*)':'((?:[^'\\]|\\.)*)'(?::'((?:[^'\\]|\\.)*)')?\]\]/,
);
our $database = bless {}, 'wiki::dummy';
require SuikaWiki::Name::Space;
require SuikaWiki::SrcFormat;

# [to be obsolete]
sub do_comment {
    my ($content) = $main::database{$main::form{mypage}};
    my $default_name;   ## this code is not strict.
    $default_name = $1 if $content =~ /default-name="([^"]+)"/;
    my @time = gmtime (time);
    my $datestr = sprintf '[WEAK[%04d-%02d-%02d %02d:%02d:%02d +00:00]]', $time[5]+1900,$time[4]+1,@time[3,2,1,0];
    my $namestr = $main::form{myname} || $default_name || &Resource('WikiForm:WikiComment:DefaultName');
    ($namestr = '', $datestr = '') if $main::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 == $main::form{comment_index}) {
        if ($embed ne '[[#rcomment]]') {
          $embed = "- [$anchor] $datestr$namestr$main::form{mymsg}\n$embed";  $o = 1;
        } else {
          $embed .= "\n- [$anchor] $datestr$namestr$main::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$main::form{mymsg}\n";
    }
    $main::form{__comment_anchor_index} = $anchor;
    if ($main::form{mymsg} || $main::form{myname}) {
        $main::form{mymsg} = $content;
        $main::form{mytouch} = 'on';
        &do_write;
    } else {    ## Don't write
        #$main::form{mycmd} = 'default';
        #&do_view;
      die "No comment specified";
    }
}

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

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

# [to be obsolete] ->Message::MIME::Charset
sub code_convert {
  require Jcode;
  my ($contentref, $code, $srccode) = @_;
  $code ||= $WIKI->{config}->{charset}->{internal};
  for ($code, $srccode) {
    if    ($_ eq 'euc-jp') { $_ = 'euc' }
    elsif ($_ eq 'iso-2022-jp') { $_ = 'jis' }
    elsif ($_ eq 'utf-8') { $_ = 'utf8' }
    elsif ($_ eq 'shift_jis') { $_ = 'sjis' }
  }
  if ($code eq 'iso-8859-1') {
    return $$contentref; ## TODO:
  }
  $$contentref = Jcode->new ($contentref, $srccode)
    ## Normalize FULLWIDTH characters and IDEOGRAPHIC SPACE
                      ->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\xA1\xE4\xA1\xE3\xA1\xA1\xA2\xAF\xA2\xB0\xA2\xB2\xA2\xB1\xA1\xA1\xC0" => q(0-9A-Za-z&,.:;?!`^_/|()[]{}+$%#*@=>< '"~-))
                      ->tr (qq(\x8E\xDE\x8E\xDF) => qq(\xA1\xAB\xA1\xAC))
                      ->h2z
                      ->$code;
  return $$contentref;
}

# [to be obsolete] ->Message::Field::Date : Map
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];
}

# [obsolete] ->SuikaWiki::SrcFormat : SuikaWiki09 plugin
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/) {
    if (length $content) {
my $NS_XHTML1 = 'http://www.w3.org/1999/xhtml';
      my $r = Message::Markup::XML::Node->new
        (type => '#element', namespace_uri => $NS_XHTML1, local_name => 'pre');
      $r->append_text ($content);
      return $r;
    } else {
      return '';
    }
  } else {
    $content;
  }
}

package SuikaWiki::Plugin;
## Obsolete
sub magic_and_content ($$) {
  my ($magic, $page) = ('', $_[1]);
  $magic = $1 if $page =~ s!^((?:\#\?|/\*|<\?)[^\x02\x0A\x0D]+)[\x02\x0A\x0D]+!!s;
  ($magic, $page);
}

## Obsolete
sub get_data ($$$$;%) {
    my ($self, $prop, $key, %opt) = @_;
    ## TODO: common interface to WikiDB
    ## TODO: error recovering
    $main::WIKI->{db}->get ($prop => $key);
}

package wiki::transitional::uri_param;
require Tie::Hash;
our @ISA = 'Tie::Hash';

sub TIEHASH ($@) {
  bless {http => $_[1]}, $_[0];
}

sub FETCH ($$) {
  my ($self, $key) = @_;
  exists $self->{val}->{$key} ?
    $self->{val}->{$key}:
    $self->{http}->parameter ($key);
}

sub STORE ($$$) {
  my ($self, $key, $val) = @_;
  $self->{val}->{$key} = $val;
}

sub DELETE ($$) {
  my ($self, $key) = @_;
  $self->{val}->{$key} = undef;
}

sub EXISTS ($$) {
  my ($self, $key) = @_;
  exists $self->{val}->{$key} ?
    1:
    defined $self->{http}->parameter ($key);
}

package main;
our $VERSION = do{my @r=(q$Revision: 1.20 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};

    $WIKI->{implementation_version} = 'hcs'.$VERSION;
    
    ## Error output
    require SuikaWiki::Output::CGICarp;
    $SuikaWiki::Output::CGICarp::CUSTOM_REASON_TEXT
      = 'Internal WikiEngine Error';
    CGI::Carp::set_message (sub {
      my $msg = shift;
      #$msg =~ s/&/&amp;/g;
      #$msg =~ s/</&lt;/g;
      my $wiki_name_version = $WIKI->{implementation_name} .'/'. $WIKI->version;
      for ($wiki_name_version) { s/&/&amp;/g; s/</&lt;/g;
                                 s/([^\x20-\x7E])/sprintf '&#x%02X;',
                                                          ord $1/g; };
      print STDOUT <<EOH;
<!DOCTYPE html SYSTEM>
<title>500 Internal WikiEngine Error</title>
<h1>Internal WikiEngine Error</h1>
<p>$msg</p>
<address>$wiki_name_version</address>
EOH
    });
    
  push @{$WIKI->{event}->{setting_initial_variables}}, sub {
    my $wiki = shift;
    $wiki->{var}->{db}->{read_only}->{'#default'} = 1;
    
    require SuikaWiki::Input::HTTP;
    $wiki->{input} = SuikaWiki::Input::HTTP->new (wiki => $wiki);
    $wiki->{input}->{decoder}->{'#default'} = sub {
      my ($http, $s, $temp_params) = @_;
      return main::code_convert (\$s, $wiki->{config}->{charset}->{internal},
                                 lc (@{$temp_params->{_charset_}||[]}[0])
                                 || $wiki->{config}->{charset}->{uri_param});
    };
    $wiki->{var}->{client}->{user_agent_name}
      = $wiki->{input}->meta_variable ('HTTP_USER_AGENT');
    $wiki->{var}->{client}->{used_for_negotiate} = ['User-Agent'];
    my $dg = SuikaWiki::Plugin->module_package ('Downgrade');
    $dg->set_downgrade_flags ($wiki) if $dg;
    
    ## TODO: PATH_INFO support
    my $page = $wiki->{input}->meta_variable ('QUERY_STRING');
    if ($page && !(index ($page, '=') > -1)) {
      $page =~ tr/+/ /;
      $page =~ s/%([0-9A-Fa-f][0-9A-Fa-f])/pack 'C', hex $1/ge;
      $page = main::code_convert 
        (\$page, $wiki->{config}->{charset}->{internal},
         $wiki->{config}->{charset}->{uri_query});
    } else {
      $page = $wiki->{input}->parameter ('mypage');
    }
    

    ## TODO: SuikaWiki 3 WikiName
    $page =~ tr/\x00-\x20\x7F//d;
    $page = SuikaWiki::Name::Space::normalize_name ($page);
    if ($page) {
      $wiki->{var}->{page} = [split '//', $page];
    } else {
      $wiki->{var}->{page} = $wiki->{config}->{page}->{Default};
    }
 
    ## Mode
    my $mode = $wiki->{input}->parameter ('mode')
            || $wiki->{input}->parameter ('mycmd') ## for compatibility with
            || 'default';                          ## YukiWiki and SuikaWiki 2
    $mode =~ tr/-/_/;
    if ($mode eq 'default' || $mode =~ /[^0-9A-Za-z_]/) {
      ## BUG: this code is not strict
      my $cookie = $wiki->{input}->meta_variable ('HTTP_COOKIE');
      if ($cookie =~ /SelectedMode=([0-9A-Za-z_-]+)/) {
        $mode = $1; $mode =~ tr/-/_/;
      } else {
        $mode = 'read';
      }
      push @{$wiki->{var}->{client}->{used_for_negotiate}}, 'Cookie';
    }
    $wiki->{var}->{mode} = $mode;
  };

{
  my $error_report = sub {
    my ($wiki, $err) = @_;
      my $report = ($err->{-def}->{level} eq 'fatal' or
                    $err->{-def}->{level} eq 'stop' or
                    $wiki->{config}->{debug}->{db}) ? 1 : 0;
      if ($report and $wiki->{config}->{path_to}->{db__content__error_log}) {
        my $err_msg = caller (1).($err->{-method}? '->'.$err->{-method}: '').': '
                    .(defined $err->{-file}? $err->{-file} . ': ' : '')  
                    .(defined $err->{-prop}? $err->{-prop} . ': ' : '')
                    .(defined $err->{-key}? join ('//', @{$err->{-key}}).': ':'')
                    . $err->text;
        open LOG, '>>', $wiki->{config}->{path_to}->{db__content__error_log};
          print LOG scalar (gmtime), " @{[$$]} {$err->{-def}->{level}}: ",
                    $err_msg, "\n";
        close LOG;
      }
      SuikaWiki::Plugin->module_package ('WikiDB')
                       ->reporting_error ($err, $wiki) if $report;
      if ($err->{-def}->{level} eq 'fatal' or $err->{-def}->{level} eq 'stop') {
        $wiki->view_in_mode (mode => '-wdb--fatal-error');
        throw SuikaWiki::DB::Util::Error -type => 'ERROR_REPORTED';
      }
  };
  unshift @{$WIKI->{event}->{database_loaded}}, sub {
    my $wiki = shift;
    unshift @{$wiki->{db}->{event}->{error}}, sub {
      my ($db, $event) = @_;
      $error_report->($wiki, $event->{error});
      if ($event->{error}->{-type} eq 'INFO_DB_PROP_OPENED') {
        unshift @{$db->{prop}->{$event->{error}->{prop}}->{-db}
                     ->{event}->{error}}, sub {
          my ($db, $event) = @_;
          $error_report->($wiki, $event->{error});
        };
      }
    }; # database error
  }; # database_loaded
}
  
  if ($WIKI->{config}->{debug}->{general}) {
    $main::SIG{__WARN__} = sub {
    push @{$WIKI->{var}->{error}||=[]}, {
        description => Message::Markup::XML::Node->new
                                         (type => '#text',
                                          value => $_[0]),
      };
    };
  }
    
  push @{$WIKI->{event}->{view_in_mode}}, sub {
    my ($wiki, $opt) = @_;
    my $arg = {condition => {mode => $opt->{mode} || '-error',
                             output => 'http-cgi',
                             http_method => $opt->{method} || 'GET'}};
    my $viewobj = $wiki->{view}->instantiate ($opt->{mode} || '-error', $arg);
    if (ref $viewobj) {
      $viewobj->main ($arg);
    } elsif ($opt->{mode} ne '-error') {
      $wiki->view_in_mode (mode => '-error', method => 'GET');
        ## TODO: cache control for non-GET
    } else {
      die "Some error happens.  Additionally, error reporting mode not defined";
    }
  };

  $WIKI->init_plugin;     ## WikiPlugin manager
  $WIKI->init_view;       ## WikiView manager
  $WIKI->{view}->register_common_modes;

## Error handlers
use SuikaWiki::DB::Util::Error;
my $catcher = catch SuikaWiki::DB::Util::Error with {
  my $err = shift;
  exit if $err->{-type} eq 'ERROR_REPORTED';
  $err->throw;
} catch SuikaWiki::View::Implementation::error with {
  my $err = shift;
  exit if $err->{-type} eq 'ERROR_REPORTED';
  $err->throw;
};

$WIKI->{config}->{catch}->{formatter_view}
  = catch Message::Util::Formatter::error with {
  my $err = shift;
  my $wiki = $err->{-option}->{param}->{wiki};
  SuikaWiki::Plugin->module_package ('Error')
                   ->reporting_formatting_template_error ($err, $wiki);
  $wiki->view_in_mode (mode => '-error', method => 'GET');
  throw SuikaWiki::View::Implementation::error
    -type => 'ERROR_REPORTED';
};

$WIKI->{config}->{catch}->{formatter_view_error}
  = catch Message::Util::Formatter::error with {
  my $err = shift;
  my $wiki = $err->{-option}->{param}->{wiki};
  SuikaWiki::Plugin->module_package ('Error')
                   ->reporting_formatting_template_error ($err, $wiki);
  $wiki->view_in_mode (mode => '-error-error', method => 'GET');
  throw SuikaWiki::View::Implementation::error
    -type => 'ERROR_REPORTED';
};

## Main
$WIKI->init_variables;  ## Per-session variables
try {
  $WIKI->view_in_mode
    (mode => $WIKI->{var}->{mode},
     method => $WIKI->{input}->meta_variable ('REQUEST_METHOD'));
} $catcher;
exit;
END {
  try {
    $WIKI->exit;
  } $catcher;
};

=head1 NAME

lib/suikawiki.pl --- SuikaWiki : WikiEngine driver for HTTP CGI

=head1 LICENSE

Copyright 2000-2003 Wakaba <w@suika.fam.cx>, et. al

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

=cut

1; # $Date: 2003/12/06 02:22:10 $
1	wakaba	1.1	use strict;
2			package main;
3			binmode STDOUT; binmode STDIN;
4	wakaba	1.18	our $WIKI;
5	wakaba	1.1	require SuikaWiki::Plugin;
6	wakaba	1.18	our %embed_command = ( # Map, main
7	wakaba	1.1	form => qr/\[\[\#form(?:\(([A-Za-z0-9-]+)\))?:'((?:[^'\\]\|\\.))':'((?:[^'\\]\|\\.))'(?::'((?:[^'\\]\|\\.)*)')?\]\]/,
8			);
9			our $database = bless {}, 'wiki::dummy';
10	w	1.9	require SuikaWiki::Name::Space;
11	wakaba	1.18	require SuikaWiki::SrcFormat;
12	wakaba	1.1
13	w	1.9	# [to be obsolete]
14	wakaba	1.1	sub do_comment {
15	wakaba	1.15	my ($content) = $main::database{$main::form{mypage}};
16	wakaba	1.1	my $default_name; ## this code is not strict.
17			$default_name = $1 if $content =~ /default-name="([^"]+)"/;
18	w	1.9	my @time = gmtime (time);
19			my $datestr = sprintf '[WEAK[%04d-%02d-%02d %02d:%02d:%02d +00:00]]', $time[5]+1900,$time[4]+1,@time[3,2,1,0];
20	wakaba	1.15	my $namestr = $main::form{myname} \|\| $default_name \|\| &Resource('WikiForm:WikiComment:DefaultName');
21			($namestr = '', $datestr = '') if $main::form{myname} eq 'nodate';
22	wakaba	1.1	if ($namestr =~ /^(?:>>)?[0-9]/) {
23			$namestr = qq( ''$namestr'': );
24			} elsif (length $namestr) {
25			$namestr = qq( ''[[$namestr]]'': );
26			}
27			my $anchor = &get_new_anchor_index ($content);
28			my $i = 1; my $o = 0;
29			$content =~ s{(\[\[\#r?comment\]\])}{
30			my $embed = $1;
31	wakaba	1.15	if ($i == $main::form{comment_index}) {
32	wakaba	1.1	if ($embed ne '[[#rcomment]]') {
33	wakaba	1.15	$embed = "- [$anchor] $datestr$namestr$main::form{mymsg}\n$embed"; $o = 1;
34	wakaba	1.1	} else {
35	wakaba	1.15	$embed .= "\n- [$anchor] $datestr$namestr$main::form{mymsg}"; $o = 1;
36	wakaba	1.1	}
37			}
38			$i++; $embed;
39			}ge;
40			unless ($o) {
41			$content = "#?SuikaWiki/0.9\n\n" unless $content;
42			$content .= "\n" unless $content =~ /\n$/s;
43	wakaba	1.15	$content .= "- [$anchor] $datestr$namestr$main::form{mymsg}\n";
44	wakaba	1.1	}
45	wakaba	1.15	$main::form{__comment_anchor_index} = $anchor;
46			if ($main::form{mymsg} \|\| $main::form{myname}) {
47			$main::form{mymsg} = $content;
48			$main::form{mytouch} = 'on';
49	wakaba	1.1	&do_write;
50			} else { ## Don't write
51	wakaba	1.15	#$main::form{mycmd} = 'default';
52			#&do_view;
53			die "No comment specified";
54	wakaba	1.1	}
55			}
56
57	w	1.9	# [move to SuikaWiki::Plugin::WikiForm]
58	wakaba	1.1	sub get_new_anchor_index ($) {
59			my $content = shift;
60			my $anchor = 0;
61			$content =~ s/^(?:[-=]+\s*)?\[([0-9]+)\]/$anchor = $1 if $1 > $anchor; $&/mge;
62			$anchor + 1;
63			}
64
65	w	1.9	# [move to SuikaWiki::Plugin::WikiForm]
66	wakaba	1.1	sub do_wikiform {
67	wakaba	1.15	my $content = $main::database{$main::form{mypage}};
68	wakaba	1.1	my $anchor = &get_new_anchor_index ($content);
69			my $write = 0;
70			my $i = 1;
71			$content =~ s{$embed_command{form}}{
72			my ($embed, $wfname, $template, $option) = ($&, $1, $3, $4);
73	wakaba	1.15	if (($wfname && $wfname eq $main::form{wikiform_targetform})
74			\|\| $i == $main::form{wikiform_index}) {
75	wakaba	1.1	$template =~ s/\\([\\'])/$1/g;
76			$option =~ s/\\([\\'])/$1/g;
77			my $param = bless {depth=>10}, 'SuikaWiki::Plugin';
78	wakaba	1.15	$param->{page} = $main::form{mypage};
79	wakaba	1.1	$param->{form_index} = $i;
80			$param->{form_name} = $wfname;
81			$param->{anchor_index} = $anchor;
82	wakaba	1.15	$param->{argv} = \%main::form;
83	wakaba	1.1	$param->{default_name} = $1 if $content =~ /default-name="([^"]+)"/;
84			$param->{default_name} \|\|= &Resource('WikiForm:WikiComment:DefaultName');
85	w	1.9	SuikaWiki::Plugin->formatter ('form_option')->replace ($option, $param);
86	wakaba	1.1	my $t = 1;
87			for (keys %{$param->{require}\|\|{}}) {
88			(undef $t, last) unless length $param->{argv}->{'wikiform__'.$_};
89			}
90	w	1.9	$t = SuikaWiki::Plugin->formatter ('form_template')->replace ($template, $param) if $t;
91	wakaba	1.1	if (length $t) {
92			if ($param->{output}->{reverse}) {
93			$embed .= "\n" . $t;
94			} else {
95			$embed = $t . "\n" . $embed;
96			}
97			$write = 1;
98	wakaba	1.15	$main::form{__comment_anchor_index} = $anchor
99	wakaba	1.1	if $param->{anchor_index_}; ## $anchor is used!
100			}
101	wakaba	1.15	$main::form{__wikiform_anchor_index} = $i;
102			undef $main::form{wikiform_targetform}; ## Make sure never to match
103			undef $main::form{wikiform_index}; ## with WikiForm in rest of page!
104	wakaba	1.1	}
105			$i++; $embed;
106			}ge;
107			unless ($write) {
108			#$content = "#?SuikaWiki/0.9\n\n" unless $content;
109			#$content .= "\n" unless $content =~ /\n$/s;
110			#
111			}
112			if ($write) {
113	wakaba	1.15	$main::form{mymsg} = $content;
114			$main::form{mytouch} = 'on';
115	wakaba	1.1	&do_write;
116			} else { ## Don't write!
117	wakaba	1.15	#$main::form{mycmd} = 'default';
118			#&do_view;
119			die "No content specified";
120	wakaba	1.1	}
121			}
122
123	w	1.9	# [to be obsolete] ->Message::MIME::Charset
124	wakaba	1.1	sub code_convert {
125			require Jcode;
126	wakaba	1.15	my ($contentref, $code, $srccode) = @_;
127			$code \|\|= $WIKI->{config}->{charset}->{internal};
128			for ($code, $srccode) {
129			if ($_ eq 'euc-jp') { $_ = 'euc' }
130			elsif ($_ eq 'iso-2022-jp') { $_ = 'jis' }
131			elsif ($_ eq 'utf-8') { $_ = 'utf8' }
132			elsif ($_ eq 'shift_jis') { $_ = 'sjis' }
133			}
134	wakaba	1.19	if ($code eq 'iso-8859-1') {
135			return $$contentref; ## TODO:
136			}
137	wakaba	1.15	$$contentref = Jcode->new ($contentref, $srccode)
138			## Normalize FULLWIDTH characters and IDEOGRAPHIC SPACE
139			->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\xA1\xE4\xA1\xE3\xA1\xA1\xA2\xAF\xA2\xB0\xA2\xB2\xA2\xB1\xA1\xA1\xC0" => q(0-9A-Za-z&,.:;?!`^_/\|()[]{}+$%#*@=>< '"~-))
140			->tr (qq(\x8E\xDE\x8E\xDF) => qq(\xA1\xAB\xA1\xAC))
141			->h2z
142			->$code;
143			return $$contentref;
144	wakaba	1.1	}
145
146	wakaba	1.18	# [to be obsolete] ->Message::Field::Date : Map
147	wakaba	1.1	sub _rfc3339_date ($) {
148			my @time = gmtime (shift);
149			sprintf '%04d-%02d-%02dT%02d:%02d:%02d+00:00', $time[5]+1900,$time[4]+1,@time[3,2,1,0];
150			}
151
152	wakaba	1.15	# [obsolete] ->SuikaWiki::SrcFormat : SuikaWiki09 plugin
153	w	1.9	sub convert_format ($$$;%) {
154			my ($content, $d => $t, %option) = @_;
155			my $f = SuikaWiki::Plugin->format_converter ($d => $t);
156			if (ref $f) {
157			$option{content} = $content;
158			$option{from} = $d;
159			$option{to} = $t;
160			&$f ({}, bless (\%option, 'SuikaWiki::Plugin'));
161			} elsif ($option{-error_no_return}) {
162			return undef;
163			} elsif ($t =~ /HTML\|xml/) {
164			if (length $content) {
165	wakaba	1.18	my $NS_XHTML1 = 'http://www.w3.org/1999/xhtml';
166	wakaba	1.19	my $r = Message::Markup::XML::Node->new
167			(type => '#element', namespace_uri => $NS_XHTML1, local_name => 'pre');
168	w	1.9	$r->append_text ($content);
169			return $r;
170			} else {
171			return '';
172			}
173			} else {
174			$content;
175			}
176			}
177
178	wakaba	1.20	package SuikaWiki::Plugin;
179			## Obsolete
180			sub magic_and_content ($$) {
181			my ($magic, $page) = ('', $_[1]);
182			$magic = $1 if $page =~ s!^((?:\#\?\|/\*\|<\?)[^\x02\x0A\x0D]+)[\x02\x0A\x0D]+!!s;
183			($magic, $page);
184			}
185
186			## Obsolete
187			sub get_data ($$$$;%) {
188			my ($self, $prop, $key, %opt) = @_;
189			## TODO: common interface to WikiDB
190			## TODO: error recovering
191			$main::WIKI->{db}->get ($prop => $key);
192			}
193
194	wakaba	1.15	package wiki::transitional::uri_param;
195			require Tie::Hash;
196			our @ISA = 'Tie::Hash';
197
198			sub TIEHASH ($@) {
199			bless {http => $_[1]}, $_[0];
200			}
201
202			sub FETCH ($$) {
203			my ($self, $key) = @_;
204			exists $self->{val}->{$key} ?
205			$self->{val}->{$key}:
206			$self->{http}->parameter ($key);
207			}
208
209			sub STORE ($$$) {
210			my ($self, $key, $val) = @_;
211			$self->{val}->{$key} = $val;
212			}
213
214			sub DELETE ($$) {
215			my ($self, $key) = @_;
216			$self->{val}->{$key} = undef;
217			}
218
219			sub EXISTS ($$) {
220			my ($self, $key) = @_;
221			exists $self->{val}->{$key} ?
222			1:
223			defined $self->{http}->parameter ($key);
224			}
225	w	1.9
226	wakaba	1.1	package main;
227	wakaba	1.21	our $VERSION = do{my @r=(q$Revision: 1.20 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
228
229			$WIKI->{implementation_version} = 'hcs'.$VERSION;
230	wakaba	1.15
231			## Error output
232			require SuikaWiki::Output::CGICarp;
233			$SuikaWiki::Output::CGICarp::CUSTOM_REASON_TEXT
234			= 'Internal WikiEngine Error';
235			CGI::Carp::set_message (sub {
236			my $msg = shift;
237			#$msg =~ s/&/&/g;
238			#$msg =~ s/</</g;
239	wakaba	1.21	my $wiki_name_version = $WIKI->{implementation_name} .'/'. $WIKI->version;
240	wakaba	1.15	for ($wiki_name_version) { s/&/&/g; s/</</g;
241			s/([^\x20-\x7E])/sprintf '&#x%02X;',
242			ord $1/g; };
243	wakaba	1.18	print STDOUT <<EOH;
244	wakaba	1.15	<!DOCTYPE html SYSTEM>
245			<title>500 Internal WikiEngine Error</title>
246			<h1>Internal WikiEngine Error</h1>
247			<p>$msg</p>
248			<address>$wiki_name_version</address>
249			EOH
250			});
251
252	wakaba	1.21	push @{$WIKI->{event}->{setting_initial_variables}}, sub {
253			my $wiki = shift;
254	wakaba	1.15	$wiki->{var}->{db}->{read_only}->{'#default'} = 1;
255
256			require SuikaWiki::Input::HTTP;
257	wakaba	1.21	$wiki->{input} = SuikaWiki::Input::HTTP->new (wiki => $wiki);
258	wakaba	1.15	$wiki->{input}->{decoder}->{'#default'} = sub {
259			my ($http, $s, $temp_params) = @_;
260	wakaba	1.18	return main::code_convert (\$s, $wiki->{config}->{charset}->{internal},
261			lc (@{$temp_params->{_charset_}\|\|[]}[0])
262	wakaba	1.15	\|\| $wiki->{config}->{charset}->{uri_param});
263			};
264			$wiki->{var}->{client}->{user_agent_name}
265			= $wiki->{input}->meta_variable ('HTTP_USER_AGENT');
266			$wiki->{var}->{client}->{used_for_negotiate} = ['User-Agent'];
267	wakaba	1.21	my $dg = SuikaWiki::Plugin->module_package ('Downgrade');
268			$dg->set_downgrade_flags ($wiki) if $dg;
269	wakaba	1.15
270			## TODO: PATH_INFO support
271			my $page = $wiki->{input}->meta_variable ('QUERY_STRING');
272			if ($page && !(index ($page, '=') > -1)) {
273			$page =~ tr/+/ /;
274			$page =~ s/%([0-9A-Fa-f][0-9A-Fa-f])/pack 'C', hex $1/ge;
275			$page = main::code_convert
276	wakaba	1.18	(\$page, $wiki->{config}->{charset}->{internal},
277	wakaba	1.15	$wiki->{config}->{charset}->{uri_query});
278			} else {
279			$page = $wiki->{input}->parameter ('mypage');
280			}
281
282
283			## TODO: SuikaWiki 3 WikiName
284			$page =~ tr/\x00-\x20\x7F//d;
285			$page = SuikaWiki::Name::Space::normalize_name ($page);
286			if ($page) {
287			$wiki->{var}->{page} = [split '//', $page];
288			} else {
289			$wiki->{var}->{page} = $wiki->{config}->{page}->{Default};
290			}
291
292			## Mode
293			my $mode = $wiki->{input}->parameter ('mode')
294			\|\| $wiki->{input}->parameter ('mycmd') ## for compatibility with
295			\|\| 'default'; ## YukiWiki and SuikaWiki 2
296			$mode =~ tr/-/_/;
297			if ($mode eq 'default' \|\| $mode =~ /[^0-9A-Za-z_]/) {
298			## BUG: this code is not strict
299			my $cookie = $wiki->{input}->meta_variable ('HTTP_COOKIE');
300			if ($cookie =~ /SelectedMode=([0-9A-Za-z_-]+)/) {
301			$mode = $1; $mode =~ tr/-/_/;
302			} else {
303			$mode = 'read';
304			}
305			push @{$wiki->{var}->{client}->{used_for_negotiate}}, 'Cookie';
306			}
307			$wiki->{var}->{mode} = $mode;
308			};
309	wakaba	1.21
310			{
311			my $error_report = sub {
312			my ($wiki, $err) = @_;
313			my $report = ($err->{-def}->{level} eq 'fatal' or
314			$err->{-def}->{level} eq 'stop' or
315			$wiki->{config}->{debug}->{db}) ? 1 : 0;
316			if ($report and $wiki->{config}->{path_to}->{db__content__error_log}) {
317			my $err_msg = caller (1).($err->{-method}? '->'.$err->{-method}: '').': '
318			.(defined $err->{-file}? $err->{-file} . ': ' : '')
319			.(defined $err->{-prop}? $err->{-prop} . ': ' : '')
320			.(defined $err->{-key}? join ('//', @{$err->{-key}}).': ':'')
321			. $err->text;
322			open LOG, '>>', $wiki->{config}->{path_to}->{db__content__error_log};
323			print LOG scalar (gmtime), " @{[$$]} {$err->{-def}->{level}}: ",
324			$err_msg, "\n";
325			close LOG;
326			}
327			SuikaWiki::Plugin->module_package ('WikiDB')
328			->reporting_error ($err, $wiki) if $report;
329			if ($err->{-def}->{level} eq 'fatal' or $err->{-def}->{level} eq 'stop') {
330			$wiki->view_in_mode (mode => '-wdb--fatal-error');
331			throw SuikaWiki::DB::Util::Error -type => 'ERROR_REPORTED';
332			}
333			};
334			unshift @{$WIKI->{event}->{database_loaded}}, sub {
335			my $wiki = shift;
336			unshift @{$wiki->{db}->{event}->{error}}, sub {
337			my ($db, $event) = @_;
338			$error_report->($wiki, $event->{error});
339			if ($event->{error}->{-type} eq 'INFO_DB_PROP_OPENED') {
340			unshift @{$db->{prop}->{$event->{error}->{prop}}->{-db}
341			->{event}->{error}}, sub {
342			my ($db, $event) = @_;
343			$error_report->($wiki, $event->{error});
344			};
345			}
346			}; # database error
347			}; # database_loaded
348			}
349	wakaba	1.15
350	wakaba	1.21	if ($WIKI->{config}->{debug}->{general}) {
351			$main::SIG{__WARN__} = sub {
352			push @{$WIKI->{var}->{error}\|\|=[]}, {
353			description => Message::Markup::XML::Node->new
354			(type => '#text',
355			value => $_[0]),
356			};
357			};
358			}
359
360	wakaba	1.18	push @{$WIKI->{event}->{view_in_mode}}, sub {
361			my ($wiki, $opt) = @_;
362			my $arg = {condition => {mode => $opt->{mode} \|\| '-error',
363			output => 'http-cgi',
364			http_method => $opt->{method} \|\| 'GET'}};
365			my $viewobj = $wiki->{view}->instantiate ($opt->{mode} \|\| '-error', $arg);
366			if (ref $viewobj) {
367			$viewobj->main ($arg);
368			} elsif ($opt->{mode} ne '-error') {
369			$wiki->view_in_mode (mode => '-error', method => 'GET');
370			## TODO: cache control for non-GET
371			} else {
372			die "Some error happens. Additionally, error reporting mode not defined";
373			}
374			};
375
376	wakaba	1.21	$WIKI->init_plugin; ## WikiPlugin manager
377			$WIKI->init_view; ## WikiView manager
378	wakaba	1.14	$WIKI->{view}->register_common_modes;
379
380	wakaba	1.19	## Error handlers
381			use SuikaWiki::DB::Util::Error;
382			my $catcher = catch SuikaWiki::DB::Util::Error with {
383			my $err = shift;
384	wakaba	1.21	exit if $err->{-type} eq 'ERROR_REPORTED';
385			$err->throw;
386	wakaba	1.19	} catch SuikaWiki::View::Implementation::error with {
387			my $err = shift;
388	wakaba	1.21	exit if $err->{-type} eq 'ERROR_REPORTED';
389	wakaba	1.20	$err->throw;
390	wakaba	1.19	};
391
392			$WIKI->{config}->{catch}->{formatter_view}
393			= catch Message::Util::Formatter::error with {
394			my $err = shift;
395			my $wiki = $err->{-option}->{param}->{wiki};
396			SuikaWiki::Plugin->module_package ('Error')
397			->reporting_formatting_template_error ($err, $wiki);
398			$wiki->view_in_mode (mode => '-error', method => 'GET');
399			throw SuikaWiki::View::Implementation::error
400	wakaba	1.21	-type => 'ERROR_REPORTED';
401	wakaba	1.19	};
402
403			$WIKI->{config}->{catch}->{formatter_view_error}
404			= catch Message::Util::Formatter::error with {
405			my $err = shift;
406			my $wiki = $err->{-option}->{param}->{wiki};
407			SuikaWiki::Plugin->module_package ('Error')
408			->reporting_formatting_template_error ($err, $wiki);
409			$wiki->view_in_mode (mode => '-error-error', method => 'GET');
410			throw SuikaWiki::View::Implementation::error
411	wakaba	1.21	-type => 'ERROR_REPORTED';
412	wakaba	1.19	};
413
414			## Main
415	wakaba	1.21	$WIKI->init_variables; ## Per-session variables
416	wakaba	1.19	try {
417	wakaba	1.18	$WIKI->view_in_mode
418			(mode => $WIKI->{var}->{mode},
419			method => $WIKI->{input}->meta_variable ('REQUEST_METHOD'));
420	wakaba	1.19	} $catcher;
421	wakaba	1.14	exit;
422			END {
423	wakaba	1.19	try {
424			$WIKI->exit;
425			} $catcher;
426			};
427	wakaba	1.1
428			=head1 NAME
429
430	wakaba	1.18	lib/suikawiki.pl --- SuikaWiki : WikiEngine driver for HTTP CGI
431	wakaba	1.1
432			=head1 LICENSE
433
434	wakaba	1.18	Copyright 2000-2003 Wakaba <w@suika.fam.cx>, et. al
435	wakaba	1.1
436			This program is free software; you can redistribute it and/or
437			modify it under the same terms as Perl itself.
438
439			=cut
440
441	wakaba	1.21	1; # $Date: 2003/12/06 02:22:10 $