From: Aaron Trevena <aaron.trevena@gmail.com>
Date: Wed, 5 Oct 2005 15:17:50 +0000 (+0000)
Subject: merged in TEEJAY Changes with current head
X-Git-Tag: 2.11~130
X-Git-Url: https://git.decadent.org.uk/gitweb/?p=maypole.git;a=commitdiff_plain;h=2e483f35964e1ddd2022df6adc2b6d6a631c0cbd

merged in TEEJAY Changes with current head

git-svn-id: http://svn.maypole.perl.org/Maypole/trunk@388 48953598-375a-da11-a14b-00016c27c3ee
---

diff --git a/lib/Apache/MVC.pm b/lib/Apache/MVC.pm
index c9d6a32..4653112 100644
--- a/lib/Apache/MVC.pm
+++ b/lib/Apache/MVC.pm
@@ -7,6 +7,7 @@ use warnings;
 
 use base 'Maypole';
 use Maypole::Headers;
+use Maypole::Constants;
 
 __PACKAGE__->mk_accessors( qw( ar ) );
 
@@ -14,7 +15,6 @@ BEGIN {
     my $version;
     eval 'use mod_perl2; $version = $mod_perl2::VERSION; ';
     if ($@) {
-	warn "no mod_perl 2.x using mod_perl 1.x\n";
 	use mod_perl;
 	$version = 0;
 	require Apache;
@@ -28,7 +28,6 @@ BEGIN {
     }
 
     use constant APACHE2 => $version;
-
 }
 
 sub get_request {
@@ -36,6 +35,12 @@ sub get_request {
     $self->{ar} = (APACHE2) ? Apache2::Request->new($r) : Apache::Request->new($r);
 }
 
+sub get_protocol {
+  my $self = shift;
+  my $protocol = ( $self->{ar}->protocol =~ m/https/i ) ? 'https' : 'http' ;
+  return $protocol;
+}
+
 sub parse_location {
     my $self = shift;
 
@@ -63,6 +68,29 @@ sub parse_args {
     $self->{query}  = { $self->_mod_perl_args( $self->{ar} ) };
 }
 
+# FIXME: use headers_in to gather host and other information?
+sub redirect_request {
+  my $self = shift;
+  my $redirect_url = $_[0];
+  my $status = "302";
+  if ($_[1]) {
+    my %args = @_;
+    if ($args{url}) {
+      $redirect_url = $args{url};
+    } else {
+      my $path = $args{path} || $self->{path};
+      my $host = $args{domain} || $self->{ar}->hostname;
+      my $protocol = $args{protocol} || ( $self->{ar}->protocol =~ m/https/i ) ? 'https' : 'http' ;;
+      $redirect_url = "${protocol}://${host}/${path}";
+    }
+    $status = $args{status} if ($args{status});
+  }
+
+  $self->headers_out->set('Status' => $status);
+  $self->headers_out->set('Location' => $redirect_url);
+  return OK;
+}
+
 sub send_output {
     my $r = shift;
     $r->{ar}->content_type(
diff --git a/lib/CGI/Maypole.pm b/lib/CGI/Maypole.pm
index b7e5ca2..bb6de3f 100644
--- a/lib/CGI/Maypole.pm
+++ b/lib/CGI/Maypole.pm
@@ -5,6 +5,7 @@ use strict;
 use warnings;
 use CGI::Simple;
 use Maypole::Headers;
+use Maypole::Constants;
 
 our $VERSION = '2.10';
 
@@ -17,6 +18,11 @@ sub get_request {
     shift->{cgi} = CGI::Simple->new();
 }
 
+sub get_protocol {
+  my $self = shift;
+  my $protocol = ($self->{cgi}->https()) ? 'https' : 'http';
+  return $protocol;
+}
 
 sub parse_location {
     my $self = shift;
@@ -49,6 +55,32 @@ sub parse_args {
     $self->{query}  = {%vars};
 }
 
+# FIXME: use headers_in to gather host and other information?
+sub redirect_request {
+  my $self = shift;
+  my $redirect_url = $_[0];
+  my $status = "302";
+  if ($_[1]) {
+    my %args = @_;
+    if ($args{url}) {
+      $redirect_url = $args{url};
+    } else {
+      my $path = $args{path} || $self->{cgi}->url(-absolute => 1, -query=>1);
+      my $host = $args{domain};
+      ($host = $self->{cgi}->url(-base => 1)) =~ s/^https?:\/\///i unless ($host);
+      my $protocol = $args{protocol} || ($self->{cgi}->https()) ? 'https' : 'http';
+      $redirect_url = "${protocol}://${host}/${path}";
+    }
+    $status = $args{status} if ($args{status});
+  }
+
+  $self->headers_out->set('Status' => $status);
+  $self->headers_out->set('Location' => $redirect_url);
+
+  return;
+}
+
+
 sub send_output {
     my $r = shift;
 
diff --git a/lib/Maypole.pm b/lib/Maypole.pm
index 908662f..664df4b 100644
--- a/lib/Maypole.pm
+++ b/lib/Maypole.pm
@@ -7,7 +7,7 @@ use Maypole::Config;
 use Maypole::Constants;
 use Maypole::Headers;
 
-our $VERSION = '2.10';
+our $VERSION = '2.11';
 
 # proposed privacy conventions:
 # - no leading underscore     - public to custom application code and plugins
@@ -247,6 +247,25 @@ sub is_applicable
                         
     return DECLINED unless exists $config->ok_tables->{$table};
 
+    my $path_is_ok = 0;
+    if (exists $config->ok_tables->{ $self->{table} }) {
+      $path_is_ok = 1;
+    } else {
+      if ( $self->_have_default_table_view ) {
+	my $path_is_ok = $self->default_table_view($self->{path},$self->{args});
+      }
+      unless ($path_is_ok) {
+	warn "We don't have that table ($self->{table}).\n"
+	  . "Available tables are: "
+	    . join( ",", @{ $config->{display_tables} } )
+	      if $self->debug
+		and not $config->ok_tables->{ $self->{table} }
+		  and $self->{action};
+      }
+    }
+
+    return DECLINED() unless $path_is_ok;
+
     # Is it public?
     return DECLINED unless $self->model_class->is_public($self->action);
     
@@ -285,6 +304,27 @@ sub call_exception
     return $self->exception($error);
 }
 
+sub default_table_view {
+  my ($self,$path,$args) = @_;
+  my $path_is_ok = 0;
+  my $default_table_view = __PACKAGE__->_default_table_view;
+  # (path class action field)
+  my @path = $self->{path} =~ m{([^/]+)/?}g;
+  my $search_value = shift(@path);
+  if ($default_table_view->{path}) {
+    if ($default_table_view->{path} eq $search_value) {
+      $search_value = shift(@path);
+    } else {
+      return 0;
+    }
+  }
+
+  $self->{table} = $default_table_view->{class};
+  $self->{action} = $default_table_view->{action};
+  $self->{args} = [ $search_value,@path ];
+  return $path_is_ok;
+}
+
 sub additional_data { }
 
 sub authenticate { return OK }
@@ -325,12 +365,20 @@ sub param
 sub get_template_root {'.'}
 sub get_request       { }
 
+sub get_protocol {
+  die "get_protocol is a virtual method. Do not use Maypole directly; use Apache::MVC or similar";
+}
+
 sub parse_location {
-    die "Do not use Maypole directly; use Apache::MVC or similar";
+    die "parse_location is a virtual method. Do not use Maypole directly; use Apache::MVC or similar";
+}
+
+sub redirect_request {
+  die "parse_location is a virtual method. Do not use Maypole directly; use Apache::MVC or similar";
 }
 
 sub send_output {
-    die "Do not use Maypole directly; use Apache::MVC or similar";
+    die "send_output is a virtual method. Do not use Maypole directly; use Apache::MVC or similar";
 }
 
 # Session and Repeat Submission Handling
@@ -591,6 +639,26 @@ exception method of your Maypole application.
 returns a unique id for this request can be used to prevent or detect repeat
 submissions.
 
+=head3 get_protocol
+
+Returns the protocol the request was made with, i.e. https
+
+=head3 redirect_request
+
+Sets output headers to redirect based on the arguments provided
+
+Accepts either a single argument of the full url to redirect to, or a hash of named parameters :
+
+$r->redirect_request('http://www.example.com/path');
+
+or
+
+$r->redirect_request(protocol=>'https', domain=>'www.example.com', path=>'/path/file?arguments', status=>'302', url=>'..');
+
+The named parameters are protocol, domain, path, status and url
+
+Only 1 named parameter is required but other than url, they can be combined as required and current values (from the request) will be used in place of any missing arguments. The url argument must be a full url including protocol and can only be combined with status.
+
 =head3 handler
 
 This method sets up the class if it's not done yet, sets some
@@ -598,7 +666,10 @@ defaults and leaves the dirty work to handler_guts.
 
 =head3 handler_guts
 
-This is the core of maypole. You don't want to know.
+This is the main request handling method and calls various methods to handle the request/response
+and defines the workflow within Maypole.
+
+Currently undocumented and liable to be refactored without warning.
 
 =head1 SEE ALSO