package Maypole::Plugin::Redirect;
use strict;
use warnings;
print "USING Maypole::Plugin::Redirect";

our $VERSION = '0.01';

use Maypole::Constants;
use URI; use URI::QueryParam; 	
use Data::Dumper; 				# for Debugging

=pod

=head1 NAME

Maypole::Plugin::Redirect -- do internal redirects in Maypole and return from them.

=head1 SYNOPSIS

package Beer;

. . .

sub do_edit {
	...
	# Just created a new beer. 
	...
	return $r->redirect('beer/list'); 
	# This is the simplest case when you don't want a return.
	# This has same effect as if you followed a link to beer/list -- 
	# authentication is checked, accessibility, and the objects and templatee
	# are set. 
}

sub create_or_select {
 	...
	my $action = $r->params->{action};
	unless ($action) {
	{
		# make forms to create or select an object 
		...
	   return;
	}
	# process forms
	$self->do_edit($r)   if $action eq 'create';
	$self->do_select($r) if $action eq 'select';
	if ($r->redirect->is_applicable) { 
		#see Pub below. This checks if someone requested something and returns
		#to them if we have it. Next line goes back to pub/add_beer_tomany
		return $r->from_redirect; 
	}
	return $r->redirect('beer/view'); 
}

package Pub;
...
sub add_beer_tomany {
 	...
	unless ( $r->params->{beer_id} } ) {
		$r->redirect('beer/create_or_select', ['beer_id']);
	}
	# Go to beer/create_or_select and letting them know that you would like
	# a beer_id. 
	my $redirect = $r->redirect; # get redirect object -- say if you want
	                             # to check it more thoroughly than is_app did
	...
}
	
=head1 DESCRIPTION 

This module adds internal "redirect" capability to Maypole applications with a little twist -- it keeps a track of the maypole requests you redirect from via a redirect object that is stored in the user session. This enables you to return  from a redirect to where you came from. 

Furthermore, you can redirect from a redirect and then again as many times as you like. The redirect object is a stack that holds the last state of r before a redirect. You must already have a session that's kept in $r->{session} but eventually it could create a session for you. If you have no session you can still do redirects but can't return from them.

This plugin adds the following methods to the maypole request object:

redirect

from_redirect


Warning: This module is still under developement. Parts are in  highly experimental stages.  The C<redirect> and C<from_redirect> do their jobs. The tricky part is figuring out the life cycle of the redirects and if a redirect is applicable to the current request. I feel i'm getting close. If you just want to redirect and not return, That seems to work just fine. I haven't found any problems doing that.

=head1 TODO

A greate deal.

=cut

# Saves state, makes new state, and then calls  redirect_guts to process the new
# request as if it were a normal request -- including checking if its
# an applicable request and doing authentication.
sub redirect {
	my ($r, @args) = @_;
	my $redir = $r->get_redirect; 
    return  $redir unless $args[0];
	$redir->push_r($r, @args) if $r->{session};
	warn "in redirect after push_r. redir is " . Dumper($redir);
	$redir->make_new_r($r,@args); 
	$r->{is_redirect} = 1; $r->{is_from_redirect} = 0;
	$r->redirect_guts(); # just handler_guts without the VIEW processing
}

# from_redirect -- does stuff necessary return to page redirected from. This 
# restores the saved request and then calls redirect_guts to process it.
# a "Maypole" redirect based on data in session->redirect. 
sub from_redirect {
	my $r = shift;
	my $redir = $r->get_redirect; 
	unless ($redir->restore_r($r)) {
		die "tried to return from a non-existant redirect." ;
	}
	$r->{is_redirect} = 0; $r->{is_from_redirect} = 1; 
	warn "in from_redirect after restor_r. redir is " . Dumper($redir);
	$r->redirect_guts;
}

# returns redirect object. If one doesn't exist, makes new one and stores in
# a Maypole request session and  returns that.
sub get_redirect {
	my $r = shift;
	my $sess = $r->{session};
	return undef unless $sess;  # won't be storing 
	unless ($sess->{redirect}) { 
		my $redir = Maypole::Plugin::RedirectObj->new; 
		warn "Creating redirect in session";
		$sess->{redirect} = $redir;
		$redir->_stamp_session($r);
		#warn "session now is " . Dumper($sess);
	}
	return $sess->{redirect};
}

# redirect_guts();
# This is just Maypole::handler_guts with view class processing (output generation) left out.

sub redirect_guts { 
	my $r = shift;
	$r->model_class( $r->config->model->class_of( $r, $r->{table} ) );
	
	warn "In redirect guts. model class = ". $r->model_class; # is_redirect = " . $r->{is_redirect} . " is_from redirect = " . $r->{is_from_redirect}; 

	my $applicable = $r->is_applicable;
	unless ( $applicable == OK ) {
	
		# It's just a plain template
		delete $r->{model_class};
		$r->{path} =~ s{/$}{};    # De-absolutify
		$r->template( $r->{path} );
	}
	
	# We authenticate every request, needed for proper session management
	my $status;
	eval { $status = $r->call_authenticate };
	if ( my $error = $@ ) {
		$status = $r->call_exception($error);
		if ( $status != OK ) {
			warn "caught authenticate error: $error";
			return $r->debug ? $r->view_object->error( $r, $error ) : ERROR;
		}
	}
	if ( $r->debug and $status != OK and $status != DECLINED ) {
		$r->view_object->error( $r,
		"Got unexpected status $status from calling authentication" );
	}
	return $status unless $status == OK;
	
	# We run additional_data for every request
	$r->additional_data;
	if ( $applicable == OK ) {
		eval { $r->model_class->process($r) };
		if ( my $error = $@ ) {
			$status = $r->call_exception($error);
			if ( $status != OK ) {
				warn "caught model error: $error";
				return $r->debug ? $r->view_object->error( $r, $error ) : ERROR;
			}
		}
	}

}



{  
# The Redirect Object 
package Maypole::Plugin::RedirectObj;
use strict;
use warnings;

use Time::HiRes qw(gettimeofday);
use Data::Dumper;

sub new {
	warn "Making a new Redirect Object.";
	my $class =  shift;
    $class = ref $class || $class;	
	my $self = [];
	bless $self, $class;
}


# Determines if a request should return from redirect or not. This may not be
# efficient in it self to determine that but it does best it can. 
# I checks the topmost redirect to see if we should return from it or not. 
# It does this by checking if the requested params have been gotten
# and if return from path matches current path. 
#
# acceptable cases are : 
#   return_params are ok      and return_from is not set
#   return_params are not set and return_from is ok
#   return_params don't match and return_from matches and has other elements.

# cleans up the redirect object. IE deletes redirects if they are no longer 
# applicable
# TODO thouroughly test this
sub cleanup {
	my ($self, $r) = @_;

	warn " Starting cleanup: redirect is  = " . Dumper($self);
	# done if empty, we just did a redirect or from redirect
	return if  ($r->{is_redirect} || $r->{is_from_redirect});
	return if @$self eq 0;

   
	# what if refresh was hit? How can you determine this? 
	# right now redir pobably empty.
warn "cleanup: self, is_redirect, or is_from_redirect passed. about to call is_applicable";	
    # delete it if redirect is no longer valid
	unless ($self->is_applicable($r)) {
		@$self = ();
		$self->_stamp_session($r);
		return;
	}

	# shift return_from list if exists
	my $return_from = eval { shift @{ $self->[0]->{return_from} }; };
	warn "lost return from is " . $return_from || '';
	$self->_stamp_session($r);
	warn "Finished cleanup";

}

sub top { return shift->[-1]; }
# This tries to determine if a redirect is applicable to current request
# ie if it should return from redirect or not. It simply checks return params'
# and return path to see if current page did /is what the redirector wanted.
sub is_applicable {
	my ($self, $r) = @_;
	my $top = $self->top; #[-1]; # top redirect
	
	
	warn "is_applicable: top is : " . Dumper($top);
	# Get lists of parameters we may be asked to return and path we are expected
	# to come back on.
	my ($return_params, $return_from) = ( $top->{return_params}, 
	                                     $top->{return_from} );
	# Case: if both are empty arrays,  not applicable
	return 0 unless eval { @$return_params || @$return_from; };
	warn " we have return prams or  from: " . Dumper($return_params,  $return_from); 
	
	
    # Case: return_from has more than one element
	# Action: ONly check that current path matches return_from->[0].
	# Explanation: This case is probably only used when Maypole decides
	# if it should delete redirects or not. 
	# This means we may be on a path to getting some params but not on page
	# that makes those. For this reason params is not checked in this case.
	# Return params are only checked when return from has 1 or 0 elements.

	my $return_from_ok = 1; 	# ok if it matches or doesn't exist its
	if (my $this_rtrn = eval {$return_from->[0]} ) {
		my $path = $r->path;
		$this_rtrn =~ s/\/+$//; # chop trailing slashes
		$path 	   =~ s/\/+$//; 
		$return_from_ok = 0 unless $this_rtrn eq $path; 
		warn "is_applicable -- return from ok? path is $path, rhis retrn = $this_rtrn";
	# TODO -- watch match above -- should it be exact, should it be just obj/act
	# , ? 
	}
	
	warn "return from ok = $return_from_ok";
	return 1 if ( @$return_from > 1 and $return_from_ok);

	# Case: wanted params -- Are all the params the original r wanted here and
	# are we still on return path?
	# Action: set return_params_ok and check it with return_from_ok
	
	my $return_params_ok = 1; # ok if no return_params or all are here
	my $params = $r->params; 
	warn "is_app -- params: " . Dumper($params, $return_params);
	if ( eval{ @$return_params }) {  	
		foreach ( @$return_params ) {
		    $return_params_ok = 0 unless exists($params->{$_});
			last unless $return_params_ok;
		}
	}	
	my $retrnlast = $return_params_ok && $return_from_ok;
	warn "last retrun $retrnlast : $return_params_ok";
	return  $retrnlast;
}

# return Maypole session to put redirect object in.
sub _get_redirect_session {
	$_[1]->{session}; # $r->{session}
}




# Pushes current Maypole request's state (which  we are redirecting from if this
# is called) onto redirect stack so we can return back later if we want.
sub push_r {
	my ($self, $r, @args) = @_; #$path, $rtrn_params, $rtrn_path) = @_;
	warn " push r -- @_"; 
	die unless ref $self eq 'Maypole::Plugin::RedirectObj';
	push @$self, { 
					redirected_to	=> $args[0],  		#$path,
					return_params 	=> $args[1] || [],  #$rtrn_params || [],
					return_from  	=> $args[2] || [],  #$rtrn_path   || [],

					path        	=> $r->path,
					model_class 	=> $r->model_class,
	     			table       	=> $r->table,
				  	action      	=> $r->action, 
				   	args			=> $r->args,
					
	#				params      	=> $r->params,
	#				template_args 	=> $r->template_args,
	# TODO maybe save and restore params and template_args
				  };
	$self->_stamp_session($r);
}


sub make_new_r {
	my ($self, $r, $path) = @_;
	my $url = URI->new($path);
	warn "in make new r: r path = " . $r->path . " new path = " . $url->path;
	$r->{path} = $url->path;

	$r->parse_path;
	# TODO test this
	# make params be the orig $r params, query params on redirect path, + an
	# element to tell model action its been redirected to.
	$r->{params} = { %{$r->params}, %{$url->query_form_hash} };

	# Assert -- original $r's template args included + element to tell template
	# its a redirect.
	warn " path is : " . $r->path . " params are " . Dumper( $r->params) . " tmpl args = " . Dumper($r->template_args);

	# delete r->template or model_class process will return prematurely
	$r->template(undef); 

}

# Restores state of request before redirect. Does nothing if no redirect
# Pops last redirect off stack and puts data in $r. Marks request as
# from_redirect.
sub restore_r {
	my ($self, $r) = @_;
	my $top = pop @$self;
	unless ($top) {
		warn "Couldn't restore state No redirects." ;
		return undef;
	}
	#warn "after restore state session is " . Dumper($r->{session});
	$self->_stamp_session($r);

    # TODO -- put requested parameters in params
	#foreach my $wanted ($top->requested_params) {
	#	$r->params->{$wanted} = [
	$r->path( $top->{path} );
	$r->model_class( $top->{model_class} );
	$r->table($top->{table}); 
	$r->action( $top->{action} );
	$r->args( $top->{args} );
	$r->template(undef);   		# delete this or model_class process will return
	                            # before doing anything
	return 1;
}


# _stamp_session()
# Do something to session so it will be written back before request terminates.
# The default assumes you are using an Apache::Session which only checks the 
# top level of the hash so we timestamp it in top level.
sub _stamp_session {
   my $sess = shift->_get_redirect_session(shift);
   my ($s, $m) = gettimeofday(); 
   $sess->{timestamp} = "". gettimeofday() . ""; 
}
1;
} # end RedirectObj

1;

=head1 LIMITATIONS

=cut