view release on metacpan or  search on metacpan

Apache2/Apache2/CPAN/Query.pm  view on Meta::CPAN

package Apache2::CPAN::Query;
use strict;
use warnings;
use utf8;
use mod_perl2 1.999022;     # sanity check for a recent version
use Apache2::Const -compile => qw(OK REDIRECT SERVER_ERROR 
                                  TAKE1 RSRC_CONF ACCESS_CONF);
use CPAN::Search::Lite::Query;
use CPAN::Search::Lite::Util qw($mode_info $query_info %modes
                                %chaps_rev %chaps $tt2_pages);
our $chaps_desc = {};
our $pages = {};

use CPAN::Search::Lite::Lang qw(%langs load);
use Template;
use File::Spec::Functions qw(catfile catdir);
use Apache2::Request;
use Apache2::Cookie;
use Apache2::RequestRec ();
use Apache2::RequestIO ();
use Apache2::RequestUtil ();
use Apache2::Module ();
use Apache2::Log ();
use APR::Date;
use APR::URI;
use Apache2::URI;
use APR::Const -compile => qw(URI_UNP_OMITQUERY);

our $VERSION = 0.77;

my @directives = (
                  {name      => 'CSL_db',
                   errmsg    => 'database name',
                   args_how  => Apache2::Const::TAKE1,
                   req_override => Apache2::Const::RSRC_CONF | Apache2::Const::ACCESS_CONF,
                  },
                  {name      => 'CSL_user',
                   errmsg    => 'user to log in as',
                   args_how  => Apache2::Const::TAKE1,
                   req_override => Apache2::Const::RSRC_CONF | Apache2::Const::ACCESS_CONF,
                  },
                  {name      => 'CSL_passwd',
                   errmsg    => 'password for user',
                   args_how  => Apache2::Const::TAKE1,
                   req_override => Apache2::Const::RSRC_CONF | Apache2::Const::ACCESS_CONF,
                  },
                  {name      => 'CSL_tt2',
                   errmsg    => 'location of tt2 pages',
                   args_how  => Apache2::Const::TAKE1,
                   req_override => Apache2::Const::RSRC_CONF | Apache2::Const::ACCESS_CONF,
                  },
                  {name      => 'CSL_dl',
                   errmsg    => 'default download location',
                   args_how  => Apache2::Const::TAKE1,
                   req_override => Apache2::Const::RSRC_CONF | Apache2::Const::ACCESS_CONF,
                  },
                  {name      => 'CSL_max_results',
                   errmsg    => 'maximum number of results',
                   args_how  => Apache2::Const::TAKE1,
                   req_override => Apache2::Const::RSRC_CONF | Apache2::Const::ACCESS_CONF,
                  },
                  {name      => 'CSL_html_root',
                   errmsg    => 'root directory of html files',
                   args_how  => Apache2::Const::TAKE1,
                   req_override => Apache2::Const::RSRC_CONF | Apache2::Const::ACCESS_CONF,
                  },
                  {name      => 'CSL_html_uri',
                   errmsg    => 'root uri of html files',
                   args_how  => Apache2::Const::TAKE1,
                   req_override => Apache2::Const::RSRC_CONF | Apache2::Const::ACCESS_CONF,
                  },
                 );
Apache2::Module::add(__PACKAGE__, \@directives);

my $cookie_mirror = 'cslmirror';
my $cookie_ws = 'cslwebstart';
my $cookie_lang = 'csllang';

my ($template, $query, $cfg, $dl, $max_results);

sub new {
    my ($class, $r) = @_;
    my $lang = lang_wanted($r);
    my $req = Apache2::Request->new($r);
    $cfg = Apache2::Module::get_config(__PACKAGE__, 
                                      $r->server,
                                      $r->per_dir_config) || { };

    $dl ||= $cfg->{dl} || 'http://www.cpan.org';
    $max_results ||= $cfg->{max_results} || 200;
    my $passwd = $cfg->{passwd} || '';

    $template ||= Template->new({
                                 INCLUDE_PATH => [$cfg->{tt2},
                                                  Template::Config->instdir('templates')],
                                 PRE_PROCESS => ['config', 'header'],
                                 POST_PROCESS => 'footer',
                                 POST_CHOMP => 1,
                                })  || do {
                                  $r->log_error(Template->error());
                                  return Apache2::Const::SERVER_ERROR;
                                };
    $query ||= CPAN::Search::Lite::Query->new(db => $cfg->{db},
                                              user => $cfg->{user},
                                              passwd => $passwd,
                                              max_results => $max_results);

    my $mode = $req->param('mode') || 'dist';
    unless ($r->location eq '/mirror') {
        if ($r->protocol =~ /(\d\.\d)/ && $1 >= 1.1) {
            $r->headers_out->{'Cache-Control'} = 'max-age=36000';
        }
        else {
            $r->headers_out->{Expires} = APR::Date::parse_http(time+36000);
        }
    }
    my $mirror;
    my $submit = $req->param('submit') || '';
    my $webstart;
    my $lang_cookie;

    if ($submit) {
      $webstart = $req->param('webstart');
      my $value = $webstart || 1;
      my $expires = $webstart ? '+1y' : 'now';
      my $c_ws = Apache2::Cookie->new($r, 
                                           name => $cookie_ws, 
                                           path => '/',
                                           value => $value,
                                           expires => $expires);
      $c_ws->bake($r);
      
      $lang_cookie = $req->param('lang');
      $value = $lang_cookie || 1;
      $expires = $lang_cookie ? '+1y' : 'now';
      my $c_lang = Apache2::Cookie->new($r, 
                                        name => $cookie_lang, 
                                        path => '/',
                                        value => $value,
                                        expires => $expires);
      $c_lang->bake($r);
      $lang = $lang_cookie if $lang_cookie;

      my $host = $req->param('host') || $req->param('url') || '';
      if ($host) {
        my $cookie = Apache2::Cookie->new($r, 
                                          name => $cookie_mirror, 
                                          path => '/',
                                          value => $host,
                                          expires => '+1y');
        $cookie->bake($r);
        $mirror = $host;
      }
    }
    else {
      my %cookies = Apache2::Cookie->fetch($r);
      unless ($mirror) {
        if (my $c = $cookies{$cookie_mirror}) {
          $mirror = $c->value;
        }
      }
      unless ($webstart) {
        if (my $c = $cookies{$cookie_ws}) {
          $webstart = $c->value;
        }
      }
      unless ($lang_cookie) {
        if (my $c = $cookies{$cookie_lang}) {
          $lang = $lang_cookie = $c->value;
        }
      }
    }

    $CPAN::Search::Lite::Query::lang = $lang;
    unless ($pages->{$lang}) {
      my $rc = load(lang => $lang, pages => $pages, chaps_desc => $chaps_desc);
      unless ($rc == 1) {
        $r->log_error($rc);
        return;
      }
    }

    $mirror ||= $dl;
    $r->content_type('text/html; charset=UTF-8');

    my $self = {mode => $mode, mirror => $mirror, req => $req,
                html_root => $cfg->{html_root}, lang => $lang,
                html_uri => $cfg->{html_uri}, webstart => $webstart,
                title => $pages->{$lang}->{title}};
    bless $self, $class;
}

sub search : method {
    my ($self, $r) = @_;
    $self = __PACKAGE__->new($r) 
        unless ref($self) eq __PACKAGE__;
    
    my $req = $self->{req};
    my $query_term = trim($req->param('query'));
    return $self->chapter($r) unless $query_term;
    my $mode = $self->{mode};
    $mode = 'module' if $query_term =~ /::/;
    $mode = 'dist' if $query_term =~ /-/;
    $query_term =~ s{\.pm$}{} if ($mode eq 'module');
    my ($results, $page, %extra_info, $search_page);
    if ($query_term and $mode eq 'chapter') {
      if ($query_term =~ / /) {
        $mode = 'dist';
        $search_page = 'search';
      }
      else {
#        $query_term =~ s/[^\w]//g;
        $search_page = 'query';
      }
    }
    else {

Apache2/Apache2/CPAN/Query.pm  view on Meta::CPAN

  }
  return 'en';
}

sub CSL_db {
  my ($cfg, $parms, $db) = @_;
  $cfg->{ db } = $db;
}

sub CSL_user {
  my ($cfg, $parms, $user) = @_;
  $cfg->{ user } = $user;
}

sub CSL_passwd {
  my ($cfg, $parms, $passwd) = @_;
  $cfg->{ passwd } = $passwd;
}

sub CSL_tt2 {
  my ($cfg, $parms, $tt2) = @_;
  $cfg->{ tt2 } = $tt2;
}

sub CSL_dl {
  my ($cfg, $parms, $dl) = @_;
  $cfg->{ dl } = $dl;
}

sub CSL_max_results {
  my ($cfg, $parms, $max_results) = @_;
  $cfg->{ max_results } = $max_results;
}

sub CSL_html_root {
  my ($cfg, $parms, $html_root) = @_;
  $cfg->{ html_root } = $html_root;
}

sub CSL_html_uri {
  my ($cfg, $parms, $html_uri) = @_;
  $cfg->{ html_uri } = $html_uri;
}

#sub DESTROY {
#    $dbh->disconnect;
#}

1;

__END__

=head1 NAME

Apache2::CPAN::Query - mod_perl interface to CPAN::Search::Lite::Query

=head1 DESCRIPTION

This module provides a mod_perl (2) interface to CPAN::Search::Lite::Query.
The modules C<Apache2::Request>
and C<Apache2::Cookie> of the C<libapreq2> distribution
are required. A directive

    PerlLoadModule Apache2::CPAN::Query

should appear before any of the C<Location> directives
using the module. As well, the following directives should
be defined in the Apache configuration file.

=over 3

=item C<CSL_db database>

the name of the database [required]

=item C<CSL_user user>

the user to connect to the database as [required]

=item C<CSL_passwd password>

the password to use for this user [optional if no password
is required for the user specified in C<CSL_user>.]

=item C<CSL_tt2 /path/to/tt2>

the path to the tt2 pages [required].

=item C<CSL_dl http://www.cpan.org>

the default download location [optional - http://www.cpan.org will
be used if not specified]

=item C<CSL_max_results 200>

the maximum number of results to obtain [optional - 200 will be
used if not specified]

=item C<CSL_html_root /usr/local/httpd/CPAN>

the path to the local html docs [required for the perldoc handler]

=item C<CSL_html_uri http://you.org/CPAN/docs>

the uri to use for the html docs [required for the perldoc handler]

=back

Available response handlers are as follows.

=over 3

=item * search

 <Location "/search">
   SetHandler perl-script
   PerlResponseHandler Apache2::CPAN::Query->search
 </Location>

This handles search queries such as for
I<http://localhost/search?mode=dist;query=libnet>.