Item11583: modernizing

git-svn-id: http://svn.foswiki.org/trunk/XmlRpcContrib@14154 0b4bb1d4-4e5a-0410-9cc4-b2b747904278
foswiki · Feb 29, 2012 · 58dfd09 · 58dfd09
1 parent 320be8f
commit 58dfd09
Show file tree

Hide file tree

Showing 3 changed files with 184 additions and 93 deletions.
diff --git a/bin/xmlrpc b/bin/xmlrpc
@@ -1,41 +1,54 @@
 #!/usr/bin/perl -wT
-# xmlrpc service point
-#
-# Copyright (c) 2006-2010 by Michael Daum http://michaeldaumconsulting.com
-#
-# based on 
-# Pingback Proxy Copyright (c) 2002 by Ian Hickson
-#
-# This program is free software; you can redistribute it and/or modify
-# it under the terms of the GNU General Public License as published by
-# the Free Software Foundation; either version 2 of the License, or
-# (at your option) any later version.
-#
-# This program is distributed in the hope that it will be useful, but
-# WITHOUT ANY WARRANTY; without even the implied warranty of
-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-# General Public License for more details.
-#
-# You should have received a copy of the GNU General Public License
-# along with this program; if not, write to the Free Software
-# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-
+# See bottom of file for license and copyright information
 use strict;
+use warnings;
+
+use File::Spec;
 
 BEGIN {
-    # Set default current working directory (needed for mod_perl)
-    if( $ENV{"SCRIPT_FILENAME"} && $ENV{"SCRIPT_FILENAME"} =~ /^(.+)\/[^\/]+$/ ) {
-        chdir $1;
+    if ( defined $ENV{GATEWAY_INTERFACE} || defined $ENV{MOD_PERL} ) {
+        $Foswiki::cfg{Engine} = 'Foswiki::Engine::CGI';
+        use CGI::Carp qw(fatalsToBrowser);
+        $SIG{__DIE__} = \&CGI::Carp::confess;
     }
-    # Set library paths in @INC, at compile time
-    $ENV{FOSWIKI_ACTION} = 'xmlrpc';
-    unshift @INC, '.';
-    require 'setlib.cfg';
+    else {
+        $Foswiki::cfg{Engine} = 'Foswiki::Engine::CLI';
+        require Carp;
+        $SIG{__DIE__} = \&Carp::confess;
+    }
+    my ( $volume, $binDir, $action ) = File::Spec->splitpath(__FILE__);
+    my $setlib = File::Spec->catpath( $volume, $binDir, 'setlib.cfg' );
+    @INC = ( '.', grep { $_ ne '.' } @INC ) unless $binDir;
+    require $setlib;
+    $action =~ s/\..*$//;    # Remove eventual file extension
+    $ENV{FOSWIKI_ACTION} = $action;
 }
 
-use Foswiki ();
-use Foswiki::UI (); 
+use Foswiki     ();
+use Foswiki::UI ();
 $Foswiki::engine->run();
+__END__
+Foswiki - The Free and Open Source Wiki, http://foswiki.org/
+
+Copyright (C) 2008-2010 Foswiki Contributors. Foswiki Contributors
+are listed in the AUTHORS file in the root of this distribution.
+NOTE: Please extend that file, not this notice.
+
+Additional copyrights apply to some or all of the code in this
+file as follows:
+
+Copyright (C) 1999-2007 Peter Thoeny, peter@thoeny.org
+and TWiki Contributors. All Rights Reserved. TWiki Contributors
+are listed in the AUTHORS file in the root of this distribution.
+
+This program is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public License
+as published by the Free Software Foundation; either version 2
+of the License, or (at your option) any later version. For
+more details read LICENSE in the root of this distribution.
 
-1;
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
 
+As per the GPL, removal of this notice is prohibited.
diff --git a/lib/Foswiki/Contrib/XmlRpcContrib.pm b/lib/Foswiki/Contrib/XmlRpcContrib.pm
@@ -1,6 +1,6 @@
 # Foswiki - The Free and Open Source Wiki, http://foswiki.org/
 #
-# Copyright (C) 2006-2010 Michael Daum http://michaeldaumconsulting.com
+# Copyright (C) 2006-2012 Michael Daum http://michaeldaumconsulting.com
 #
 # This program is free software; you can redistribute it and/or
 # modify it under the terms of the GNU General Public License
@@ -15,49 +15,61 @@
 # As per the GPL, removal of this notice is prohibited.
 
 use strict;
+use warnings;
+
+=begin TML
+
+---+ package XmlRpcContrib
+
+=cut
 
 package Foswiki::Contrib::XmlRpcContrib;
 
 our $VERSION = '$Rev$';
 our $RELEASE = '1.00';
 our $SERVER;
-our %handler;
 our $SHORTDESCRIPTION = '';
 
-################################################################################
-# register an implementation for a handler
-sub registerRPCHandler {
-  my ($methodName, $methodImpl) = @_;
+=begin TML
+
+---++ ClassMethod registerMethod($methodName, $handler)
+
+register an implementation for a handler
 
-  # SMELL: this may override a previous registration; must we take care?
-  $handler{$methodName} = $methodImpl;
+=cut
+
+sub registerMethod {
+  getServer()->registerMethod(@_);
 }
 
-################################################################################
-# process an xml call
-sub dispatch {
-  my ($session, $data) = @_;
+=begin TML
 
-  $Foswiki::Plugins::SESSION = $session;
+---++ ClassMethod dispatch($session, $data)
 
-  initServer();
-  unless ($data) {
-    my $query = $session->{cgiQuery};
-    $data = $query->param('POSTDATA') || '';
-  }
+process an xml call
+
+=cut
 
-  return $SERVER->dispatch($session, $data);
+sub dispatch {
+  getServer()->dispatch(@_);
 }
 
-################################################################################
-# create a singleton server object
-sub initServer {
+=begin TML
+
+---++ ClassMethod getServer()
+
+create a singleton server object
+
+=cut
+
+sub getServer {
+
+  unless (defined $SERVER) {
+    require Foswiki::Contrib::XmlRpcContrib::Server;
+    $SERVER = Foswiki::Contrib::XmlRpcContrib::Server->new();
+  }
 
-  return if $SERVER;
-  require Foswiki::Contrib::XmlRpcContrib::Server;
-  $SERVER = Foswiki::Contrib::XmlRpcContrib::Server->new(%handler);
   return $SERVER;
 }
 
-
 1;
diff --git a/lib/Foswiki/Contrib/XmlRpcContrib/Server.pm b/lib/Foswiki/Contrib/XmlRpcContrib/Server.pm
@@ -1,6 +1,6 @@
-# XML-RPC server 4 Foswiki
+# XML-RPC server for Foswiki
 #
-# Copyright (C) 2006-2010 Michael Daum http://michaeldaumconsulting.com
+# Copyright (C) 2006-2012 Michael Daum http://michaeldaumconsulting.com
 #
 # This program is free software; you can redistribute it and/or
 # modify it under the terms of the GNU General Public License
@@ -14,13 +14,29 @@
 #
 # As per the GPL, removal of this notice is prohibited.
 
+use strict;
+use warnings;
+
 package Foswiki::Contrib::XmlRpcContrib::Server;
 
 use RPC::XML ();
 use RPC::XML::Parser ();
+use Error qw( :try );
 
 use constant DEBUG => 0; # toggle me
 
+# predefined error codes:
+# -32700: parse error. not well formed
+# -32701: parse error. unsupported encoding
+# -32702: parse error. invalid character for encoding
+# -32600: server error. invalid xml-rpc. not conforming to spec.
+# -32601: server error. requested method not found
+# -32602: server error. invalid method parameters
+# -32603: server error. internal xml-rpc error
+# -32500: application error
+# -32400: system error
+# -32300: transport error
+
 ################################################################################
 # static
 sub writeDebug {
@@ -30,7 +46,7 @@ sub writeDebug {
 ################################################################################
 # constructor
 sub new {
-  my ($class, %handler) = @_;
+  my $class = shift;
 
   writeDebug("called constructor");
 
@@ -39,79 +55,129 @@ sub new {
     session=>'',
   };
 
-  foreach my $methodName (keys %handler) {
-    my $methodImpl = $handler{$methodName};
-    writeDebug("new handler $methodName=$methodImpl");
-    $this->{handler}{$methodName} = $methodImpl;
-  }
-
   return bless($this, $class);
 }
 
 ################################################################################
-sub getError  {
-  my ($this, $status, $error, $data) = @_;
-
-  return $this->getResponse($status, RPC::XML::fault->new($error, $data));
-}
-
-################################################################################
-sub getResponse {
-  my ($this, $status, $data) = @_;
+sub registerMethod {
+  my ($this, $methodName, $fnref, %options) = @_;
 
-  my $response = RPC::XML::response->new($data);
+  writeDebug("registerMethod($methodName, $fnref)");
 
-  return 
-    "Status: $status\n".
-    "Content-Type: text/xml\n\n".
-    $response->as_string;
+  $this->{handler}{$methodName} = {
+    function => $fnref,
+    %options
+  };
 }
 
 ################################################################################
 sub dispatch {
   my ($this, $session, $data) = @_;
 
   writeDebug("called dispatch");
-  writeDebug("data=$data");
+  $this->{session} = $session;
+
+  unless (defined $data) {
+    my $query = $session->{cgiQuery};
+    $data = $query->param('POSTDATA') || '';
+  }
+
+  #writeDebug("data=$data");
 
   # check ENV
   if ($ENV{'REQUEST_METHOD'} ne 'POST') {
-    return $this->getError('405 Method Not Allowed', -32300, 'Only XML-RPC POST requests recognised.');
+    $this->printError('405 Method Not Allowed', -32300, 'Only XML-RPC POST requests recognised.');
+    return;
   }
 
   if ($ENV{'CONTENT_TYPE'} ne 'text/xml') {
-    return $this->getError('415 Unsupported Media Type', -32300, 'Only XML-RPC POST requests recognised.');
+    $this->printError('415 Unsupported Media Type', -32300, 'Only XML-RPC POST requests recognised.');
+    return;
   }
 
   # parse
   my $request = $this->{parser}->parse($data);
-  return $this->getError('400 Bad Request', -32700, $request) unless ref($request);
+  unless (ref($request)) {
+    $this->printError('400 Bad Request', -32700, $request) unless ref($request);
+    return;
+  }
 
-  # check impl
+  # get handler
   my $name = $request->name;
-  unless ($this->{handler}{$name}) {
-    return $this->getError('501 Not Implemented', -32601, "Method $name not supported");
+  my $handler = $this->{handler}{$name};
+
+  # check impl
+  unless ($handler) {
+    $this->printError('501 Not Implemented', -32601, "Method $name not supported");
+    return;
   }
 
   # call 
+  my $result;
+  my $status;
+  my $error;
   $session->enterContext($name);
-  my ($status, $error, $result) = &{$this->{handler}{$name}}($session, $request->args);
+  try {
+    no strict 'refs';
+    my $function = $handler->{function};
+    ($status, $error, $result) = &$function($session, $request->args);
+    use strict 'refs';
+  } catch Error::Simple with {
+    $status = '500 Server Error';
+    $error  = -32500;
+    $result = "Internal server error".shift;
+  };
   $session->leaveContext($name);
 
   writeDebug("status=$status");
   writeDebug("error=$error");
   writeDebug("result=$result");
 
   # print response
-  my $response;
   if ($error == 0) {
     $result = RPC::XML::string->new($result) if not ref $result;
-    $response = $this->getResponse($status, $result); # default 
+    $this->print($status, $this->getResponse($result)); # default 
   } else {
-    $response = $this->getError($status, $error, $result); # error
+    $this->printError($status, $error, $result); # error
   }
-  writeDebug("response=$response");
-  return $response;
+
+  return;
+}
+
+################################################################################
+sub getError  {
+  my ($this, $error, $data) = @_;
+
+  return $this->getResponse(RPC::XML::fault->new($error, $data));
+}
+
+################################################################################
+sub getResponse {
+  my ($this, $data) = @_;
+
+  return RPC::XML::response->new($data);
+}
+
+################################################################################
+sub printError {
+  my ($this, $status, $error, $data) = @_;
+
+  $this->print($status, $this->getError(-32300, 'Only XML-RPC POST requests recognised.'));
+}
+
+################################################################################
+sub print {
+  my ($this, $status, $response) = @_;
+
+  $this->{session}->{response}->header(
+    -status  => $status,
+    -type    => 'text/plain',
+  );
+
+  my $text = $response->as_string;
+print STDERR "response=$text\n";
+
+  $this->{session}->{response}->print($response->as_string);
 }
 
 1;