redirecting...

X-Git-Url: https://git.decadent.org.uk/gitweb/?a=blobdiff_plain;f=lib%2FApache%2FMVC.pm;h=0f99fbfa20a1e7cb47c8197daecee3c7d0ac0885;hb=5f93d42b8c5164f2444d5f4ba29ed47611d7dfde;hp=6f85d6e170145dfd200333e9d5cfd6677ee6f99a;hpb=dd1b398a6d2ba788021fafdb7d385e0dae1b0b50;p=maypole.git diff --git a/lib/Apache/MVC.pm b/lib/Apache/MVC.pm index 6f85d6e..0f99fbf 100644 --- a/lib/Apache/MVC.pm +++ b/lib/Apache/MVC.pm @@ -1,6 +1,6 @@ package Apache::MVC; -our $VERSION = '2.11'; +our $VERSION = '2.121'; use strict; use warnings; @@ -27,6 +27,7 @@ BEGIN { } require Apache2::RequestIO; require Apache2::RequestRec; + require Apache2::Log; require Apache2::RequestUtil; eval 'use Apache2::Const -compile => qw/REDIRECT/;'; # -compile 4 no import require APR::URI; @@ -93,11 +94,17 @@ functionality. See L for these: sub get_request { my ($self, $r) = @_; + my $request_options = $self->config->request_options || {}; my $ar; if ($MODPERL2) { - $ar = eval {require Apache2::Request} ? Apache2::Request->new($r) : $r; - } - else { $ar = Apache::Request->instance($r); } + $ar = eval {require Apache2::Request} ? Apache2::Request->new($r,%{$request_options}) : $r; + } else { + if (keys %$request_options) { + $ar = Apache::Request->new($r,%{$request_options}); + } else { + $ar = Apache::Request->instance($r); + } + } $self->ar($ar); } @@ -110,9 +117,15 @@ sub warn { my ($package, $line) = (caller)[0,2]; my $ar = $self->parent ? $self->parent->{ar} : $self->{ar}; if ( $args[0] and ref $self ) { + my @lines = split /\n/, (join '', @args); + $ar->warn("[$package line $line] ".shift(@lines)); + foreach(@lines) { + next unless $_; + $ar->warn(" $_"); + } $ar->warn("[$package line $line] ", @args) ; } else { - print "warn called by ", caller, " with ", @_, "\n"; + print STDERR "warn called by ", caller, " with ", @_, "\n"; } return; } @@ -127,6 +140,7 @@ sub parse_location { # Reconstruct the request headers $self->headers_in(Maypole::Headers->new); + my %headers; if ($MODPERL2) { %headers = %{$self->ar->headers_in}; } else { %headers = $self->ar->headers_in; } @@ -134,6 +148,8 @@ sub parse_location { $self->headers_in->set($_, $headers{$_}); } + $self->preprocess_location(); + my $path = $self->ar->uri; my $base = URI->new($self->config->uri_base); my $loc = $base->path; @@ -185,12 +201,10 @@ can only be combined with status. =cut -sub redirect_request -{ +sub redirect_request { my $r = shift; my $redirect_url = $_[0]; - my $status = $MODPERL2 ? eval 'Apache2::Const::REDIRECT;' : - eval 'Apache::Constants::REDIRECT;'; # why have to eval this? + my $status = $MODPERL2 ? eval 'Apache2::Const::REDIRECT;' : eval 'Apache::Constants::REDIRECT;'; if ($_[1]) { my %args = @_; if ($args{url}) { @@ -199,16 +213,22 @@ sub redirect_request my $path = $args{path} || $r->path; my $host = $args{domain} || $r->ar->hostname; my $protocol = $args{protocol} || $r->get_protocol; - $redirect_url = "${protocol}://${host}/${path}"; + + $redirect_url = URI->new; + $redirect_url->scheme($protocol); + $redirect_url->host($host); + $redirect_url->path($path); } $status = $args{status} if ($args{status}); } $r->ar->status($status); $r->ar->headers_out->set('Location' => $redirect_url); + $r->output('redirecting...

redirecting..

') unless ($r->output); return OK; } + =item get_protocol =cut