GSP/GSP-Agent-Linux
1
0
Fork 0
Code Issues 1 Pull requests Projects Releases Packages Wiki Activity Actions

Initial Linux agent repository

Browse source
This commit is contained in:
Frank Harris 2026-06-08 10:48:00 -05:00
commit ff2cb0d399
235 changed files with 40477 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

285
Frontier/Client.pm Normal file
View file

@ -0,0 +1,285 @@
#
# Copyright (C) 1998 Ken MacLeod
# Frontier::Client is free software; you can redistribute it
# and/or modify it under the same terms as Perl itself.
#
# $Id: Client.pm,v 1.8 2001/10/03 01:30:54 kmacleod Exp $
#
# NOTE: see Net::pRPC for a Perl RPC implementation
use strict;
package Frontier::Client;
use Frontier::RPC2;
use LWP::UserAgent;
use HTTP::Request;
use vars qw{$AUTOLOAD};
sub new {
my $class = shift;
my $self = ($#_ == 0) ? { %{ (shift) } } : { @_ };
bless $self, $class;
die "Frontier::RPC::new: no url defined\n"
if !defined $self->{'url'};
$self->{'ua'} = LWP::UserAgent->new;
$self->{'ua'}->proxy('http', $self->{'proxy'})
if(defined $self->{'proxy'});
$self->{'rq'} = HTTP::Request->new (POST => $self->{'url'});
$self->{'rq'}->header('Content-Type' => 'text/xml');
my @options;
if(defined $self->{'encoding'}) {
push @options, 'encoding' => $self->{'encoding'};
}
if (defined $self->{'use_objects'} && $self->{'use_objects'}) {
push @options, 'use_objects' => $self->{'use_objects'};
}
$self->{'enc'} = Frontier::RPC2->new(@options);
return $self;
}
sub call {
my $self = shift;
my $text = $self->{'enc'}->encode_call(@_);
if ($self->{'debug'}) {
print "---- request ----\n";
print $text;
}
$self->{'rq'}->content($text);
my $response = $self->{'ua'}->request($self->{'rq'});
if (!$response->is_success) {
die $response->status_line . "\n";
}
my $content = $response->content;
if ($self->{'debug'}) {
print "---- response ----\n";
print $content;
}
my $result = $self->{'enc'}->decode($content);
if ($result->{'type'} eq 'fault') {
die "Fault returned from XML RPC Server, fault code " . $result->{'value'}[0]{'faultCode'} . ": "
. $result->{'value'}[0]{'faultString'} . "\n";
}
return $result->{'value'}[0];
}
# shortcuts
sub base64 {
my $self = shift;
return Frontier::RPC2::Base64->new(@_);
}
sub boolean {
my $self = shift;
return Frontier::RPC2::Boolean->new(@_);
}
sub double {
my $self = shift;
return Frontier::RPC2::Double->new(@_);
}
sub int {
my $self = shift;
return Frontier::RPC2::Integer->new(@_);
}
sub string {
my $self = shift;
return Frontier::RPC2::String->new(@_);
}
sub date_time {
my $self = shift;
return Frontier::RPC2::DateTime::ISO8601->new(@_);
}
# something like this could be used to get an effect of
#
# $server->examples_getStateName(41)
#
# instead of
#
# $server->call('examples.getStateName', 41)
#
# for Frontier's
#
# [server].examples.getStateName 41
#
# sub AUTOLOAD {
# my ($pkg, $method) = ($AUTOLOAD =~ m/^(.*::)(.*)$/);
# return if $method eq 'DESTROY';
#
# $method =~ s/__/=/g;
# $method =~ tr/_=/._/;
#
# splice(@_, 1, 0, $method);
#
# goto &call;
# }
=head1 NAME
Frontier::Client - issue Frontier XML RPC requests to a server
=head1 SYNOPSIS
use Frontier::Client;
$server = Frontier::Client->new( I<OPTIONS> );
$result = $server->call($method, @args);
$boolean = $server->boolean($value);
$date_time = $server->date_time($value);
$base64 = $server->base64($value);
$value = $boolean->value;
$value = $date_time->value;
$value = $base64->value;
=head1 DESCRIPTION
I<Frontier::Client> is an XML-RPC client over HTTP.
I<Frontier::Client> instances are used to make calls to XML-RPC
servers and as shortcuts for creating XML-RPC special data types.
=head1 METHODS
=over 4
=item new( I<OPTIONS> )
Returns a new instance of I<Frontier::Client> and associates it with
an XML-RPC server at a URL. I<OPTIONS> may be a list of key, value
pairs or a hash containing the following parameters:
=over 4
=item url
The URL of the server. This parameter is required. For example:
$server = Frontier::Client->new( 'url' => 'http://betty.userland.com/RPC2' );
=item proxy
A URL of a proxy to forward XML-RPC calls through.
=item encoding
The XML encoding to be specified in the XML declaration of outgoing
RPC requests. Incoming results may have a different encoding
specified; XML::Parser will convert incoming data to UTF-8. The
default outgoing encoding is none, which uses XML 1.0's default of
UTF-8. For example:
$server = Frontier::Client->new( 'url' => 'http://betty.userland.com/RPC2',
'encoding' => 'ISO-8859-1' );
=item use_objects
If set to a non-zero value will convert incoming E<lt>i4E<gt>,
E<lt>floatE<gt>, and E<lt>stringE<gt> values to objects instead of
scalars. See int(), float(), and string() below for more details.
=item debug
If set to a non-zero value will print the encoded XML request and the
XML response received.
=back
=item call($method, @args)
Forward a procedure call to the server, either returning the value
returned by the procedure or failing with exception. `C<$method>' is
the name of the server method, and `C<@args>' is a list of arguments
to pass. Arguments may be Perl hashes, arrays, scalar values, or the
XML-RPC special data types below.
=item boolean( $value )
=item date_time( $value )
=item base64( $base64 )
The methods `C<boolean()>', `C<date_time()>', and `C<base64()>' create
and return XML-RPC-specific datatypes that can be passed to
`C<call()>'. Results from servers may also contain these datatypes.
The corresponding package names (for use with `C<ref()>', for example)
are `C<Frontier::RPC2::Boolean>',
`C<Frontier::RPC2::DateTime::ISO8601>', and
`C<Frontier::RPC2::Base64>'.
The value of boolean, date/time, and base64 data can be set or
returned using the `C<value()>' method. For example:
# To set a value:
$a_boolean->value(1);
# To retrieve a value
$base64 = $base64_xml_rpc_data->value();
Note: `C<base64()>' does I<not> encode or decode base64 data for you,
you must use MIME::Base64 or similar module for that.
=item int( 42 );
=item float( 3.14159 );
=item string( "Foo" );
By default, you may pass ordinary Perl values (scalars) to be encoded.
RPC2 automatically converts them to XML-RPC types if they look like an
integer, float, or as a string. This assumption causes problems when
you want to pass a string that looks like "0096", RPC2 will convert
that to an E<lt>i4E<gt> because it looks like an integer. With these
methods, you could now create a string object like this:
$part_num = $server->string("0096");
and be confident that it will be passed as an XML-RPC string. You can
change and retrieve values from objects using value() as described
above.
=back
=head1 SEE ALSO
perl(1), Frontier::RPC2(3)
<http://www.scripting.com/frontier5/xml/code/rpc.html>
=head1 AUTHOR
Ken MacLeod <ken@bitsko.slc.ut.us>
=cut
1;

96
Frontier/Daemon.pm Normal file
View file

@ -0,0 +1,96 @@
#
# Copyright (C) 1998 Ken MacLeod
# Frontier::Daemon is free software; you can redistribute it
# and/or modify it under the same terms as Perl itself.
#
# $Id: Daemon.pm,v 1.5 2001/10/03 01:30:54 kmacleod Exp $
#
# NOTE: see Net::pRPC for a Perl RPC implementation
###
### NOTE: $self is inherited from HTTP::Daemon and the weird access
### comes from there (`${*$self}').
###
use strict;
package Frontier::Daemon;
use vars qw{@ISA};
@ISA = qw{HTTP::Daemon};
use Frontier::RPC2;
use HTTP::Daemon;
use HTTP::Status;
sub new {
my $class = shift; my %args = @_;
my $self = $class->SUPER::new(%args);
return undef unless $self;
${*$self}{'methods'} = $args{'methods'};
${*$self}{'decode'} = new Frontier::RPC2 'use_objects' => $args{'use_objects'};
${*$self}{'response'} = new HTTP::Response 200;
${*$self}{'response'}->header('Content-Type' => 'text/xml');
my $conn;
while ($conn = $self->accept) {
my $rq = $conn->get_request;
if ($rq) {
if ($rq->method eq 'POST' && $rq->url->path eq '/RPC2') {
${*$self}{'response'}->content(${*$self}{'decode'}->serve($rq->content, ${*$self}{'methods'}));
$conn->send_response(${*$self}{'response'});
} else {
$conn->send_error(RC_FORBIDDEN);
}
}
$conn->close;
$conn = undef; # close connection
}
return $self;
}
=head1 NAME
Frontier::Daemon - receive Frontier XML RPC requests
=head1 SYNOPSIS
use Frontier::Daemon;
Frontier::Daemon->new(methods => {
'rpcName' => \&sub_name,
...
});
=head1 DESCRIPTION
I<Frontier::Daemon> is an HTTP/1.1 server that listens on a socket for
incoming requests containing Frontier XML RPC2 method calls.
I<Frontier::Daemon> is a subclass of I<HTTP::Daemon>, which is a
subclass of I<IO::Socket::INET>.
I<Frontier::Daemon> takes a `C<methods>' parameter, a hash that maps
an incoming RPC method name to reference to a subroutine.
I<Frontier::Daemon> takes a `C<use_objects>' parameter that if set to
a non-zero value will convert incoming E<lt>intE<gt>, E<lt>i4E<gt>,
E<lt>floatE<gt>, and E<lt>stringE<gt> values to objects instead of
scalars. See int(), float(), and string() in Frontier::RPC2 for more
details.
=head1 SEE ALSO
perl(1), HTTP::Daemon(3), IO::Socket::INET(3), Frontier::RPC2(3)
<http://www.scripting.com/frontier5/xml/code/rpc.html>
=head1 AUTHOR
Ken MacLeod <ken@bitsko.slc.ut.us>
=cut
1;

95
Frontier/Daemon/OGP/Forking.pm Normal file
View file

@ -0,0 +1,95 @@
package Frontier::Daemon::OGP::Forking;
# $Id: Forking.pm,v 1.6 2004/01/23 19:48:33 tcaine Exp $
use strict;
use vars qw{@ISA $VERSION};
$VERSION = '0.02';
use Frontier::RPC2;
use HTTP::Daemon;
use HTTP::Status;
@ISA = qw{HTTP::Daemon};
# most of this routine comes directly from Frontier::Daemon
sub new {
my $class = shift;
my %args = @_;
my $encoding = delete $args{encoding};
my $self = $class->SUPER::new( %args );
return undef unless $self;
my @options;
push @options, encoding => $encoding
if $encoding;
${*$self}{methods} = $args{methods};
${*$self}{decode} = new Frontier::RPC2(@options);
${*$self}{response} = new HTTP::Response 200;
${*$self}{response}->header( 'Content-Type' => 'text/xml' );
local $SIG{CHLD} = 'IGNORE';
ACCEPT:
while ( my $conn = $self->accept ) {
my $pid = fork;
next ACCEPT if $pid;
if ( not defined $pid ) {
warn "fork() failed: $!";
$conn = undef;
}
else {
my $request = $conn->get_request;
if ($request) {
if ($request->method eq 'POST' && $request->url->path eq '/RPC2') {
${*$self}{'response'}->content(
${*$self}{'decode'}->serve(
$request->content,
${*$self}{'methods'},
)
);
$conn->send_response(${*$self}{'response'});
} else {
$conn->send_error(RC_FORBIDDEN);
}
}
}
exit;
}
}
1;
__END__
=head1 NAME
Frontier::Daemon::Forking - receive Frontier XML RPC requests
=head1 SYNOPSIS
use Frontier::Daemon::Forking;
Frontier::Daemon::Forking->new(
methods => {
rpcName => \&rpcHandler,
},
encoding => 'ISO-8859-1',
);
sub rpcHandler { return 'OK' }
=head1 DESCRIPTION
L<Frontier::Daemon::Forking> is a drop in replacement for L<Frontier::Daemon> when a forking HTTP/1.1 server is needed that listens on a socket for incoming requests containing Frontier XML RPC2 method calls. Most of the code was borrowed from L<Frontier::Daemon>.
=head1 AUTHOR
Todd Caine, tcaine@pobox.com
=head1 SEE ALSO
L<Frontier::RPC2>, L<Frontier::Daemon>, L<HTTP::Daemon>
=cut

701
Frontier/RPC2.pm Normal file
View file

@ -0,0 +1,701 @@
#
# 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;
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;
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};
=head1 NAME
Frontier::RPC2 - encode/decode RPC2 format XML
=head1 SYNOPSIS
use Frontier::RPC2;
$coder = Frontier::RPC2->new;
$xml_string = $coder->encode_call($method, @args);
$xml_string = $coder->encode_response($result);
$xml_string = $coder->encode_fault($code, $message);
$call = $coder->decode($xml_string);
$response_xml = $coder->serve($request_xml, $methods);
$boolean_object = $coder->boolean($boolean);
$date_time_object = $coder->date_time($date_time);
$base64_object = $coder->base64($base64);
$int_object = $coder->int(42);
$float_object = $coder->float(3.14159);
$string_object = $coder->string("Foo");
=head1 DESCRIPTION
I<Frontier::RPC2> encodes and decodes XML RPC calls.
=over 4
=item $coder = Frontier::RPC2->new( I<OPTIONS> )
Create a new encoder/decoder. The following option is supported:
=over 4
=item encoding
The XML encoding to be specified in the XML declaration of encoded RPC
requests or responses. Decoded results may have a different encoding
specified; XML::Parser will convert decoded data to UTF-8. The
default encoding is none, which uses XML 1.0's default of UTF-8. For
example:
$server = Frontier::RPC2->new( 'encoding' => 'ISO-8859-1' );
=item use_objects
If set to a non-zero value will convert incoming E<lt>i4E<gt>,
E<lt>floatE<gt>, and E<lt>stringE<gt> values to objects instead of
scalars. See int(), float(), and string() below for more details.
=back
=item $xml_string = $coder->encode_call($method, @args)
`C<encode_call>' converts a method name and it's arguments into an
RPC2 `C<methodCall>' element, returning the XML fragment.
=item $xml_string = $coder->encode_response($result)
`C<encode_response>' converts the return value of a procedure into an
RPC2 `C<methodResponse>' element containing the result, returning the
XML fragment.
=item $xml_string = $coder->encode_fault($code, $message)
`C<encode_fault>' converts a fault code and message into an RPC2
`C<methodResponse>' element containing a `C<fault>' element, returning
the XML fragment.
=item $call = $coder->decode($xml_string)
`C<decode>' converts an XML string containing an RPC2 `C<methodCall>'
or `C<methodResponse>' element into a hash containing three members,
`C<type>', `C<value>', and `C<method_name>'. `C<type>' is one of
`C<call>', `C<response>', or `C<fault>'. `C<value>' is array
containing the parameters or result of the RPC. For a `C<call>' type,
`C<value>' contains call's parameters and `C<method_name>' contains
the method being called. For a `C<response>' type, the `C<value>'
array contains call's result. For a `C<fault>' type, the `C<value>'
array contains a hash with the two members `C<faultCode>' and
`C<faultMessage>'.
=item $response_xml = $coder->serve($request_xml, $methods)
`C<serve>' decodes `C<$request_xml>', looks up the called method name
in the `C<$methods>' hash and calls it, and then encodes and returns
the response as XML.
=item $boolean_object = $coder->boolean($boolean);
=item $date_time_object = $coder->date_time($date_time);
=item $base64_object = $coder->base64($base64);
These methods create and return XML-RPC-specific datatypes that can be
passed to the encoder. The decoder may also return these datatypes.
The corresponding package names (for use with `C<ref()>', for example)
are `C<Frontier::RPC2::Boolean>',
`C<Frontier::RPC2::DateTime::ISO8601>', and
`C<Frontier::RPC2::Base64>'.
You can change and retrieve the value of boolean, date/time, and
base64 data using the `C<value>' method of those objects, i.e.:
$boolean = $boolean_object->value;
$boolean_object->value(1);
Note: `C<base64()>' does I<not> encode or decode base64 data for you,
you must use MIME::Base64 or similar module for that.
=item $int_object = $coder->int(42);
=item $float_object = $coder->float(3.14159);
=item $string_object = $coder->string("Foo");
By default, you may pass ordinary Perl values (scalars) to be encoded.
RPC2 automatically converts them to XML-RPC types if they look like an
integer, float, or as a string. This assumption causes problems when
you want to pass a string that looks like "0096", RPC2 will convert
that to an E<lt>i4E<gt> because it looks like an integer. With these
methods, you could now create a string object like this:
$part_num = $coder->string("0096");
and be confident that it will be passed as an XML-RPC string. You can
change and retrieve values from objects using value() as described
above.
=back
=head1 SEE ALSO
perl(1), Frontier::Daemon(3), Frontier::Client(3)
<http://www.scripting.com/frontier5/xml/code/rpc.html>
=head1 AUTHOR
Ken MacLeod <ken@bitsko.slc.ut.us>
=cut
1;

170
Frontier/Responder.pm Normal file
View file

@ -0,0 +1,170 @@
# File: Repsonder.pm
# based heavily on Ken MacLeod's Frontier::Daemon
# Author: Joe Johnston 7/2000
# Revisions:
# 11/2000 - Cleaned/Add POD. Took out 'use CGI'.
#
# Meant to be called from a CGI process to answer client
# requests and emit the appropriate reponses. See POD for details.
#
# LICENSE: This code is released under the same licensing
# as Perl itself.
#
# Use the code where ever you want, but due credit is appreciated.
package Frontier::Responder;
use strict;
use vars qw/@ISA/;
use Frontier::RPC2;
my $snappy_answer = "Hey, I need to return true, don't I?";
# Class constructor.
# Input: (expects parameters to be passed in as a hash)
# methods => hashref, keys are API procedure names, values are
# subroutine references
#
# Output: blessed reference
sub new {
my $class = shift;
my %args = @_;
my $self = bless {}, (ref $class ? ref $class : $class);
# Store the dispatch table away for future use.
$self->{methods} = $args{methods};
$self->{_decode} = Frontier::RPC2->new();
return $self;
}
# Grabs input from CGI "stream", makes request
# if possible, packs up the response in purddy
# XML
# Input: None
# Output: A XML string suitable for printing from a CGI process
sub answer{
my $self = shift;
# fetch the xml message sent
my $request = get_cgi_request();
unless( defined $request ){
print
"Content-Type: text/txt\n\n";
exit;
}
# Let's figure out the method to execute
# along with its arguments
my $response = $self->{_decode}->serve( $request,
$self->{methods} );
# Ship it!
return
"Content-Type: text/xml \n\n" . $response;
}
# private function. No need to advertise this.
# Remember, this is just XML.
# CGI.pm doesn't grok this.
sub get_cgi_request{
my $in;
if( $ENV{REQUEST_METHOD} eq 'POST' ){
my $len = $ENV{CONTENT_LENGTH};
unless ( read( STDIN, $in, $len ) == $len ){
return;
}
}else{
$in = $ENV{QUERY_STRING};
}
return $in;
}
=pod
=head1 NAME
Frontier::Responder - Create XML-RPC listeners for normal CGI processes
=head1 SYNOPSIS
use Frontier::Responder;
my $res = Frontier::Responder->new( methods => {
add => sub{ $_[0] + $_[1] },
cat => sub{ $_[0] . $_[1] },
},
);
print $res->answer;
=head1 DESCRIPTION
Use I<Frontier::Responder> whenever you need to create an XML-RPC listener
using a standard CGI interface. To be effective, a script using this class
will often have to be put a directory from which a web server is authorized
to execute CGI programs. An XML-RPC listener using this library will be
implementing the API of a particular XML-RPC application. Each remote
procedure listed in the API of the user defined application will correspond
to a hash key that is defined in the C<new> method of a I<Frontier::Responder>
object. This is exactly the way I<Frontier::Daemon> works as well.
In order to process the request and get the response, the C<answer> method
is needed. Its return value is XML ready for printing.
For those new to XML-RPC, here is a brief description of this protocol.
XML-RPC is a way to execute functions on a different
machine. Both the client's request and listeners response are wrapped
up in XML and sent over HTTP. Because the XML-RPC conversation is in
XML, the implementation languages of the server (here called a I<listener>),
and the client can be different. This can be a powerful and simple way
to have very different platforms work together without acrimony. Implicit
in the use of XML-RPC is a contract or API that an XML-RPC listener
implements and an XML-RPC client calls. The API needs to list not only
the various procedures that can be called, but also the XML-RPC datatypes
expected for input and output. Remember that although Perl is permissive
about datatyping, other languages are not. Unforuntately, the XML-RPC spec
doesn't say how to document the API. It is recomended that the author
of a Perl XML-RPC listener should at least use POD to explain the API.
This allows for the programmatic generation of a clean web page.
=head1 METHODS
=over 4
=item new( I<OPTIONS> )
This is the class constructor. As is traditional, it returns
a blessed reference to a I<Frontier::Responder> object. It expects
arguments to be given like a hash (Perl's named parameter mechanism).
To be effective, populate the C<methods> parameter with a hashref
that has API procedure names as keys and subroutine references as
values. See the SYNOPSIS for a sample usage.
=item answer()
In order to parse the request and execute the procedure, this method
must be called. It returns a XML string that contains the procedure's
response. In a typical CGI program, this string will simply be printed
to STDOUT.
=back
=head1 SEE ALSO
perl(1), Frontier::RPC2(3)
<http://www.scripting.com/frontier5/xml/code/rpc.html>
=head1 AUTHOR
Ken MacLeod <ken@bitsko.slc.ut.us> wrote the underlying
RPC library.
Joe Johnston <jjohn@cs.umb.edu> wrote an adaptation
of the Frontier::Daemon class to create this CGI XML-RPC
listener class.
=cut