package POEDaemon::WheelRun;


use strict;
use warnings FATAL => 'all';
no warnings 'redefine';

use Data::Dumper;
use POE qw(Wheel::Run);
use POEDaemon;


sub states
{
	return $_[0],
	[qw(
		wheelrun_exec
		wheelrun_child_stdout
		wheelrun_child_stderr
		wheelrun_child_close
		wheelrun_child_signal
		wheelrun_child_error
		wheelrun_kill
		wheelrun_send_network_reply
	)];
}


sub wheelrun_exec
{
	my ($kernel, $heap, $args) = @_[KERNEL, HEAP, ARG0];
	
	
	my $anti_forkbomb = 0;
	
	
	if ($heap->{wheel_run}->{possible_forkbomb})
	{
		log_enabled && logline "return (possible_forkbomb = '%s')", $heap->{wheel_run}->{possible_forkbomb};
		
		return;
	}
	
	
	if ($heap->{shutdown})
	{
		log_enabled && logline "return (shutdown = '%s')", $heap->{shutdown};
		
		return;
	}
	
	
	unless (defined $args)
	{
		log_enabled && logline 'invalid (undef) args';
		
		return;
	}
	
	
	unless (ref $args eq 'HASH')
	{
		log_enabled && logline 'args not HASHref';
		
		return;
	}
	
	
	my @wr_wids = keys %{$heap->{wheel_run}->{children_by_wid}};
	
	
	my ($program, $program_args);
	
	
	my $prog         = $args->{prog};
	my $name         = $args->{name};
	my $stdout_event = $args->{stdout_event};
	my $stderr_event = $args->{stderr_event};
	
	
	if (defined $prog && ref $prog eq 'ARRAY')
	{
		my @prog_array = @$prog;
		
		if ($#prog_array == 0)
		{
			$program      = [ $prog_array[0] ];
			$program_args = [];
		}
		elsif ($#prog_array > 0)
		{
			$program      = [ $prog_array[0] ];
			$program_args = [ @prog_array[1 .. $#prog_array] ];
		}
		else
		{
			log_enabled && logline "invalid ARRAYref prog:\n%s", Dumper $prog;
			
			return;
		}
	}
	else
	{
		log_enabled && logline "invalid prog\n%s", Dumper $prog;
		
		return;
	}
	
	
	my $line_filter_stdio  = POE::Filter::Line->new
	(
		InputLiteral  => "\n",
		OutputLiteral => "\n",
	);
	
	my $line_filter_stderr = POE::Filter::Line->new
	(
		InputLiteral  => "\n",
		OutputLiteral => "\n",
	);
	
	
	my $wheel = POE::Wheel::Run->new
	(
		Program      => $program,
		ProgramArgs  => $program_args,
		
		StdioFilter  => $line_filter_stdio,
		StderrFilter => $line_filter_stderr,
		
		StdoutEvent  => $stdout_event || 'wheelrun_child_stdout',
		StderrEvent  => $stderr_event || 'wheelrun_child_stderr',
		
		CloseEvent   => 'wheelrun_child_close',
		ErrorEvent   => 'wheelrun_child_error',
	);
	
	my $wheel_id   = $wheel->ID;
	my $wheel_pid  = $wheel->PID;
	my $wheel_name = $name;
	
	
	$kernel->sig_child($wheel_pid, 'wheelrun_child_signal');
	
	
	$heap->{wheel_run}->{children_by_wid}->{$wheel_id} =
	{
		wheel => $wheel,
		args  => $args,
	};
	
	$heap->{wheel_run}->{children_by_pid}->{$wheel_pid}   = $heap->{wheel_run}->{children_by_wid}->{$wheel_id};
	$heap->{wheel_run}->{children_by_name}->{$wheel_name} = $heap->{wheel_run}->{children_by_wid}->{$wheel_id} if $wheel_name;
	
	
	log_enabled && logline "[%s WIDs active] child PID %s started as wheel #%s%s: execute program '%s', args '%s'",
		$#wr_wids + 1,
		$wheel_pid,
		$wheel_id,
		($wheel_name ? sprintf ", name '%s'", $wheel_name : ''),
		join(' ', @$program),
		join('|', @$program_args);
	
	
	if ($anti_forkbomb && $heap->{wheel_run}->{last_pid})
	{
		my $pid_diff = $wheel_pid - $heap->{wheel_run}->{last_pid};
		
		
		my $max_pid_diff = 500;
		
		
		if ($pid_diff > $max_pid_diff)
		{
			$heap->{wheel_run}->{possible_forkbomb} = 1;
			
			my $message = sprintf "possible fork bomb, PID diff '%s' > max. PID diff '%s'",
				$pid_diff,
				$max_pid_diff;
			
			log_enabled && logline $message;
			
			$kernel->yield(shutdown => $message);
			
			return;
		}
	}
	
	
	$heap->{wheel_run}->{last_pid} = $wheel_pid;
}


sub wheelrun_child_stdout
{
	my ($kernel, $heap, $stdout_line, $wheel_id) = @_[KERNEL, HEAP, ARG0, ARG1];
	
	
	my $wheel = $heap->{wheel_run}->{children_by_wid}->{$wheel_id};
	
	
	log_enabled && logline "PID %s STDOUT: %s",
		$wheel->{wheel}->PID,
		$stdout_line;
}


sub wheelrun_child_stderr
{
	my ($kernel, $heap, $stderr_line, $wheel_id) = @_[KERNEL, HEAP, ARG0, ARG1];
	
	
	my $wheel = $heap->{wheel_run}->{children_by_wid}->{$wheel_id};
	
	
	log_enabled && logline "PID %s STDERR: %s",
		$wheel->{wheel}->PID,
		$stderr_line;
}


sub wheelrun_child_close
{
	my ($kernel, $heap, $wheel_id) = @_[KERNEL, HEAP, ARG0];
	
	
	my $wheel = delete $heap->{wheel_run}->{children_by_wid}->{$wheel_id};
	
	
	unless (defined $wheel)
	{
		log_enabled && logline "WID %s closed all pipes", $wheel_id;
		
		return;
	}
	
	
	log_enabled && logline "PID %s closed all pipes", $wheel->{wheel}->PID;
	
	#delete $heap->{wheel_run}->{children_by_pid}->{$wheel->{wheel}->PID};
	
	
	my $name = $wheel->{args}->{name};
	
	
	if ($name)
	{
		delete $heap->{wheel_run}->{children_by_name}->{$name};
		
		
		#$kernel->yield(sprintf "%s_childexit", $name);
	}
}


sub wheelrun_child_signal
{
	my ($kernel, $heap, $wheel_pid, $exit_status) = @_[KERNEL, HEAP, ARG1, ARG2];
	
	
	log_enabled && logline "PID %s exited with status %s",
		$wheel_pid,
		$exit_status;
	
	
	my $wheel = delete $heap->{wheel_run}->{children_by_pid}->{$wheel_pid};
	
	
	return unless defined $wheel;
	
	
	#log_enabled && logline Dumper $wheel;
	
	
	delete $heap->{wheel_run}->{children_by_wid}->{$wheel->{wheel}->ID};
	
	
	my $name = $wheel->{args}->{name};
	
	
	if ($name)
	{
		delete $heap->{wheel_run}->{children_by_name}->{$name};
		
		
		$kernel->yield(sprintf("%s_childexit", $name) => { exitcode => $exit_status });
	}
}


sub wheelrun_child_error
{
	my ($operation, $errnum, $errstr, $wheel_id, $filehandle_name) = @_[ARG0 .. $#_];
	
	
	if ($operation eq 'read' && !$errnum)
	{
		$errstr = 'remote end closed';
		
		return;
	}
	
	
	log_enabled && logline "wheel '%s' generated '%s' error on fh '%s', '%s': '%s'",
		$wheel_id,
		$operation,
		$filehandle_name,
		$errnum,
		$errstr;
}


sub wheelrun_kill
{
	my ($heap, $args) = @_[HEAP, ARG0];
	
	
	my $wheel_id   = $args->{wheel_id};
	my $wheel_pid  = $args->{wheel_pid};
	my $wheel_name = $args->{wheel_name};
	
	
	if ($wheel_id && $heap->{wheel_run}->{children_by_wid}->{$wheel_id})
	{
		my $wheel = $heap->{wheel_run}->{children_by_wid}->{$wheel_id}->{wheel};
		
		
		if ($wheel)
		{
			log_enabled && logline "kill by wid '%s'", $wheel_id;
			
			$wheel->kill;
		}
		else
		{
			log_enabled && logline "no wid to kill: '%s'", $wheel_id;
		}
	}
	
	
	elsif ($wheel_pid && $heap->{wheel_run}->{children_by_pid}->{$wheel_pid})
	{
		my $wheel = $heap->{wheel_run}->{children_by_pid}->{$wheel_pid}->{wheel};
		
		
		if ($wheel)
		{
			log_enabled && logline "kill by pid '%s'", $wheel_pid;
			
			$wheel->kill;
		}
		else
		{
			log_enabled && logline "no pid to kill: '%s'", $wheel_pid;
		}
	}
	
	
	elsif ($wheel_name && $heap->{wheel_run}->{children_by_name}->{$wheel_name})
	{
		my $wheel = $heap->{wheel_run}->{children_by_name}->{$wheel_name}->{wheel};
		
		
		if ($wheel)
		{
			log_enabled && logline "kill by name '%s'", $wheel_name;
			
			$wheel->kill;
		}
		else
		{
			log_enabled && logline "no name to kill: '%s'", $wheel_name;
		}
	}
}


sub wheelrun_send_network_reply
{
	my ($kernel, $session, $heap, $args) = @_[KERNEL, SESSION, HEAP, ARG0];
	
	
	my $output_per_target = $args->{output_per_target};
	my $use_flush         = $args->{use_flush};
	
	
	unless (ref $output_per_target eq 'HASH')
	{
		log_enabled && logline '$args->{output_per_target} not HASHref';
		
		return;
	}
	
	
	foreach my $target (qw(tcpserver tcpclient))
	{
		next unless exists $heap->{$target};
		next unless exists $heap->{$target}->{connections};
		
		
		my $output = $output_per_target->{$target};
		
		next unless defined $output;
		
		
		foreach my $wheel_id (keys %{$heap->{$target}->{connections}})
		{
			next unless exists $heap->{$target}->{connections}->{$wheel_id};
			next unless exists $heap->{$target}->{connections}->{$wheel_id}->{wheel};
			
			
			$kernel->call($session => sprintf("%s_output", $target) =>
			{
				wheel_id => $wheel_id,
				output   => $output,
				
				($use_flush ? (use_flush => 1) : ()),
			});
		}
	}
}


1;