package SL::Handler;

use Data::Dumper;
 $Data::Dumper::Sortkeys = 1;
use Apache2::RequestRec (); # for $r->content_type
use Apache2::RequestIO ();  # for print
use Apache2::SubRequest ();
use APR::Finfo ();
use APR::Table ();
use Apache2::Const -compile => (':common');
use CGI;

our %config = (
	per_user_namespaces=>1,
	slbase=>'/home/sql-ledger/htdocs'
);


sub handler { 
	my $r = shift;
	

	if($r->path_info =~ /\.pl$/) { 
		# reload, only in dev/debug mode
		@ARGV = @SL::base::_sl_next_argv;
		@SL::base::_sl_next_argv = ();
		
		my $self = __PACKAGE__->new($r);
		$r->pnotes('_sl_handler'=>$self);

		chdir $config{slbase};
		$self->run_sl();

		return OK;
	} else {
		# let apache serve othe rcontent.
		# can probably avoid this w/ more judicious use of 
		# apache configuration statements
		my $file = $config{slbase}.$r->path_info;
		
		#TODO: fix this hack:
		$file =~ s/\/sl\//\//;

		print STDERR '[debug] serving '.$file."\n";
		
		my $subr = $r->lookup_file($file);
		$r->content_type($subr->content_type);
		$subr->run();
		return OK;
	}
}

# -----------------------------------------------------------------------------------
sub new {
	my $self = shift;
	my $request = shift;
	$self = bless {}, $self;
	$self->{_r} = $request;
	$self->{_c} = new CGI;

	$self->{_a} = {};

	for my $key ($self->cgi->param) { 
		# SQL-Ledger is SOOOOOO stupid in this regard.
		my @values =  $self->cgi->param($key);
		$self->{_a}{$key} =  $values[-1];
	}
	
	$self->debug('---------------------------------------------------------------- new,'.$self.' vars is '.Dumper($self->args));

	return $self;	
}

sub script_namespace {
	my $self = shift;
	
	my $username = $self->args('login')||'';
	my $path = $self->args('path')||'';
	my $script = $self->script({full=>1});

	return join('::','Sl_mod_perl',grep { $_ } map { s/[^a-zA-Z0-9]//g;$_} $username, $path, $script);
	
}

=head3 script

Sql-ledger only accesses URLs one level deep.

=cut

sub script { 
	my $self = shift;
	my $args = shift || {};

	my $script = $self->request->path_info;
	$script =~ s#^/##;
	unless($args->{full}) { 
		$script =~ s#^.*/##;
	}
	return $script;
}

sub formdata { 
	my $self = shift;
	my $args = $self->args;
	my $string = '';
	$string = join('&', map { sprintf("%s=%s", $_, $args->{$_}) } keys %$args);

	return $string;
}

sub args { $_[1] ? $_[0]->{_a}->{$_[1]} : $_[0]->{_a}; }
sub cgi { $_[0]->{_c} };
sub request { $_[0]->{_r} };
sub current { $self->request->pnotes('_sl_handler'); }

sub debug {
	my $self = shift;

	#$self->request->content_type('text/html') if not $self->request->content_type;

	#$self->request->print(@_,"<br>\n");

	print STDERR '[debug] '.join(' ',@_)."\n";
}

# ------------------------------------------------------------------
use IO::String;
use Devel::Peek 'Dump';

sub run_sl {
	my $self = shift;
	my $namespace = $self->script_namespace;

	$self->debug("$$, calling on $namespace");

	unless(UNIVERSAL::can($namespace,'runit')) { 
		$self->debug("$$, compiled $namespace");
		my $code =  qq{
			package $namespace;
			\@${namespace}::ISA = qw(SL::base);
			__PACKAGE__->startup();
		};
		eval $code;
	}
	
	$self->debug('just before tying it to IO::String'.ref tied(*STDOUT));

	untie *STDOUT;
	my $output = tie *STDOUT, IO::String;

	$namespace->install_hacks($self);
	if($self->script eq 'login.pl') { 
		$namespace->loginscreen($self); 
	} else { 
		$namespace->runit($self);
	}
	$self->sl_parse_send_response($output);
}

sub sl_parse_send_response {
	my $self = shift;
	my $outputbuf = shift;

	my $head = $self->request->headers_out;

	my $content = ${$outputbuf->sref};
	my ($unparsed_headers,$output) = $content =~ m/^(.*?)\n\n/s;

	foreach my $line (split /\n/,$unparsed_headers) { 
		my ($key, $value) = $line =~ /^([^:]+):\s*(.*)$/;
#	$head->{$key} = $value;
	}
	$self->debug('Going to sen out '.length($content). ' bytes');
	$self->request->print($content);
	
}
sub sl_exit { 
	my $self = shift;
	$self->{_exit} = shift;
}


# ----------------------------------------------------------------------------------------------------
# ----------------------------------------------------------------------------------------------------
# ----------------------------------------------------------------------------------------------------
# ----------------------------------------------------------------------------------------------------
# ----------------------------------------------------------------------------------------------------
# ----------------------------------------------------------------------------------------------------
# ----------------------------------------------------------------------------------------------------
# ----------------------------------------------------------------------------------------------------
# ----------------------------------------------------------------------------------------------------
# ----------------------------------------------------------------------------------------------------
# ----------------------------------------------------------------------------------------------------
# ----------------------------------------------------------------------------------------------------
# ----------------------------------------------------------------------------------------------------
# ----------------------------------------------------------------------------------------------------
# ----------------------------------------------------------------------------------------------------
# ----------------------------------------------------------------------------------------------------
# ----------------------------------------------------------------------------------------------------
# ----------------------------------------------------------------------------------------------------
# ----------------------------------------------------------------------------------------------------
# ----------------------------------------------------------------------------------------------------
# ----------------------------------------------------------------------------------------------------
# ----------------------------------------------------------------------------------------------------
# ----------------------------------------------------------------------------------------------------
# ----------------------------------------------------------------------------------------------------
# ----------------------------------------------------------------------------------------------------
# Below is stolen from 2.6.10 of Sql-ledger, may need to be updated/hacked as nessecary.
# ----------------------------------------------------------------------------------------------------
package SL::base;
use SL::Form;
#use DBI qw(:sql_types);
use Data::Dumper; 
 $Data::Dumper::Sortkeys = 1;
use Scalar::Util qw(blessed);
use Carp;

no strict;
no warnings;

our $userspath = "users";
our $spool = "spool";
our $templates = "templates";
our $memberfile = "users/members";
our $sendmail = "| /usr/sbin/sendmail -t";
our %printer = ( Printer => 'lpr' );
our $mod_sl;
our $form;
our $locale;
our %myconfig;
our $sl_module;


sub startup { 
	my $self = shift;
	$sl_module = $self;
}

sub _sl_do { 
	my $self = shift;
	my $file = shift;
	
	$mod_sl->debug('_sl_do: '.$file);

	open FH,'<'.$file or confess("Can't open $file: $!");	
	my $code = join('',<FH>);
	close FH;

	@ARGV = @_ if @_;
	$0 = $file;

	return $self->_sl_eval($code,$file);
}

sub _sl_eval { 
	my $self = shift;
	my $code = shift;
	my $hint = shift||'Code evaled with _sl_eval';

	my $namespace = blessed($self)||$self;
	
	$mod_sl->debug('_sl_eval: namespace: '.$namespace);
	
	$aliases = $self->_sl_alias_globals($namespace);

	$code = qq{
		package $namespace;
		no strict;
		no warnings;
		$aliases

#line 0 "$hint"
		$code;
	};

	eval $code;
	$mod_sl->debug("Errors compiling $hint: $@") if $@;

}

sub _sl_alias_globals { 
	my $self = shift;
	my $type = ref($self)||$self;

	return qq{
		*userspath = \\\$SL::base::userspath;
		*spool = \\\$SL::base::spool;
		*templates = \\\$SL::base::templates;
		*memberfile = \\\$SL::base::memberfile;
		*sendmail = \\\$SL::base::sendmail;
		*printer = \\\%SL::base::printer;
		*mod_sl = \\\$SL::base::mod_sl;
		*form = \\\$SL::base::form;
		*locale = \\\$SL::base::locale;
		*myconfig = \\\%SL::base::myconfig;

	}	
	
}


sub _sl_form_new { 
		my $type = shift;
		my $self = {};

		if ($ARGV[0]) {
			$_ = $ARGV[0];
			%$self = split /[&=]/;
			#for (keys %$self) { $self->{$_} = unescape("", $self->{$_}) }
			for (keys %$self) { $self->{$_} = $self->{$_} }
			$mod_sl->debug('used ARGV technique');
		} else { 
			%$self = %{$mod_sl->args};
			$mod_sl->debug('used args method');
		}
		$mod_sl->debug('in hacked new, '.$mod_sl.'self is '.Dumper($self));
		$self->{JASON} = 'yea i got it';	
		if (substr($self->{action}, 0, 1) !~ /( |\.)/) {
			$self->{action} = lc $self->{action};
			$self->{action} =~ s/( |-|,|\#|\/|\.$)/_/g;
		}
		$self->{menubar} = 1 if $self->{path} =~ /lynx/i;

		$self->{version} = "2.6.15";
		$self->{dbversion} = "2.6.12";
		bless $self, $type;
}

sub install_hacks { 
	my $self = shift;
	$mod_sl = shift;

	$mod_sl->debug('Installing hacks');
	
	$self->_hack_reset_inc();
	$self->_hack_setup_env();

	require SL::Form;

	my $sl_base = $self;
	*Form::redirect = sub { 
		my ($self, $msg) = @_;
		$mod_sl->debug($$.' -------------------------------------------------- in my hacked redirect');

		if ($self->{callback}) {
			$mod_sl->debug("callback is: $self->{callback}");
			untie *STDOUT;
			$mod_sl->cgi->initialize_globals();
		    my ($script, $argv) = split(/\?/, $self->{callback});
			@SL::base::_sl_next_argv = ($argv);
			$mod_sl->request->internal_redirect('/sl/'.$self->{callback});
		} else {

			$self->info($msg);

		}
	};

	*Form::new = \&SL::base::_sl_form_new;
}

sub _hack_setup_env { 
	$ENV{HTTP_USER_AGENT} = $mod_sl->request->headers_in->{'User-Agent'};
	$ENV{HTTP_COOKIE} = $mod_sl->request->headers_in->{'Cookie'};	

}

sub _hack_reset_inc { 

	my $slbase = $config{slbase};
	foreach my $key ( keys %INC ) { 
		if($INC{$key} =~ /^$slbase/) { 
			# reset everything loaded from slbase EXCEPT SL/*.pm, since it doesn't have any code 
			# that needs to be executed every time it's required.
			next if $key =~ m#SL(.*?)/Form.pm#;
			$mod_sl->debug("deleting INC key $key");
			delete $INC{$key};
		}
	}
}

sub loginscreen { 
	my $self = shift;
	$mod_sl = shift;
	
	$mod_sl->debug('hello - doing loginscreen');

	$self->_sl_do('sql-ledger.conf');


	%form = %{$mod_sl->args};

	# fix for apache 2.0 bug
	map { $form{$_} =~ s/\\$// } keys %form;

	# name of this script
	$form{script} = $script = $mod_sl->script;


	if (-e "$userspath/nologin" && $script ne 'admin.pl') {
		print "Content-Type: text/html\n\n" if $ENV{HTTP_USER_AGENT};
		print "\nLogin disabled!\n";
		exit;
	}

	$mod_sl->debug('passed the login disabled test');


	if ($form{path}) {
		$form{path} =~ s/%2f/\//gi;
		$form{path} =~ s/\.\.\///g;

		if ($form{path} !~ /^bin\//) {
			print "Content-Type: text/html\n\n" if $ENV{HTTP_USER_AGENT};
			print "\nInvalid path!\n";
			exit;
		}


		$mod_sl->debug("$$ login path-case: handing things off: $form{path}/$script",  'args are ',$ARGV[0], 'form is ');

		$self->_sl_do("$form{path}/$script",$mod_sl->formdata."&script=$script");
		$mod_sl->debug('path: came back?');

	} else {
		$mod_sl->debug('in the no-path case');

		if (!$form{terminal}) {
			if ($ENV{HTTP_USER_AGENT}) {
				# web browser
				$form{terminal} = "lynx";
				if ($ENV{HTTP_USER_AGENT} !~ /lynx/i) {
					$form{terminal} = "mozilla";
				}
			} else {
				# we don't support console access in the mod_perl handler.	
			}
		}
		


		if ($form{terminal}) {

			$ARGV[0] = "path=bin/$form{terminal}&script=$script";
			map { $ARGV[0] .= "&${_}=$form{$_}" } keys %form;

			$mod_sl->debug("$$ login terminal-case: handing things off: bin/$form{terminal}/$script",  'args are ',$ARGV[0], 'form is ');
			$self->_sl_do("bin/$form{terminal}/$script");

			$mod_sl->debug('terminal: came back?');

		} else {

			print "Content-Type: text/html\n\n" if $ENV{HTTP_USER_AGENT};
			print qq|\nUnknown terminal\n|;
		}

}

# end of main

}


sub runit {
	my $self = shift;
	$mod_sl = shift;

	$mod_sl->debug('hello - doing runit');

	$self->_sl_do('sql-ledger.conf');

	$form = Form->new();

# name of this script
	$script = $mod_sl->script();

# we use $script for the language module
	$form->{script} = $script;
# strip .pl for translation files
	$script =~ s/\.pl//;

# check for user config file, could be missing or ???
	eval { $self->_sl_do("$userspath/$form->{login}.conf"); };
	if ($@) {
		$mod_sl->debug('Logged out, message is '.$@);
		$locale = new Locale "$language", "$script";
		$form->{callback} = "";
		$msg1 = $locale->text("You are logged out!");
		$msg2 = $locale->text("Login");
		$form->redirect("$msg1 <p><a href=login.pl target=_top>$msg2</a>");
	}

# locale messages
	$locale = new Locale "$myconfig{countrycode}", "$script";
	$form->{charset} = $locale->{charset};

	$myconfig{dbpasswd} = unpack "u", $myconfig{dbpasswd};
	map { $form->{$_} = $myconfig{$_} } qw(stylesheet timeout) unless ($form->{type} eq "preferences");

	$form->{path} =~ s/\.\.\///g;
	if ($form->{path} !~ /^bin\//) {
		$form->error($locale->text("Invalid path!")."\n");
	}

# did sysadmin lock us out
	if (-f "$userspath/nologin") {
		$form->error($locale->text("System currently down for maintenance!"));
	}

# pull in the main code
	$mod_sl->debug("path is $form->{path}, script is $form->{script}");
	$self->_sl_do("$form->{path}/$form->{script}");

# customized scripts
	if (-f "$form->{path}/custom_$form->{script}") {
		$self->_sl_do("$form->{path}/custom_$form->{script}");
	}

# customized scripts for login
	if (-f "$form->{path}/$form->{login}_$form->{script}") {
		$self->_sl_do("$form->{path}/$form->{login}_$form->{script}");
	}

	$mod_sl->debug("regular: handing things off:, looking for action ". $form->{action}. Dumper($form) );

	if ($form->{action}) {
# window title bar, user info
		$form->{titlebar} = "SQL-Ledger ".$locale->text("Version"). " $form->{version} - $myconfig{name} - $myconfig{dbname}";

		&check_password || return;

		if (substr($form->{action}, 0, 1) =~ /( |\.)/) {
			&{ (blessed($self)||$self).'::'.$form->{nextsub} };
		} else {
			my $method =  $locale->findsub($form->{action});
			my $package =  (blessed($self)||$self);
			warn "[jay] calling sub  $method on a $package";
			eval {
				&{ $package.'::'.$method };
			};
			$mod_sl->debug('after eval');

			$mod_sl->debug($@);
		}
	} else {
		$form->error($locale->text("action= not defined!"));
	}
}

sub check_password {
	$mod_sl->debug('check_password');

	if ($myconfig{password}) {

		$sl_module->_sl_do("$form->{path}/pw.pl");

		if ($form->{password}) {
			if ((crypt $form->{password}, substr($form->{login}, 0, 2)) ne $myconfig{password}) {
				$sl_module->_sl_eval('&getpassword;');
				return 0;
			}
		} else {
			if ($ENV{HTTP_USER_AGENT}) {
				$ENV{HTTP_COOKIE} =~ s/;\s*/;/g;
				@cookies = split /;/, $ENV{HTTP_COOKIE};
				foreach (@cookies) {
					($name,$value) = split /=/, $_, 2;
					$cookie{$name} = $value;
				}

				if ($form->{action} ne "display") {
					if ((! $cookie{"SQL-Ledger-$form->{login}"}) || $cookie{"SQL-Ledger-$form->{login}"} ne $form->{sessionid}) {
						$sl_module->_sl_eval('&getpassword(1);');
						return 0;
					}
				}
			}
		}
	}
	return 1;
}

1;