| Subject: | Apache2::RequestRec misparses URI |
I'm using mod_perl v2.0.1 (from FC4 rpm) and using the
Apache2::RequestRec->uri truncates the URI for /nmr/admin and only for
/nmr/admin (i.e. /nmr/admi and /nmr/admin2 are fine).
I have gone through my Apache configuration files and I cannot find a
redirector or URL rewriting statement. Attached is the code for the
modules involved.
[gchlip2@anabaena Apps]$ perl -v
This is perl, v5.8.6 built for i386-linux-thread-multi
Copyright 1987-2004, Larry Wall
Perl may be copied only under the terms of either the Artistic License
or the
GNU General Public License, which may be found in the Perl 5 source kit.
Complete documentation for Perl, including FAQ lists, should be found on
this system using `man perl' or `perldoc perl'. If you have access to the
Internet, point your browser at http://www.perl.org/, the Perl Home Page.
[gchlip2@anabaena Apps]$ uname -a
Linux anabaena 2.6.13-1.1526_FC4 #1 Wed Sep 28 19:15:10 EDT 2005 i686
i686 i386 GNU/Linux
[root@anabaena httpd]# httpd -v
Server version: Apache/2.0.54
Server built: Sep 2 2005 11:54:18
From httpd/error_log
[Fri Dec 28 15:17:09 2007] [notice] Apache/2.0.54 (Fedora) configured --
resuming normal operations
Rec Object: Apache2::RequestRec Got URI: /nmr/main For location: /nmr
Unparsed URI: /nmr/main at /usr/local/http-apps/perl/Apps/Reserve.pm
line 38.
Rec Object: Apache2::RequestRec Got URI: /nmr/main For location: /nmr
Unparsed URI: /nmr/main at /usr/local/http-apps/perl/Apps/Reserve.pm
line 38.
Rec Object: Apache2::RequestRec Got URI: /admin For location: /nmr
Unparsed URI: /nmr/admin at /usr/local/http-apps/perl/Apps/Reserve.pm
line 38.
Rec Object: Apache2::RequestRec Got URI: /nmr/selfadmin For location:
/nmr Unparsed URI: /nmr/selfadmin at
/usr/local/http-apps/perl/Apps/Reserve.pm line 38.
Rec Object: Apache2::RequestRec Got URI: /nmr/selfadmin For location:
/nmr Unparsed URI: /nmr/selfadmin at
/usr/local/http-apps/perl/Apps/Reserve.pm line 38.
Rec Object: Apache2::RequestRec Got URI: /nmr/mydata For location: /nmr
Unparsed URI: /nmr/mydata at /usr/local/http-apps/perl/Apps/Reserve.pm
line 38.
Rec Object: Apache2::RequestRec Got URI: /nmr/mydata For location: /nmr
Unparsed URI: /nmr/mydata at /usr/local/http-apps/perl/Apps/Reserve.pm
line 38.
Rec Object: Apache2::RequestRec Got URI: /nmr/logout For location: /nmr
Unparsed URI: /nmr/logout at /usr/local/http-apps/perl/Apps/Reserve.pm
line 38.
Rec Object: Apache2::RequestRec Got URI: /nmr/logout For location: /nmr
Unparsed URI: /nmr/logout at /usr/local/http-apps/perl/Apps/Reserve.pm
line 38.
Rec Object: Apache2::RequestRec Got URI: /nmr/admin2 For location: /nmr
Unparsed URI: /nmr/admin2 at /usr/local/http-apps/perl/Apps/Reserve.pm
line 38.
Rec Object: Apache2::RequestRec Got URI: /nmr/admi For location: /nmr
Unparsed URI: /nmr/admi at /usr/local/http-apps/perl/Apps/Reserve.pm
line 38.
[gchlip2@anabaena conf]$ ls
htpasswd httpd.conf httpd.conf.bak httpd.conf.default httpd.conf.old
httpd-lab.conf magic ssl.crt ssl.key workers.properties
[gchlip2@anabaena conf]$ pwd
/etc/httpd/conf
[gchlip2@anabaena conf]$ grep Rewrite *
grep: ssl.crt: Permission denied
grep: ssl.key: Permission denied
[gchlip2@anabaena conf]$ cd ../conf.d
[gchlip2@anabaena conf.d]$ grep Rewrite *
grep: README: Permission denied
grep: ssl.conf.rpmnew: Permission denied
[gchlip2@anabaena conf.d]$
| Subject: | Form.pm |
package Apps::Reserve::Form;
our @ISA = qw(Apps::Object);
use strict vars;
use Apps::Reserve::User;
use Apache2::Const qw(:common);
use Apps::Reserve::Form::main;
use Apps::Reserve::Form::selfadmin;
use Apps::Reserve::Form::mydata;
use Apps::Reserve::Form::logout;
use Apps::Reserve::Form::admin;
sub new {
my $self = {};
my $class = shift;
if ( $class eq 'Apps::Reserve::Form' ) {
if ( $_[0]->getMod ne '') {
$class .= '::' . lc($_[0]->getMod);
} else {
$class .= '::main';
}
}
bless $self, $class;
$self->_init(@_);
return $self;
}
sub _init {
my $self = shift;
$self->app(shift);
return;
}
sub user {
my $self = shift;
return $self->app->user;
}
sub login {
my $self = shift;
my $cgi = $self->cgi;
my $user = Apps::Reserve::User->new($self->dbh, $cgi->param('username'));
if ( $user->checkPassword($cgi->param('passwd')) > 0 ) {
$self->session->param('user',$user->id);
$self->req->user($user->id);
$self->req->headers_out->set('Location' => $self->req->location);
return REDIRECT;
} else {
my $message;
if ( $cgi->param('username') ne '' ) {
$message = $cgi->font({-color=>'red'}, $cgi->b('Login Failed'));
}
$self->req->print($self->header);
$self->req->print($cgi->start_form(), $cgi->table({-align=>'center'},
$cgi->Tr([
$cgi->td({-colspan=>2, -align=>'center'}, $message),
$cgi->td(['Email Address: ', $cgi->textfield(-name=>'username', -value=>$cgi->param('username'))]),
$cgi->td(['Password: ', $cgi->password_field(-name=>'passwd', -value=>'')]),
$cgi->td({-colspan=>2, -align=>'center'},$cgi->submit(-name=>'action', -value=>'Login')),
$cgi->td({-colspan=>2, -align=>'center'},'<A HREF="selfadmin?form=reset">Reset Password</A>') ])),
$cgi->end_form);
$self->req->print( $self->footer );
return OK;
}
}
sub header {
my $self = shift;
my $cgi = $self->cgi;
my $title = ( @_ ? shift : 'Reservation system');
my @output;
open HEADER, $self->config('header');
my $menu = $self->menu;
while (<HEADER> ) {
$_ =~ s/__RESERVE__/$menu/;
push @output, $_;
}
close HEADER;
return $cgi->start_html(-title => $title . '- Department of Medicinal Chemistry & Pharmacognosy - UIC',
-encoding=>'utf-8',
-style=>{'src'=>[ '/_styles/global.css', '/_styles/style_nmr.css'] },
-meta=>{'keywords' => 'NMR, UIC, College of of Pharmacy, Chicago',
'description' => 'Reservation System - Department of Medicinal Chemistry & Pharmacognosy - UIC'}),
@output, $cgi->h2({-class=>'boxTitle'},$cgi->b($title));
}
sub footer {
my $self = shift;
open FOOTER, $self->config('footer');
my @output = <FOOTER>;
close FOOTER;
return @output, '</HTML>';
}
sub menu {
my $self = shift;
my $cgi = $self->cgi;
my @items = ( '<LI><A HREF="main">Reservation System</A></LI>' );
if ( $self->user ) {
my $user = $self->user;
push @items, '<LI><A HREF="selfadmin">Update My Account</A></LI>';
if ( $user->hasRole('admin') ) { push @items, '<LI><A HREF="admin">Admin Page</A></LI>'; }
push @items, '<LI><A HREF="logout">Logout</A></LI>';
}
return $cgi->ul( @items )
}
sub app {
my $self = shift;
if (ref $_[0]) {
$self->{'_app'} = shift;
}
return $self->{'_app'};
}
sub cgi {
my $self = shift;
return $self->app->cgi(@_);
}
sub dbh {
my $self = shift;
return $self->app->dbh(@_);
}
sub session {
my $self = shift;
return $self->app->session(@_);
}
sub req {
my $self = shift;
return $self->app->req(@_);
}
sub config {
my $self = shift;
return $self->req->dir_config(@_);
}
1;
| Subject: | Reserve.pm |
package Apps::Reserve;
use strict vars;
use Apache2::Const qw(:common);
use CGI;
use CGI::Cookie;
use CGI::Session;
use DBI;
use Apps::Session;
use Apps::Reserve::Form;
use Apps::Reserve::User;
our $VERSION = '0.5';
sub handler {
my $r = shift;
if ( $r->location eq $r->uri ) {
$r->headers_out->set('Location' => $r->location . '/');
return REDIRECT;
}
my $self = Apps::Reserve->new($r);
return OK if $self->error;
my $form = Apps::Reserve::Form->new($self);
if ( $form ) {
return $form->printForm;
} else {
$self->req->content_type('text/plain');
return;
}
}
sub getMod {
my $self = shift;
warn 'Rec Object: ', ref($self->req), ' Got URI: ', $self->req->uri,
' For location: ', $self->req->location, ' Unparsed URI: ', $self->req->unparsed_uri;
my $pos = index( $self->req->uri, $self->req->location);
if ( $pos < 0 ) {
return;
} else {
my $len = length($self->req->location);
my $module = $self->req->uri;
substr($module, $pos, $len) = '';
$module =~ s/^\///;
$module =~ s/\?.+$//;
return $module;
}
}
sub new {
my $self = {};
bless $self, shift;
$self->_init(@_);
return $self;
}
sub _init {
my $self = shift;
$self->req(shift);
$self->cgi(shift);
$self->dbh(shift);
$self->session()->param('last_req' => $self->req->the_request);
return;
}
sub req {
my $self = shift;
if ( ref $_[0] ) {
$self->{'_req'} = shift;
}
return $self->{'_req'};
}
sub cgi {
my $self = shift;
if ( ref $_[0] ) {
$self->{'_cgi'} = shift;
}
if ( exists $self->{'_cgi'} ) {
return $self->{'_cgi'};
} else {
$self->{'_cgi'} = CGI->new($self->req);
if ( $self->req->unparsed_uri =~ /\?/ ) {
use URI;
use URI::QueryParam;
my $uri = URI->new('http://localhost' . $self->req->unparsed_uri);
my $cgi = $self->{'_cgi'};
foreach my $key ( $uri->query_param ) {
$cgi->param($key, $uri->query_param($key)) if $cgi->param($key) eq '';
}
}
return $self->{'_cgi'};
}
return;
}
sub dbh {
my $self = shift;
if ( ref $_[0] ) {
$self->{'_dbh'} = shift;
}
if ( exists $self->{'_dbh'} ) {
return $self->{'_dbh'};
} else {
my $dbh = DBI->connect($self->config('DBI-URL'), $self->config('DBI-User'), $self->config('DBI-Pwd')) ||
$self->add_err("Connection failed: ", DBI->errstr);
$self->{'_dbh'} = $dbh;
return $dbh;
}
}
sub add_err {
my $self = shift;
warn (@_);
if ( exists $self->{'_error'} ) {
push @{$self->{'_error'}}, join(' ',@_);
} else {
$self->{'_error'} = [ join(' ',@_) ];
}
return;
}
sub error {
my $self = shift;
if ( exists $self->{'_error'} ) {
my $r = $self->req;
$r->content_type('text/plain');
$r->print(join("\n",@{$self->{'_error'}}), "\n");
return 1;
} else {
return;
}
}
sub session {
my $self = shift;
my $req = $self->req;
my %cookie = CGI::Cookie->parse($req->headers_in->{'Cookie'});
if ( ref $_[0] ) {
$self->{'_session'} = shift;
}
if ( exists $self->{'_session'} ) {
return $self->{'_session'};
} else {
if ( exists $cookie{'SESSIONID'} ) {
$self->{'_session'} = CGI::Session->new('driver:MySQL', $cookie{'SESSIONID'}->value,
{Handle => $self->dbh});
} else {
$self->{'_session'} = CGI::Session->new('driver:MySQL', undef, {Handle => $self->dbh});
$self->{'_session'}->expires('+1d');
my $cookie = CGI::Cookie->new('SESSIONID' => $self->{'_session'}->id);
$self->req->headers_out->add('Set-Cookie' => $cookie);
}
if ( $self->{'_session'}->param('user') ) {
$self->req->user($self->{'_session'}->param('user'));
}
return $self->{'_session'};
}
}
sub login {
my $self = shift;
return;
}
sub rc {
my $self = shift;
if ( @_ ) {
$self->{'_rc'} = shift;
}
if ( exists $self->{'_rc'} ) {
return $self->{'_rc'};
} else {
return OK;
}
}
sub user {
my $self = shift;
my $dbh = $self->dbh;
if ( exists $self->{'_user'} ) {
return $self->{'_user'};
} elsif ( $self->req->user ) {
$self->{'_user'} = Apps::Reserve::User->new($dbh, $self->req->user);
return $self->{'_user'};
} else {
return;
}
return;
}
sub user_list {
my $self = shift;
return unless $self->user->has_role('admin');
my @users;
my $sql = 'SELECT user FROM users';
foreach my $id ( @{$self->dbh->selectcol_arrayref($sql)} ) {
push @users, Apps::Reserve::User->new($self->dbh, $id);
}
return @users;
}
sub session_list {
my $self = shift;
return unless $self->user->has_role('admin');
my @sess;
my $sql = 'SELECT id FROM sessions ORDER BY id';
foreach my $id ( @{$self->dbh->selectcol_arrayref($sql)} ) {
push @sess, Apps::Session->new($self->dbh, $id);
}
return @sess;
}
sub app {
my $self = shift;
return $self;
}
sub config {
my $self = shift;
return $self->req->dir_config(@_);
}
1;