FS/FS/XMLRPC.pm

   1 package FS::XMLRPC;
   2
   3 use strict;
   4 use vars qw( @ISA $DEBUG );
   5 use Frontier::RPC2;
   6 use FS::Record qw( qsearch qsearchs );
   7 use FS::cust_main qw( smart_search );
   8
   9 @ISA = qw( );
  10
  11 $DEBUG = 1;
  12
  13 =head1 NAME
  14
  15 FS::XMLRPC - Object methods for handling XMLRPC requests
  16
  17 =head1 SYNOPSIS
  18
  19   use FS::XMLRPC;
  20
  21   $xmlrpc = new FS::XMLRPC;
  22
  23   ($error, $response_xml) = $xmlrpc->serve($request_xml);
  24
  25 =head1 DESCRIPTION
  26
  27 The FS::XMLRPC object is a mechanisim to access read-only data from freeside's subroutines.  It does not, at least not at this point, give you the ability to access methods of freeside objects remotely.  It can, however, be used to call subroutines such as FS::cust_main::smart_search and FS::Record::qsearch.
  28
  29 See the serve method below for calling syntax.
  30
  31 =head1 METHODS
  32
  33 =over 4
  34
  35 =item new
  36
  37 Provides a FS::XMLRPC object used to handle incoming XMLRPC requests.
  38
  39 =cut
  40
  41 sub new {
  42
  43   my $class = shift;
  44   my $self = {};
  45   bless($self, $class);
  46
  47   $self->{_coder} = new Frontier::RPC2;
  48
  49   return $self;
  50
  51 }
  52
  53 =item serve REQUEST_XML_SCALAR
  54
  55 The serve method takes a scalar containg an XMLRPC request for one of freeside's subroutines (not object methods).  Parameters passed in the 'methodCall' will be passed as a list to the subroutine untouched.  The return value of the called subroutine _must_ be a freeside object reference (eg. qsearchs) or a list of freeside object references (eg. qsearch, smart_search), _and_, the object(s) returned must support the hashref method.  This will be checked first by calling UNIVERSAL::can('FS::class::subroutine', 'hashref').
  56
  57 Return value is an XMLRPC methodResponse containing the results of the call.  The result of the subroutine call itself will be coded in the methodResponse as an array of structs, regardless of whether there was many or a single object returned.  In other words, after you decode the response, you'll always have an array.
  58
  59 =cut
  60
  61 sub serve {
  62
  63   my ($self, $request_xml) = (shift, shift);
  64   my $response_xml;
  65
  66   my $coder = $self->{_coder};
  67   my $call = $coder->decode($request_xml);
  68
  69   warn "Got methodCall with method_name='" . $call->{method_name} . "'"
  70     if $DEBUG;
  71
  72   $response_xml = $coder->encode_response(&_serve($call->{method_name}, $call->{value}));
  73
  74   return ('', $response_xml);
  75
  76 }
  77
  78 sub _serve { #Subroutine, not method
  79
  80   my ($method_name, $params) = (shift, shift);
  81
  82   use Data::Dumper;
  83
  84   #die 'Called _serve without parameters' unless ref($params) eq 'ARRAY';
  85   $params = [] unless (ref($params) eq 'ARRAY');
  86
  87   my ($class, $sub) = split(/\./, $method_name);
  88   my $fssub = "FS::${class}::${sub}";
  89   warn "fssub: ${fssub}" if $DEBUG;
  90   warn "params: " . Dumper($params) if $DEBUG;
  91
  92   unless (UNIVERSAL::can("FS::${class}", $sub)) {
  93     warn "FS::XMLRPC: Can't call undefined subroutine '${fssub}'";
  94     # Should we encode an error in the response,
  95     # or just break silently to the remote caller and complain locally?
  96     return [];
  97   }
  98
  99   my @result;
 100   eval {
 101     no strict 'refs';
 102     my $fssub = "FS::${class}::${sub}";
 103     @result = (&$fssub(@$params));
 104   };
 105
 106   if ($@) {
 107     warn "FS::XMLRPC: Error while calling '${fssub}': $@";
 108     return [];
 109   }
 110
 111   warn Dumper(@result);
 112
 113   if (grep { UNIVERSAL::can($_, 'hashref') ? 0 : 1 } @result) {
 114     warn "FS::XMLRPC: One or more objects returned from '${fssub}' doesn't " .
 115          "support the 'hashref' method.";
 116     return [];
 117   } else {
 118     return [ map { $_->hashref } @result ];
 119   }
 120
 121 }
 122
 123 =head1 BUGS
 124
 125 Probably lots.
 126
 127 =head1 SEE ALSO
 128
 129 L<Frontier::RPC2>.
 130
 131 =cut
 132
 133 1;
 134