view release on metacpan or  search on metacpan

lib/AnnoCPAN/Control.pm  view on Meta::CPAN

package AnnoCPAN::Control;

$VERSION = '0.22';

use strict;
use warnings;
no warnings 'uninitialized';
use AnnoCPAN::Config;
use AnnoCPAN::DBI;
use CGI::Cookie;
use Digest::MD5 qw(md5_hex);
use IO::String;
use POSIX qw(ceil);
use Lingua::EN::Inflect qw(NO);
use AnnoCPAN::Feed;

# it should be possible to subclass this module to use a different
# interface and templating system by overriding new and the simple
# 'delegational' methods param, process, header...

=head1 NAME

AnnoCPAN::Control - Main AnnoCPAN Web Interface Control Module

=head1 SYNOPSIS

    # in the simplest case, this is all you need...
    use AnnoCPAN::Control;
    AnnoCPAN::Control->new->run;

=head1 DESCRIPTION

This is the main module that handles the AnnoCPAN web application. It handles
getting the CGI parameters, running the appropriate handlers, and making sure
that the appropriate templates are processed.

=head1 METHODS

=over

=item $class->new(%options)

Create a new AnnoCPAN control object. Options:

 cgi => cgi object
 tt  => template object

=cut

sub new {
    my ($class, %args) = @_;
    my $self = bless {
        log => [],
        cgi => $args{cgi} || CGI->new, 
        tt  => $args{tt}  || Template->new(
            INCLUDE_PATH => AnnoCPAN::Config->option('template_path'),
            PRE_PROCESS => 'util.tt',
            FILTERS => { myuri => \&myuri_filter },
        ),
    }, $class;
    $self;
}

=item $obj->run

Process the request. This includes figuring out the runmode, checking if 
the user is logged in, running the handler, printing the headers, and
processing the template.

=cut

lib/AnnoCPAN/Control.pm  view on Meta::CPAN

        $uri->host($ENV{HTTP_HOST});
    }
    print $self->header(
        -cookie => $self->cookies, 
        -status => $ENV{REQUEST_METHOD} eq 'POST' ? 303 : 302, 
        -location => $uri,
    );
}

=item $obj->process($template_file, \%vars [, \$ret])

Process a template. Delegated to $self->tt.

=cut

sub process { shift->tt->process(@_) }

=item $obj->default_vars

Return a hashref with the default template variables, common to all runmodes
(for example, the user object).

=cut

sub default_vars {
    my ($self) = @_;
    +{
        param        => sub { $self->param(@_) },
        user         => $self->user,
        mode         => $self->mode,
        log          => $self->{log},
        prefs        => sub { $self->prefs(@_) },
        my_html      => sub { $self->my_html(@_) },
        request_uri  => $ENV{REQUEST_URI},
        cgi          => $self->cgi,
        root_uri_rel => AnnoCPAN::Config->option('root_uri_rel'),
        img_root     => AnnoCPAN::Config->option('img_root'),
        root_uri_abs => AnnoCPAN::Config->option('root_uri_abs'),
        NO           => \&NO,
    }
}

=item $obj->prefs($pref_name)

Returns the value for a given user preference.

=cut

sub prefs {
    my ($self, $name) = @_;
    my $user = $self->user;
    my $value;
    if ($user) {
        $value = AnnoCPAN::DBI::Prefs->retrieve(user => $user, name => $name);
    }
    defined $value ? $value->value : AnnoCPAN::Config->option($name);
}

=item $obj->cookies

Return an arrayref with the current cookies (which are L<CGI::Cookie> objects).

=cut

sub cookies { 
    my ($self) = @_;
    $self->{cookies} || [];
}

=item $obj->add_cookie($name, $value)

Create a cookie. It will be later pushed to the client with the HTTP headers,
and it is immediately available via $obj->cookies.

=cut

sub add_cookie {
    my ($self, $name, $val) = @_;

    my $max_time = AnnoCPAN::Config->option('cookie_duration');
    push @{$self->{cookies}}, CGI::Cookie->new(
        -name => $name, -value => $val,
        $max_time ? (-expires => "+${max_time}d") : (),
    );
}

=item $obj->delete_cookie($name)

Issue an expired cookie with a given name, forcing the client to forget it (one
use is for logging out).

=cut

sub delete_cookie {
    my ($self, $name) = @_;
    push @{$self->{cookies}}, CGI::Cookie->new(
        -name => $name, -value => '', -expires => '-1Y',
    );
}

=item $obj->check_login

Check if the user is logged in (by checking the login, time, and key cookies);
Returns an AnnoCPAN::DBI::User object if logged in, or false if not.

=cut

sub check_login {
    my ($self) = @_;
    if ($ENV{TEST_USER}) {
        return AnnoCPAN::DBI::User->retrieve(username => 'test');
    }
    my %cookies = CGI::Cookie->fetch;
    my $login = $cookies{login}  && $cookies{login}->value;
    my $time  = $cookies{'time'} && $cookies{'time'}->value;
    my $key   = $cookies{key}    && $cookies{key}->value;
    my $max_time = (AnnoCPAN::Config->option('cookie_duration') || 1E9) * 86400;
    if ($self->key($login, $time) eq $key and time-$time < $max_time) {
        return AnnoCPAN::DBI::User->retrieve(username => $login);
    }
    0;
}

=item $obj->set_login_cookies($user)

Creates the login cookies for $user (which should be an L<AnnoCPAN::DBI::User> 
object).

=cut

sub set_login_cookies {
    my ($self, $user) = @_;
    $self->user($user);
    my $login = $user->username;
    my $time = time;
    my $key = $self->key($login, $time);
    $self->add_cookie(login  => $login);
    $self->add_cookie(key    => $key);
    $self->add_cookie('time' => $time);
}

=item $obj->user($user)

May be used to set an arbitrary user (to force a login). If no $user is 
provided (and none has been provided before), returns whatever check_login
would return (a user object or false).

=cut

sub user {
    my ($self, $user) = @_;
    if (@_ > 1) {
        $self->{user} = $user;
    } else {
        $self->{user} = $self->check_login unless exists $self->{user};
    }
    $self->{user};
}

=item $obj->key($login, $time)

Returns a login key as a string. Depends on the "secret" configuration option.

=cut

sub key {
    my ($self, $login, $time) = @_;
    my $secret = AnnoCPAN::Config->option('secret');
    md5_hex("$login $time $secret");
}

############# MODES ###############