view release on metacpan or  search on metacpan

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

        $key ne 'id' or $value =~ /^\d+$/
            or  die "invalid $name: '$value'\n";
        my $obj = $class->retrieve($key => $value)
            or die "$name '$value' not found\n";
        return $obj unless wantarray;
        push @objs, $obj;
    }
    return @objs;
}

=item $obj->header(@_)

Return HTTP headers as a string. Delegated to $self->cgi.

=cut

sub header { shift->cgi->header(@_) }

=item $obj->redirect($uri)

Print a 303 HTTP redirect header, including the cookies in $obj->cookies.

=cut

sub redirect {
    my ($self, $uri) = @_;
    unless ($uri =~ /^\w+:/) {
        require URI;
        $uri = URI->new(AnnoCPAN::Config->option('root_uri_abs') . $uri);
        $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) = @_;

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

        unless ($login =~ /^\w+$/);

    if (AnnoCPAN::DBI::User->retrieve(username => $login)) {
        return ({%vars, error => 'login already taken'}, "new_user");
    }

    if ($passwd ne $passwd2) {
        return ({%vars, error => "passwords don't match"}, "new_user");
    }

    my $user = AnnoCPAN::DBI::User->create({
        username => $login,
        password => crypt($passwd, $login),
        email    => $email,
        member_since => time,
        privs    => 1,
    });
    $self->set_login_cookies($user);
    $self->Main({%vars, message => "account created"});
}

=item $sub->Login

Log in; comes from the login form on login_form.html. Uses the login and
passwd CGI parameters.

=cut

sub Login {
    my ($self) = @_;
    my $passwd  = $self->param('passwd');

    my $user = eval { $self->param_obj('User', 'username') };
    unless ($user and crypt($passwd, $user->password) eq $user->password) {
        return $self->Main({error => 'invalid login/password'});
    }
    $self->set_login_cookies($user);
    my $from = $self->param('from');
    $self->redirect($from =~ /logout/ ? '/' : $from);
    return;
    #$self->Main({message => "welcome, you have logged in!"});
}

=item $obj->Logout

Log out. Clears the authentication key.

=cut

sub Logout {
    my ($self) = @_;
    $self->delete_cookie('key');
    $self->user(undef);
    $self->redirect($self->param('from'));
    return;
    #$self->Main({message => "You have logged out"});
}

sub Prefs {
    my ($self) = @_;
    return $self->error("Can't edit prefs without logging in first!")
        unless $self->user;
    ({}, 'prefs');
}

sub Save_prefs {
    my ($self) = @_;
    # XXX untaint
    my $user = $self->user;
    return $self->error("Can't edit prefs without logging in first!")
        unless $user;
    AnnoCPAN::DBI::Prefs->search(user => $user)->delete_all;
    for my $name (@{AnnoCPAN::Config->option('prefs')}) {
        AnnoCPAN::DBI::Prefs->create({user => $user, name => $name, 
            value => $self->param($name) || '' });
    }
    ({ message => 'Preferences saved'}, 'prefs');
}


sub Delete {
    my ($self) = @_;
    return $self->_delete if $self->param('fast');
    my ($vars) = $self->_delete;
    return $self->Main($vars) if $vars->{error};
    $self->Show($vars);
}

# global delete
sub _delete {
    my ($self) = @_;

    my $notepos = $self->param_obj('NotePos');
    my $note    = $notepos->note;
    my $podver  = $notepos->podver;

    # get user, see if can delete
    my $user = $self->user
        or return $self->_error("not logged in; can't delete");
    $user->can_delete($note)
        or return $self->_error("deletion not authorized");

    $note->delete;

    $self->_message("note deleted", { podver => $podver });
}


sub Main_rss {
    my ($self) = @_;

    my ($vars) = $self->Main;

    my $link = AnnoCPAN::Config->option('root_uri_abs');
    my $rss  = AnnoCPAN::Feed->note_rss(notes => $vars->{recent}, 
        link => $link, title => 'AnnoCPAN Recent Notes');

    ({ %$vars, rss => $rss }, 'rss', 'text/xml');
}


sub Author_recent {
    my ($self, $vars) = @_;
    $vars ||= {};
    my $pause_id  = $self->param('pause_id');
    my @recent = AnnoCPAN::DBI::Note->search_recent_by_author($pause_id);
    ({notes => \@recent, author => uc $pause_id, %$vars }, "show_author_recent");
}

sub Author_rss {
    my ($self, $vars) = @_;
    $vars ||= {};

    my $pause_id  = $self->param('name');
    return $self->Main unless $pause_id;
    my @pods = AnnoCPAN::DBI::Pod->search_by_author($pause_id);
    my @notes = map { $_->notes } @pods;