Vim Patior

Edit file

File name : RPC2.pm

Content :

#
# 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 $
#

# NOTE: see Storable for marshalling.

use strict;

package Frontier::RPC2;
use XML::Parser;

use vars qw{%scalars %char_entities};

%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,
);

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 ($@) {
	return $self->encode_fault(1, "error decoding RPC.\n" . $@);
    }

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

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

my $result;
    my $eval = eval { $result = &{ $methods->{$method} }(@{ $call->{'value'} }) };
    if ($@) {
	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;

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);
    } else {
	die "can't convert \`$item' to XML\n";
    }

return @text;
}

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

my @text = "<value><struct>\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";

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

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

return @text;
}

sub _scalar {
    my $self = shift; my $value = shift;

# 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;
  $value =~ s/([\x{80}-\x{FFFF}])/'&#' . ord($1) . ';'/gse;
	return ("<value><string>$value</string></value>");
    }
}

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

$self->{'parser'} = XML::Parser->new( Style => ref($self),
					  'use_objects' => $self->{'use_objects'} );
    return $self->{'parser'}->parsestring($string);
}

# shortcuts
sub base64 {
    my $self = shift;

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

sub boolean {
    my $self = shift;
    my $elem = shift;
    if($elem == 0 or $elem == 1) {
        return Frontier::RPC2::Boolean->new($elem);
    } else {
        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($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($elem =~ /^[+-]?\d+$/) {
        return Frontier::RPC2::Integer->new($elem);
    } else {
        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
###

sub die {
    my $expat = shift; my $message = shift;

die $message
	. "at line " . $expat->current_line
        . " column " . $expat->current_column . "\n";
}

sub init {
    my $expat = shift;

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

# FIXME this state machine wouldn't be necessary if we had a DTD.
sub start {
    my $expat = shift; my $tag = shift;

my $state = $expat->{'rpc_state'}[-1];

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

sub end {
    my $expat = shift; my $tag = shift;

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

if ($state eq 'cdata') {
	my $value = $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 ($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);
	    }
	}
	$expat->{'rpc_value'} = $value;
    } elsif ($state eq 'member_name') {
	$expat->{'rpc_member_name'}[-1] = $expat->{'rpc_text'};
	$expat->{'rpc_state'}[-1] = 'want_value';
    } elsif ($state eq 'method_name') {
	$expat->{'rpc_method_name'} = $expat->{'rpc_text'};
	$expat->{'rpc_state'}[-1] = 'want_params';
    } elsif ($state eq 'struct') {
	$expat->{'rpc_value'} = pop @{ $expat->{'rpc_container'} };
	pop @{ $expat->{'rpc_member_name'} };
    } elsif ($state eq 'array') {
	$expat->{'rpc_value'} = pop @{ $expat->{'rpc_container'} };
    } elsif ($state eq 'value') {
	# the rpc_text is a string if no type tags were given
	if ($expat->{'may_get_cdata'}) {
	    $expat->{'may_get_cdata'} = 0;
	    if ($expat->{'use_objects'}) {
		$expat->{'rpc_value'}
		= Frontier::RPC2::String->new($expat->{'rpc_text'});
	    } else {
		$expat->{'rpc_value'} = $expat->{'rpc_text'};
	    }
	}
	my $container = $expat->{'rpc_container'}[-1];
	if (ref($container) eq 'ARRAY') {
	    push @$container, $expat->{'rpc_value'};
	} elsif (ref($container) eq 'HASH') {
	    $container->{ $expat->{'rpc_member_name'}[-1] } = $expat->{'rpc_value'};
	}
    }
}

sub char {
    my $expat = shift; my $text = shift;

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

sub proc {
}

sub final {
    my $expat = shift;

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

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;