package Yaa::Daemon;

# inherit methods and properties from Net::Server::PreFork and Yaa
@ISA = qw(
	Net::Server::PreFork
	Yaa
);

# standard modules
use strict;
use vars qw($VERSION $Error);
use Yaa;
use Net::Server::PreFork;

$VERSION = '0.2';
$Error = undef;

####################################################
#            OBJECT CONSTRUCTOR                    #
####################################################

sub new {
	my $proto = shift;
	my $class = ref($proto) || $proto;
	
	my $self = Yaa->new();

	$self->{daemon_timeout} = 5;				# timeout in seconds

	# private vars
	$self->{_tf} = {};							# empty timeframe hash ref
	$self->{_proto_mods} = {};					# protocol modules
	
	bless($self, $class);
	return $self;
}


####################################################
#               PUBLIC METHODS                     #
####################################################

# initializes new driver
sub factory {
	shift if ($_[0] eq 'Yaa::Daemon');
	my $driver = undef;

	# it's time to parse command line arguments
	for (my $i = 0; $i <= $#_; $i++) {
		if ($_[$i] eq 'protocol') {
			$driver = $_[$i + 1];
			last;
		}
	}

	# time to initialize driver
	if ($driver) {
		if (! grep(/^\Q$driver\E$/, Yaa::Daemon->getAvailableProtocols())) {
			$Error = "Driver " . $driver . " is not available.";
			return undef;
		}

		# Load protocol module
		eval "require Yaa::Daemon::Protocol::$driver;";

		if ($@) {
			$Error = "Unable to load protocol driver \"$driver\" (require() failed).\nMessage:\n$@";
			return undef;
		}
		return ("Yaa::Daemon::Protocol::" . $driver)->new(@_);
	}

	# hm..., looks like driver has not been initialized
	$Error = "Protocol driver was not specified.";

	# return error
	return undef;
}


# Overloaded methods
sub process_request {
	my ($self) = @_;
	$self->{error} = "This method must be overloaded by the protocol driver class.";
	return 0;
}

sub clearParams {
	my ($self) = @_;

	return 1;
}

=head2 setParams (key => value, key2 => value2)

Sets object's parameters. Parameters are driver dependent.

=cut
sub setParams {
	my ($self) = shift;

	while (defined (my $name = shift) && defined (my $value = shift)) {
		$self->{$name} = $value if (substr($name, 0, 1) ne '_');
	}
	
	return 1;
}

# This function was taken from perl DBI module,
# written by Tim Bunce and later modified for Yaa
# requirements
# returns array of maps
sub getAvailableProtocols {
	my(@drivers, %seen_dir, %seen_yaa);
	my $haveFileSpec = eval { require File::Spec };
	local (*DIR, $@);

	foreach  my $d (@INC){
		# Perl 5 beta 3 bug in #!./perl -Ilib from Test::Harness
		chomp($d);

		my $yaa_dir = ($haveFileSpec ? File::Spec->catdir($d, "Yaa", "Daemon", "Protocol") : $d . "/Yaa/Daemon/Protocol");
		next unless (-d $yaa_dir);
		next if ($seen_dir{$d});
		$seen_dir{$d} = 1;

		# XXX we have a problem here with case insensitive file systems
		# XXX since we can't tell what case must be used when loading.
		if (! opendir(DIR, $yaa_dir)) {
			print STDERR "Cannot open directory ", $yaa_dir, ": ", $!, "\n";
			next;
		}
		foreach my $f (readdir(DIR)){
 			next unless ($f =~ s/\.pm$//);
			next if ($f eq 'NullP');
			
			# this map driver seems ok, push it into list of drivers
			push(@drivers, $f) unless ($seen_yaa{$f});
			$seen_yaa{$f} = $d;
		}
		closedir(DIR);
	}

	# "return sort @drivers" will not DWIM in scalar context.
	return (wantarray ? sort @drivers : @drivers);
}

####################################################
#             Net::Server HOOKS                    #
####################################################

sub write_to_log_hook {
	my $self = shift;
	my $level = shift;
	$self->_logger(@_);
}

sub post_bind_hook {
	my ($self) = @_;

#	return chmod(0666, @{$self->{daemon_sockets}}) if (@{$self->{daemon_sockets}});
}

sub child_init_hook {
	local $SIG{CHLD} = 'DEFAULT';
	$0 = "Yaa! (child, idle, unused)";
}

sub post_accept_hook {
	my ($self) = @_;
	local $SIG{CHLD} = 'DEFAULT';
	$self->_logger("Connect from " . $self->{server}->{client}->peerhost . ":" . $self->{server}->{client}->peerport);
	$0 = "Yaa! (child, connect from: " . $self->{server}->{client}->peerhost . ": processing)";
}

sub post_process_request_hook {
	my ($self) = @_;
	local $SIG{CHLD} = 'DEFAULT';
	$self->_logger("Disconnect from: " . $self->{server}->{client}->peerhost);
	$0 = "Yaa! (child, idle)";

	# TODO shutdown child process after client disconnects
	#$self->_logger("Child process exiting.");
	#exit 0;
}

sub fatal_hook {
	my ($self, $msg, $package, $file, $line_no) = @_;

	$self->_logger("Fatal error accoured in package '" . $package . "' in file '" . $file . "' line number " . $line_no. ": " . $msg);

	return 1;
}

sub post_child_cleanup_hook {
	my ($self) = @_;

	$self->_logger("Yaa! shutting down.");
	return 1;
}

sub restart_close_hook {
	my($self) = @_;

	$self->_logger("Yaa! restarting.");
	return 1;
}

####################################################
#               PRIVATE METHODS                    #
####################################################

1;

=head1 SEE ALSO

perldoc Yaa.

=cut

=head1 AUTHOR

Branko F. Gracnar <bfg@frost.ath.cx>
http://frost.ath.cx/~bfg

=cut

=head1 LICENSE

This software is released under BSD-style license. If you like this software, send me a nice postcard from somewhere to the snail mail address published on my website.

=cut

