package Proxy;			# -*-Perl-*-*

# Copyright (c) 1994 Malcolm Beattie.
# You may distribute under the terms of the GNU General Public License,
# as specified in the README file.
#
# Each class derived from Proxy is a transport domain through which
# processes can communicate. The Proxy module is an abstraction layer
# around transport classes which allows processes to invoke arbitrary
# perl commands in remote processes and to treat object which exist
# remotely as though they were ordinary local (opaque) objects.
# A minimal transport class just has to provide a way of sending a
# string to a remote process and a way of getting a string back again.
# Here's how to invoke commands in a remote process using proxy transport
# class Proxy::SomeTransport derived from Proxy.
# First get a proxy object referring to the remote process:
#     $proxy = new Proxy::SomeTransport(...)
# where the arguments identify the remote process in a transport-dependent
# way. To invoke method $method in the process $proxy on class or object
# $classorobj, use
#     @result = $proxy->rexec($method, $classorobj, @args);
# Use $result instead of @result if desired; the appropriate scalar/array
# context will be propagated to the remote process.
# The $classorobj and the @args can be any data type. Array refs, hash refs
# and their contents will travel unscathed and blessed objects (including
# those already returned from other processes) are all OK. The only two
# types which cannot be enlivened again at the other side are CVs (such
# as \&foo) and GVs (*foo). If $method in the remote process is a
# constructor then the blessed object returned to you can be used just
# like an (opaque) local object, and method calls on it will automatically
# travel to the appropriate remote process to be executed.
#
# Each transport class must provide the following methods (all others
# are (or can be) inherited from Proxy:
# $proxy = new(...);
#      The new constructor must take arguments (which depend on the
#      transport) which identify a remote process and return an object
#      which can be used to communicate with that prcoess.
# $proxy->tranport($string)
#      The "transport" method must take a single string (in which all 256
#      ASCII characters are possible), encode it if necessary, and ship
#      the resulting data packet synchronously across to the remote process
#      identified by $proxy.
# $proxy->receive($string)
#      The "receive" method must receive a data packet synchronously from
#      the remote process identified by $proxy. The data packet is one which
#      was created by the "transport" method in the same class in the peer.
#      The data must be decoded, if necessary, into the original string and
#      returned.
# $proxy->route($id)
#	The "route" method must return an appropriate proxy handle on which
#	a reply to a command from $id can be sent.
#
# Each transport class may optionally provide the following methods:
# $proxy->strict()
#     Default is true, i.e. always strict mode for all transports.
# $proxy->execute($method, $classorobj, @args)
#    Default is just to execute $classorobj->$method(@args) without checking.
#
# For a process to act successfully on proxy commands sent from remote
# processes, it must act on any data packets received by calling the
# (inherited) method $proxy->lexec($string) when data packet $string is
# received from a remote process whose route is findable via object $proxy.
#
# For commands directly invoked with the rexec method, there is no
# problem determining where the command is to be sent: the $proxy
# object on which rexec is called determines it. However, for methods
# invoked on proxy objects returned by a remote process, it is not
# always obvious to which process the method command ought to be sent.
# That's because the remote process which originally returned the object
# might have obtained it from some other remote process. It would be
# possible (but non-optimal) to send back all method calls on proxy objects
# to the remote process from which the object was obtained. This is what
# happens if the "route" method returns false (as the default Proxy route
# method does) but it can be overriden on a transport-dependent basis to
# provide better means of route discovery.
# See the comments preceding the route method itself for details.
#
# Recall that Perl subroutines can treat their arguments as lvalues and
# change them at will but that many do not. The proxy class must deal
# with this by receiving in the data returned from a proxy not only the
# return value(s) of the command but also all of its arguments (now
# possibly altered). For transport classes in which data transfer is
# expensive it is possible to switch to a non-strict mode in which only
# the return values are sent back. When forming replies, the Proxy class
# calls the method "strict" on the $proxy object which should return a
# true value to reply with strict behaviour or a false value for the
# non-strict. By default, the "strict" method inherited from Proxy
# always returns true.
#
# Bugs
#  * "Optional" methods such as DESTROY, TIEARRAY and so on are not handled
# properly on proxy objects. This is because they are lookup up client-side
# and always "found" because of Proxy::Object::AUTOLOAD. The Proxy code
# ought to be able to perform an eval{}-protected call at the remote side
# and return appropriately.
# * Passing CVs (like \&foo) across to proxy processes would be possible
# but is not yet implemented. The freezing side can cache the CV and
# generate a handle, just as with proxy objects. The thawing side can
# generate a new sub on the fly which, when invoked, does the appropriate
# rexec in the process which orginally froze it.
# * The id() subroutine below (which should provide a unique identifier
# for this process unique amongst all potential communicating processes)
# only returns the PID. I can think of no guaranteed way of providing a
# host-dependent field too. Any transport class using more than one host
# should provide a better Proxy::id() subroutine.

#
# Internal details.
#
# Packets are either commands or replies. Commands are of the form
#     [01][$@]data
# The second byte being '$' (resp. '@') means the command is in scalar
# (resp. array) context.
# Replies are of the form
#     [23]data
# Each data field depends on the type indicated by the
# first byte of the packet.
#
# Byte	Packet type		Data
# 0	strict command		freeze([$id, $method, $classorobj, @args])
# 1	non-strict command	freeze([$id, $method, $classorobj, @args])
# 2	strict reply		freeze([\@returnvalues, @newargs])
# 3	non-strict reply	freeze(\@returnvalues)
#
# For comand packets, $id is the id to which the peer must reply.
# For replies in scalar context, $returnvalue[0] is the scalar to return.
#

#
# The id subroutine must provide a string identifier (which can contain
# any characters at all) which is unique amongst all processes that may
# communicate with the current one. It must be *independent* of any
# transport class (or else objects could not be sent transparently over
# different transports).
#
# Warning: the subroutine here merely returns the PID which is not
# independent between processes on multiple hosts. Transport classes
# should redefine this subroutine where necessary.
#
sub id { $$ }

sub strict { 1 }

sub rexec {
    printf "rexec called in %s context\n", wantarray ? "array" : "scalar"
	if $debug{Rexec};
    my $proxy = shift;
    my $string = ($proxy->strict() ? '0' : '1')
	       . (wantarray ? '@' : '$') . freeze([id(), @_]);
    my($type, $context, $result, @args);
    $proxy->transport($string);
    while (1) {
	$string = $proxy->receive();
	die "timeout waiting for proxy" unless defined($string);
	$type = substr($string, 0, 1);
	print "rexec received reply packet type $type\n" if $debug{Rexec};
	if ($type eq '0' || $type eq '1') {
	    # a command
	    $proxy->lexec($string);
	} elsif ($type eq '2' || $type eq '3') {
	    # a reply
	    $context = substr($string, 1, 1);
	    $string = substr($string, 2);
	    if ($type eq '2') {
		# strict reply
		($result, @args) = @{thaw($proxy, $string)};
		@_ = @args;
	    } else {
		# non-strict reply
		$result = thaw($proxy, $string);
	    }
	    if ($context eq '$') {
		return $result->[0];
	    } elsif ($context eq '@') {
		return @$result;
	    } else {
		die "bad context type '$context' from proxy";
	    }
	} else {
	    die "bad reply code '$type' from proxy";
	}
    }
    # not reached
}

sub lexec {
    my($proxy, $string) = @_;
    my($retid, $method, $classorobj, @args, @result);
    my ($type, $context);

    $type = substr($string, 0, 1);    # 0 for strict command, 1 for non-strict
    $context = substr($string, 1, 1); # '$' for scalar context, '@' for array
    ($retid, $method, $classorobj, @args) = @{thaw($proxy, substr($string,2))};
    printf "Executing %sstrict command: %s = $method $classorobj (%s)\n",
        ($type ? "non-" : ""), $context, join(", ", @args) if $debug{Lexec};
    if ($context eq '@') {
	@result = $proxy->execute($method, $classorobj, @args);
    } elsif ($context eq '$') {
	$result[0] = $proxy->execute($method, $classorobj, @args);
    } else {
	die "Bad context type '$context' found\n";
    }
    $proxy = $proxy->route($retid) || $proxy; # find the route back
    if ($type == 0) {
	# transport back strict reply
	$proxy->transport('2' . $context . freeze([\@result, @args]));
    } else {
	# transport back non-strict reply
	$proxy->transport('3' . $context . freeze(\@result));
    }
}

#
# Default "execute" method just carries out the command. Transport classes
# can have their own methods which do extra checking or authentication.
#
sub execute {
    my ($proxy, $method, $classorobj, @args) = @_;
    return $classorobj->$method(@args);
}

sub freeze {
    my $arg = $_[0];
    my $id = id();
    my $type = ref($arg);
    print "freezing object type $type: $arg\n" if $debug{Freeze};
    if (!defined($arg)) {
	# undef
	return 'u';
    } elsif (!defined($type)) {
	# string
	return 's' . $arg;
    } elsif ($type eq "ARRAY")  {
	my $i;
	my $qi;
	my @list;
	foreach $i (@$arg) {
	    ($qi = freeze($i)) =~ s/\000/\000n/g;
	    push(@list, $qi);
	}
	return '@' . @list . "#" . join("\000,", @list);
    } elsif ($type eq "HASH")  {
	my $i;
	my $qi;
	my @list;
	foreach $i (%$arg) {
	    ($qi = freeze($i)) =~ s/\000/\000n/g;
	    push(@list, $qi);
	}
	return '%' . @list . "#" . join("\000,", @list);
    } elsif ($type eq "SCALAR") {
	return '$' . freeze($$arg);
    } elsif ($type eq "CODE") {
	return '&';
    } elsif ($type eq "GLOB") {
	return '*';
    } elsif ($type eq 'Proxy::Object') {
	print "frozen proxy object $arg->[0]\@$arg->[1]\n" if $debug{Freeze};
	return "p$arg->[0]\@$arg->[1]";
    } else {
	my $handle = "$arg";
	$cache{$handle} = $arg;
	print "caching object $handle\n" if $debug{Freeze};
	return "p$handle\@$id";
    }
}

sub thaw {
    my ($proxy, $data) = @_;
    my $id = id();
    $data =~ s/^.//;
    my $type = $&;
    print "Thawing data (type $type) from $proxy: $data\n" if $debug{Thaw};
    if ($type eq 's') {
	return $data;
    } elsif ($type eq 'u') {
        return undef;
    } elsif ($type eq '@') {
	$data =~ s/^([^#]+)#//;
	my(@list) = split(/\000,/, $data, $1);
	my $i;
	print "Thawing array size $1\n" if $debug{Thaw};
	foreach $i (@list) {
	    $i =~ s/\000n/\000/g;
	    $i = thaw($proxy, $i);
	}
	return \@list;
    } elsif ($type eq '%') {
	$data =~ s/^([^#]+)#//;
	my(@list) = split(/\000,/, $data, $1);
	my $i;
	print "Thawing hash with ", $1/2, " keys\n" if $debug{Thaw};
	foreach $i (@list) {
	    $i =~ s/\000n/\000/g;
	    $i = thaw($proxy, $i);
	}
	return {@list};
    } elsif ($type eq '$') {
	print "Thawing scalar ref\n" if $debug{Thaw};
	return \thaw($proxy, $data);
    } elsif ($type eq '&') {
	die "Cannot thaw code ref $data";
    } elsif ($type eq '*') {
	die "Cannot thaw glob $data";
    } elsif ($type eq 'p') {
	$data =~ /\@/;		# we require that an "$obj" never contains '@'
	if ($' eq $id) {
	    # a proxy object that we created
	    print "Thawing our own cached object $data\n" if $debug{Thaw};
	    return $cache{$`};
	} else {
	    # a proxy object from someone else
	    print "Thawing remote object $`\@$' by local blessing\n"
		if $debug{Thaw};
	    return bless([$`, $', $proxy], Proxy::Object);
	}
    } else {
	die "Bad type $type in thaw for data $data\n";
    }
}

#
# This subroutine is used to find a route to a proxy given an id number
# that appeared in a packet somewhere. When the proxy object is blesed
# into Proxy::Object, it has the form [$handle, $id, $proxy] where
# $handle was the handle assigned by the proxy with id $id. Proxy $proxy
# was the communication channel on which we were given this object.
# Notice, however, that this need *not* be the appropriate proxy to call
# for method on the object. This is because someone could have sent us
# an object belonging to a third party. The route method can be redefined
# by proxy transports who wish to do route discovery, but we default here
# simply to returning false. This means that replies to commands always get
# sent back on the same proxy handle on which process is listening. Note:
# this is even if the command comes in from some other peer (if that is
# possible with the given transport protocol). It also means that remote
# object on which methods are invoked are sent back with the command on the
# proxy handle on which the object itself was originally received.
# 
sub route {
    return 0;
}
    
package Proxy::Object;

AUTOLOAD {
    my $obj = shift;
    my($handle, $retid, $proxy) = @$obj;
    my $method = $AUTOLOAD;
    $method =~ s/^Proxy::Object:://;
    print "proxy method $method on $handle to $retid\n"
	if $Proxy::debug{Rexec};
    return if $method eq "DESTROY";  # ignore DESTROY for now
    $proxy = $proxy->route($retid) || $proxy;
    return $proxy->rexec($method, $obj, @_);
}    

1;
