[Gd-chatter] r10730 - in trunk/libraries/xmpp: . xmpp-test
turbo24prg at gwydiondylan.org
turbo24prg at gwydiondylan.org
Fri May 12 20:32:59 CEST 2006
Author: turbo24prg
Date: Fri May 12 20:32:56 2006
New Revision: 10730
Added:
trunk/libraries/xmpp/
trunk/libraries/xmpp/client.dylan (contents, props changed)
trunk/libraries/xmpp/connection.dylan (contents, props changed)
trunk/libraries/xmpp/error.dylan (contents, props changed)
trunk/libraries/xmpp/iq.dylan (contents, props changed)
trunk/libraries/xmpp/jid.dylan (contents, props changed)
trunk/libraries/xmpp/message.dylan (contents, props changed)
trunk/libraries/xmpp/presence.dylan (contents, props changed)
trunk/libraries/xmpp/query.dylan (contents, props changed)
trunk/libraries/xmpp/stanza-error.dylan (contents, props changed)
trunk/libraries/xmpp/stanza.dylan (contents, props changed)
trunk/libraries/xmpp/stream-error.dylan (contents, props changed)
trunk/libraries/xmpp/stream.dylan (contents, props changed)
trunk/libraries/xmpp/vcard.dylan (contents, props changed)
trunk/libraries/xmpp/version.dylan (contents, props changed)
trunk/libraries/xmpp/x.dylan (contents, props changed)
trunk/libraries/xmpp/xmpp-exports.dylan (contents, props changed)
trunk/libraries/xmpp/xmpp-test/
trunk/libraries/xmpp/xmpp-test/xmpp-test-exports.dylan (contents, props changed)
trunk/libraries/xmpp/xmpp-test/xmpp-test.dylan (contents, props changed)
trunk/libraries/xmpp/xmpp-test/xmpp-test.lid (contents, props changed)
trunk/libraries/xmpp/xmpp.dylan (contents, props changed)
trunk/libraries/xmpp/xmpp.lid (contents, props changed)
Log:
Bug: 7313
* initial import
Added: trunk/libraries/xmpp/client.dylan
==============================================================================
--- (empty file)
+++ trunk/libraries/xmpp/client.dylan Fri May 12 20:32:56 2006
@@ -0,0 +1,102 @@
+module: xmpp
+synopsis:
+author:
+copyright:
+
+define variable *parser-depth* = 0;
+
+define class <xmpp-client> (<object>)
+ slot jid :: <jid>,
+ required-init-keyword: jid:;
+ slot socket :: <tcp-socket>,
+ init-keyword: socket:;
+ slot state :: one-of(#"disconnected", #"authenticating", #"connected");
+ virtual slot password;
+end class <xmpp-client>;
+
+define method connect (client :: <xmpp-client>, #key port :: <integer> = 5222)
+ start-sockets();
+ client.socket := make(<tcp-socket>, host: client.jid.domain, port: port);
+ client.state := #"connected";
+ make(<thread>, function: curry(listen, client));
+end method connect;
+
+define method listen (client :: <xmpp-client>)
+block ()
+ let stanza-complete? = #f;
+ while (#t)
+ let (received, found?) = read-to(client.socket, '>');
+ received := concatenate(received, ">");
+ format-out(">>> %=\n", received);
+//XXX should strip spaces before first element!
+ if (found? & (received[0] = '<'))
+//check xml-decl
+ let (index, processing-instruction) = scan-xml-decl(received);
+ if (processing-instruction)
+ format-out("!!! %=: %=\n", object-class(processing-instruction), processing-instruction.name);
+ end if;
+// check if start
+ format-out("!!! %=\n", "Check for element start");
+
+ let (index, name) = scan-start-of-tag("<foo"); // scan-start-tag(received);
+ if (name)
+ format-out("!!! (start) %=\n", name);
+ *parser-depth* := *parser-depth* + 1;
+ else
+ format-out("!!! no start!\n");
+ end if;
+ format-out("%=\n", received);
+ end if;
+//dispatch(received);
+ end while;
+exception (condition :: <condition>)
+ disconnect(client);
+ format-out("client: listen: Error: %=", condition);
+end block;
+end method listen;
+
+define method disconnect (client :: <xmpp-client>)
+ close(client.socket);
+ client.state := #"disconnected";
+end method disconnect;
+
+define method send (client :: <xmpp-client>, data)
+ write-line(client.socket, as(<string>, data));
+ force-output(client.socket);
+ format-out("<<< %=\n", data);
+end method send;
+
+define method password-setter (password, client :: <xmpp-client>)
+ => (res);
+
+ password;
+end method password-setter;
+
+define meta start-of-tag(elt-name, sym-name, attribs, s)
+ => (sym-name, attribs)
+ "<", scan-name(elt-name), scan-s?(s), scan-xml-attributes(attribs),
+// (push(*tag-name-with-proper-capitalization*, elt-name)),
+ set!(sym-name, as(<symbol>, elt-name))
+end meta start-of-tag;
+
+define meta start-tag
+//(name, s, attribs) => (name)
+ "<", ">"
+//, scan-name(name), scan-s?(s), scan-xml-attributes(attribs), ">"
+end meta start-tag;
+
+define meta end-tag (name, s) => (name)
+ "</", scan-name(name), scan-s?(s), ">"
+end meta end-tag;
+
+/*
+define method valid-xmpp-data? (data :: <string>)
+ => (res :: <boolean>);
+ if (parse-document(data))
+ #t;
+ else
+ #f;
+ end if;
+end method valid-xmpp-data?;
+*/
+//define method dispatch (
Added: trunk/libraries/xmpp/connection.dylan
==============================================================================
--- (empty file)
+++ trunk/libraries/xmpp/connection.dylan Fri May 12 20:32:56 2006
@@ -0,0 +1,24 @@
+module: xmpp
+synopsis:
+author:
+copyright:
+
+/*
+define class <xmpp-host> (<host>)
+
+end class <xmpp-host>;
+
+define class <xmpp-connection> (<object>)
+ slot socket :: <tcp-socket>,
+ init-keyword: socket:;
+ slot state :: <type> = #"disconnected",
+ init-keyword: state:;
+ slot jid :: <jid>,
+ init-keyword: jid:;
+end class <xmpp-connection>;
+
+define method connect (connection :: <xmpp-connection>, host, port)
+ let socket = make(<tcp-socket>, host: host, port: port);
+end method connect;
+
+*/
Added: trunk/libraries/xmpp/error.dylan
==============================================================================
--- (empty file)
+++ trunk/libraries/xmpp/error.dylan Fri May 12 20:32:56 2006
@@ -0,0 +1,36 @@
+module: xmpp
+synopsis:
+author:
+copyright:
+
+define class <xmpp-error> (<element>, <error>)
+ virtual slot condition;
+ virtual slot description;
+end class <xmpp-error>;
+
+define method initialize (error :: <xmpp-error>, #key condition, description, #all-keys)
+ next-method();
+
+ if (condition)
+ condition-setter(condition, error);
+ end if;
+ if (description)
+ description-setter(description, error);
+ end if;
+end method initialize;
+
+define method description-setter (description == #f, error :: <xmpp-error>)
+ => (res);
+ remove-element(error, "text");
+ description;
+end method description-setter;
+
+define method description (error :: <xmpp-error>)
+ => (res :: false-or(<string>));
+ let descriptions = elements(error, "text");
+ if (~ empty?(descriptions))
+ first(descriptions).text;
+ else
+ #f;
+ end if;
+end method description;
Added: trunk/libraries/xmpp/iq.dylan
==============================================================================
--- (empty file)
+++ trunk/libraries/xmpp/iq.dylan Fri May 12 20:32:56 2006
@@ -0,0 +1,118 @@
+module: xmpp
+synopsis:
+author:
+copyright:
+
+define class <iq> (<stanza>)
+ inherited slot name-with-proper-capitalization = "iq";
+ virtual slot query;
+ virtual slot vcard;
+end class <iq>;
+
+define method initialize (iq :: <iq>, #key query, vcard, #all-keys)
+ next-method();
+
+ if (query)
+ query-setter(query, iq);
+ end if;
+ if (vcard)
+ vcard-setter(vcard, iq);
+ end if;
+
+end method;
+
+define method type-setter (type, iq :: <iq>)
+ => (res);
+ if (member?(type, #(#"error", #"get", #"set", #"result")))
+ next-method();
+ end if;
+ type;
+end method type-setter;
+
+define method type (iq :: <iq>)
+ => (res :: false-or(<symbol>));
+ let type = next-method();
+ if (member?(as(<symbol>, type), #(#"error", #"get", #"set", #"result")))
+ as(<symbol>, type);
+ else
+ #f;
+ end if;
+end method type;
+
+define method vcard (iq :: <iq>)
+ => (res :: false-or(<vcard>));
+ let vcards = elements(iq, "vCard");
+ if (~ empty?(vcards))
+ first(vcards);
+ else
+ #f;
+ end if;
+end method vcard;
+
+define method vcard-setter (vcard :: <element>, iq :: <iq>)
+ => (res);
+ remove-element(iq, vcard.name);
+ add-element(iq, vcard);
+ vcard;
+end method vcard-setter;
+
+define method query (iq :: <iq>)
+ => (res :: false-or(<query>));
+ let queries = elements(iq, "query");
+ if (~ empty?(queries))
+ first(queries);
+ else
+ #f;
+ end if;
+end method query;
+
+define method query-setter (query :: <element>, iq :: <iq>)
+ => (res);
+ remove-element(iq, query.name);
+ add-element(iq, query);
+ query;
+end method query-setter;
+
+define method make-query (#key type, to: jid)
+ => (iq :: <iq>);
+ let iq = make(<iq>, type: type, to: jid);
+ add-element(iq, make(<query>));
+ iq;
+end method make-query;
+
+define method make-vcard (#key type = #"get", to: jid)
+ => (iq :: <iq>);
+ let iq = make(<iq>, type: type, to: jid);
+ add-element(iq, make(<vcard>));
+ iq;
+end method make-vcard;
+
+define method make-authentication (jid :: <jid>, password :: <string>)
+ => (iq :: <iq>);
+ let iq = make(<iq>, type: #"set");
+ let query = with-xml()
+ query(xmlns => "jabber:iq:auth") {
+ username(jid.node),
+ password(password),
+ do(if (jid.resource)
+ with-xml() resource(jid.resource) end;
+ end)
+ }
+ end;
+ add-element(iq, query);
+ iq;
+end method make-authentication;
+
+define method make-registration (#key username :: false-or(<string>), password :: false-or(<string>))
+ => (iq :: <iq>);
+ let iq = make(<iq>, type: #"set");
+ let query = with-xml() query(xmlns => "jabber:iq:register") end;
+ if (username)
+ add-element(query, with-xml() username(username) end);
+ end if;
+ if (password)
+ add-element(query, with-xml() password(password) end);
+ end if;
+ add-element(iq, query);
+ iq;
+end method make-registration;
Added: trunk/libraries/xmpp/jid.dylan
==============================================================================
--- (empty file)
+++ trunk/libraries/xmpp/jid.dylan Fri May 12 20:32:56 2006
@@ -0,0 +1,92 @@
+module: xmpp
+synopsis:
+author:
+copyright:
+
+define class <jid> (<object>)
+ slot node :: false-or(<string>) = #f,
+ init-keyword: node:;
+ slot domain :: <string>,
+ required-init-keyword: domain:;
+ slot resource :: false-or(<string>) = #f,
+ init-keyword: resource:;
+end class <jid>;
+
+define method initialize (jid :: <jid>, #key node, domain, resource, #all-keys)
+ next-method();
+
+/*
+ if (size(jid.node | "") > 1023)
+ signal("Node exceeds 1023 chars.");
+ end if;
+ if (~ jid.domain)
+ signal
+ else
+ (size(jid.domain) > 1023)
+ signal("Node exceeds 1023 chars.");
+ end if;
+ if (size(jid.resource | "") > 1023)
+ signal("Node exceeds 1023 chars.");
+ end if;
+*/
+end method initialize;
+
+define method as (class == <string>, jid :: <jid>)
+ => (res :: <string>)
+ let res = "";
+ if (jid.node)
+ res := concatenate(jid.node, "@");
+ end if;
+ if (jid.domain)
+ res := concatenate(res, jid.domain);
+ end if;
+ if (jid.resource)
+ res := concatenate(res, "/", jid.resource);
+ end if;
+ res;
+end method as;
+
+define method as (class == <jid>, jid :: <string>)
+ => (res :: <jid>)
+ let node = #f;
+ let domain = #f;
+ let resource = #f;
+
+ if (subsequence-position(jid, "@"))
+ let splitted-node = split(jid, '@');
+ node := splitted-node[0];
+ domain := splitted-node[1];
+ if (subsequence-position(domain, "/"))
+ let splitted-domain = split(domain, '/');
+ domain := splitted-domain[0];
+ resource := splitted-domain[1];
+ end if;
+ elseif (subsequence-position(jid, "/"))
+ let splitted-node = split(jid, '/');
+ domain := splitted-node[0];
+ resource := splitted-node[1];
+ else
+ domain := jid;
+ end if;
+ make(<jid>, node: node, domain: domain, resource: resource);
+end method as;
+
+define method print-object(jid :: <jid>, stream :: <stream>) => ()
+ format(stream, "%s", as(<string>, jid));
+end method print-object;
+
+define method strip (jid :: <jid>)
+ => (res :: <jid>)
+ make(<jid>, node: jid.node, domain: jid.domain);
+end method strip;
+
+define method strip! (jid :: <jid>)
+ => (res :: <jid>)
+ jid.resource := #f;
+ jid;
+end method strip!;
+
+define method \= (jid1 :: <jid>, jid2 :: <jid>)
+ => (ans :: <boolean>);
+ as(<string>, jid1) = as(<string>, jid2);
+end method \=;
Added: trunk/libraries/xmpp/message.dylan
==============================================================================
--- (empty file)
+++ trunk/libraries/xmpp/message.dylan Fri May 12 20:32:56 2006
@@ -0,0 +1,147 @@
+module: xmpp
+synopsis:
+author:
+copyright:
+
+define constant $message-types = #(#"error", #"chat", #"groupchat", #"headline", #"normal");
+
+define class <message> (<stanza>)
+ inherited slot name-with-proper-capitalization = "message";
+ virtual slot body;
+ virtual slot subject;
+ virtual slot thread;
+end class <message>;
+
+define method initialize (message :: <message>, #key body, subject, thread, #all-keys)
+ next-method();
+
+ if (body)
+ body-setter(body, message);
+ end if;
+ if (subject)
+ subject-setter(subject, message);
+ end if;
+ if (thread)
+ thread-setter(thread, message);
+ end if;
+end method initialize;
+
+define method type-setter (type, message :: <message>)
+ => (res);
+ if (member?(type, $message-types))
+ next-method();
+ end if;
+ type;
+end method type-setter;
+
+define method type (message :: <message>)
+ => (res :: false-or(<symbol>));
+ let type = next-method();
+ if (member?(as(<symbol>, type), $message-types))
+ as(<symbol>, type);
+ else
+ #f;
+ end if;
+end method type;
+
+define method body (message :: <message>)
+ => (res :: false-or(<string>));
+ let bodies = elements(message, "body");
+ if (~ empty?(bodies))
+ first(bodies).text;
+ else
+ #f;
+ end if;
+end method body;
+
+define method body-setter (body :: <string>, message :: <message>)
+ => (res :: <string>);
+ replace-element-text(message, "body", body);
+ body;
+end method body-setter;
+
+define method body-setter (body == #f, message :: <message>)
+ => (res);
+ remove-element(message, "body");
+ body;
+end method body-setter;
+
+define method add-body (message :: <message>, body :: <string>, #key language: lang)
+ let element = make(<element>, name: "body");
+ element.text := body;
+ element.language := lang;
+ add-element(message, element);
+end method add-body;
+
+define method subject (message :: <message>)
+ => (res :: false-or(<string>));
+ let subjects = elements(message, "subject");
+ if (~ empty?(subjects))
+ first(subjects).text;
+ else
+ #f;
+ end if;
+end method subject;
+
+define method subject-setter (subject :: <string>, message :: <message>)
+ => (res :: <string>);
+ replace-element-text(message, "subject", subject);
+ subject;
+end method subject-setter;
+
+define method subject-setter (subject == #f, message :: <message>)
+ => (res);
+ remove-element(message, "subject");
+ subject;
+end method subject-setter;
+
+define method add-subject (message :: <message>, subject :: <string>, #key language: lang)
+ let element = make(<element>, name: "subject");
+ element.text := subject;
+ element.language := lang;
+ add-element(message, element);
+end method add-subject;
+
+define method thread (message :: <message>)
+ => (res :: false-or(<string>));
+ let threads = elements(message, "thread");
+ if (~ empty?(threads))
+ first(threads).text;
+ else
+ #f;
+ end if;
+end method thread;
+
+define method thread-setter (thread :: false-or(<string>), message :: <message>)
+ => (res :: <string>);
+ replace-element-text(message, "thread", thread);
+ thread;
+end method thread-setter;
+
+define method thread-setter (thread == #f, message :: <message>)
+ => (res);
+ remove-element(message, "thread");
+ thread;
+end method thread-setter;
+
+define method normalize (message :: <message>)
+ let tmp = #f;
+ if (~ empty?(message.node-children))
+ let subject = find-key(message.node-children, method (a)
+ a.name = #"subject";
+ end);
+ if (subject)
+ tmp := message.node-children[0];
+ message.node-children[0] := message.node-children[subject];
+ message.node-children[subject] := tmp;
+ end if;
+ let body = find-key(message.node-children, method (a)
+ a.name = #"body";
+ end);
+ if (body)
+ tmp := message.node-children[1];
+ message.node-children[1] := message.node-children[body];
+ message.node-children[body] := tmp;
+ end if;
+ end if;
+end method normalize;
Added: trunk/libraries/xmpp/presence.dylan
==============================================================================
--- (empty file)
+++ trunk/libraries/xmpp/presence.dylan Fri May 12 20:32:56 2006
@@ -0,0 +1,127 @@
+module: xmpp
+synopsis:
+author:
+copyright:
+
+define constant $presence-types = #(#"error", #"probe", #"subscribe", #"subscribed",
+ #"unavailable", #"unsubscribe", #"unsubscribed");
+define constant $presence-shows = #(#"away", #"chat", #"dnd", #"xa");
+
+define class <presence> (<stanza>)
+ inherited slot name-with-proper-capitalization = "presence";
+ virtual slot show;
+ virtual slot status;
+ virtual slot priority;
+end class <presence>;
+
+define method initialize (presence :: <presence>, #key show, status, priority, #all-keys)
+ next-method();
+
+ if (show)
+ show-setter(show, presence);
+ end if;
+ if (status)
+ status-setter(status, presence);
+ end if;
+ if (priority)
+ priority-setter(priority, presence);
+ end if;
+end method;
+
+define method type-setter (type, presence :: <presence>)
+ => (res);
+ if (member?(type, $presence-types))
+ next-method();
+ end if;
+ type;
+end method type-setter;
+
+define method type (presence :: <presence>)
+ => (res :: false-or(<symbol>));
+ let type = next-method();
+ if (member?(as(<symbol>, type), $presence-types))
+ as(<symbol>, type);
+ else
+ #f;
+ end if;
+end method type;
+
+define method show (presence :: <presence>)
+ => (res :: false-or(<string>));
+ let show = elements(presence, "show");
+ if (~ empty?(show))
+ show := first(show).text;
+ if (member?(as(<symbol>, show), $presence-shows))
+ show;
+ else
+ #f;
+ end if;
+ else
+ #f;
+ end if;
+end method show;
+
+define method show-setter (show, presence :: <presence>)
+ => (res);
+ if (member?(as(<symbol>, show), $presence-shows))
+ replace-element-text(presence, "show", as(<string>, show));
+ end if;
+ show;
+end method show-setter;
+
+define method show-setter (show == #f, presence :: <presence>)
+ => (res);
+ remove-element(presence, "show");
+ show;
+end method show-setter;
+
+define method status (presence :: <presence>)
+ => (res :: false-or(<string>));
+ let status = elements(presence, "status");
+ if (~ empty?(status))
+ first(status).text;
+ else
+ #f;
+ end if;
+end method status;
+
+define method status-setter (status :: <string>, presence :: <presence>)
+ => (res :: <string>);
+ replace-element-text(presence, "status", status);
+ status;
+end method status-setter;
+
+define method status-setter (status == #f, presence :: <presence>)
+ => (res);
+ remove-element(presence, "status");
+ status;
+end method status-setter;
+
+define method add-status (presence :: <presence>, status :: <string>, #key language: lang)
+ let element = make(<element>, name: "status");
+ element.text := status;
+ element.language := lang;
+ add-element(presence, element);
+end method add-status;
+
+define method priority (presence :: <presence>)
+ => (res :: false-or(<integer>));
+ let priorities = elements(presence, "priority");
+ if (~ empty?(priorities))
+ string-to-integer(first(priorities).text);
+ else
+ #f;
+ end if;
+end method priority;
+
+define method priority-setter (priority :: <integer>, presence :: <presence>)
+ => (res :: <integer>);
+ remove-element(presence, "priority");
+ priority;
+end method priority-setter;
+
+define method priority-setter (priority == #f, presence :: <presence>)
+ => (res);
+ remove-element(presence, "priority");
+ priority;
+end method priority-setter;
Added: trunk/libraries/xmpp/query.dylan
==============================================================================
--- (empty file)
+++ trunk/libraries/xmpp/query.dylan Fri May 12 20:32:56 2006
@@ -0,0 +1,7 @@
+module: xmpp
+synopsis:
+author:
+copyright:
+
+define element query ()
+end element query;
Added: trunk/libraries/xmpp/stanza-error.dylan
==============================================================================
--- (empty file)
+++ trunk/libraries/xmpp/stanza-error.dylan Fri May 12 20:32:56 2006
@@ -0,0 +1,96 @@
+module: xmpp
+synopsis:
+author:
+copyright:
+
+define constant $xmpp-stanza-error-types = #(#"cancel", #"continue", #"modify", #"auth", #"wait");
+define constant $xmpp-stanza-error-conditions =
+ #(#"bad-request", #"conflict", #"feature-not-implemented",
+ #"forbidden", #"gone", #"internal-server-error",
+ #"item-not-found", #"jid-malformed", #"not-acceptable",
+ #"not-allowed", #"payment-required", #"recipient-unavailable",
+ #"redirect registration-required", #"remote-server-not-found",
+ #"remote-server-timeout", #"resource-constraint",
+ #"service-unavailable", #"subscription-required",
+ #"undefined-condition", #"unexpected-request");
+
+define class <xmpp-stanza-error> (<xmpp-error>)
+ inherited slot name-with-proper-capitalization = "error";
+ virtual slot type;
+end class <xmpp-stanza-error>;
+
+define method initialize (error :: <xmpp-stanza-error>, #key type, #all-keys)
+ next-method();
+
+ if (type)
+ type-setter(type, error);
+ end if;
+end method initialize;
+
+define method type-setter (type, iq :: <xmpp-stanza-error>)
+ => (res);
+ if (member?(type, $xmpp-stanza-error-types))
+ next-method();
+ end if;
+ type;
+end method type-setter;
+
+define method type (iq :: <xmpp-stanza-error>)
+ => (res :: false-or(<symbol>));
+ let type = next-method();
+ if (member?(as(<symbol>, type), $xmpp-stanza-error-types))
+ as(<symbol>, type);
+ else
+ #f;
+ end if;
+end method type;
+
+define method description-setter (description :: <string>, error :: <xmpp-stanza-error>)
+ => (res :: <string>);
+ replace-element-text(error, "text", description);
+ add-namespace(element(error, "text"), "urn:ietf:params:xml:ns:xmpp-stanzas");
+ description;
+end method description-setter;
+
+define method condition-setter (condition :: <symbol>, error :: <xmpp-stanza-error>)
+ => (res :: <symbol>);
+ if (member?(condition, $xmpp-stanza-error-conditions))
+ let defined-condition = make(<element>, name: as(<string>, condition));
+ add-namespace(defined-condition, "urn:ietf:params:xml:ns:xmpp-stanzas");
+ for (condition in $xmpp-stanza-error-conditions)
+ remove-element(error, condition);
+ end for;
+ add-element(error, defined-condition);
+ normalize(error);
+ end if;
+ condition;
+end method condition-setter;
+
+define method normalize (error :: <xmpp-stanza-error>)
+ let tmp = #f;
+ if (~ empty?(error.node-children))
+ let condition = find-key(error.node-children, method (a)
+ member?(a.name, $xmpp-stanza-error-conditions);
+ end);
+ if (condition)
+ tmp := error.node-children[0];
+ error.node-children[0] := error.node-children[condition];
+ error.node-children[condition] := tmp;
+ else
+ // signal an error! (there should be an condition element!)
+ end if;
+ if (find-key(error.node-children, method (a)
+ member?(a.name, $xmpp-stanza-error-conditions);
+ end, skip: 1))
+ // signal an error! (there shouldn't be a second condition!)
+ end if;
+ let description = find-key(error.node-children, method (a)
+ a.name = #"text";
+ end);
+ if (description)
+ tmp := error.node-children[1];
+ error.node-children[1] := error.node-children[description];
+ error.node-children[description] := tmp;
+ end if;
+ end if;
+end method normalize;
Added: trunk/libraries/xmpp/stanza.dylan
==============================================================================
--- (empty file)
+++ trunk/libraries/xmpp/stanza.dylan Fri May 12 20:32:56 2006
@@ -0,0 +1,102 @@
+module: xmpp
+synopsis:
+author:
+copyright:
+
+define class <stanza> (<element>)
+ virtual slot id;
+ virtual slot to;
+ virtual slot from;
+ virtual slot type;
+ virtual slot language;
+ virtual slot x;
+end class <stanza>;
+
+define method initialize (stanza :: <stanza>, #key id, to, from, type, language, x, #all-keys)
+ next-method();
+
+ if (id)
+ id-setter(id, stanza);
+ end if;
+ if (to)
+ to-setter(to, stanza);
+ end if;
+ if (from)
+ from-setter(from, stanza);
+ end if;
+ if (type)
+ type-setter(type, stanza);
+ end if;
+ if (language)
+ language-setter(language, stanza);
+ end if;
+/* if (x)
+ x-setter(x, stanza);
+ end if;
+*/
+end method initialize;
+
+/*
+define method error (stanza :: <stanza>)
+ => (res :: false-or(<attribute>));
+ attribute(stanza, "error");
+end method error;
+*/
+
+define method x (stanza :: <stanza>)
+ => (res :: false-or(<x>));
+ let xs = elements(stanza, "x");
+ if (~ empty?(xs))
+ first(xs);
+ else
+ #f;
+ end if;
+end method x;
+
+define method answer (stanza :: <stanza>, #key import :: <boolean> = #t)
+ => (res);
+ let answer-stanza = make(object-class(stanza));
+ if (import)
+ import-element(answer-stanza, stanza);
+ end if;
+ answer-stanza.to := stanza.from;
+ answer-stanza.from := stanza.to;
+ answer-stanza.id := stanza.id;
+ answer-stanza;
+end method answer;
+
+define method elements (stanza :: <stanza>, element-name :: <string>)
+ => (res :: <sequence>)
+ let res = next-method();
+ let tmp = #f;
+ let name = as(<symbol>, element-name);
+ if (~ empty?(res) & element(*element-translation*, name, default: #f))
+ if (object-class(first(res)) ~= *element-translation*[name])
+ for (i from 0 below size(res))
+ tmp := make(*element-translation*[name]);
+ import-element(tmp, res[i]);
+ res[i] := tmp;
+ end for;
+ end if;
+ end if;
+ res;
+end method elements;
+
+define method add-element (stanza :: <stanza>, node :: <element>)
+ if (element(*element-translation*, node.name, default: #f) & object-class(node) ~= *element-translation*[node.name])
+ let tmp = make(*element-translation*[node.name]);
+ import-element(tmp, node);
+ next-method(stanza, tmp);
+ else
+ next-method();
+ end if;
+end method add-element;
+
+define macro element-definer
+ { define element ?identifier:name () ?body:* end } =>
+ { define class "<" ## ?identifier ## ">" (<element>)
+ inherited slot name-with-proper-capitalization = ?"identifier";
+ ?body
+ end;
+ *element-translation*[?#"identifier"] := "<" ## ?identifier ## ">"; }
+end macro element-definer;
Added: trunk/libraries/xmpp/stream-error.dylan
==============================================================================
--- (empty file)
+++ trunk/libraries/xmpp/stream-error.dylan Fri May 12 20:32:56 2006
@@ -0,0 +1,70 @@
+module: xmpp
+synopsis:
+author:
+copyright:
+
+define constant $xmpp-stream-error-conditions =
+ #(#"bad-format", #"bad-namespace-prefix", #"conflict",
+ #"connection-timeout", #"host-gone", #"host-unknown",
+ #"improper-addressing", #"internal-server-error",
+ #"invalid-from", #"invalid-id", #"invalid-namespace",
+ #"invalid-xml", #"not-authorized", #"policy-violation",
+ #"remote-connection-failed", #"resource-constraint",
+ #"restricted-xml", #"see-other-host", #"system-shutdown",
+ #"undefined-condition", #"unsupported-encoding",
+ #"unsupported-stanza-type", #"unsupported-version",
+ #"xml-not-well-formed");
+
+define class <xmpp-stream-error> (<xmpp-error>)
+ inherited slot name-with-proper-capitalization = "stream:error";
+end class <xmpp-stream-error>;
+
+define method description-setter (description :: <string>, error :: <xmpp-stream-error>)
+ => (res :: <string>);
+ replace-element-text(error, "text", description);
+ add-namespace(element(error, "text"), "urn:ietf:params:xml:ns:xmpp-streams");
+ description;
+end method description-setter;
+
+define method condition-setter (condition :: <symbol>, error :: <xmpp-stream-error>)
+ => (res :: <symbol>);
+ if (member?(condition, $xmpp-stream-error-conditions))
+ let defined-condition = make(<element>, name: as(<string>, condition));
+ add-namespace(defined-condition, "urn:ietf:params:xml:ns:xmpp-streams");
+ for (condition in $xmpp-stream-error-conditions)
+ remove-element(error, condition);
+ end for;
+ add-element(error, defined-condition);
+ normalize(error);
+ end if;
+ condition;
+end method condition-setter;
+
+define method normalize (error :: <xmpp-stream-error>)
+ let tmp = #f;
+ if (~ empty?(error.node-children))
+ let condition = find-key(error.node-children, method (a)
+ member?(a.name, $xmpp-stream-error-conditions);
+ end);
+ if (condition)
+ tmp := error.node-children[0];
+ error.node-children[0] := error.node-children[condition];
+ error.node-children[condition] := tmp;
+ else
+ // signal an error! (there should be an condition element!)
+ end if;
+ if (find-key(error.node-children, method (a)
+ member?(a.name, $xmpp-stream-error-conditions);
+ end, skip: 1))
+ // signal an error! (there shouldn't be a second condition!)
+ end if;
+ let description = find-key(error.node-children, method (a)
+ a.name = #"text";
+ end);
+ if (description)
+ tmp := error.node-children[1];
+ error.node-children[1] := error.node-children[description];
+ error.node-children[description] := tmp;
+ end if;
+ end if;
+end method normalize;
Added: trunk/libraries/xmpp/stream.dylan
==============================================================================
--- (empty file)
+++ trunk/libraries/xmpp/stream.dylan Fri May 12 20:32:56 2006
@@ -0,0 +1,76 @@
+module: xmpp
+synopsis:
+author:
+copyright:
+
+define class <xmpp-stream> (<element>)
+ inherited slot name-with-proper-capitalization = "stream:stream";
+ inherited slot attributes = vector(make(<attribute>, name: "xmlns:stream", value: "http://etherx.jabber.org/streams"));
+ virtual slot id,
+ init-keyword: id:;
+ virtual slot to,
+ init-keyword: to:;
+ virtual slot from,
+ init-keyword: from:;
+ virtual slot language,
+ init-keyword: language:;
+ virtual slot version,
+ init-keyword: version:;
+ virtual slot type,
+ init-keyword: type:;
+end class <xmpp-stream>;
+
+define method initialize (stream :: <xmpp-stream>, #key id, to, from, language, version, type = #"client", #all-keys)
+ next-method();
+
+ if (id)
+ id-setter(id, stream);
+ end if;
+ if (to)
+ to-setter(to, stream);
+ end if;
+ if (from)
+ from-setter(from, stream);
+ end if;
+ if (language)
+ language-setter(language, stream);
+ end if;
+ if (version)
+ version-setter(version, stream);
+ end if;
+ type-setter(type, stream);
+end method initialize;
+
+define method version (stream :: <xmpp-stream>)
+ => (res :: false-or(<version>));
+ let a = attribute(stream, "version");
+ a & as(<version>, a.attribute-value);
+end method version;
+
+define method version-setter (version, stream :: <xmpp-stream>)
+ => (res);
+ add-attribute(stream, make(<attribute>, name: "version", value: as(<string>, version)));
+ version;
+end method version-setter;
+
+define method type (stream :: <xmpp-stream>)
+ => (res :: false-or(<symbol>));
+ let type = namespace(stream);
+ if (type = "jabber:server")
+ #"server";
+ elseif (type = "jabber:client")
+ #"client";
+ else
+ #f;
+ end if;
+end method type;
+
+define method type-setter (type, stream :: <xmpp-stream>)
+ => (res);
+ if (type = #"server")
+ add-namespace(stream, "jabber:server");
+ elseif (type = #"client")
+ add-namespace(stream, "jabber:client");
+ end if;
+ type;
+end method type-setter;
Added: trunk/libraries/xmpp/vcard.dylan
==============================================================================
--- (empty file)
+++ trunk/libraries/xmpp/vcard.dylan Fri May 12 20:32:56 2006
@@ -0,0 +1,7 @@
+module: xmpp
+synopsis:
+author:
+copyright:
+
+define element vcard ()
+end element vcard;
Added: trunk/libraries/xmpp/version.dylan
==============================================================================
--- (empty file)
+++ trunk/libraries/xmpp/version.dylan Fri May 12 20:32:56 2006
@@ -0,0 +1,51 @@
+module: xmpp
+synopsis:
+author:
+copyright:
+
+define class <version> (<object>)
+ slot major :: <integer>,
+ required-init-keyword: major:;
+ slot minor :: <integer>,
+ required-init-keyword: minor:;
+end class <version>;
+
+define method \< (first :: <version>, second :: <version>)
+ => (less-then? :: <boolean>);
+ if (first.major < second.major)
+ #t;
+ elseif (first.major > second.major)
+ #f;
+ else
+ first.minor < second.minor;
+ end if;
+end method \<;
+/*
+define method \> (first :: <version>, second :: <version>)
+ => (greater-then? :: <boolean>);
+ second < first;
+end method \>;
+*/
+define method \= (first :: <version>, second :: <version>)
+ => (equal? :: <boolean>);
+ if ((first.minor = second.minor) & (first.major = second.major))
+ #t;
+ else
+ #f;
+ end if;
+end method \=;
+
+define method as (class == <string>, version :: <version>)
+ => (res :: <string>)
+ concatenate(integer-to-string(version.major), ".", integer-to-string(version.minor));
+end method as;
+
+define method as (class == <version>, version :: <string>)
+ => (res :: <version>)
+ if (subsequence-position(version, "."))
+ let splitted-version = split(version, '.');
+ make(<version>, major: string-to-integer(splitted-version[0]), minor: string-to-integer(splitted-version[1]));
+ else
+ make(<version>, major: string-to-integer(version), minor: 0);
+ end if;
+end method as;
Added: trunk/libraries/xmpp/x.dylan
==============================================================================
--- (empty file)
+++ trunk/libraries/xmpp/x.dylan Fri May 12 20:32:56 2006
@@ -0,0 +1,9 @@
+module: xmpp
+synopsis:
+author:
+copyright:
+
+define element x ()
+end element x;
+
+define open generic x (element :: <element>) => (res :: false-or(<x>));
Added: trunk/libraries/xmpp/xmpp-exports.dylan
==============================================================================
--- (empty file)
+++ trunk/libraries/xmpp/xmpp-exports.dylan Fri May 12 20:32:56 2006
@@ -0,0 +1,88 @@
+module: dylan-user
+
+define library xmpp
+ use common-dylan;
+ use io;
+ use network;
+ use xml-parser;
+ use meta;
+
+ export xmpp;
+end library;
+
+define module xmpp
+ use common-dylan;
+ use threads;
+ use common-extensions;
+ use format, exclude: { format-to-string };
+ use sockets;
+ use streams;
+ use xml-parser;
+ use simple-xml;
+
+ //XXX
+ use standard-io;
+ use format-out;
+ use %productions;
+
+ export <jid>,
+ node, node-setter,
+ domain, domain-setter,
+ resource, resource-setter,
+ strip, strip!;
+
+ export <stanza>,
+ answer;
+
+ export <presence>,
+ show, show-setter,
+ status, status-setter, add-status,
+ priority, priority-setter;
+
+ export <message>,
+ body, body-setter, add-body,
+ subject, subject-setter, add-subject,
+ thread, thread-setter;
+
+ export <x>,
+ x;
+
+ export <iq>,
+ query, query-setter,
+ vcard, vcard-setter,
+ make-query, make-vcard,
+ make-authentication,
+ make-registration;
+
+ export <query>;
+
+ export <vcard>;
+
+ export <xmpp-stream>,
+ language, language-setter,
+ version, version-setter;
+
+ export <version>,
+ major, major-setter,
+ minor, minor-setter;
+
+ export <xmpp-stream-error>,
+ <xmpp-stanza-error>,
+ condition, condition-setter,
+ description, description-setter;
+
+ export <xmpp-client>,
+ jid, socket, state,
+ connect, disconnect,
+ send;
+
+ export normalize,
+ id, id-setter,
+ from, from-setter,
+ to, to-setter,
+ language, language-setter,
+ type, type-setter,
+ *default-language*,
+ print-object;
+
+end module;
Added: trunk/libraries/xmpp/xmpp-test/xmpp-test-exports.dylan
==============================================================================
--- (empty file)
+++ trunk/libraries/xmpp/xmpp-test/xmpp-test-exports.dylan Fri May 12 20:32:56 2006
@@ -0,0 +1,22 @@
+module: dylan-user
+
+define library xmpp-test
+ use common-dylan;
+ use io;
+ use network;
+ use xml-parser;
+ use xmpp;
+ use meta;
+end library;
+
+define module xmpp-test
+ use common-dylan, exclude: { split };
+ use format-out;
+ use sockets;
+ use streams;
+ use standard-io;
+ use xml-parser;
+ use simple-xml;
+ use xmpp;
+ use meta;
+end module;
Added: trunk/libraries/xmpp/xmpp-test/xmpp-test.dylan
==============================================================================
--- (empty file)
+++ trunk/libraries/xmpp/xmpp-test/xmpp-test.dylan Fri May 12 20:32:56 2006
@@ -0,0 +1,300 @@
+module: xmpp-test
+synopsis:
+author:
+copyright:
+
+define function main(name :: <string>, #rest strings)
+
+/*
+ let jid = make(<jid>, domain: "foo");
+ format-out("%=, %=, %=\n", jid.node, jid.domain, jid.resource);
+
+ jid := make(<jid>, node: "a", domain: "b", resource: "c");
+ format-out("%=, %=, %=\n", jid.node, jid.domain, jid.resource);
+
+ jid := as(<jid>, "a at b/c");
+ format-out("%=, %=, %=\n", jid.node, jid.domain, jid.resource);
+
+ jid := as(<jid>, "a at b");
+ format-out("%=, %=, %=\n", jid.node, jid.domain, jid.resource);
+
+ jid := as(<jid>, "b");
+ format-out("%=, %=, %=\n", jid.node, jid.domain, jid.resource);
+
+ format-out("%=\n", as(<string>, make(<jid>, domain: "b")));
+ format-out("%=\n", as(<string>, make(<jid>, node: "a", domain: "b")));
+ format-out("%=\n", as(<string>, make(<jid>, node: "a", domain: "b", resource: "c")));
+ format-out("%=\n", as(<string>, make(<jid>, domain: "b", resource: "c")));
+
+ format-out("%=\n", begin
+ as(<jid>, "b") = make(<jid>, domain: "b");
+ end);
+ format-out("%=\n", begin
+ as(<jid>, "a at b") = make(<jid>, node: "a", domain: "b");
+ end);
+ format-out("%=\n", begin
+ as(<jid>, "a at b/c") = make(<jid>, node: "a", domain: "b", resource: "c");
+ end);
+ format-out("%=\n", begin
+ as(<jid>, "b/c") = make(<jid>, domain: "b", resource: "c");
+ end);
+
+ let presence = make(<presence>);
+ format-out("%=\n", presence);
+
+ presence.type := #"foobar";
+ format-out("%=\n", presence);
+
+ presence.type := #"error";
+ format-out("%=\n", presence);
+ format-out("%=\n", presence.type);
+ format-out("%=\n", presence.x);
+
+ presence.show := "foobar";
+ format-out("%=\n", presence);
+
+ presence.show := "chat";
+ format-out("%=\n", presence);
+
+ presence.show := "dnd";
+ format-out("%=\n", presence);
+ format-out("%=\n", presence.show);
+
+
+ format-out("%=\n", presence.status);
+ presence.status := "Foo-Bar <3";
+ format-out("%=\n", presence);
+ format-out("%=\n", presence.status);
+
+ presence.priority := 1;
+ format-out("%=\n", presence);
+ format-out("%=\n", presence.priority);
+
+ presence.to := make(<jid>, node: "alice", domain: "jabber.ccc.de", resource: "dylan");
+ presence.from := "bob";
+ presence.id := "2342";
+
+ let answer = answer(presence);
+ format-out("%s %s %s\n", presence.to, presence.from, presence.id);
+ format-out("%s %s %s\n", answer.to, answer.from, answer.id);
+ format-out("%=\n", presence);
+ format-out("%=\n", answer);
+
+ let foo = make(<element>, name: "foo1");
+ let foo2 = make(<element>, name: "foo1");
+ add-element(foo2, make(<element>, name: "foo2"));
+ add-attribute(foo2, make(<attribute>, name: "a", value: "1"));
+ add-attribute(foo2, make(<attribute>, name: "b", value: "2"));
+ add-attribute(foo2, make(<attribute>, name: "c", value: "3"));
+ add-attribute(foo, make(<attribute>, name: "d", value: "4"));
+ add-attribute(foo, make(<attribute>, name: "a", value: "0"));
+ format-out("%=\n", foo);
+ format-out("%=\n", foo2);
+ import-element(foo, foo2);
+ format-out("%=\n", foo);
+
+ let message = make(<message>, to: presence.to, body: "Hello, World");
+ format-out("%=\n", message);
+
+ let presence = make(<presence>);
+ let presence-x = make(<x>);
+ add-element(presence, presence-x);
+ format-out("%=\n", presence.x);
+ format-out("%=\n", object-class(presence.x));
+
+ let presence = make(<presence>);
+ let presence-x = make(<element>, name: "x");
+ add-element(presence, presence-x);
+ format-out("%=\n", presence.x);
+ format-out("%=\n", object-class(presence.x));
+
+ add-namespace(presence, "jabber:foo");
+ format-out("%=\n", presence);
+
+ let foobar = make(<element>, name: "foobar");
+ add-attribute(foobar, make(<attribute>, name: "a", value: "1"));
+ add-attribute(foobar, make(<attribute>, name: "a", value: "2"));
+ format-out("%=\n", foobar);
+ add-element(foobar, make(<element>, name: "foo"));
+ add-element(foobar, make(<element>, name: "foo2"));
+ add-element(foobar, make(<element>, name: "foo2"));
+ add-element(foobar, make(<element>, name: "foo"));
+ remove-element(foobar, "foo");
+ format-out("%=\n", foobar);
+ remove-element(foobar, "foo2", count: 1);
+ format-out("%=\n", foobar);
+
+ let iq = make(<iq>);
+ format-out("%=\n", iq);
+ iq.vcard := make(<element>, name: "vCard");
+ format-out("%=\n", object-class(iq.vcard));
+ iq.vcard := make(<vcard>);
+ format-out("%=\n", object-class(iq.vcard));
+ iq.query := make(<element>, name: "query");
+ format-out("%=\n", object-class(iq.query));
+ iq.query := make(<query>);
+ format-out("%=\n", object-class(iq.query));
+
+ let iq2 = make(<iq>, vcard: make(<vcard>));
+ format-out("%=\n", iq);
+
+ let m = make(<message>);
+ add-element(m, make(<element>, name: "foo1"));
+ add-element(m, make(<element>, name: "foo2"));
+ m.body := "Whooha!";
+ m.subject := "Simple Test";
+ format-out("%=\n", m);
+ normalize(m);
+ format-out("%=\n", m);
+
+ let foo-stanza = make(<message>);
+ let xxx = make(<element>, name: "x");
+ add-element(foo-stanza, xxx);
+ format-out("%=\n", object-class(first(foo-stanza.node-children)));
+ format-out("%=\n", object-class(first(elements(foo-stanza, "x"))));
+
+ let test-table = make(<table>);
+ test-table[#"x"] := <x>;
+ format-out("%=\n", test-table[#"x"]);
+ let foox = #"x";
+ format-out("%=\n", object-class(make(test-table[foox])));
+
+ let superfluous-jid = make(<jid>, node: "turbo24prg", domain: "jabber.ccc.de", resource: "marvin");
+ let cool-query = make-query(type: #"get", to: superfluous-jid);
+ format-out("%=\n", cool-query);
+
+ format-out("%=\n", make-authentication(make(<jid>, node: "turbo24prg", domain: "jabber.ccc.de"), "1337"));
+ format-out("%=\n", make-authentication(superfluous-jid, "1337"));
+ format-out("%=\n", make-registration(username: "turbo24prg", password: "foobar"));
+ format-out("%=\n", make-registration(username: "turbo24prg"));
+ format-out("%=\n", make-vcard(to: superfluous-jid));
+
+ let ns-test = make(<element>, name: "foo:bar");
+ add-attribute(ns-test, make(<attribute>, name: "xml:lang", value: "blah"));
+ format-out("%=\n", ns-test);
+
+ let stream = make(<xmpp-stream>);
+
+ stream.version := "1.0";
+ format-out("%=\n", stream);
+ stream.version := "0.9";
+ format-out("%=\n", stream);
+ stream.version := make(<version>, major: 1, minor: 0);
+ format-out("%=\n", stream);
+
+ stream.version := "1.0";
+ format-out("%= %= %=\n", stream.version, stream.version.major, stream.version.minor);
+ stream.version := "0.9";
+ format-out("%= %= %=\n", stream.version, stream.version.major, stream.version.minor);
+ stream.version := "1";
+ format-out("%= %= %=\n", stream.version, stream.version.major, stream.version.minor);
+
+ let stream-error = make(<xmpp-stream-error>);
+ stream-error.description := "Uff! Don't know?!";
+ stream-error.condition := #"server-shutdown";
+ format-out("%=\n", stream-error);
+ stream-error.condition := #"system-shutdown";
+ format-out("%=\n", stream-error);
+ stream-error.condition := #"policy-violation";
+ stream-error.description := #f;
+ format-out("%=\n", stream-error);
+
+ let stanza-error = make(<xmpp-stanza-error>);
+ stanza-error.description := "Boo!";
+ stanza-error.type := #"continue";
+ stanza-error.condition := #"unexpected-request";
+ format-out("%=\n", stanza-error);
+
+ let intl-message = make(<message>, body: "Dies ist ein Test.", to: superfluous-jid, language: "de");
+ add-body(intl-message, "This is a test.", language: "en");
+ add-body(intl-message, "C'est une test.", language: "fr");
+ format-out("%=\n", intl-message);
+
+ let test-document :: <document> = parse-document("<foo>Blub</foo>");
+ format-out("%=\n", object-class(test-document.root));
+ format-out("%=\n", test-document.node-children);
+
+ let test-document :: <document> = parse-document("<foo>Blub</foo><foo2>Blob</foo2>");
+ format-out("%=\n", object-class(test-document.root));
+ format-out("%=\n", test-document.node-children);
+
+*/
+format-out("%=\n", parse-document("<stream:stream xmlns:stream='http://etherx.jabber.org/streams' id='4463ACD5' xmlns='jabber:client' from='192.168.0.1'></stream:stream>"));
+
+//start-sockets();
+ let client = make(<xmpp-client>, jid: make(<jid>, node: "foo", domain: "192.168.0.1"));
+ let stream = make(<xmpp-stream>, to: client.jid.domain);
+
+// connect(client);
+// send(client, stream);
+// listen(client);
+// let response = read-line(client.socket, on-end-of-stream: #f);
+// if (response) write-line(*standard-output*, response); end if;
+// disconnect(client);
+
+/*
+// format-out("%=\n", object-class(parse-document("<foo>Blub</foo>")));
+ block ()
+ format-out("%=\n", object-class(parse-document("<foo>Blub")));
+// format-out("%=\n", object-class(parse-document("<foo>Blub</fo")));
+// format-out("%=\n", object-class(parse-document("<foo t='>Blub</foo>")));
+// format-out("%=\n", object-class(parse-document("<foo>Blub</blub>")));
+ exception (condition :: <condition>)
+ format-out("Error: %=\n", condition);
+ format-out("%=\n", object-class(condition));
+ end block;
+*/
+ block()
+ connect(client);
+ format-out("Connected to xmpp server at %s port: %d\n",
+ client.socket.remote-host.host-name,
+ client.socket.remote-port);
+ send(client, stream);
+ while (#t)
+//foo
+ end while;
+
+//close(client-socket);
+ disconnect(client);
+ format-out("Connection closed. Bye\n");
+ exception (condition :: <condition>)
+ disconnect(client);
+ format-out("xmpp-test: Error: %=\n", condition);
+ end block;
+
+/*
+ block ()
+ format-out("%=\n", scan-xml-decl("<?xml version='1.0'?>"));
+ format-out("%=\n", scan-xml-decl("<?xml version=''?>"));
+//format-out("%=\n", scan-xml-decl("<?xml?>"));
+ format-out("%=\n", scan-xml-decl("<?xml '"));
+ exception (condition :: <condition>)
+ format-out("Error: %=: %=\n", condition);
+ end block;
+*/
+/*
+ block ()
+ let (index, element) = scan-maybe-element-data("<foo123'%>");
+ format-out("%=\n", element);
+ let (index, element) = scan-maybe-element-data("<foo123'%><foo");
+ format-out("%=\n", element);
+ let (index, element) = scan-maybe-element-data("<foo123'%><foo>");
+ format-out("%=\n", element);
+ let (index, element) = scan-maybe-element-data("a<foo123'%><foo>", start: 1);
+ format-out("%=\n", element);
+ let (index, positions) = scan-positions("1 2 3 4");
+ format-out("%=\n", positions);
+
+ exception (condition :: <condition>)
+ format-out("Error: %=: %=\n", condition);
+ end block;
+*/
+ exit-application(0);
+end function main;
+/*
+define meta positions (space) => (space)
+ "1", scan-s(space), "2", scan-s(space), "3", scan-s(space), "4"
+end meta positions;
+*/
+// Invoke our main() function.
+main(application-name(), application-arguments());
Added: trunk/libraries/xmpp/xmpp-test/xmpp-test.lid
==============================================================================
--- (empty file)
+++ trunk/libraries/xmpp/xmpp-test/xmpp-test.lid Fri May 12 20:32:56 2006
@@ -0,0 +1,4 @@
+library: xmpp-test
+executable: xmpp-test
+files: xmpp-test-exports
+ xmpp-test
Added: trunk/libraries/xmpp/xmpp.dylan
==============================================================================
--- (empty file)
+++ trunk/libraries/xmpp/xmpp.dylan Fri May 12 20:32:56 2006
@@ -0,0 +1,79 @@
+module: xmpp
+synopsis:
+author:
+copyright:
+
+define variable *default-language* = "en";
+define variable *element-translation* = make(<table>);
+
+define generic normalize (element :: <element>);
+
+define generic id-setter (id :: <object>, element :: <element>) => (res :: <object>);
+define generic to-setter (jid :: <object>, element :: <element>) => (res :: <object>);
+define generic from-setter (jid :: <object>, element :: <element>) => (res :: <object>);
+define generic type-setter (type :: <object>, element :: <element>) => (res :: <object>);
+
+define generic language-setter (language :: <object>, element :: <object>) => (res :: <object>);
+
+define generic description-setter (description :: <object>, error :: <xmpp-error>) => (res :: <object>);
+define generic condition-setter (condition :: <object>, error :: <xmpp-error>) => (res :: <object>);
+
+define method id (element :: <element>)
+ => (res :: false-or(<string>));
+ let a = attribute(element, "id");
+ a & a.attribute-value;
+end method id;
+
+define method id-setter (id, element :: <element>)
+ => (res);
+ add-attribute(element, make(<attribute>, name: "id", value: as(<string>, id)));
+ id;
+end method id-setter;
+
+define method to (element :: <element>)
+ => (res :: false-or(<jid>));
+ let a = attribute(element, "to");
+ a & as(<jid>, a.attribute-value);
+end method to;
+
+define method to-setter (jid, element :: <element>)
+ => (res);
+ add-attribute(element, make(<attribute>, name: "to", value: as(<string>, jid)));
+ jid;
+end method to-setter;
+
+define method from (element :: <element>)
+ => (res :: false-or(<jid>));
+ let a = attribute(element, "from");
+ a & as(<jid>, a.attribute-value);
+end method from;
+
+define method from-setter (jid, element :: <element>)
+ => (res);
+ add-attribute(element, make(<attribute>, name: "from", value: as(<string>, jid)));
+ jid;
+end method from-setter;
+
+define method type (element :: <element>)
+ => (res :: false-or(<string>));
+ let a = attribute(element, "type");
+ a & a.attribute-value;
+end method type;
+
+define method type-setter (type, element :: <element>)
+ => (res);
+ add-attribute(element, make(<attribute>, name: "type", value: as(<string>, type)));
+ type;
+end method type-setter;
+
+define method language (element :: <element>)
+ => (res :: false-or(<string>));
+ let a = attribute(element, "xml:lang");
+ a & a.attribute-value;
+end method language;
+
+define method language-setter (language, element :: <element>)
+ => (res);
+ add-attribute(element, make(<attribute>, name: "xml:lang", value: as(<string>, language)));
+ language;
+end method language-setter;
Added: trunk/libraries/xmpp/xmpp.lid
==============================================================================
--- (empty file)
+++ trunk/libraries/xmpp/xmpp.lid Fri May 12 20:32:56 2006
@@ -0,0 +1,18 @@
+library: xmpp
+files: xmpp-exports
+ xmpp
+ stream
+ jid
+ stanza
+ presence
+ message
+ iq
+ x
+ query
+ vcard
+ version
+ error
+ stream-error
+ stanza-error
+ connection
+ client
More information about the chatter
mailing list