app.pm

1. 记录每个帖子的访问人情况

# Copyright 2001-2005 Six Apart.
# SCRiPTMAFiA 2005 - THE DiRTY HANDS ON YOUR SCRiPTS
#
# $Id: App.pm 12790 2005-06-02 15:57:42Z bchoate $

package MT::App;
use strict;

use File::Spec;

use MT::Log;
use MT::Request;
use MT::Util qw( encode_html offset_time_list decode_html );
use MT::Author qw( AUTHOR );
use MT;
@MT::App::ISA = qw( MT );

use vars qw( %Global_actions );
sub add_methods {
    my $this = shift;
    my %meths = @_;
    if (ref($this)) {
        for my $meth (keys %meths) {
            $this->{vtbl}{$meth} = $meths{$meth};
        }
    } else {
        for my $meth (keys %meths) {
            $Global_actions{$this}{$meth} = $meths{$meth};
        }
    }
}

sub handler ($$) {
    my $class = shift;
    my($r) = @_;
    require Apache::Constants;
    if (lc($r->dir_config('Filter') || '') eq 'on') {
        $r = $r->filter_register;
    }
    my $config_file = $r->dir_config('MTConfig');
    undef $0; # $0 should be blank for handlers
    my $app = $class->new( Config => $config_file, ApacheObject => $r )
        or die $class->errstr;
    my $cfg = $app->{cfg};
    my @extra = $r->dir_config('MTSetVar');
    for my $d (@extra) {
        my($var, $val) = $d =~ /^\s*(\S+)\s+(.+)$/;
        $cfg->set($var, $val);
    }
    $app->run;
    return Apache::Constants::OK();
}

sub response_code {
    my $app = shift;
    $app->{response_code} = shift if @_;
    $app->{response_code};
}

sub response_message {
    my $app = shift;
    $app->{response_message} = shift if @_;
    $app->{response_message};
}

sub response_content_type {
    my $app = shift;
    $app->{response_content_type} = shift if @_;
    $app->{response_content_type};
}

sub send_http_header {
    my $app = shift;
    my($type) = @_;
    $type ||= 'text/html';
    if (my $charset = $app->{charset}) {
        $type .= "; charset=$charset"
            if $type =~ m!^text/! && $type !~ /\bcharset\b/;
    }
    if ($ENV{MOD_PERL}) {
        if ($app->{response_message}) {
            $app->{apache}->status_line(($app->response_code || 200) . " " 
                                         . $app->{response_message});
        } else {
            $app->{apache}->status($app->response_code || 200);
        }
        $app->{apache}->send_http_header($type);
    } else {
        $app->{cgi_headers}{-status} = ($app->response_code || 200) . " "
                                         . ($app->{response_message} || "");
        $app->{cgi_headers}{-type} = $type;
        print $app->{query}->header(%{ $app->{cgi_headers} });
    }
}

sub print {
    my $app = shift;
    if ($ENV{MOD_PERL}) {
        $app->{apache}->print(@_);
    } else {
        CORE::print(@_);
    }
}

my $TransparentProxyIPs = 0;

sub init {
    my $app = shift;
    my %param = @_;
    if ($ENV{MOD_PERL}) {
        require Apache::Request;
        $app->{apache} = $param{ApacheObject} || Apache->request;
    }
    $app->SUPER::init(%param) or return;
    $app->{vtbl} = { };
    $app->{requires_login} = 0;
    $app->{is_admin} = 0;
    $app->{template_dir} = 'cms';
    $app->{user_class} = 'MT::Author';
    $app->{cgi_headers} = { };
    $app->{plugin_template_path} = 'tmpl';
    if ($ENV{MOD_PERL}) {
        $app->{query} = Apache::Request->instance($app->{apache},
            POST_MAX => $app->{cfg}->CGIMaxUpload);
    } else {
        require CGI;
        $CGI::POST_MAX = $app->{cfg}->CGIMaxUpload;
        $app->{query} = CGI->new( $app->{no_read_body} ? {} : () );
    }
    $app->{cookies} = $app->cookies;
    ## Initialize the MT::Request singleton for this particular request.
    my $mt_req = MT::Request->instance;
    $mt_req->stash('App-Class', ref $app);
    ## Load up the object's initial vtbl with any global methods.
    if (my $meths = $Global_actions{ref($app)}) {
        for my $meth (keys %$meths) {
            $app->{vtbl}{$meth} = $meths->{$meth};
        }
    }
    # stash this for use after app object is destroyed
    $TransparentProxyIPs = MT::ConfigMgr->instance()->TransparentProxyIPs;
    $app;
}

sub add_breadcrumb {
    push @{ $_[0]->{breadcrumbs} }, {
        bc_name => $_[1],
        bc_uri => $_[2],
    }
}

sub is_authorized { 1 }

my $COOKIE_NAME = 'mt_user';

sub login {
    my $app = shift;
    my $q = $app->{query};
    my $cookies = $app->{cookies};
    my($user, $pass, $remember, $crypted);
    my $first_time = 0;
    if ($cookies->{$COOKIE_NAME}) {
        ($user, $pass, $remember) = split /::/, $cookies->{$COOKIE_NAME}->value;
        $crypted = 1;
    }
    if ($q->param('username') && $q->param('password')) {
        $first_time = 1;
        $user = $q->param('username');
        $pass = $q->param('password');
        $crypted = 0;
    }
    return unless $user && $pass;
    my $user_class = $app->{user_class};
    eval "use $user_class;";
    return $app->error("Error loading $user_class: $@") if $@;
    if (my $author = $user_class->load({ name => $user, type => AUTHOR })) {
        if ($author->is_valid_password($pass, $crypted)) {
            if ($first_time) {
                $app->log("User '" . $author->name . "' logged in " .
                          "successfully");
            }
            return($author, $first_time);
        }
    }
    ## Login invalid, so get rid of cookie (if it exists) and let the
    ## user know.
    $app->log("Invalid login attempt from user '$user'");
    $app->bake_cookie(-name => $COOKIE_NAME, -value => '', -expires => '-1y')
        unless $first_time;
    return $app->error($app->translate('Invalid login.'));
}

sub request_content {
    my $app = shift;
    unless (exists $app->{request_content}) {
        if ($ENV{MOD_PERL}) {
            ## Read from $app->{apache}
            my $r = $app->{apache};
            my $len = $app->get_header('Content-length');
            $r->read($app->{request_content}, $len);
        } else {
            ## Read from STDIN
            my $len = $ENV{CONTENT_LENGTH} || 0;
            read STDIN, $app->{request_content}, $len;
        }
    }
    $app->{request_content};
}

sub get_header {
    my $app = shift;
    my($key) = @_;
    if ($ENV{MOD_PERL}) {
        return $app->{apache}->header_in($key);
    } else {
        ($key = uc($key)) =~ tr/-/_/;
        return $ENV{'HTTP_' . $key};
    }
}

sub set_header {
    my $app = shift;
    my($key, $val) = @_;
    if ($ENV{MOD_PERL}) {
        $app->{apache}->header_out($key, $val);
    } else {
        unless ($key =~ /^-/) {
            ($key = lc($key)) =~ tr/-/_/;
            $key = '-' . $key;
        }
        if ($key eq '-cookie') {
            push @{$app->{cgi_headers}{$key}}, $val;
        } else {
            $app->{cgi_headers}{$key} = $val;
        }
    }
}

sub request_method {
    my $app = shift;
    if (@_) {
        $app->{request_method} = shift;
    } elsif (!exists $app->{request_method}) {
        if ($ENV{MOD_PERL}) {
            $app->{request_method} = Apache->request->method;
        } else {
            $app->{request_method} = $ENV{REQUEST_METHOD};
        }
    }
    $app->{request_method};
}

sub cookie_val {
    my $app = shift;
    my $cookies = $app->{cookies};
    if ($cookies && $cookies->{$_[0]}) {
        return $cookies->{$_[0]}->value() || "";
    }
    return "";
}

sub bake_cookie {
    my $app = shift;
    my %param = @_;
    if ((!exists $param{'-secure'}) && $app->is_secure) {
        $param{'-secure'} = 1;
    }
    unless ($param{-path}) {
        $param{-path} = $app->app_path;
    }
    if ($ENV{MOD_PERL}) {
        require Apache::Cookie;
        my $cookie = Apache::Cookie->new($app->{apache}, %param);
        $cookie->bake;
    } else {
        require CGI::Cookie;
        my $cookie = CGI::Cookie->new(%param);
        $app->set_header('-cookie', $cookie);
    }
}

sub cookies {
    my $app = shift;
    my $class = $ENV{MOD_PERL} ? 'Apache::Cookie' : 'CGI::Cookie';
    eval "use $class;";
    $class->fetch;
}

sub show_error {
    my $app = shift;
    my($error) = @_;
    my $tmpl;
    $error = encode_html($error);
    $error =~ s!(http://\S+)!<a href="$1" target="_blank">$1</a>!g;
    $tmpl = $app->load_tmpl('error.tmpl') or
        return "Can't load error template; got error '" . $app->errstr .
               "'. Giving up. Original error was <pre>$error</pre>";
    $tmpl->param(ERROR => $error);
    $tmpl->param(GOBACK => $app->{goback} || 'history.back()');
    $app->l10n_filter($tmpl->output);
}

sub pre_run { 1 }

sub post_run { 1 }

sub run {
    my $app = shift;
    my $q = $app->{query};
    my($body);
    eval {
        if ($ENV{MOD_PERL}) {
            unless ($app->{no_read_body}) {
                my $status = $q->parse;
                unless ($status == Apache::Constants::OK()) {
                    die $app->translate('The file you uploaded is too large.') .
                        "\n";
                }
            }
        } else {
            my $err;
            eval { $err = $q->cgi_error };
            unless ($@) {
                if ($err && $err =~ /^413/) {
                    die $app->translate('The file you uploaded is too large.') .
                        "\n";
                }
            }
        }

        REQUEST:
        {
            if ($app->{requires_login}) {
            LOGIN:
            {
                my($author, $first_time) = $app->login;
                if ($author) {
                    $app->{author} = $app->{$COOKIE_NAME} = $author;
                    if ($first_time) {
                        my $remember = $q->param('remember') ? 1 : 0;
                        my %arg = (
                            -name => $COOKIE_NAME,
                            -value => join('::', $author->name,$author->password,
                                                 $remember),
                        );
                        $arg{-expires} = '+10y' if $remember;
                        $app->bake_cookie(%arg);
                    }
                    last LOGIN if $app->is_authorized;
                }
                $body = $app->build_page('login.tmpl', {error => $app->errstr,
                                                        no_breadcrumbs => 1})
                    or $body = $app->show_error( $app->errstr ), last REQUEST;
                last REQUEST;
            }  ## end LOGIN block
            }

            $app->pre_run;
            my $mode = $q->param('__mode') || $app->{default_mode};
            my $code = $app->{vtbl}{$mode} or
                $app->error($app->translate('Unknown action [_1]', $mode));
            if ($code) {
                $body = $code->($app);
            }
            $app->post_run;
            unless (defined $body || $app->{redirect}) {
                if ($app->{no_print_body}) {
                    $app->print($app->errstr);
                } else {
                    $body = $app->show_error( $app->errstr );
                }
            }
        }  ## end REQUEST block
    };
    if ($@) {
        $body = $app->show_error($@);
    }

    ## Add the Pragma: no-cache header.
    ## WEIRD: for CGI::cache, any true argument to cache means NO cache
    if ($ENV{MOD_PERL}) {
        $app->{apache}->no_cache(1);
    } else {
        $q->cache(1);
    }