root/lang/perl/MENTA/trunk/lib/MENTA.pm @ 23982

Revision 23982, 13.3 kB (checked in by tokuhirom, 5 years ago)

do_* を menta.cgi にかける機能は消しましたよ

Line 
1package MENTA;
2use strict;
3use warnings;
4use utf8;
5
6our $REQ;
7our $CONFIG;
8our $REQUIRED;
9our $MOBILEAGENTRE;
10our $CARRIER;
11our $STASH;
12our $BUILT = 0;
13BEGIN {
14    $REQUIRED = {};
15
16    {
17        # copied from HTTP::MobileAgent
18        my $DoCoMoRE = '^DoCoMo/\d\.\d[ /]';
19        my $JPhoneRE = '^(?i:J-PHONE/\d\.\d)';
20        my $VodafoneRE = '^Vodafone/\d\.\d';
21        my $VodafoneMotRE = '^MOT-';
22        my $SoftBankRE = '^SoftBank/\d\.\d';
23        my $SoftBankCrawlerRE = '^Nokia[^/]+/\d\.\d';
24        my $EZwebRE = '^(?:KDDI-[A-Z]+\d+[A-Z]? )?UP\.Browser\/';
25        my $AirHRE = '^Mozilla/3\.0\((?:WILLCOM|DDIPOCKET)\;';
26        $MOBILEAGENTRE = qr/(?:($DoCoMoRE)|($JPhoneRE|$VodafoneRE|$VodafoneMotRE|$SoftBankRE|$SoftBankCrawlerRE)|($EZwebRE)|($AirHRE))/;
27    }
28}
29
30sub import {
31    strict->import;
32    warnings->import;
33    utf8->import;
34}
35
36sub DEFAULT_MAX_POST_BODY () { 1_024_000 }
37
38package main;
39
40sub config () { $MENTA::CONFIG }
41
42sub run_menta {
43    my $config = shift @_;
44
45    local $MENTA::CONFIG;
46    local $MENTA::REQ;
47    local $MENTA::CARRIER;
48    local $MENTA::STASH;
49
50    {
51        $config->{menta}->{max_post_body} ||= MENTA::DEFAULT_MAX_POST_BODY;
52        $MENTA::CONFIG = $config;
53    }
54
55    local $SIG{__DIE__} = sub {
56        my $msg = shift;
57        warn $msg unless ref $msg;
58        return $msg if ref $msg && ref $msg eq 'HASH' && $msg->{finished};
59        my $i = 0;
60        my @trace;
61        while ( my ($package, $filename, $line,) = caller($i) ) {
62            last if $filename eq 'bin/cgi-server.pl';
63            my $context = sub {
64                my ( $file, $linenum ) = @_;
65                my $code;
66                if ( -f $file ) {
67                    my $start = $linenum - 3;
68                    my $end   = $linenum + 3;
69                    $start = $start < 1 ? 1 : $start;
70                    open my $fh, '<:utf8', $file or die "エラー画面表示用に ${file} を開こうとしたのに開けません: $!";
71                    my $cur_line = 0;
72                    while ( my $line = <$fh> ) {
73                        chomp $line;
74                        ++$cur_line;
75                        last if $cur_line > $end;
76                        next if $cur_line < $start;
77                        my @tag =
78                            $cur_line == $linenum
79                            ? ( '<strong>', '</strong>' )
80                            : ( '', '' );
81                        $code .= sprintf( "%s%5d: %s%s\n",
82                            $tag[0], $cur_line,
83                            escape_html($line),
84                            $tag[1], );
85                    }
86                    close $file;
87                    chomp $code;
88                }
89                return $code;
90            }->($filename, $line);
91            push @trace, +{ level => $i, package => $package, filename => $filename, line => $line, context => $context };
92            $i++;
93        }
94        die { message => $msg, trace => \@trace };
95    };
96
97    eval {
98        my $path = $ENV{PATH_INFO} || '/';
99        $path =~ s!^/+!!g;
100        if ($path =~ /^[a-z0-9_]*$/) {
101            my $mode = $path || 'index';
102            my $meth = "do_$mode";
103            if (my $cdir = config->{menta}->{controller_dir}) {
104                my $controller = "${cdir}/${path}.pl";
105                if (-f $controller) {
106                    package main;
107                    do $controller;
108                    if (my $e = $@) {
109                        if (ref $e) {
110                            die $e->{message};
111                        } else {
112                            die $e;
113                        }
114                    }
115                    die $@ if $@;
116                    if (my $code = main->can($meth)) {
117                        $code->();
118                        die "なにも出力してません";
119                    } else {
120                        die "「${mode}」というモードは存在しません!${controller} の中に ${meth} が定義されていないようです";
121                    }
122                } else {
123                    my $tmplfname = ($MENTA::BUILT ? config->{menta}->{tmpl_cache_dir} : config->{menta}->{tmpl_dir}) . "/${mode}.html";
124                    if (-f $tmplfname) {
125                        render("${mode}.html");
126                    } else {
127                        die "「${mode}」というモードは存在しません。別コントローラファイルもありません(${controller})。テンプレートファイルもありません(${tmplfname})";
128                    }
129                }
130            } else {
131                die "「${mode}」というモードは存在しません。別コントローラ用ディレクトリは設定されていません";
132            }
133        } elsif ($path ne 'menta.cgi' && -f $path) {
134            if (open my $fh, '<', $path) {
135                printf "Content-Type: %s\r\n\r\n", guess_mime_type($path);
136                print do { local $/; <$fh> };
137                close $fh;
138            } else {
139                die "ファイルが開きません";
140            }
141        } elsif ($path =~ /^(?:crossdomain\.xml|favicon\.ico|robots\.txt)$/) {
142            print "status: 404\r\ncontent-type: text/plain\r\n\r\n";
143        } else {
144            die "${path} を処理する方法がわかりません";
145        }
146    };
147    if (my $err = $@) {
148        die "エラー処理失敗: ${err}" unless ref $err eq 'HASH';
149        return if $err->{finished};
150
151        warn $err->{message};
152
153        print "Status: 500\r\n";
154        print "Content-type: text/html; charset=utf-8\r\n";
155        print "\r\n";
156
157        my $body = do {
158            if ($config->{menta}->{kcatch_mode}) {
159                my $msg = escape_html($err->{message});
160                chomp $msg;
161                my $out = qq{<!doctype html><head><title>500 Internal Server Error</title><style type="text/css">body { margin: 0; padding: 0; background: rgb(230, 230, 230); color: rgb(44, 44, 44); } h1 { margin: 0 0 .5em; padding: .25em .5em .1em 1.5em; border-bottom: thick solid rgb(0, 0, 15); background: rgb(63, 63, 63); color: rgb(239, 239, 239); font-size: x-large; } p { margin: .5em 1em; } li { font-size: small; } pre { background: rgb(255, 239, 239); color: rgb(47, 47, 47); font-size: medium; } pre code strong { color: rgb(0, 0, 0); background: rgb(255, 143, 143); } p.f { text-align: right; font-size: xx-small; } p.f span { font-size: medium; }</style></head><h1>500 Internal Server Error</h1><p>${msg}</p><ol>};
162                for my $stack (@{$err->{trace}}) {
163                    $out .= '<li>' . escape_html(join(', ', $stack->{package}, $stack->{filename}, $stack->{line}))
164                         . qq(<pre><code>$stack->{context}</code></pre></li>);
165                }
166                $out .= qq{</ol><p class="f"><span>Powered by <strong>MENTA</strong></span>, Web application framework</p>};
167                $out;
168            } else {
169                qq{<html><body><p style="color: red">500 Internal Server Error</p></body></html>\n};
170            }
171        };
172        utf8::encode($body);
173        print $body;
174    }
175}
176
177sub escape_html {
178    local $_ = shift;
179    return $_ unless $_;
180    s/&/&amp;/g;
181    s/>/&gt;/g;
182    s/</&lt;/g;
183    s/"/&quot;/g;
184    s/'/&#39;/g;
185    return $_;
186}
187
188sub unescape_html {
189    local $_ = shift;
190    return $_ unless $_;
191    s/&gt;/>/g;
192    s/&lt;/</g;
193    s/&quot;/"/g;
194    s/&#39;/'/g;
195    s/&amp;/&/g;
196    return $_;
197}
198
199sub guess_mime_type {
200    my $ext = shift;
201    $ext =~ s/.+\.(.+)$/$1/;
202
203    # TODO should be moved to other.
204    my $mime_map = {
205        css => 'text/css',
206        js  => 'application/javascript',
207        txt => 'text/plain',
208    };
209    $mime_map->{$ext} || 'application/octet-stream';
210}
211
212# TODO: ディレクトリトラバーサル対策
213sub render_partial {
214    my ($tmpl, @params) = @_;
215    my $conf = config()->{menta};
216    my $tmpldir = $conf->{tmpl_dir} or die "[menta] セクションに tmpl_dir が設定されていません";
217    my $cachedir = $conf->{tmpl_cache_dir} or die "[menta] セクションに tmpl_cache_dir が設定されていません";
218    mkdir $cachedir unless $MENTA::BUILT || -d $cachedir;
219    my $cachefname = "$cachedir/$tmpl";
220    my $tmplfname = "$tmpldir/$tmpl";
221    my $use_cache = $MENTA::BUILT || sub {
222        my @orig = stat $tmplfname or return 1;
223        my @cached = stat $cachefname or return;
224        return $orig[9] < $cached[9];
225    }->();
226    my $out;
227    if ($use_cache) {
228        my $tmplcode = do $cachefname;
229        die $@ if $@;
230        die "テンプレートキャッシュを読み込めませんでした: ${tmplfname}" unless $tmplcode;
231        $out = $tmplcode->(@params);
232    } else {
233        die "「${tmplfname}」という名前のテンプレートファイルは見つかりません" unless -f $tmplfname;
234        require_once('MENTA/Template.pm');
235        my $tmplsrc = read_file($tmplfname);
236        my $mt = MENTA::Template->new;
237        $mt->parse($tmplsrc);
238        $mt->build();
239        my $src = $mt->code();
240        my $tmplcode = eval $src;
241        die $@ if $@;
242        $out = $tmplcode->(@params);
243        write_file($cachefname, "package main; use utf8;\n${src}");
244    }
245    $out;
246}
247
248sub detach() {
249    die {finished => 1};
250}
251
252sub render {
253    my ($tmpl, @params) = @_;
254    my $out = render_partial($tmpl, @params);
255    utf8::encode($out);
256    print "Content-Type: text/html; charset=utf-8\r\n";
257    print "\r\n";
258    print $out;
259
260    detach;
261}
262
263sub redirect {
264    my ($location, ) = @_;
265    print "Status: 302\r\n";
266    print "Location: $location\r\n";
267    print "\r\n";
268
269    detach;
270}
271
272sub finalize {
273    my $str = shift;
274    my $content_type = shift || 'text/html; charset=utf-8';
275
276    print "Content-Type: $content_type\r\n";
277    print "\r\n";
278    print $str;
279
280    detach;
281}
282
283sub read_file {
284    my $fname = shift;
285    open my $fh, '<:utf8', $fname or die "${fname} を読み込み用に開けません: $!";
286    my $s = do { local $/; join '', <$fh> };
287    close $fh;
288    $s;
289}
290
291sub write_file {
292    my ($fname, $stuff) = @_;
293    open my $fh, '>:utf8', $fname or die "${fname} を書き込み用に開けません: $!";
294    print $fh $stuff;
295    close $fh;
296}
297
298sub parse_multipart {
299    my ($data, $boundary) = @_;
300
301    my @lines = split(/\n/, $data);
302    my ($val, $key, $step) = ('', '', 0);
303    for my $line (@lines) {
304        my $sline = $line;
305        $sline =~ s![\r\n]+!!msg;
306        if ($boundary eq $sline) {
307            if($step eq 2 && $key ne '') {
308                chop($val);
309                $MENTA::REQ->{$key} = $val;
310            }
311            $step = 1;
312            $key = '';
313            $val = '';
314        } elsif ("${boundary}--" eq $sline) {
315            if ($step eq 2 && $key ne '') {
316                chop($val);
317                $MENTA::REQ->{$key} = $val;
318            }
319            return 1;
320        } elsif ($step eq 2) {
321            $val .= "\n" if $val;
322            $val .= $line;
323        } elsif ($sline =~ /^(?i:Content-Disposition): *form-data; *name="((?:\\"|[^"])*)/ && $step eq 1) {
324            $key = $1;
325        } elsif ($sline eq '' && $step eq 1) {
326            $step = 2;
327        }
328    }
329    return 1;
330}
331
332sub param {
333    my $key = shift;
334
335    unless (defined $MENTA::REQ) {
336        my $input;
337        if ($ENV{'REQUEST_METHOD'} eq 'POST') {
338            my $max_post_body = config()->{menta}->{max_post_body};
339            if ($max_post_body > 0 && $ENV{CONTENT_LENGTH} > $max_post_body) {
340                die "投稿データが長すぎです";
341            } else {
342                read(STDIN, $input, $ENV{'CONTENT_LENGTH'});
343            }
344        } else {
345            $input = $ENV{QUERY_STRING};
346        }
347
348        my $type = $ENV{'CONTENT_TYPE'};
349        if ($type && $type =~ m{^multipart/form-data; *boundary=}) {
350            parse_multipart $input, '--'.substr($type, 30);
351        } else {
352            for (split /[&;]+/, $input) {
353                my ($key, $val) = split /=/, $_;
354                if ($val) {
355                    $val =~ tr/+/ /;
356                    $val =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack('H2', $1)/eg;
357                    utf8::decode($val);
358                }
359                $MENTA::REQ->{$key} = $val;
360            }
361        }
362    }
363
364    return $MENTA::REQ->{$key};
365}
366
367sub require_once {
368    my $path = shift;
369    return if $MENTA::REQUIRED->{$path};
370    require $path;
371    $MENTA::REQUIRED->{$path} = 1;
372}
373
374# これが返す文字は HTTP::MobileAgent と互換性がある
375sub mobile_carrier () {
376    if ($MENTA::CARRIER) { return $MENTA::CARRIER }
377
378    my $ua = $ENV{HTTP_USER_AGENT} || '';
379    my $ret = 'N';
380    if ($ua =~ /$MENTA::MOBILEAGENTRE/) {
381        $ret = $1 ? 'I' : $2 ? 'V' : $3 ? 'E' : 'H';
382    }
383    $MENTA::CARRIER = $ret;
384    $ret;
385}
386
387sub mobile_carrier_longname {
388    {
389        N => 'NonMobile',
390        I => 'DoCoMo',
391        E => 'EZweb',
392        V => 'Softbank',
393        H => 'AirH',
394    }->{ mobile_carrier() }
395}
396
397sub load_plugin {
398    my $plugin = shift;
399    require_once($MENTA::BUILT ? "plugins/${plugin}.pl" : "../plugins/${plugin}.pl");
400}
401
402sub is_post_request () {
403    my $method = $ENV{REQUEST_METHOD};
404    return $method eq 'POST';
405}
406
407# TODO: CGI にはこのための環境変数ってなかったっけ?
408sub docroot () {
409    config()->{application}->{docroot}
410}
411
412sub uri_for {
413    my ($path, $query) = @_;
414    my @q;
415    while (my ($key, $val) = each %$query) {
416        $val = join '', map { /^[a-zA-Z0-9_.!~*'()-]$/ ? $_ : '%' . uc(unpack('H2', $_)) } split //, $val;
417        push @q, "${key}=${val}";
418    }
419    docroot . $path . (scalar @q ? '?' . join('&', @q) : '');
420}
421
4221;
Note: See TracBrowser for help on using the browser.