####    Glue Logic  Application Program Interface Package
####                            Copyright (c) 1995-1997  Masayuki Takata
####
####            This software is provided "AS IS" with "NO WARRANTY".
####            Entire risk on using this software is with you.


package GlueLogic;

require Exporter;
require DynaLoader;

@ISA = qw(Exporter DynaLoader);
@EXPORT = qw(
	$GlueLogicServer	$GlueLogicAgent		$GlueLogicAnchor
	@GlueLogicMessageQueue	&GlueLogicEndOfMessage
	@GlueLogicStdinQueue	&GlueLogicEndOfStdin
	&GlueLogicConnect	&GlueLogicDisconnect	&GlueLogicAccess
	&GlueLogicParseArgs
	&GlueLogicEnqueueMessage
	&GlueLogicWaitForMessage	&GlueLogicSleepUntil
	&GlueLogicWaitForChanged	&GlueLogicDequeueChanged
	&GlueLogicMainLoop
	%GlueLogicMessageDispatch	%GlueLogicChangeDispatch
	%GlueLogicCommandDispatch
);
@EXPORT_OK = qw( );

#bootstrap GlueLogic;

# Preloaded methods go here.

BEGIN {
    $RCSstring = q$Id: GlueLogic.pm,v 1.5 1997/06/28 11:17:16 takata Exp $;
    print STDERR <<"ETX";
Glue Logic:  Application Program Interface Package\t(c)1995-1997  M. Takata
\tRCS $RCSstring
ETX
}

use Socket;
use FileHandle;
use English;

$MessageEof = 1;
$StdinEof = 0;

$MessagePoolBuffer  = $MessageBlockBuffer  = '';
$StdinPoolBuffer = $StdinBlockBuffer = '';

undef %GlueLogicMessageDispatch;
undef %GlueLogicChangeDispatch;
undef %GlueLogicCommandDispatch;

$SIG{'TTIN'} = 'IGNORE';



########################################################################
################					################
################	    Initialize Routine		################
################					################
########################################################################


sub dokill  {
    if ( defined $child ) {
	if ( $child ) {			# parent
	    close ( TrnsS ); close ( PipeR ); kill 9, $child; exit ( 0 );
	} else {			# child
	    shutdown ( AcceptS, 2 ); close ( PipeW ); exit ( 0 );
	}
    } else {
	exit ( 0 );
    };
};


sub GlueLogicParseArgs {
    my( @switches ) = ( 'Agent', 'Server', 'Anchor', @_ );
    my( %switches ) = ();
    my( $p, $n, $v ) = 0;
    autoflush STDOUT 1;
    autoflush STDERR 1;
    select ( STDERR );
    foreach (@switches) {
	$_ = "\L\u$_\E";
	$switches{$_}=1;
	eval '*main::GlueLogic' . $_ . '=\$GlueLogic' . $_;
    }
    while ($p <= $#ARGV) {
	if ( $ARGV[$p] =~ /^--$/o ) {
	    splice( @ARGV, $p, 1 ); last; }
	if ( ($n,$v) = ($ARGV[$p] =~ /^-([^=]+)=(.+)$/o) ) {
	    $n = "\L\u$n\E";
	    splice( @ARGV, $p, 1, "-$n", $v ) if (defined $switches{$n});
	}
	last unless (($n = $ARGV[$p]) =~ s/^-//o );
	$n = "\L\u$n\E";
	if ( defined $switches{$n} ) {
	    splice( @ARGV, $p, 1 );
	    if ( ($p <= $#ARGV) && ( $ARGV[$p] !~ /^-/o) ) {
		eval "\$GlueLogic$n = \$v = splice(\@ARGV,$p,1)";
	    } else {
		eval "\$GlueLogic$n = \$v = 1";
	    }
#print "GlueLogic$n = $v\n";
	} else {   $p++;   }
    }
#print "@ARGV\n";
}


sub GlueLogicConnect {

    local( $AgentID, $ServerSpec, $AnchorName ) = @_;
    $AgentID	= $ENV{'GLUELOGICAGENT'}  if defined $ENV{'GLUELOGICAGENT'};
    $ServerSpec	= $ENV{'GLUELOGICSERVER'} if defined $ENV{'GLUELOGICSERVER'};
    $AnchorName	= $ENV{'GLUELOGICANCHOR'} if defined $ENV{'GLUELOGICANCHOR'};
    $AgentID	= $GlueLogicAgent	if defined $GlueLogicAgent;
    $ServerSpec	= $GlueLogicServer	if defined $GlueLogicServer;
    $AnchorName	= $GlueLogicAnchor	if defined $GlueLogicAnchor;
    $GlueLogicAnchor = $AnchorName;
    autoflush STDOUT 1;
    autoflush STDERR 1;
    select ( STDERR );
    undef @_;
#print STDERR "$AgentID, $ServerSpec, $AnchorName\n";


    ########
    #	Preparing Message Queueing

    END {
	if ( defined $child ) {
	    if ( $child ) {		# parent
		close ( TrnsS ); close ( PipeR ); kill 9, $child; exit ( 0 );
	    } else {			# child
		shutdown ( AcceptS, 2 ); close ( PipeW ); exit ( 0 );
	    }
	} else {
	    exit ( 0 );
	};
    };

    $ParentProcess = $$;
    undef $child;
    undef @GlueLogicMessageQueue;
    undef @GlueLogicStdinQueue;

    ########
    #	Preparing IP Connections

    chop($hostname = `hostname`);
    $ServerSpec = '' unless defined $ServerSpec;
    ($ServerHost,$dummy) = ($ServerSpec =~ /^([A-Za-z0-9\.]+)(:){0,1}/io);
    ($dummy,$Port) = ($ServerSpec =~ /(:)([0-9]+)$/io);
    $Port = 9669 unless $Port;
    $ServerHost = $hostname unless $ServerHost;
    $sockaddr = 'S n a4 x8';
    ($name, $aliases, $ProtoTCP) = getprotobyname('tcp');
    ($name, $aliases, $type, $len, $ClientAddr) = gethostbyname($hostname);
    ($name, $aliases, $type, $len, $ServerAddr) = gethostbyname($ServerHost);


    ########
    #	Startup Message Receiver Process

    pipe ( PipeR, PipeW );
    
    if (! ($child = fork)) {	# child - sender

	close( PipeR );
	autoflush PipeW 1;
	$PipeWfn = fileno( PipeW );

	########
	#	Opening Message Socket

	$Message = pack( $sockaddr, &AF_INET, 0, $ClientAddr );
	socket( AcceptS, AF_INET, SOCK_STREAM, $ProtoTCP ) || die "socket: $!";
	bind  ( AcceptS, $Message ) || die "bind: $!";
	listen( AcceptS, 3 ) || die "listen: $!";
	($af,$pt,$inetaddr) = unpack( $sockaddr, getsockname(AcceptS) );
	$netaddr = "$hostname:$pt";
	if ( defined ( $AgentID ) ) {
	    $AgentID =~ s/#$/$$/o;
	    $AgentID = "$hostname:$AgentID";
	} else {
	    $AgentID = $netaddr;
	}
#print STDERR "Child: Identifier of this agent is $AgentID\n";

	########
	#	Connecting Message Socket

	print PipeW "$netaddr $AgentID\n";
	accept( MesgS, AcceptS );
	autoflush MesgS 1;
	autoflush PipeW 1;
	select( STDERR );
	$IPPROTO_TCP = 6; $TCP_NODELAY = 0x01;
	setsockopt( MesgS, $IPPROTO_TCP, $TCP_NODELAY, 1 );
	$MesgSfn = fileno( MesgS );

	open( STDIN,  "<&" . $MesgSfn );
	open( STDOUT, ">&" . $PipeWfn );
	exec 'GlueLogicQueue';
	die "exec failed: $!\n";
    }

    
    
    ########
    #	Transaction Socket Connection

    close( PipeW );

    $trial = 0;	
AGAIN: $trial++;
    die($!) if $trial > 10;
    print STDERR "\nConnecting Transaction Channel to $ServerHost:$Port ...";
    $ClientEnd = pack( $sockaddr, AF_INET, 0,     $ClientAddr );
    $ServerEnd = pack( $sockaddr, AF_INET, $Port, $ServerAddr );

    die($!) unless( socket ( TrnsS, AF_INET, SOCK_STREAM, $ProtoTCP ) );
    die($!) unless( bind   ( TrnsS, $ClientEnd ) );
    $IPPROTO_TCP = 6; $TCP_NODELAY = 0x01;
    setsockopt( TrnsS, $IPPROTO_TCP, $TCP_NODELAY, 1 );

    ($Port++, goto AGAIN) unless( connect( TrnsS, $ServerEnd ) );
    autoflush TrnsS 1;
    select( STDERR );
    $GlueLogicServer = $ServerSpec = "$ServerHost:$Port";
    print STDERR " done.\n";


    ########
    #	Define Signal Handler

    $SIG{'INT'} = \&dokill;


    ########
    #   Confirming Message Socket Connection

    $FPipeRDsc = '';
    vec( $FPipeRDsc, $PipeRfn = fileno( PipeR ), 1 ) = 1; 
    vec( $FPipeRDsc, 0, 1 ) = 1; 
#print STDERR "PipeRfn: $PipeRfn\n";

    while (1) {
	$leng = sysread(PipeR, $MessageBlockBuffer, 4096);
	next if ( ! defined $leng ) && ( $! =~ /interrupt/io );
	$MessagePoolBuffer .= $MessageBlockBuffer;
#	print "[$MessagePoolBuffer]\n";
	next unless $MessagePoolBuffer =~ /^(.*)\n([.\n]*)/o;
	$Line = $1; $MessagePoolBuffer = $2; last;
    } 

#print STDERR "PipeR: $Line\n";
    ( $netaddr, $AgentID ) = split( /\s+/, $Line );
    ( $hoge, $portaddr ) = split( /:/, $netaddr );
    print STDERR "Connecting Message Channel $AgentID (port$portaddr) ...";
    print TrnsS "!InitiateChannel $netaddr $AgentID\n";
    chomp ( $Line = <TrnsS> );
#print STDERR "TrnsS: $Line\n";
    unless ( ($ServerVersion) = ($Line =~ /Greeting (.*)/o) ) {
	print STDERR "$Line\n";
	&dokill();
	return $GlueLogicAgent = undef;
    }
    sleep 0;

    while (1) {
	$leng = sysread(PipeR, $MessageBlockBuffer, 4096);
	next if ( ! defined $leng ) && ( $! =~ /interrupt/io );
	$MessagePoolBuffer .= $MessageBlockBuffer;
#	print "[$MessagePoolBuffer]\n";
	next unless $MessagePoolBuffer =~ /^(.*)\n([.\n]*)/o;
	$Line = $1; $MessagePoolBuffer = $2; last;
    }

#print STDERR "PipeR: $Line\n";
    print STDERR " done.\n" if $Line =~ /^!Greeting$/o;
    $MessageEof = 0;

    return $GlueLogicAgent = $AgentID;
}



########################################################################
################					################
################      A c c e s s   R o u t i n e	################
################					################
########################################################################


sub GlueLogicAccess {
    my( @Input ) = @_;
    my( @Output );

    return undef if $MessageEof;
    chomp @Input;
    $Commands = join ( "\034", @Input );
    print TrnsS "$Commands\n";
    chomp( $Results = <TrnsS> );
    @Output = split ( /\034/, $Results );
    &GlueLogicEnqueueMessage();

    return @Output;
}


sub GlueLogicDisconnect {
    return undef if $MessageEof;
    print TrnsS "!DisconnectChannel\n";
    &GlueLogicEnqueueMessage(); 
    until ( $MessageEof ) {
	&GlueLogicWaitForMessage(); &GlueLogicEnqueueMessage();   }
    return undef;
};



########################################################################
################					################
################    M e s s a g e    H a n d l i n g	################
################					################
########################################################################


sub GlueLogicEndOfMessage {
    return( @GlueLogicMessageQueue && ! defined $GlueLogicMessageQueue[0] );
}

sub GlueLogicEndOfStdin {
    return( @GlueLogicStdinQueue && ! defined $GlueLogicStdinQueue[0] );
}

sub GlueLogicEnqueueMessage {
    my( $leng );
    return undef if $MessageEof && $StdinEof;
    autoflush PipeR 1;
    sleep 0;
    while ( $f = select( $PipeRDsc=$FPipeRDsc, undef, undef, 0 ) ) {
#print STDERR "FOUND: $f ", unpack("b*",$PipeRDsc), "/", unpack("b*",$FPipeRDsc), "\n";
	next if $f < 0;
	if ( vec( $PipeRDsc, 0, 1 ) ) {
	    if ( ($leng = sysread(STDIN, $StdinBlockBuffer, 4096)) == 0 ) { # EOF Condition
		next if ( ! defined $leng ) && ( $! =~ /interrupted/io );
#		warn( "End of STDIN detected\n" );
		$StdinEof = 1;
		vec( $FPipeRDsc, 0, 1 ) = 0;
		push( @GlueLogicStdinQueue, undef );
		next;
	    }
	    $StdinPoolBuffer .= $StdinBlockBuffer;
	    while ( $StdinPoolBuffer =~ /^(.*\n)([^\0]*)/o ) {
		push( @GlueLogicStdinQueue, $1 ); $StdinPoolBuffer = $2;   }
	    next;
	}
	next unless vec( $PipeRDsc, $PipeRfn, 1 );
	if ( ($leng = sysread(PipeR, $MessageBlockBuffer, 4096)) == 0 ) {	# EOF Condition
	    next if ( ! defined $leng ) && ( $! =~ /interrupted/io );
	    close ( TrnsS ); close ( PipeR );
	    kill 9, $child if $child;
	    $MessageEof = 1;
	    vec( $FPipeRDsc, $PipeRfn, 1 ) = 0;
	    push( @GlueLogicMessageQueue, undef );
	    warn( "SERVER TERMINATED\n" );
	    last;
	}
	$MessagePoolBuffer .= $MessageBlockBuffer;
	while ( $MessagePoolBuffer =~ /^(.*)\n([^\0]*)/o ) {
#print STDERR "parse: [$1] [$2]\n";
	    push( @GlueLogicMessageQueue, $1 );
	    $MessagePoolBuffer = $2;
	}
	$text = $GlueLogicMessageQueue[$#GlueLogicMessageQueue];
#print STDERR "RCV: $text\n";
	if ( $text =~ /^!DisconnectChannel$/o ) {
	    pop( @GlueLogicMessageQueue );
	    push( @GlueLogicMessageQueue, undef );
	    close ( TrnsS ); close ( PipeR );
	    kill 9, $child if $child;
	    $MessageEof = 1;
	    vec( $FPipeRDsc, $PipeRfn, 1 ) = 0;
#	    warn( "Channel disconnected\n" );
	    last;
	}
    }
    return undef;
}

sub GlueLogicWaitForMessage {
    my( $f, $PipeRDsc );
    return undef if $MessageEof && $StdinEof;
    sleep 0;
    while ( 1 ) {
	$f = select( $PipeRDsc=$FPipeRDsc, undef, undef, undef );
#print STDERR "FOUND: $f ", unpack("b*",$PipeRDsc), "/", unpack("b*",$FPipeRDsc), "\n";
	next if $f <= 0;
	last if vec( $PipeRDsc, $PipeRfn, 1 );
	last if vec( $PipeRDsc, 0, 1 );
    };
    return undef;
}

sub GlueLogicSleepUntil {
    my( $time ) = @_;
    my( $for, $f, $PipeRDsc );
#print STDERR "SleepUntil: $time; Now ", time, "\n";
    while ( ( $for = $time - time ) > 0 ) {
	$for = 86400000 if $for > 86400000;
	$f = select( $PipeRDsc=$FPipeRDsc, undef, undef, $for );
#print STDERR "FOUND: $f ",unpack("b*",$PipeRDsc),"/",unpack("b*",$FPipeRDsc),"\n";
	last if $time <= time;
	next if $f <= 0;
	last if vec( $PipeRDsc, $PipeRfn, 1 );
	last if vec( $PipeRDsc, 0, 1 );
    }
    return undef;
}

sub GlueLogicWaitForChanged {
    my( @name ) = @_;
    my( $n, $before, $after, $idx );
    
    $before = 0;
#print "MsgQueue: ", join('/',@GlueLogicMessageQueue), "\n";
    while (1) {
	&GlueLogicEnqueueMessage();
#	@GlueLogicMessageQueue = grep( !/^!Sync/o, @GlueLogicMessageQueue );

	$after = scalar( @GlueLogicMessageQueue );
	for ($idx=$before; $idx<$after; $idx++) {
	    foreach $n ( @name ) {
		return $n if $GlueLogicMessageQueue[$idx] eq "Changed $n";
	}   }
	$before = $after;

	return undef if $MessageEof;
	&GlueLogicWaitForMessage();
#	&GlueLogicAccess("!Sync"); &GlueLogicSleepUntil( time+5 );
    }
}

sub GlueLogicDequeueChanged {
    my( @name ) = @_;
    my( $m, $n, $p );
    foreach $n ( @name ) {
	$p = "Changed $n";
	foreach $m ( @GlueLogicMessageQueue ) { $m = '*' if $m eq $p; }
    }
    @GlueLogicMessageQueue = grep( $_ ne '*', @GlueLogicMessageQueue );
    undef;
}



########################################################################
################					################
################    D i s p a t c h    R o u t i n e	################
################					################
########################################################################


sub GlueLogicMainLoop {
    my( $v, $a );

    while (1){
	&GlueLogicWaitForMessage() unless ( @GlueLogicMessageQueue || @GlueLogicStdinQueue );
	&GlueLogicEnqueueMessage();

	if ( @GlueLogicMessageQueue ) {
	    last unless defined ( $_ = shift(@GlueLogicMessageQueue) );
	    if ( $_ eq "Changed $GlueLogicAnchor" ) {		# Message via Anchor
		( $_ ) = &GlueLogicAccess( "$GlueLogicAnchor?" );
		next if $_ eq "$GlueLogicAnchor=UNBOUND";
		( $v, $a ) = /^[^=]+=.(\S+)\s*(.*)$/o;
		&{$GlueLogicMessageDispatch{$v}}($v,$a) if defined $GlueLogicMessageDispatch{$v};
	    } elsif ( ( $v ) = /^Changed (\S+)$/o ) {		# Information Message
		&{$GlueLogicChangeDispatch{$v}}($v) if defined $GlueLogicChangeDispatch{$v};
	    }
	} elsif ( @GlueLogicStdinQueue ) {			# Command from STDIN
	    last unless defined ( $_ = shift(@GlueLogicStdinQueue) );
	    next if /^\s*$/o;
	    chop;
	    ( $v ) = /^(\S+)\s*.*$/o;
	    if ( defined ( $GlueLogicCommandDispatch{$v} ) ) {
		&{$GlueLogicCommandDispatch{$v}}($_);
	    } else {
		print "Unknown Command\n";
	    }
	}

    }
    return undef;
}


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

1;
__END__