[Gd-chatter] r10952 - in branches/libraries-reorg/libraries: network/web-framework network/xml-rpc-client network/xml-rpc-client/test registry/generic web-framework
cgay at gwydiondylan.org
cgay at gwydiondylan.org
Tue Nov 14 04:56:11 CET 2006
Author: cgay
Date: Tue Nov 14 04:56:07 2006
New Revision: 10952
Added:
branches/libraries-reorg/libraries/network/web-framework/
- copied from r10949, branches/libraries-reorg/libraries/web-framework/
branches/libraries-reorg/libraries/network/xml-rpc-client/library.dylan (contents, props changed)
branches/libraries-reorg/libraries/network/xml-rpc-client/test/
branches/libraries-reorg/libraries/network/xml-rpc-client/test/library.dylan (contents, props changed)
branches/libraries-reorg/libraries/network/xml-rpc-client/test/xml-rpc-test.dylan (contents, props changed)
branches/libraries-reorg/libraries/network/xml-rpc-client/test/xml-rpc-test.lid (contents, props changed)
branches/libraries-reorg/libraries/network/xml-rpc-client/xml-rpc-client.dylan (contents, props changed)
branches/libraries-reorg/libraries/network/xml-rpc-client/xml-rpc-client.lid (contents, props changed)
branches/libraries-reorg/libraries/registry/generic/xml-rpc-client (contents, props changed)
Removed:
branches/libraries-reorg/libraries/web-framework/
Modified:
branches/libraries-reorg/libraries/registry/generic/web-framework
Log:
job: 7335
Moved web-framework to libraries/network.
Re-added xml-rpc-client files that weren't added on previous commit.
(Testing to see if the svn mv of a directory works this time.)
Added: branches/libraries-reorg/libraries/network/xml-rpc-client/library.dylan
==============================================================================
--- (empty file)
+++ branches/libraries-reorg/libraries/network/xml-rpc-client/library.dylan Tue Nov 14 04:56:07 2006
@@ -0,0 +1,41 @@
+Module: dylan-user
+Synopsis: XML-RPC client
+Author: Carl Gay
+Copyright: (C) 2002, Carl L Gay. All rights reserved.
+License: Functional Objects Library Public License Version 1.0
+Warranty: Distributed WITHOUT WARRANTY OF ANY KIND
+
+define library xml-rpc-client
+ use common-dylan;
+ use io;
+ use network;
+ use dylan-basics; // dylan survival kit
+ use xml-parser;
+ use xml-rpc-common;
+
+ export xml-rpc-client;
+end;
+
+
+define module xml-rpc-client
+ use common-dylan, exclude: { format-to-string, split };
+ use format;
+ use format-out; // for debugging only
+ use sockets;
+ use streams;
+ use xml-parser,
+ prefix: "xml$";
+ use xml-rpc-common,
+ export: {
+ <xml-rpc-error>, <xml-rpc-parse-error>,
+ <xml-rpc-fault>, xml-rpc-fault,
+ base64-encode, base64-decode,
+ };
+ use dylan-basics;
+
+ export
+ xml-rpc-call, // standard interface
+ xml-rpc-call-2; // accepts port and url arguments
+end;
+
+
Added: branches/libraries-reorg/libraries/network/xml-rpc-client/test/library.dylan
==============================================================================
--- (empty file)
+++ branches/libraries-reorg/libraries/network/xml-rpc-client/test/library.dylan Tue Nov 14 04:56:07 2006
@@ -0,0 +1,16 @@
+Module: dylan-user
+Synopsis: Tests the xml-rpc-client library
+Author: Carl Gay
+
+define library xml-rpc-test
+ use common-dylan;
+ use xml-rpc-client;
+end;
+
+
+define module xml-rpc-test
+ use common-dylan;
+ use simple-io, import: { format-out };
+ use xml-rpc-client;
+end;
+
Added: branches/libraries-reorg/libraries/network/xml-rpc-client/test/xml-rpc-test.dylan
==============================================================================
--- (empty file)
+++ branches/libraries-reorg/libraries/network/xml-rpc-client/test/xml-rpc-test.dylan Tue Nov 14 04:56:07 2006
@@ -0,0 +1,36 @@
+Module: xml-rpc-test
+Synopsis: Tests the xml-rpc-client library
+Author: Carl Gay
+
+
+define method main () => ()
+ let host = "localhost";
+ let port = 7020;
+ let url = "/RPC2";
+ for (val in vector(-1,
+ 0,
+ 1,
+ 3.1415927d0,
+ "a <string>",
+ vector("one", 2),
+ begin
+ let t = make(<string-table>);
+ t["one"] := 1;
+ t["two"] := 2;
+ t
+ end))
+ // "echo" returns its argument(s) in an array...
+ let result = xml-rpc-call-2(host, port, "/RPC2", "echo", val);
+ let val2 = result[0];
+ format-out("%sSent: %=, Received: %=\n",
+ if (val = val2) "" else "ERROR: " end, val, val2);
+ end;
+ let s = "my dog has fleas";
+ if (s ~= base64-decode(base64-encode(s)))
+ format-out("base64 encoding/decoding is broken.\n");
+ end;
+end;
+
+begin
+ main();
+end;
Added: branches/libraries-reorg/libraries/network/xml-rpc-client/test/xml-rpc-test.lid
==============================================================================
--- (empty file)
+++ branches/libraries-reorg/libraries/network/xml-rpc-client/test/xml-rpc-test.lid Tue Nov 14 04:56:07 2006
@@ -0,0 +1,3 @@
+library: xml-rpc-test
+files: library
+ xml-rpc-test
Added: branches/libraries-reorg/libraries/network/xml-rpc-client/xml-rpc-client.dylan
==============================================================================
--- (empty file)
+++ branches/libraries-reorg/libraries/network/xml-rpc-client/xml-rpc-client.dylan Tue Nov 14 04:56:07 2006
@@ -0,0 +1,188 @@
+Module: xml-rpc-client
+Author: Carl Gay
+Copyright: (C) 2002, Carl L Gay. All rights reserved.
+
+// An XML-RPC client.
+//
+// Status:
+// There are a few TODO items left to complete here (search for "TODO" below)
+// but I have tested it against a Java XML-RPC server with no problems so far.
+
+
+define thread variable *xml-rpc-port* :: <integer> = 80;
+define thread variable *xml-rpc-url* :: <string> = "/RPC2";
+
+define function xml-rpc-call
+ (host :: <string>, method-name :: <string>, #rest args)
+ => (response :: <object>)
+ apply(xml-rpc-call-2, host, *xml-rpc-port*, *xml-rpc-url*, method-name, args)
+end;
+
+// xml-rpc-call-2("192.168.26.73", 8502, "/RPC2", "psapi.getAvailableAgentSlas", 10);
+//
+define function xml-rpc-call-2
+ (host :: <string>, port :: <integer>, url :: <string>, method-name :: <string>, #rest args)
+ => (response :: <object>)
+ let xml = apply(create-method-call-xml, method-name, args);
+ when (*debugging-xml-rpc*)
+ format-out("%s\n\n", xml);
+ end;
+ let stream = make(<TCP-socket>, host: host, port: port);
+ format(stream, "POST %s HTTP/1.0\r\n", url);
+ format(stream, "Host: %s\r\n", host);
+ write (stream, "User-Agent: Koala XML-RPC client\r\n");
+ write (stream, "Content-Type: text/xml\r\n");
+ format(stream, "Content-Length: %d\r\n", xml.size);
+ write(stream, "Pragma: no-cache\r\n");
+ write(stream, "\r\n");
+ write(stream, xml);
+ force-output(stream);
+ read-response(stream)
+end;
+
+
+
+define table $html-quote-map
+ = { '<' => "<",
+ '>' => ">",
+ '&' => "&",
+ '"' => """
+ };
+
+// This is copied from Koala's utils.dylan. If you fix it here, fix
+// it there.
+// I'm sure this could use a lot of optimization.
+define function quote-html
+ (text :: <string>, #key stream)
+ if (~stream)
+ with-output-to-string (s)
+ quote-html(text, stream: s)
+ end
+ else
+ for (char in text)
+ let translation = element($html-quote-map, char, default: char);
+ iff(instance?(translation, <sequence>),
+ write(stream, translation),
+ write-element(stream, translation));
+ end;
+ end;
+end quote-html;
+
+define function create-method-call-xml
+ (method-name :: <string>, #rest args)
+ => (xml :: <string>)
+ with-output-to-string (s)
+ write(s, "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?><methodCall><methodName>");
+ quote-html(method-name, stream: s);
+ write(s, "</methodName><params>");
+ for (arg in args)
+ write(s, "<param><value>");
+ to-xml(arg, s);
+ write(s, "</value></param>");
+ end;
+ write(s, "</params></methodCall>");
+ end
+end;
+
+
+// Quick and dirty. Should import the string utils from Koala instead.
+//
+define function char-equal?
+ (c1 :: <character>, c2 :: <character>) => (b :: <boolean>)
+ as-lowercase(c1) = as-lowercase(c2)
+end;
+
+define function read-response
+ (stream :: <tcp-socket>)
+ => (response :: <object>)
+ let content-length :: <integer> = -1;
+ let cl = "Content-length: ";
+ let line :: false-or(<string>) = #f;
+ while ((line := read-line(stream, on-end-of-stream: #f))
+ & ~zero?(size(line)))
+ when (*debugging-xml-rpc*)
+ format-out("%s\n", line);
+ end;
+ if (subsequence-position(line, cl, test: char-equal?) == 0)
+ // ---TODO: robustify this to skip whitespace and handle errors.
+ content-length := string-to-integer(line, start: cl.size);
+ end;
+ end;
+ if (content-length == -1)
+ signal(make(<xml-rpc-error>,
+ format-string: "No Content-Length header was received."));
+ else
+ // TODO: signal <xml-rpc-error> on end of stream.
+ //let xml = read(stream, content-length);
+ let xml = make(<byte-string>, size: content-length, fill: ' ');
+
+ // kludge to work around hideous bug in the read method. This is
+ // fixed in the FunDev sources, so the fix should be in the next
+ // release after 2.0 SP1.
+ block (continue)
+ for (i from 0 below content-length)
+ let elem = read-element(stream, on-end-of-stream: #f);
+ if (elem)
+ xml[i] := elem;
+ else
+ continue();
+ end;
+ end;
+ end block;
+
+ parse-response(xml)
+ end if;
+end;
+
+define function parse-response
+ (xml :: <string>)
+ => (response :: <object>)
+ when (*debugging-xml-rpc*)
+ format-out("Received response:\n%s\n", xml);
+ end;
+ let doc :: xml$<document> = xml$parse-document(xml);
+ parse-xml-rpc-response(doc);
+end;
+
+define method parse-xml-rpc-response (node :: xml$<document>)
+ let method-response = find-child(node, #"methodresponse")
+ | xml-rpc-parse-error("Bad method response, no <methodResponse> node found");
+ let params = find-child(method-response, #"params");
+ let fault = find-child(method-response, #"fault");
+ let value = #f;
+ if (params)
+ // signal an error here if more than one param present?
+ let param = find-child(params, #"param")
+ | xml-rpc-parse-error("Bad method response, no param element found.");
+ value := find-child(param, #"value");
+ elseif (fault)
+ value := find-child(fault, #"value");
+ else
+ xml-rpc-parse-error("Bad method response, neither params nor fault found.");
+ end;
+ // signal an error here if more than one value present?
+ value
+ | xml-rpc-parse-error("Bad method response, no value element found.");
+ let result = from-xml(value, xml$name(value));
+ if (fault)
+ let code = element(result, "faultCode", default: 0);
+ signal(make(<xml-rpc-fault>,
+ fault-code: code,
+ format-string: "XML-RPC error (code = %d): %=",
+ format-arguments: vector(code,
+ element(result, "faultString",
+ default: "<no explanation provided>"))))
+ else
+ result
+ end
+end;
+
+define function init-xml-rpc ()
+ start-sockets();
+end;
+
+begin
+ init-xml-rpc();
+end;
+
+
Added: branches/libraries-reorg/libraries/network/xml-rpc-client/xml-rpc-client.lid
==============================================================================
--- (empty file)
+++ branches/libraries-reorg/libraries/network/xml-rpc-client/xml-rpc-client.lid Tue Nov 14 04:56:07 2006
@@ -0,0 +1,3 @@
+library: xml-rpc-client
+files: library
+ xml-rpc-client
Modified: branches/libraries-reorg/libraries/registry/generic/web-framework
==============================================================================
--- branches/libraries-reorg/libraries/registry/generic/web-framework (original)
+++ branches/libraries-reorg/libraries/registry/generic/web-framework Tue Nov 14 04:56:07 2006
@@ -1 +1 @@
-abstract://dylan/web-framework/web-framework.lid
+abstract://dylan/network/web-framework/web-framework.lid
Added: branches/libraries-reorg/libraries/registry/generic/xml-rpc-client
==============================================================================
--- (empty file)
+++ branches/libraries-reorg/libraries/registry/generic/xml-rpc-client Tue Nov 14 04:56:07 2006
@@ -0,0 +1 @@
+abstract://dylan/network/xml-rpc-client/xml-rpc-client.lid
\ No newline at end of file
More information about the chatter
mailing list