RPC2.pm - This Perl code implements an XML parser for RPC (…

/src/agent/lib/Frontier/RPC2.pm

http://keywatch.googlecode.com/ · Perl · 824 lines · 635 code · 130 blank · 59 comment · 42 complexity · 4c0a28fea4623d7f5a270c8033959499 MD5 · raw file

# ----------------------------------------------------------------------------
# Copyright (C) 1998, 1999 Ken MacLeod
# Frontier::RPC is free software; you can redistribute it
# and/or modify it under the same terms as Perl itself.
#
# $Id: RPC2.pm,v 1.18 2002/08/02 18:35:21 ivan420 Exp $
#
#
# SRS: Added support for SAX parsing in pure Perl (i.e. no expat dependency)
#
# ----------------------------------------------------------------------------

use strict;

package Frontier::RPC2;
use XML::SAX::PurePerl;

#use vars qw{%scalars %char_entities};

my %char_entities = (
    '&' => '&amp;',
    '<' => '&lt;',
    '>' => '&gt;',
    '"' => '&quot;',
);

# FIXME I need a list of these
my %scalars = (
    'base64' => 1,
    'boolean' => 1,
    'dateTime.iso8601' => 1,
    'double' => 1,
    'int' => 1,
    'i4' => 1,
    'string' => 1,
);

# Constructor
sub new
{
    my $class = shift;
    my $self = ($#_ == 0) ? { %{ (shift) } } : { @_ };

    bless $self, $class;

    if (defined $self->{'encoding'}) {
	$self->{'encoding_'} = " encoding=\"$self->{'encoding'}\"";
    } else {
	$self->{'encoding_'} = "";
    }

    return $self;
}

sub encode_call
{
    my $self = shift; my $proc = shift;

    my @text;
    push @text, <<EOF;
<?xml version="1.0"$self->{'encoding_'}?>
<methodCall>
<methodName>$proc</methodName>
<params>
EOF

    push @text, $self->_params([@_]);

    push @text, <<EOF;
</params>
</methodCall>
EOF

    return join('', @text);
}

sub encode_response {
    my $self = shift;

    my @text;
    push @text, <<EOF;
<?xml version="1.0"$self->{'encoding_'}?>
<methodResponse>
<params>
EOF

    push @text, $self->_params([@_]);

    push @text, <<EOF;
</params>
</methodResponse>
EOF

    return join('', @text);
}

sub encode_fault {
    my $self = shift; my $code = shift; my $message = shift;

    my @text;
    push @text, <<EOF;
<?xml version="1.0"$self->{'encoding_'}?>
<methodResponse>
<fault>
EOF

    push @text, $self->_item({faultCode => $code, faultString => $message});

    push @text, <<EOF;
</fault>
</methodResponse>
EOF

    return join('', @text);
}

sub serve
{
    my $self = shift; my $xml = shift; my $methods = shift;

    my $call;
    # FIXME bug in Frontier's XML
    $xml =~ s/(<\?XML\s+VERSION)/\L$1\E/;
    eval { $call = $self->decode($xml) };

    if ($@)
    {
        print "error 1 in server()\n";
        return $self->encode_fault(1, "error decoding RPC.\n" . $@);
    }

    if ($call->{'type'} ne 'call')
    {
        print "error 2 in server()\n";
        return $self->encode_fault(2,"expected RPC \`methodCall', got \`$call->{'type'}'\n");
    }

    my $method = $call->{'method_name'};
    if (!defined $methods->{$method})
    {
        print "error 3 in server()\n";
        return $self->encode_fault(3, "no such method \`$method'\n");
    }

    my $result;
    my $eval = eval { $result = &{ $methods->{$method} }(@{ $call->{'value'} }) };
    if ($@)
    {
        print "error 4 in server()\n";
        return $self->encode_fault(4, "error executing RPC \`$method'.\n" . $@);
    }

    my $response_xml = $self->encode_response($result);
    return $response_xml;
}

sub _params
{
    my $self = shift; my $array = shift;

    my @text;
    
    if(!defined $array)
    {
        print "Undefined array in _params\n";
    }
    

    my $item;
    foreach $item (@$array)
    {
        push (@text, "<param>",
	      $self->_item($item),
	      "</param>\n");
    }

    return @text;
}

sub _item
{
    my $self = shift; my $item = shift;

    my @text;

    my $ref = ref($item);

    if (!$ref)
    {
	push (@text, $self->_scalar ($item));
    }
    elsif ($ref eq 'ARRAY')
    {
	push (@text, $self->_array($item));
    }
    elsif ($ref eq 'HASH')
    {
	push (@text, $self->_hash($item));
    }
    elsif ($ref eq 'Frontier::RPC2::Boolean')
    {
	push @text, "<value><boolean>", $item->repr, "</boolean></value>\n";
    }
    elsif ($ref eq 'Frontier::RPC2::String')
    {
      push @text, "<value><string>", $item->repr, "</string></value>\n";
    }
    elsif ($ref eq 'Frontier::RPC2::Integer')
    {
      push @text, "<value><int>", $item->repr, "</int></value>\n";
    }
    elsif ($ref eq 'Frontier::RPC2::Double')
    {
      push @text, "<value><double>", $item->repr, "</double></value>\n";
    }
    elsif ($ref eq 'Frontier::RPC2::DateTime::ISO8601')
    {
	push @text, "<value><dateTime.iso8601>", $item->repr, "</dateTime.iso8601></value>\n";
    }
    elsif ($ref eq 'Frontier::RPC2::Base64')
    {
	push @text, "<value><base64>", $item->repr, "</base64></value>\n";
    }
    elsif ($ref =~ /=HASH\(/)
    {
	push @text, $self->_hash($item);
    }
    elsif ($ref =~ /=ARRAY\(/)
    {
	push @text, $self->_array($item);
    }
    elsif ($ref eq 'SCALAR')
    {
	push @text, $self->_scalar($$item);
    }
    else
    {
        # Evil hack: assume it's a struct or hash of some sort; this handles
        # Struct types as well.
        push (@text, $self->_hash($item));
    }

    return @text;
}

sub _hash
{
    my $self = shift; my $hash = shift;

    my @text = "<value><struct>\n";

    if(!defined $hash)
    {
        print "Undefined hash in _hash\n";
    }

    my ($key, $value);
    while (($key, $value) = each %$hash)
    {
	push (@text,
	      "<member><name>$key</name>",
	      $self->_item($value),
	      "</member>\n");
    }

    push @text, "</struct></value>\n";

    return @text;
}


sub _array
{
    my $self = shift; my $array = shift;

    my @text = "<value><array><data>\n";

    if(!defined $array)
    {
        print "Undefined array in _array\n";
    }


    my $item;
    foreach $item (@$array)
    {
        push @text, $self->_item($item);
    }

    push @text, "</data></array></value>\n";

    return @text;
}

sub _scalar
{
    # Turn off bogus warnings in this scope
    local $^W = 0;

    my $self = shift; my $value = shift;

    if(!defined $value)
    {
        #print "Undefined element in _scalar\n";
        #return "";
        # note: <value></nil></value> doesn't seem to be supported
        return "<value><string></string></value>";
    }

    # these are from `perldata(1)'
    if ($value =~ /^[+-]?\d+$/)
    {
        return ("<value><i4>$value</i4></value>");
    }
    elsif ($value =~ /^(-?(?:\d+(?:\.\d*)?|\.\d+)|([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?)$/)
    {
        return ("<value><double>$value</double></value>");
    }
    else
    {
        $value =~ s/([&<>\"])/$char_entities{$1}/ge;
    	return ("<value><string>$value</string></value>");
    }
}

sub decode
{
    my $self = shift; my $string = shift;

    # Get a SAX parser. This will fall back to PurePerl.pm if nothing
    # else is available.

    if(!defined  $self->{'handler'})
    {
        $self->{'handler'} = Frontier::RPC2::SAXHandler->new;
    }

    #if(!defined $self->{'parser'})
    {
	$self->{'parser'} = XML::SAX::ParserFactory->parser(Handler => $self->{'handler'});
    }

    return $self->{'parser'}->parse_string($string);
}

# shortcuts
sub base64 {
    my $self = shift;

    return Frontier::RPC2::Base64->new(@_);
}

sub boolean
{
    my $self = shift;
    my $elem = shift;
    if(defined $elem && ($elem == 0 or $elem == 1))
    {
        return Frontier::RPC2::Boolean->new($elem);
    }
    else
    {
        print "error in rendering RPC type \`$elem\' not a boolean\n";
        return Frontier::RPC2::Boolean->new(0);
        #die "error in rendering RPC type \`$elem\' not a boolean\n";
    }
}

sub double
{
    my $self = shift;
    my $elem = shift;
    # this is from `perldata(1)'
    if(defined $elem && $elem =~ /^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/) {
        return Frontier::RPC2::Double->new($elem);
    } else {
        die "error in rendering RPC type \`$elem\' not a double\n";
    }
}

sub int {
    my $self = shift;
    my $elem = shift;
    # this is from `perldata(1)'
    if(defined $elem && $elem =~ /^[+-]?\d+$/) {
        return Frontier::RPC2::Integer->new($elem);
    }
    else
    {
        print "error in rendering RPC type \`$elem\' not an int\n";
        return Frontier::RPC2::Integer->new($elem);
        #die "error in rendering RPC type \`$elem\' not an int\n";
    }
}

sub string {
    my $self = shift;

    return Frontier::RPC2::String->new(@_);
}

sub date_time {
    my $self = shift;

    return Frontier::RPC2::DateTime::ISO8601->new(@_);
}

######################################################################
###
### XML::Parser callbacks
###
package Frontier::RPC2::SAXHandler;

use vars qw{%scalars %char_entities %expat};
#use vars qw{%scalars %char_entities};
use base qw(XML::SAX::Base);

%char_entities = (
    '&' => '&amp;',
    '<' => '&lt;',
    '>' => '&gt;',
    '"' => '&quot;',
);

# FIXME I need a list of these
%scalars = (
    'base64' => 1,
    'boolean' => 1,
    'dateTime.iso8601' => 1,
    'double' => 1,
    'int' => 1,
    'i4' => 1,
    'string' => 1,
);

#%expat = ();


# C'tor
sub new
{
    my $package = shift;
    my $self = bless { @_ }, $package;

    #my $expat = {};
    bless \%expat, $package;

    return $self;
}

# D'tor
sub DESTROY
{
    my $self = shift;

    $self->{expat}->{'rpc_state'} = [];
    $self->{expat}->{'rpc_container'} = [ [] ];
    $self->{expat}->{'rpc_member_name'} = [];
    $self->{expat}->{'rpc_type'} = undef;
    $self->{expat}->{'rpc_args'} = undef;
    $self->{expat} = {};
}

sub die
{
   my ($self, $message) = @_;
   my $expat = $self->{expat};

    die $message, "\n";
}


# START DOC
sub start_document
{
   my ($self, $doc) = @_;

    # We call the state hash expat to easy Frontier migration from XML::Parser
    # to XML::SAX
    #my $expat = $self->{expat};
    $self->{expat} = {};
    $self->{expat}->{'rpc_state'} = [];
    $self->{expat}->{'rpc_container'} = [ [] ];
    $self->{expat}->{'rpc_member_name'} = [];
    $self->{expat}->{'rpc_type'} = undef;
    $self->{expat}->{'rpc_args'} = undef;
}

sub end_document
{
   my ($self) = @_;
   #my $expat = $self->{expat};

    $self->{expat}->{'rpc_value'} = pop @{ $self->{expat}->{'rpc_container'} };

    return
    {
	value => $self->{expat}->{'rpc_value'},
	type => $self->{expat}->{'rpc_type'},
	method_name => $self->{expat}->{'rpc_method_name'},
    };
}


# START ELEMENT
sub start_element
{
   my ($self, $el) = @_;

   #my $expat = $self->{expat};

   my $tag = $el->{"LocalName"};

   # process element start event
    my $state = $self->{expat}->{'rpc_state'}[-1];

    if (!defined $state)
    {
	if ($tag eq 'methodCall')
	{
	    $self->{expat}->{'rpc_type'} = 'call';
	    push @{ $self->{expat}->{'rpc_state'} }, 'want_method_name';
	}
	elsif ($tag eq 'methodResponse')
	{
	    push @{ $self->{expat}->{'rpc_state'} }, 'method_response';
	}
	else
	{
	    Frontier::RPC2::SAXHandler::die($self->{expat}, "unknown RPC type \`$tag'\n");
	}
    }
    elsif ($state eq 'want_method_name')
    {
	Frontier::RPC2::SAXHandler::die($self->{expat}, "wanted \`methodName' tag, got \`$tag'\n")
	    if ($tag ne 'methodName');
	push @{ $self->{expat}->{'rpc_state'} }, 'method_name';
	$self->{expat}->{'rpc_text'} = "";
    }
    elsif ($state eq 'method_response')
    {
	if ($tag eq 'params')
	{
	    $self->{expat}->{'rpc_type'} = 'response';
	    push @{ $self->{expat}->{'rpc_state'} }, 'params';
	}
	elsif ($tag eq 'fault')
	{
	    $self->{expat}->{'rpc_type'} = 'fault';
	    push @{ $self->{expat}->{'rpc_state'} }, 'want_value';
	}
    }
    elsif ($state eq 'want_params')
    {
	Frontier::RPC2::SAXHandler::die($self->{expat}, "wanted \`params' tag, got \`$tag'\n")
	    if ($tag ne 'params');
	push @{ $self->{expat}->{'rpc_state'} }, 'params';
    }
    elsif ($state eq 'params')
    {
	Frontier::RPC2::SAXHandler::die($self->{expat}, "wanted \`param' tag, got \`$tag'\n")
	    if ($tag ne 'param');
	push @{ $self->{expat}->{'rpc_state'} }, 'want_param_name_or_value';
    }
    elsif ($state eq 'want_param_name_or_value')
    {
	if ($tag eq 'value')
	{
	    $self->{expat}->{'may_get_cdata'} = 1;
	    $self->{expat}->{'rpc_text'} = "";
	    push @{ $self->{expat}->{'rpc_state'} }, 'value';
	}
	elsif ($tag eq 'name')
	{
	    push @{ $self->{expat}->{'rpc_state'} }, 'param_name';
	}
	else
	{
	    Frontier::RPC2::die($self->{expat}, "wanted \`value' or \`name' tag, got \`$tag'\n");
	}
    }
    elsif ($state eq 'param_name')
    {
	Frontier::RPC2::SAXHandler::die($self->{expat}, "wanted parameter name data, got tag \`$tag'\n");
    }
    elsif ($state eq 'want_value')
    {
	Frontier::RPC2::SAXHandler::die($self->{expat}, "wanted \`value' tag, got \`$tag'\n")
	    if ($tag ne 'value');
	$self->{expat}->{'rpc_text'} = "";
	$self->{expat}->{'may_get_cdata'} = 1;
	push @{ $self->{expat}->{'rpc_state'} }, 'value';
    }
    elsif ($state eq 'value')
    {
	$self->{expat}->{'may_get_cdata'} = 0;
	if ($tag eq 'array')
	{
	    push @{ $self->{expat}->{'rpc_container'} }, [];
	    push @{ $self->{expat}->{'rpc_state'} }, 'want_data';
	}
	elsif ($tag eq 'struct')
	{
	    push @{ $self->{expat}->{'rpc_container'} }, {};
	    push @{ $self->{expat}->{'rpc_member_name'} }, undef;
	    push @{ $self->{expat}->{'rpc_state'} }, 'struct';
	}
	elsif ($scalars{$tag})
	{
	    $self->{expat}->{'rpc_text'} = "";
	    push @{ $self->{expat}->{'rpc_state'} }, 'cdata';
	}
	else
	{
	    Frontier::RPC2::SAXHandler::die($self->{expat}, "wanted a data type, got \`$tag'\n");
	}
    }
    elsif ($state eq 'want_data')
    {
	Frontier::RPC2::SAXHandler::die($self->{expat}, "wanted \`data', got \`$tag'\n")
	    if ($tag ne 'data');
	push @{ $self->{expat}->{'rpc_state'} }, 'array';
    }
    elsif ($state eq 'array')
    {
	Frontier::RPC2::SAXHandler::die($self->{expat}, "wanted \`value' tag, got \`$tag'\n")
	    if ($tag ne 'value');
	$self->{expat}->{'rpc_text'} = "";
	$self->{expat}->{'may_get_cdata'} = 1;
	push @{ $self->{expat}->{'rpc_state'} }, 'value';
    }
    elsif ($state eq 'struct')
    {
	Frontier::RPC2::SAXHandler::die($self->{expat}, "wanted \`member' tag, got \`$tag'\n")
	    if ($tag ne 'member');
	push @{ $self->{expat}->{'rpc_state'} }, 'want_member_name';
    }
    elsif ($state eq 'want_member_name')
    {
	Frontier::RPC2::SAXHandler::die($self->{expat}, "wanted \`name' tag, got \`$tag'\n")
	    if ($tag ne 'name');
	push @{ $self->{expat}->{'rpc_state'} }, 'member_name';
	$self->{expat}->{'rpc_text'} = "";
    }
    elsif ($state eq 'member_name')
    {
	Frontier::RPC2::SAXHandler::die($self->{expat}, "wanted data, got tag \`$tag'\n");
    }
    elsif ($state eq 'cdata')
    {
	Frontier::RPC2::SAXHandler::die($self->{expat}, "wanted data, got tag \`$tag'\n");
    }
    else
    {
	Frontier::RPC2::SAXHandler::die($self->{expat}, "internal error, unknown state \`$state'\n");
    }

}

# START ELEMENT
sub end_element
{
   my ($self, $el) = @_;

   #my $expat = $self->{expat};
   my $tag = $el->{"LocalName"};

   # Process
    my $state = pop @{ $self->{expat}->{'rpc_state'} };

    if ($state eq 'cdata')
    {
	my $value = $self->{expat}->{'rpc_text'};

	if ($tag eq 'base64')
	{
	    $value = Frontier::RPC2::Base64->new($value);
	}
	elsif ($tag eq 'boolean')
	{
	    $value = Frontier::RPC2::Boolean->new($value);
	}
	elsif ($tag eq 'dateTime.iso8601')
	{
	    $value = Frontier::RPC2::DateTime::ISO8601->new($value);
	}
	elsif ($self->{expat}->{'use_objects'})
	{
	    if ($tag eq 'i4' or $tag eq 'int')
	    {
		$value = Frontier::RPC2::Integer->new($value);
	    }
	    elsif ($tag eq 'float')
	    {
		$value = Frontier::RPC2::Float->new($value);
	    }
	    elsif ($tag eq 'string')
	    {
		$value = Frontier::RPC2::String->new($value);
	    }
	}
	$self->{expat}->{'rpc_value'} = $value;
    }
    elsif ($state eq 'member_name')
    {
	$self->{expat}->{'rpc_member_name'}[-1] = $self->{expat}->{'rpc_text'};
	$self->{expat}->{'rpc_state'}[-1] = 'want_value';
    }
    elsif ($state eq 'method_name')
    {
	$self->{expat}->{'rpc_method_name'} = $self->{expat}->{'rpc_text'};
	$self->{expat}->{'rpc_state'}[-1] = 'want_params';
    }
    elsif ($state eq 'struct')
    {
	$self->{expat}->{'rpc_value'} = pop @{ $self->{expat}->{'rpc_container'} };
	pop @{ $self->{expat}->{'rpc_member_name'} };
    }
    elsif ($state eq 'array')
    {
	$self->{expat}->{'rpc_value'} = pop @{ $self->{expat}->{'rpc_container'} };
    }
    elsif ($state eq 'value')
    {
	# the rpc_text is a string if no type tags were given
	if ($self->{expat}->{'may_get_cdata'})
	{
	    $self->{expat}->{'may_get_cdata'} = 0;
	    if ($self->{expat}->{'use_objects'})
	    {
		$self->{expat}->{'rpc_value'}
		= Frontier::RPC2::String->new($self->{expat}->{'rpc_text'});
	    }
	    else
	    {
		$self->{expat}->{'rpc_value'} = $self->{expat}->{'rpc_text'};
	    }
	}

	my $container = $self->{expat}->{'rpc_container'}[-1];

	if (ref($container) eq 'ARRAY')
	{
	    push @$container, $self->{expat}->{'rpc_value'};
	}
	elsif (ref($container) eq 'HASH')
	{
	    $container->{ $self->{expat}->{'rpc_member_name'}[-1] } = $self->{expat}->{'rpc_value'};
	}
    }

}

sub characters
{
   my ($self, $text) = @_;
   #my $expat = $self->{expat};

   $self->{expat}->{'rpc_text'} .= $text->{"Data"};
}

# ----------------------------------------------------------------------------
# RPC2 DATA TYPES
# ----------------------------------------------------------------------------
package Frontier::RPC2::DataType;

sub new {
    my $type = shift; my $value = shift;

    return bless \$value, $type;
}

# `repr' returns the XML representation of this data, which may be
# different [in the future] from what is returned from `value'
sub repr {
    my $self = shift;

    return $$self;
}

# sets or returns the usable value of this data
sub value {
    my $self = shift;
    @_ ? ($$self = shift) : $$self;
}

package Frontier::RPC2::Base64;

use vars qw{@ISA};
@ISA = qw{Frontier::RPC2::DataType};

package Frontier::RPC2::Boolean;

use vars qw{@ISA};
@ISA = qw{Frontier::RPC2::DataType};

package Frontier::RPC2::Integer;

use vars qw{@ISA};
@ISA = qw{Frontier::RPC2::DataType};

package Frontier::RPC2::String;

use vars qw{@ISA};
@ISA = qw{Frontier::RPC2::DataType};

sub repr {
    my $self = shift;
    my $value = $$self;
    $value =~ s/([&<>\"])/$Frontier::RPC2::char_entities{$1}/ge;
    $value;
}

package Frontier::RPC2::Double;

use vars qw{@ISA};
@ISA = qw{Frontier::RPC2::DataType};

package Frontier::RPC2::DateTime::ISO8601;

use vars qw{@ISA};
@ISA = qw{Frontier::RPC2::DataType};

1;
Summary ✨

This Perl code implements an XML parser for RPC (Remote Procedure Call) data types. It defines a set of classes to represent various data types, such as strings, integers, and dates, which can be used in RPC requests. The parser uses these classes to parse incoming XML data and convert it into usable values.
Alerts (1)

Complexity hotspot; line 357 (total complexity: 4)
357