# Registry.pm - XML-RPC method registry for Perl
# Copyright (C) 2001 Eric Kidd
# Registry.pm is free software; you can redistribute it
# and/or modify it under the same terms as Perl itself.
#
# See http://bitsko.slc.ut.us/~ken/xml-rpc/ for a Perl XML-RPC library,
# and http://xmlrpc-c.sourceforge.net/hacks.php for new versions of
# this code.
#

package Registry;

use strict;

use vars qw($INT $BOOLEAN $DOUBLE $STRING $DATETIME $BASE64 $ARRAY $STRUCT);

# Some type names for use in method signatures.
$INT="int";
$BOOLEAN="boolean";
$DOUBLE="double";
$STRING="string";
$DATETIME="dateTime.iso8601";
$BASE64="base64";
$ARRAY="array";
$STRUCT="struct";

# Create a new method registry.
sub new {
    my ($class, %args) = @_;
    my $self = bless {'methods' => {}, 'signatures' => {}, 'help' => {}};
    $self->{'default_method'} = undef;

    if (defined $args{'allow_introspection'}) {
	$self->{'allow_introspection'} = $args{'allow_introspection'};
    } else {
	$self->{'allow_introspection'} = 1;
    }

    $self->_register_system_methods;
    return $self;
}

# Get all installed methods.  This can be passed to 'serve'.
sub methods ($) {
    my ($self) = @_;
    return $self->{'methods'};
}

# Add a method to the registry.
sub add_method ($$$%) {
    my ($self, $name, $funcref, %args) = @_;
    my $signature = $args{'signature'} || 'undef';
    my $help = $args{'help'} || '';
    $self->{'methods'}->{$name} = $funcref;
    $self->{'signatures'}->{$name} = $signature;
    $self->{'help'}->{$name} = $help;
}

# Set a default method for the registry.
# XXX - This won't do anything useful with a stock version of Frontier::RPC2.
sub set_default_method ($$) {
    my ($self, $funcref) = @_;
    $self->{'default_method'} = $funcref;
}

# Dispatch a call using the information in the registry.
sub dispatch_call ($$$) {
    my ($self, $name, $params) = @_;
    
    # Try to find our method.
    my $method = $self->{'default_method'};
    if (defined $self->{'methods'}->{$name}) {
	$method = $self->{'methods'}->{$name};
    }
    _no_such_method($name) unless defined $method;

    # Dispatch the method with the appropriate arguments.
    &$method(@$params);
}

# Raise a 'no such method' error.
sub _no_such_method ($) {
    my ($name) = @_;
    die "No such method '$name', stopped";
}

# Raise an error if introspection is disabled.
sub _introspection_check ($) {
    my ($self) = @_;
    if (!$self->{'allow_introspection'}) {
	die ("Introspection has been disabled on this " .
	     "server (probably for security reasons), stopped");
    }
}


#==========================================================================
#  system.* Methods
#==========================================================================
#  These methods are installed in every registry by default.  Note that
#  they each take a '$self' argument--they're members of Registry class,
#  and they're installed using anonymous closures.

my $system_listMethods_signature = [[$ARRAY]];
my $system_listMethods_help =
    "Return an array of all available XML-RPC methods on this server.";

sub system_listMethods ($) {
    my ($self) = @_;
    $self->_introspection_check;
    my @names = keys %{$self->{'methods'}};
    return \@names;
}

my $system_methodSignature_signature = [[$ARRAY, $STRING]];
my $system_methodSignature_help = <<EOD;
Given the name of a method, return an array of legal signatures. Each
signature is an array of strings. The first item of each signature is the
return type, and any others items are parameter types.
EOD

sub system_methodSignature ($$) {
    my ($self, $name) = @_;
    $self->_introspection_check;
    my $result = $self->{'signatures'}->{$name};
    _no_such_method($name) unless defined $result;
    return $result;
}

my $system_methodHelp_signature = [[$STRING, $STRING]];
my $system_methodHelp_help =
    "Given the name of a method, return a help string.";

sub system_methodHelp ($$) {
    my ($self, $name) = @_;
    $self->_introspection_check;
    my $result = $self->{'help'}->{$name};
    _no_such_method($name) unless defined $result;
    return $result;
}

my $system_multicall_signature = [[$STRING, $STRING]];
my $system_multicall_help = <<EOD;
Process an array of calls, and return an array of results. Calls should be
structs of the form {'methodName': string, 'params': array}. Each result
will either be a single-item array containg the result value, or a struct
of the form {'faultCode': int, 'faultString': string}. This is useful when
you need to make lots of small calls without lots of round trips.
EOD

sub system_multicall ($$) {
    my ($self, $calls) = @_;

    my @results;
    foreach my $call (@$calls) {
	my ($result, $name, $params);
	eval {
	    $name = $call->{'methodName'} or die "Expected methodName";
	    $params = $call->{'params'} or die "Expected params";
	    if ($name eq 'system.multicall') {
		die "Recursive system.multicall forbidden, stopped";
	    }
	    $result = [$self->dispatch_call($name, $params)];
	};
	if ($@) {
	    chomp $@;
	    $result = {'faultCode' => 4,
		       'faultString' => "Error executing '$name': $@"};
	}
	push @results, $result;
    }
    return \@results;
}


#==========================================================================
#  _register_system_methods
#==========================================================================
#  This is a little bit of Perl trickiness to get these methods into the
#  registry.  We use Perl closures to work our magic; see the man pages
#  for all the gruesome details.

# Return a new method which is implicitly bound to the registry.
# This makes much more sense in Scheme, trust me. ;-)
sub _remember_registry ($$) {
    my ($self, $method) = @_;
    sub { return &$method($self, @_) };
}

# Install all our system methods.
sub _register_system_methods ($) {
    my ($self) = @_;
    $self->add_method('system.listMethods',
		      $self->_remember_registry(\&system_listMethods),
		      signature => $system_listMethods_signature,
		      help => $system_listMethods_help);
    $self->add_method('system.methodSignature',
		      $self->_remember_registry(\&system_methodSignature),
		      signature => $system_methodSignature_signature,
		      help => $system_methodSignature_help);
    $self->add_method('system.methodHelp',
		      $self->_remember_registry(\&system_methodHelp),
		      signature => $system_methodHelp_signature,
		      help => $system_methodHelp_help);
    $self->add_method('system.multicall',
		      $self->_remember_registry(\&system_multicall),
		      signature => $system_multicall_signature,
		      help => $system_multicall_help);
}
