| 1 |
=head1 NAME |
| 2 |
|
| 3 |
suikawiki.pl - SuikaWiki Driver for HTTP CGI Script |
| 4 |
|
| 5 |
=cut |
| 6 |
|
| 7 |
use strict; |
| 8 |
package main; |
| 9 |
our $WIKI; |
| 10 |
package wiki::driver::http; |
| 11 |
## -- Version of WikiDriver -- |
| 12 |
our $VERSION = do{my @r=(q$Revision: 1.21 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r}; |
| 13 |
$WIKI->{implementation_version} = 'hcs'.$VERSION; |
| 14 |
|
| 15 |
## -- Dying Message as HTTP Response -- |
| 16 |
require SuikaWiki::Output::CGICarp; |
| 17 |
$SuikaWiki::Output::CGICarp::CUSTOM_REASON_TEXT |
| 18 |
= 'Internal WikiEngine Error'; |
| 19 |
CGI::Carp::set_message (sub { |
| 20 |
my $msg = shift; |
| 21 |
#$msg =~ s/&/&/g; |
| 22 |
#$msg =~ s/</</g; |
| 23 |
my $wiki_name_version = $WIKI->{implementation_name} .'/'. $WIKI->version; |
| 24 |
my $trace = Carp::longmess (); |
| 25 |
for ($trace, $wiki_name_version) |
| 26 |
{ s/&/&/g; s/</</g; |
| 27 |
s/([^\x20-\x7E])/sprintf '&#x%02X;', ord $1/ge; }; |
| 28 |
print STDOUT <<EOH; |
| 29 |
<!DOCTYPE html SYSTEM> |
| 30 |
<title>500 Internal WikiEngine Error</title> |
| 31 |
<h1>Internal WikiEngine Error</h1> |
| 32 |
<p>$msg</p> |
| 33 |
<p>$trace</p> |
| 34 |
<address>$wiki_name_version</address> |
| 35 |
EOH |
| 36 |
}); |
| 37 |
|
| 38 |
## -- Required Modules -- |
| 39 |
use SuikaWiki::DB::Util::Error; |
| 40 |
require SuikaWiki::Plugin; |
| 41 |
require SuikaWiki::Name::Space; |
| 42 |
require SuikaWiki::SrcFormat; |
| 43 |
|
| 44 |
## -- Transitional Functions -- |
| 45 |
|
| 46 |
# [to be obsolete] ->Message::MIME::Charset |
| 47 |
sub main::code_convert { |
| 48 |
require Jcode; |
| 49 |
my ($contentref, $code, $srccode) = @_; |
| 50 |
$code ||= $WIKI->{config}->{charset}->{internal}; |
| 51 |
for ($code, $srccode) { |
| 52 |
if ($_ eq 'euc-jp') { $_ = 'euc' } |
| 53 |
elsif ($_ eq 'iso-2022-jp') { $_ = 'jis' } |
| 54 |
elsif ($_ eq 'utf-8') { $_ = 'utf8' } |
| 55 |
elsif ($_ eq 'shift_jis') { $_ = 'sjis' } |
| 56 |
} |
| 57 |
if ($code eq 'iso-8859-1') { |
| 58 |
return $$contentref; ## TODO: |
| 59 |
} |
| 60 |
$$contentref = Jcode->new ($contentref, $srccode) |
| 61 |
## Normalize FULLWIDTH characters and IDEOGRAPHIC SPACE |
| 62 |
->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&,.:;?!`^_/|()[]{}+$%#*@=>< '"~-)) |
| 63 |
->tr (qq(\x8E\xDE\x8E\xDF) => qq(\xA1\xAB\xA1\xAC)) |
| 64 |
->h2z |
| 65 |
->$code; |
| 66 |
return $$contentref; |
| 67 |
} |
| 68 |
|
| 69 |
# [to be obsolete] ->Message::Field::Date : Map |
| 70 |
sub main::_rfc3339_date ($) { |
| 71 |
my @time = gmtime (shift); |
| 72 |
sprintf '%04d-%02d-%02dT%02d:%02d:%02d+00:00', $time[5]+1900,$time[4]+1,@time[3,2,1,0]; |
| 73 |
} |
| 74 |
|
| 75 |
## Obsolete |
| 76 |
sub SuikaWiki::Plugin::get_data ($$$$;%) { |
| 77 |
my ($self, $prop, $key, %opt) = @_; |
| 78 |
## TODO: common interface to WikiDB |
| 79 |
## TODO: error recovering |
| 80 |
$main::WIKI->{db}->get ($prop => $key); |
| 81 |
} |
| 82 |
|
| 83 |
## -- Initializing WikiPlugin -- |
| 84 |
|
| 85 |
$WIKI->init_plugin; ## WikiPlugin manager |
| 86 |
|
| 87 |
## -- Initializing WikiView -- |
| 88 |
|
| 89 |
$WIKI->init_view; ## WikiView manager |
| 90 |
$WIKI->{view}->register_common_modes; |
| 91 |
|
| 92 |
## WikiView manager error handler |
| 93 |
push @{$WIKI->{event}->{view_error}}, sub { |
| 94 |
my ($wiki, $event) = @_; |
| 95 |
SuikaWiki::Plugin->module_package ('Error') |
| 96 |
->report_error_simple |
| 97 |
($wiki, WikiView => $event->{error}->text, |
| 98 |
-trace => 1) |
| 99 |
if $event->{error}->{-def}->{level} eq 'fatal' |
| 100 |
or $wiki->{config}->{debug}->{view}; |
| 101 |
unless ($event->{error}->{-def}->{level} eq 'fatal' |
| 102 |
or $event->{error}->{-def}->{level} eq 'stop') { |
| 103 |
$event->{cancel} = 1; |
| 104 |
} |
| 105 |
}; |
| 106 |
|
| 107 |
## "view_in_mode" method definition |
| 108 |
push @{$WIKI->{event}->{view_in_mode}}, sub { |
| 109 |
my ($wiki, $opt) = @_; |
| 110 |
my $arg = {condition => {mode => $opt->{mode} || '-error', |
| 111 |
output => 'http-cgi', |
| 112 |
http_method => $opt->{method} || 'GET'}}; |
| 113 |
my $viewobj = $wiki->{view}->instantiate ($opt->{mode} || '-error', $arg); |
| 114 |
if (ref $viewobj) { |
| 115 |
$viewobj->main ($arg); |
| 116 |
} elsif ($opt->{mode} ne '-error') { |
| 117 |
report SuikaWiki::View::Implementation::error |
| 118 |
-type => 'WARN_VIEW_NOT_DEFINED', condition => $arg->{condition}, |
| 119 |
-object => $wiki->{view}, method => 'view_in_mode'; |
| 120 |
$wiki->view_in_mode (mode => '-error', method => 'GET'); |
| 121 |
## TODO: cache control for non-GET |
| 122 |
} else { |
| 123 |
die "Some error occured. Additionally, error reporting mode not defined"; |
| 124 |
} |
| 125 |
}; |
| 126 |
|
| 127 |
## WikiView formatting template error handler |
| 128 |
$WIKI->{config}->{catch}->{formatter_view} |
| 129 |
= catch Message::Util::Formatter::error with { |
| 130 |
my $err = shift; |
| 131 |
my $wiki = $err->{-option}->{param}->{wiki}; |
| 132 |
SuikaWiki::Plugin->module_package ('Error') |
| 133 |
->reporting_formatting_template_error ($err, $wiki); |
| 134 |
$wiki->view_in_mode (mode => '-error', method => 'GET'); |
| 135 |
throw SuikaWiki::View::Implementation::error |
| 136 |
-type => 'ERROR_REPORTED'; |
| 137 |
}; |
| 138 |
|
| 139 |
## WikiView formatting template error handler (occured in "-error" mode) |
| 140 |
$WIKI->{config}->{catch}->{formatter_view_error} |
| 141 |
= catch Message::Util::Formatter::error with { |
| 142 |
my $err = shift; |
| 143 |
my $wiki = $err->{-option}->{param}->{wiki}; |
| 144 |
SuikaWiki::Plugin->module_package ('Error') |
| 145 |
->reporting_formatting_template_error ($err, $wiki); |
| 146 |
$wiki->view_in_mode (mode => '-error-error', method => 'GET'); |
| 147 |
throw SuikaWiki::View::Implementation::error |
| 148 |
-type => 'ERROR_REPORTED'; |
| 149 |
}; |
| 150 |
|
| 151 |
## -- WikiDatabase Error Reporting -- |
| 152 |
{ |
| 153 |
my $error_report = sub { |
| 154 |
my ($wiki, $err) = @_; |
| 155 |
my $report = ($err->{-def}->{level} eq 'fatal' or |
| 156 |
$err->{-def}->{level} eq 'stop' or |
| 157 |
$wiki->{config}->{debug}->{db}) ? 1 : 0; |
| 158 |
if ($report and $wiki->{config}->{path_to}->{db__content__error_log}) { |
| 159 |
my $err_msg = caller (1).($err->{-method}? '->'.$err->{-method}: '').': ' |
| 160 |
.(defined $err->{-file}? $err->{-file} . ': ' : '') |
| 161 |
.(defined $err->{-prop}? $err->{-prop} . ': ' : '') |
| 162 |
.(defined $err->{-key}? join ('//', @{$err->{-key}}).': ':'') |
| 163 |
. $err->text; |
| 164 |
open LOG, '>>', $wiki->{config}->{path_to}->{db__content__error_log}; |
| 165 |
print LOG scalar (gmtime), " @{[$$]} {$err->{-def}->{level}}: ", |
| 166 |
$err_msg, "\n"; |
| 167 |
close LOG; |
| 168 |
} |
| 169 |
SuikaWiki::Plugin->module_package ('WikiDB') |
| 170 |
->reporting_error ($err, $wiki) if $report; |
| 171 |
if ($err->{-def}->{level} eq 'fatal' or $err->{-def}->{level} eq 'stop') { |
| 172 |
$wiki->view_in_mode (mode => '-wdb--fatal-error'); |
| 173 |
throw SuikaWiki::DB::Util::Error -type => 'ERROR_REPORTED'; |
| 174 |
} |
| 175 |
}; |
| 176 |
unshift @{$WIKI->{event}->{database_loaded}}, sub { |
| 177 |
my $wiki = shift; |
| 178 |
unshift @{$wiki->{db}->{event}->{error}}, sub { |
| 179 |
my ($db, $event) = @_; |
| 180 |
$error_report->($wiki, $event->{error}); |
| 181 |
if ($event->{error}->{-type} eq 'INFO_DB_PROP_OPENED') { |
| 182 |
unshift @{$db->{prop}->{$event->{error}->{prop}}->{-db} |
| 183 |
->{event}->{error}}, sub { |
| 184 |
my ($db, $event) = @_; |
| 185 |
$error_report->($wiki, $event->{error}); |
| 186 |
}; |
| 187 |
} |
| 188 |
}; # database error |
| 189 |
}; # database_loaded |
| 190 |
} |
| 191 |
|
| 192 |
## -- Misc. Error Reporting -- |
| 193 |
|
| 194 |
if ($WIKI->{config}->{debug}->{general}) { |
| 195 |
$main::SIG{__WARN__} = sub { |
| 196 |
push @{$WIKI->{var}->{error}||=[]}, { |
| 197 |
description => Message::Markup::XML::Node->new |
| 198 |
(type => '#text', |
| 199 |
value => $_[0]), |
| 200 |
}; |
| 201 |
}; |
| 202 |
} |
| 203 |
|
| 204 |
## -- Initializing $wiki->{var} (Declaration) -- |
| 205 |
|
| 206 |
push @{$WIKI->{event}->{setting_initial_variables}}, sub { |
| 207 |
my $wiki = shift; |
| 208 |
$wiki->{var}->{db}->{read_only}->{'#default'} = 1; |
| 209 |
|
| 210 |
require SuikaWiki::Input::HTTP; |
| 211 |
$wiki->{input} = SuikaWiki::Input::HTTP->new (wiki => $wiki); |
| 212 |
$wiki->{input}->{decoder}->{'#default'} = sub { |
| 213 |
my ($http, $s, $temp_params) = @_; |
| 214 |
return main::code_convert (\$s, $wiki->{config}->{charset}->{internal}, |
| 215 |
lc (@{$temp_params->{_charset_}||[]}[0]) |
| 216 |
|| $wiki->{config}->{charset}->{uri_param}); |
| 217 |
}; |
| 218 |
$wiki->{var}->{client}->{user_agent_name} |
| 219 |
= $wiki->{input}->meta_variable ('HTTP_USER_AGENT'); |
| 220 |
$wiki->{var}->{client}->{used_for_negotiate} = ['User-Agent']; |
| 221 |
my $dg = SuikaWiki::Plugin->module_package ('Downgrade'); |
| 222 |
$dg->set_downgrade_flags ($wiki) if $dg; |
| 223 |
|
| 224 |
## TODO: PATH_INFO support |
| 225 |
my $page = $wiki->{input}->meta_variable ('QUERY_STRING'); |
| 226 |
if ($page && !(index ($page, '=') > -1)) { |
| 227 |
$page =~ tr/+/ /; |
| 228 |
$page =~ s/%([0-9A-Fa-f][0-9A-Fa-f])/pack 'C', hex $1/ge; |
| 229 |
$page = main::code_convert |
| 230 |
(\$page, $wiki->{config}->{charset}->{internal}, |
| 231 |
$wiki->{config}->{charset}->{uri_query}); |
| 232 |
} else { |
| 233 |
$page = $wiki->{input}->parameter ('mypage'); |
| 234 |
} |
| 235 |
|
| 236 |
|
| 237 |
## TODO: SuikaWiki 3 WikiName |
| 238 |
$page =~ tr/\x00-\x20\x7F//d; |
| 239 |
$page = SuikaWiki::Name::Space::normalize_name ($page); |
| 240 |
if ($page) { |
| 241 |
$wiki->{var}->{page} = [split '//', $page]; |
| 242 |
} else { |
| 243 |
$wiki->{var}->{page} = $wiki->{config}->{page}->{Default}; |
| 244 |
} |
| 245 |
|
| 246 |
## Mode |
| 247 |
my $mode = $wiki->{input}->parameter ('mode') |
| 248 |
|| $wiki->{input}->parameter ('mycmd') ## for compatibility with |
| 249 |
|| 'default'; ## YukiWiki and SuikaWiki 2 |
| 250 |
$mode =~ tr/-/_/; |
| 251 |
if ($mode eq 'default' || $mode =~ /[^0-9A-Za-z_]/) { |
| 252 |
## BUG: this code is not strict |
| 253 |
my $cookie = $wiki->{input}->meta_variable ('HTTP_COOKIE'); |
| 254 |
if ($cookie =~ /SelectedMode=([0-9A-Za-z_-]+)/) { |
| 255 |
$mode = $1; $mode =~ tr/-/_/; |
| 256 |
} else { |
| 257 |
$mode = 'read'; |
| 258 |
} |
| 259 |
push @{$wiki->{var}->{client}->{used_for_negotiate}}, 'Cookie'; |
| 260 |
} |
| 261 |
$wiki->{var}->{mode} = $mode; |
| 262 |
}; |
| 263 |
|
| 264 |
## -- Initializing $wiki->{var} (Actual) -- |
| 265 |
|
| 266 |
$WIKI->init_variables; ## Per-session variables |
| 267 |
|
| 268 |
## -- Instantiating WikiView -- |
| 269 |
|
| 270 |
try { |
| 271 |
$WIKI->view_in_mode |
| 272 |
(mode => $WIKI->{var}->{mode}, |
| 273 |
method => $WIKI->{input}->meta_variable ('REQUEST_METHOD')); |
| 274 |
} catch SuikaWiki::DB::Util::Error with { |
| 275 |
my $err = shift; |
| 276 |
$err->throw unless $err->{-type} eq 'ERROR_REPORTED'; |
| 277 |
} catch SuikaWiki::View::Implementation::error with { |
| 278 |
my $err = shift; |
| 279 |
$err->throw unless $err->{-type} eq 'ERROR_REPORTED'; |
| 280 |
} finally { |
| 281 |
$WIKI->close_input; |
| 282 |
$WIKI->close_db; |
| 283 |
}; |
| 284 |
exit; |
| 285 |
|
| 286 |
## -- Terminating WikiEngine -- |
| 287 |
END { |
| 288 |
$WIKI->exit; |
| 289 |
} |
| 290 |
|
| 291 |
=head1 LICENSE |
| 292 |
|
| 293 |
Copyright 2000-2003 Wakaba <w@suika.fam.cx>, et. al |
| 294 |
|
| 295 |
This program is free software; you can redistribute it and/or |
| 296 |
modify it under the same terms as Perl itself. |
| 297 |
|
| 298 |
=cut |
| 299 |
|
| 300 |
1; # $Date: 2003/12/26 06:51:47 $ |
Parent Directory
| 
Revision Log