app.pm

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

    if (my $url = $app->{redirect}) {
        if ($app->{redirect_use_meta}) {
            $app->send_http_header();
            $app->print('<meta http-equiv="refresh" content="0;url=' . 
                        $app->{redirect} . '">');
        } else {
            if ($ENV{MOD_PERL}) {
                $app->{apache}->header_out(Location => $url);
                $app->response_code(Apache::Constants::REDIRECT());
                $app->send_http_header;
            } else {
                print $q->redirect(-uri => $url, %{ $app->{cgi_headers} });
            }
        }
    } else {
        unless ($app->{no_print_body}) {
            $app->send_http_header;
            $app->print($body);
            if ($app->{cfg}->DebugMode) {
                $app->print("<pre>$app->{trace}</pre>")
                    if $app->{trace} &&
                       (!defined $app->{warning_trace} || $app->{warning_trace});
            }
        }
    }
    MT::unplug();
}

sub l10n_filter { $_[0]->translate_templatized($_[1]) }

sub load_tmpl {
    my $app = shift;
    my($file, @p) = @_;
    my $path = $app->{cfg}->TemplatePath;
    require HTML::Template;
    my $tmpl;
    my $err;
    my @paths;
    if ($app->{plugin_template_path}) {
        if (File::Spec->file_name_is_absolute($app->{plugin_template_path})) {
            push @paths, $app->{plugin_template_path}
                if -d $app->{plugin_template_path};
        } else {
            my $dir = File::Spec->catdir($app->app_dir,
                                         $app->{plugin_template_path}); 
            if (-d $dir) {
                push @paths, $dir;
            } else {
                $dir = File::Spec->catdir($app->mt_dir,
                                          $app->{plugin_template_path});
                push @paths, $dir if -d $dir;
            }
        }
    }
    if (my $alt_path = $app->{cfg}->AltTemplatePath) {
        my $dir = File::Spec->catdir($path, $alt_path);
        if (-d $dir) {              # AltTemplatePath is relative
            push @paths, File::Spec->catdir($dir, $app->{template_dir})
                if $app->{template_dir};
            push @paths, $dir;
        } elsif (-d $alt_path) {    # AltTemplatePath is absolute
            push @paths, File::Spec->catdir($alt_path,
                                            $app->{template_dir})
                if $app->{template_dir};
            push @paths, $alt_path;
        }
    }
    push @paths, File::Spec->catdir($path, $app->{template_dir})
        if $app->{template_dir};
    push @paths, $path;
    my $type = {'SCALAR' => 'scalarref', 'ARRAY' => 'arrayref'}->{ref $file}
        || 'filename';
    eval {
        $tmpl = HTML::Template->new(
            type => $type, source => $file,
            path => \@paths,
            search_path_on_include => 1,
            die_on_bad_params => 0, global_vars => 1, @p);
    };
    $err = $@;
    return $app->error(
        $app->translate("Loading template '[_1]' failed: [_2]", $file, $err))
        if $@;

    ## We do this in load_tmpl because show_error and login don't call
    ## build_page; so we need to set these variables here.
    my $spath = $app->{cfg}->StaticWebPath || $app->mt_path;
    $spath .= '/' unless $spath =~ m!/$!;
    if (my $author = $app->{author}) {
        $tmpl->param(author_id => $author->id);
        $tmpl->param(author_name => $author->name);
    }
    $tmpl->param(static_uri => $spath);
    $tmpl->param(script_url => $app->app_uri);
    $tmpl->param(mt_url => $app->mt_uri);
    $tmpl->param(script_path => $app->app_path);
    $tmpl->param(script_full_url => $app->base . $app->app_uri);
    $tmpl->param(mt_version => MT->VERSION);

    $tmpl->param(language_tag => $app->current_language);
    my $enc = $app->{cfg}->PublishCharset ||
              $app->language_handle->encoding;
    $tmpl->param(language_encoding => $enc);
    $app->{charset} = $enc;

    $tmpl;
}

sub build_page {
    my $app = shift;
    my($file, $param) = @_;
    my $tmpl = $app->load_tmpl($file) or return;
    $param->{needs_magic} = 1 if !exists($param->{needs_magic});
    $param->{magic_token} = MT::Util::perl_sha1_digest_hex($app->{author}->password)
        if $app->{author} && $param->{needs_magic};
    $param->{breadcrumbs} = $app->{breadcrumbs};
    if ($param->{breadcrumbs}[-1]) {
        $param->{breadcrumbs}[-1]{is_last} = 1;
        $param->{page_titles} = [ reverse @{ $app->{breadcrumbs} } ];
    }
    pop @{ $param->{page_titles} };
    for my $key (keys %$param) {
        $tmpl->param($key, $param->{$key});
    }
    $app->l10n_filter($tmpl->output);
}

sub validate_magic {
    my $app = shift;
    return $app->errtrans("It looks like you've changed your password recently. Please log out and log in again to complete this action") unless
        MT::Util::perl_sha1_digest_hex($app->{author}->password) 
          eq $app->param('magic_token');
    1;
}

sub delete_param {
    my $app = shift;
    my($key) = @_;
    my $q = $app->{query};
    if ($ENV{MOD_PERL}) {
        my $tab = $q->parms;
        $tab->unset($key);
    } else {
        $q->delete($key);
    }
}

sub param_hash {
    my $app = shift;
    my $q = $app->{query};
    my @params = $q->param();
    my %result;
    foreach my $p (@params) {
        $result{$p} = $q->param($p);
    }
    %result;
}

## Path/server/script-name determination methods

sub query_string {
    my $app = shift;
    $ENV{MOD_PERL} ? $app->{apache}->args : $app->{query}->query_string;
}

sub base {
    my $app = shift;
    return $app->{__host} if exists $app->{__host};
    my $path = $app->{is_admin} ?
        ($app->{cfg}->AdminCGIPath || $app->{cfg}->CGIPath) :
        $app->{cfg}->CGIPath;
    if ($path =~ m!^(https?://[^/]+)!i) {
        (my $host = $1) =~ s!/$!!;
        return $app->{__host} = $host;
    }
    '';
}

*path = \&mt_path;
sub mt_path {
    my $app = shift;
    return $app->{__mt_path} if exists $app->{__mt_path};

    my $path;
    $path = $app->{is_admin} ?
        ($app->{cfg}->AdminCGIPath || $app->{cfg}->CGIPath) :
        $app->{cfg}->CGIPath;
    if ($path =~ m!^https?://[^/]+(/?.*)$!i) {
        $path = $1;
    } elsif (!$path) {
        $path = '/';
    }
    $path .= '/' unless substr($path, -1, 1) eq '/';
    $app->{__mt_path} = $path;
}

sub app_path {
    my $app = shift;
    return $app->{__path} if exists $app->{__path};

    my $path;
    if ($ENV{MOD_PERL}) {
        $path = $app->{apache}->uri;
        $path =~ s!/[^/]*$!!;
    } elsif ($app->{query}) {
        $path = $app->{query}->url;
        $path =~ s!/[^/]*$!!;
    } else {
        $path = $app->mt_path;
    }
    if ($path =~ m!^https?://[^/]+(/?.*)$!i) {
        $path = $1;
    } elsif (!$path) {
        $path = '/';
    }
    $path .= '/' unless substr($path, -1, 1) eq '/';
    $app->{__path} = $path;
}
sub envelope { '' }

sub script {
    my $app = shift;
    return $app->{__script} if exists $app->{__script};
    my $script = $ENV{MOD_PERL} ? $app->{apache}->uri : $ENV{SCRIPT_NAME};
    if (!$script) {
        require File::Basename; import File::Basename qw(basename);
        $script = basename($0);
    }
    $script =~ s!/$!!;
    $script = (split /\//, $script)[-1];
    $app->{__script} = $script;
}

*uri = \&app_uri;
sub app_uri { $_[0]->app_path . $_[0]->script }
        # app_uri refers to the active app script
sub mt_uri { $_[0]->mt_path . MT::ConfigMgr->instance->AdminScript }
        # mt_uri refers to mt's script even if we're in a plugin.

sub path_info {
    my $app = shift;
    return $app->{__path_info} if exists $app->{__path_info};
    my $path_info;
    if ($ENV{MOD_PERL}) {
        ## mod_perl often leaves part of the script name (Location)
        ## in the path info, for some reason. This should remove it.
        $path_info = $app->{apache}->path_info;
        if ($path_info) {
            my($script_last) = $app->{apache}->location =~ m!/([^/]+)$!;
            $path_info =~ s!^/$script_last!!;
        }
    } else {
        $path_info = $app->{query}->path_info;
    }
    $app->{__path_info} = $path_info;
}

sub is_secure {
    my $app = shift;
    $ENV{MOD_PERL} ? $app->{apache}->subprocess_env('https') :
        $app->{query}->protocol() eq 'https';
}

sub redirect {
    my $app = shift;
    my($url, %options) = @_;
    $app->{redirect_use_meta} = $options{UseMeta};
    unless ($url =~ m!^https?://!i) {
        $url = $app->base . $url;
    }
    $app->{redirect} = $url;
    return;
}

sub param {
    my $app = shift;
    $app->{query}->param(@_);
}

sub blog {
    my $app = shift;
    return $app->{_blog} if $app->{_blog};
    my $blog_id = $app->param('blog_id');
    if ($blog_id) {
        $app->{_blog} = MT::Blog->load($blog_id);
    }
    return $app->{_blog};
}

## Logging/tracing

sub log {
    my $app = shift;
    my($msg) = @_;
    my $log = MT::Log->new;
    $log->message($msg);
    $log->ip($app->remote_ip);
    $log->save;
}

sub trace { my $app = shift; $app->{trace} .= "@_" }

sub remote_ip {
    my $app = shift;
    $TransparentProxyIPs
        ? $app->get_header('X-Forwarded-For')
        : ($ENV{MOD_PERL}
           ? $app->{apache}->connection->remote_ip
           : $ENV{REMOTE_ADDR});
}

sub errtrans {
    my $app = shift;
    $app->error($app->translate(@_));
}

sub DESTROY {
    ## Destroy the Request object, which is used for caching
    ## per-request data. We have to do this manually, because in
    ## a persistent environment, the object will not go out of scope.
    ## Same with the ConfigMgr object and ObjectDriver.
    MT::Request->finish();
    undef $MT::Object::DRIVER;
    undef $MT::ConfigMgr::cfg;
}

1;
__END__

=head1 NAME

MT::App - Movable Type base web application class

=head1 SYNOPSIS

    package MT::App::Foo;
    use MT::App;
    @MT::App::Foo::ISA = qw( MT::App );

    package main;
    my $app = MT::App::Foo->new;
    $app->run;

=head1 DESCRIPTION

L<MT::App> is the base class for Movable Type web applications. It provides
support for an application running using standard CGI, or under
L<Apache::Registry>, or as a L<mod_perl> handler. L<MT::App> is not meant to
be used directly, but rather as a base class for other web applications using
the Movable Type framework (for example, L<MT::App::CMS>).

=head1 USAGE

L<MT::App> subclasses the L<MT> class, which provides it access to the
publishing methods in that class.

Following are the list of methods specific to L<MT::App>:

=head2 MT::App->new

Constructs and returns a new L<MT::App> object.

=head2 $app->run

Runs the application. This gathers the input, chooses the method to execute,
executes it, and prints the output to the client.

If an error occurs during the execution of the application, L<run> handles all
of the errors thrown either through the L<MT::ErrorHandler> or through C<die>.

=head2 $app->login

Checks the user's credentials, first by looking for a login cookie, then by
looking for the C<username> and C<password> CGI parameters. In both cases,
the username and password are verified for validity. This method does not set
the user's login cookie, however--that should be done by the caller (in most
cases, the caller is the L<run> method).

On success, returns the L<MT::Author> object representing the author who logged
in, and a boolean flag; if the boolean flag is true, it indicates the the login
credentials were obtained from the CGI parameters, and thus that a cookie
should be set by the caller. If the flag is false, the credentials came from
an existing cookie.

On an authentication error, L<login> removes any authentication cookies that
the user might have on his or her browser, then returns C<undef>, and the