##############################################################################
#
# $Author: lems1 $
# $Date: 1998/11/12 07:06:53 $
# $Revision: 1.8 $
# $Name:  $
#
##############################################################################
package Substandard;

#use strict;
use vars qw( $VERSION @ISA @EXPORT );

require Exporter;

@ISA = qw( Exporter );

# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.

@EXPORT = qw();

@EXPORT_OK = qw( send recv chat flush timeout clear_error );

$VERSION = '0.01';

##############################################################################

use Carp;
use Symbol;
use IPC::Open3;

# dealing with sub-processes requires some kind of boilerplate
# for defunct children.  callers can munge this to whatever
# they like.  this is pretty minimal but avoids major nasties.

$SIG{PIPE} = sub { print STDERR 'SIGPIPE handled' };

# create a new svrmgrl object

sub new
{
	# create anon hash and bless it into the package requested.

	my $self = bless {}, shift;

	$self->{isopen} = 0;
	$self->{usable} = 0;
	$self->{error}  = 1;

	$self->{command} = shift;

	return $self unless $self->{command};

	# use file descriptors with open3.  open3 requires existing symbol table
	# entries for the file descriptors.

	$self->{fd_write} = gensym();
	$self->{fd_read}  = gensym();
	$self->{fd_err}   = gensym();

	# fork off the command, opening its stdout, stdin & stderr into the 
	# file descriptors we hand it.  if the pid isn't returned then 
	# give up.

	$self->{error} = 2;

	$self->{pid} = open3( $self->{fd_write}, $self->{fd_read}, $self->{fd_err}, $self->{command} );

	return $self unless $self->{pid};

	$self->{timeout} = 30;	# standard timeout for selects

	# select requires bit masks for the file descriptors to check.  this
	# sets up the bit masks for each of the file descriptors returned
	# by open3.

	$self->{select_write} = $self->{select_read} = $self->{select_err} = '';

	vec( $self->{select_write}, fileno($self->{fd_write}), 1 ) = 1;
	vec( $self->{select_read},  fileno($self->{fd_read}),  1 ) = 1;
	vec( $self->{select_err},   fileno($self->{fd_err}),   1 ) = 1;

	# at this point the object is both open and usable.
	# future errors will normally leave the object open
	# and unusable ({useable} == 0) with the error = $!.

	$self->{isopen} = 1;	# open for use.
	$self->{usable} = 1;	# clean, so far...
	$self->{error}  = 0;	# none, yet...

	# hand the popluated hash reference back to the caller.

	$self
}


# close the item down after to goes out of scope.
# alwasys returns zero.

sub DESTROY
{
	my $self = shift;

	$self->flush if( $self->{isopen} && $self{usable} );
	
	close $self->{fd_err};
	close $self->{fd_read};
	close $self->{fd_write};

	$self->{isopen}	= 0;	# not open
	$self->{usable}	= 0;	# not usable
	$self->{error}	= 0;	# no way to handle errors anyway.
}

# get a message back from the server manaer

sub select_and_sysread
{
	my( $fd, $sel, $time ) = @_;

	my $result = '';

	my ( $i, $j, $k );

	while( (select($i=@$sel[0], $j=@$sel[1], $k=@$sel[2], $time) )[0] > 0 )
	{
		my $buffer = '';

		if( sysread $fd, $buffer, 8192 )
		{
			if( $! )
			{
				confess "failed sysread: $!";
			}
			elsif( $buffer =~ m/\S/sg )
			{
				# if we find at least one non-space character on the line then 
				# split it up and store the result.

				$result .= $buffer;

				$time = 1;
			}
		}
	}

	[ split m/\n/, $result ]
}

sub recv
{
	my $self = shift;

	$self = shift unless ref $self;

	# return empty list unless the object is in a useful 
	# state for reading.

	return () unless $self->{isopen} && $self->{usable};

	my $fd   = $self->{fd_err};
	my $sel  = [ ( undef, undef, $self->{select_err} ) ];

	my $err =  select_and_sysread($fd, $sel, 0 );

	my $fd   = $self->{fd_read};
	my $sel  = [ ( $self->{select_read}, undef, undef  ) ];
	my $time = $self->{timeout};

	my $out =  select_and_sysread( $fd, $sel, 30 );

	$self->{reply} = [ ( @$err, @$out ) ];

	@{ $self->{reply} }
}

# remove any pending input from the input stream 
# and discard it.

sub flush
{
	my $self = shift;

	# set the object to use polling then grab, discard any input.

	my $time = $self->{timeout};
	$self->{timeout} = 0;

	# suck up any data remaining in the pipeline

	$self->recv;

	# reset the timeout.

	$self->{timeout} = $time;

	# reply set to nothing after the flush.

	$self->{reply} = [];

	0
}

# send a message to the svrmgrl.

sub send
{
	my $self = shift;

	$self = shift unless ref $self;

	return scalar @_ unless $self->{isopen};

	my $timeout = $self->{timeout};

	LOOP:
	for( ; @_ ; $timeout = 0 )
	{
		# same basic issues as in recv, above: make local copy of 
		# the select bit mask, $writeable is 0 or 1 because there is only
		# one item in the select list.  if the write fd is not ready to 
		# accept data then quit.

		my $write = $self->{select_write} ;

		my ( $writeable, $timeleft ) = select( undef, $write, undef, $timeout );
	
		last LOOP unless $writeable;

		# lines are written as-is to allow better control.
		# for automatic line breaks, etc, use chat.

		my $message = shift;

		syswrite $self->{fd_write}, $message, length $message;
	}

	# scalar @_ will give the number of un-written messages.
	# zero return indicates success.  caller can use the 
	# negative of this value to show list of messages unsent
	# (e.g., if this returns 2 then @list[-2] was the first
	# unsent message).

	scalar @_;
}

# pass a set of messages to the server manager, recording the
# result of each line.  this is different from send which
# ignores any replys to multiple-line messages.  this puts 
# the sent messages onto the same list as the replys.  mainly
# useful for logging.

sub chat
{
	my $self = shift;

	$self = shift unless ref $self;

	my @result = ();

	LOOP:
	for( @_ )
	{
		# break up multi-line input into single lines.  makes
		# the mixed input and output easier on the eye...

		for( split m/\n/, $_ )
		{
			next unless m/\S/;
			s/\t/ /g;

			push @result, "> $_";

			if( $self->send("$_\n") )
			{
				push @result, "ERROR: SEND FAILED";
			}
			else
			{
				push @result, $self->recv();
			}
		}
	}

	@result
}

sub timeout
{
	$self = shift;

	$self->{timeout} = @_ ? shift : 1 ;
}

sub clear_error
{
	my $self = shift;

	$self->{error}  = '';
	$self->{usable} = 1;
}


# Autoload methods go after =cut, and are processed by the autosplit program.

1;
__END__
# Below is the stub of documentation for your module. You better edit it!

=head1 NAME

Svrmgrl - KwikHak perl extension to control a svrmgrl process.

=head1 Synopsis

  use Svrmgrl;
  
  new		create new object

  send @	send message(s) to svrmgrl.  each scaler is
  			sent as is to the server.

  recv 		recieve a message from the server.
 
  chat @	send message(s) to svrmgrl.  each scalar is
  			broken up on newlines with the messages sent
			and replys stored in the return list.

  quit		explicit close.

=head1 DESCRIPTION

Blah blah blah.

=head1 AUTHOR

Steven Lembark <lembark@wrkhors.com>

=head1 SEE ALSO

perl(1).

=cut

