[Gd-chatter] r10796 - in trunk/libraries/xmpp: . xmpp-test
turbo24prg at gwydiondylan.org
turbo24prg at gwydiondylan.org
Sun Jun 11 00:09:34 CEST 2006
Author: turbo24prg
Date: Sun Jun 11 00:09:32 2006
New Revision: 10796
Added:
trunk/libraries/xmpp/generator.dylan (contents, props changed)
Modified:
trunk/libraries/xmpp/xmpp-exports.dylan
trunk/libraries/xmpp/xmpp-test/xmpp-test.dylan
trunk/libraries/xmpp/xmpp.lid
Log:
Bug: 7313
* new partly-working macro
Added: trunk/libraries/xmpp/generator.dylan
==============================================================================
--- (empty file)
+++ trunk/libraries/xmpp/generator.dylan Sun Jun 11 00:09:32 2006
@@ -0,0 +1,169 @@
+module: xmpp
+synopsis:
+author:
+copyright:
+
+define macro xmpp-element-definer
+ { define xmpp-element ?:name (?superclasses:*)
+ ?slots:*
+ end }
+ => {
+ define-xmpp-element-class(?name; ?name; ?superclasses; ?slots);
+ define-xmpp-element-initializer(?name; ?slots);
+ define-xmpp-element-generic-method(?slots);
+ define-xmpp-element-getter-setter("<" ## ?name ## ">"; ?slots);
+ }
+
+ { define abstract xmpp-element ?:name (?superclasses:*)
+ ?slots:*
+ end }
+ => {
+ define-xmpp-element-class(?name; ?name; ?superclasses; ?slots);
+ define-xmpp-element-initializer(?name; ?slots);
+ define-xmpp-element-generic-method(?slots);
+ define-xmpp-element-getter-setter("<" ## ?name ## ">"; ?slots);
+ }
+
+ { define xmpp-element ?:name = ?real-name:name (?superclasses:*)
+ ?slots:*
+ end }
+ => {
+ define-xmpp-element-class(?name; ?real-name; ?superclasses; ?slots);
+ define-xmpp-element-initializer(?name; ?slots);
+ define-xmpp-element-generic-method(?slots);
+ define-xmpp-element-getter-setter("<" ## ?name ## ">"; ?slots);
+ }
+
+ superclasses:
+ { } => { <xmpp-element> }
+ { ?superclass:*, ... } => { "<" ## ?superclass ## ">" , ... }
+end macro xmpp-element-definer;
+
+define macro define-xmpp-element-class
+ { define-xmpp-element-class(?:name; ?real-name:name; ?superclasses:*; ?slots:*) }
+ => { define class "<" ## ?name ## ">" (?superclasses)
+ inherited slot name-with-proper-capitalization = ?"real-name";
+ ?slots
+ end }
+ { define-xmpp-element-class(?:name; none; ?superclasses:*; ?slots:*) }
+ => { define class "<" ## ?name ## ">" (?superclasses)
+ ?slots
+ end }
+
+ slots:
+ { } => { }
+ { ?slot:*; ... } => { ?slot ; ... }
+
+ slot:
+ { } => { }
+ { ?foo:* ?slot-name:name \:: ?slot-type:* } => { virtual slot ?slot-name }
+ { ?foo:* ?slot-name:name alias ?alias-name:expression \:: ?slot-type:* } => { virtual slot ?slot-name }
+
+end macro define-xmpp-element-class;
+
+define macro define-xmpp-element-initialize-setter
+ { define-xmpp-element-initialize-setter(?:name; ?foo:* ?slot-name:name \:: ?slot-type:*; ?rest:* ) }
+ => {
+ if (?slot-name)
+ ?slot-name ## "-setter" (?slot-name, ?name);
+ end if;
+ define-xmpp-element-initialize-setter(?name, ?rest)
+ }
+ { define-xmpp-element-initialize-setter(?:name; ?foo:* ?slot-name:name alias ?alias-name:expression \:: ?slot-type:*; ?rest:* ) }
+ => {
+ if (?slot-name)
+ ?slot-name ## "-setter" (?slot-name, ?name);
+ end if;
+ define-xmpp-element-initialize-setter(?name, ?rest)
+ }
+
+end macro define-xmpp-element-initialize-setter;
+
+define macro define-xmpp-element-initializer
+ { define-xmpp-element-initializer(?:name; ?slots:*) }
+ => {
+ define method initialize (?name :: "<" ## ?name ## ">", #key define-xmpp-element-initializer-keywords(?slots) , #all-keys )
+ define-xmpp-element-initialize-setter(?name, ?slots);
+ end method
+ }
+end macro define-xmpp-element-initializer;
+
+define macro define-xmpp-element-initializer-keywords
+ { define-xmpp-element-initializer-keywords(?slots:*) } => { ?slots }
+
+ slots:
+ { } => { }
+ { ?slot:*; ... } => { ?slot, ... }
+
+ slot:
+ { ?foo:* ?slot-name:name \:: ?slot-type:* } => { ?slot-name }
+ { ?foo:* ?slot-name:name alias ?alias-name:expression \:: ?slot-type:* } => { ?slot-name }
+end macro define-xmpp-element-initializer-keywords;
+
+define macro define-xmpp-element-generic-method
+ { define-xmpp-element-generic-method(?slots:*) }
+ => {
+ ?slots
+ }
+
+ slots:
+ { } => { }
+ { ?slot:*; ... } => { ?slot ... }
+
+ slot:
+ { } => { }
+ { ?foo:* ?slot-name:name \:: ?slot-type:* } =>
+ { define generic ?slot-name ## "-setter" (?slot-name :: <object>, element :: <xmpp-element>) => (res :: <object>);
+ define generic ?slot-name (element :: <xmpp-element>) => (res :: <object>);
+ }
+ { ?foo:* ?slot-name:name alias ?alias-name:expression \:: ?slot-type:* } =>
+ { define generic ?slot-name ## "-setter" (?slot-name :: <object>, element :: <xmpp-element>) => (res :: <object>);
+ define generic ?slot-name (element :: <xmpp-element>) => (res :: <object>);
+ }
+
+
+end macro define-xmpp-element-generic-method;
+
+define macro define-xmpp-element-getter-setter
+ { define-xmpp-element-getter-setter(?:name; attribute-property ?slot-name:name \:: ?slot-type:*; ?rest:*) }
+ => {
+ define method ?slot-name ## "-setter" (value, object :: ?name) => (res);
+ add-attribute(object, make(<attribute>, name: ?"slot-name", value: as(<string>, value)));
+ value;
+ end method;
+ define method ?slot-name (object :: ?name) => (res :: false-or(?slot-type));
+ let a = attribute(object, ?"slot-name");
+ a & as(?slot-type, a.attribute-value);
+ end method;
+ define-xmpp-element-getter-setter(?name; ?rest)
+ }
+
+ { define-xmpp-element-getter-setter(?:name; attribute-property ?slot-name:name alias ?alias-name:expression \:: ?slot-type:*; ?rest:*) }
+ => {
+ define method ?slot-name ## "-setter" (value, object :: ?name) => (res);
+ add-attribute(object, make(<attribute>, name: ?alias-name, value: as(<string>, value)));
+ value;
+ end method;
+ define method ?slot-name (object :: ?name) => (res :: false-or(?slot-type));
+ let a = attribute(object, ?alias-name);
+ a & as(?slot-type, a.attribute-value);
+ end method;
+ define-xmpp-element-getter-setter(?name; ?rest)
+ }
+
+
+ { define-xmpp-element-getter-setter(?:name) } => { }
+end macro define-xmpp-element-getter-setter;
+
+define xmpp-element foo-stanza ()
+ attribute-property foo-id :: <string>;
+ attribute-property foo-from :: <jid>;
+ attribute-property foo-to :: <jid>;
+ attribute-property foo-type :: <symbol>;
+ attribute-property foo-language alias "xml:lang" :: <string>;
+end xmpp-element foo-stanza;
+
+/*
+define element authentication-query ("query", "jabber:iq:auth")
+end element query;
+*/
Modified: trunk/libraries/xmpp/xmpp-exports.dylan
==============================================================================
--- trunk/libraries/xmpp/xmpp-exports.dylan (original)
+++ trunk/libraries/xmpp/xmpp-exports.dylan Sun Jun 11 00:09:32 2006
@@ -96,5 +96,12 @@
type, type-setter,
*default-language*,
print-object;
-
+
+ export xmpp-element-definer;
+ export <foo-stanza>,
+ foo-id, foo-id-setter,
+ foo-from, foo-from-setter,
+ foo-to, foo-to-setter,
+ foo-type, foo-type-setter,
+ foo-language, foo-language-setter;
end module;
Modified: trunk/libraries/xmpp/xmpp-test/xmpp-test.dylan
==============================================================================
--- trunk/libraries/xmpp/xmpp-test/xmpp-test.dylan (original)
+++ trunk/libraries/xmpp/xmpp-test/xmpp-test.dylan Sun Jun 11 00:09:32 2006
@@ -220,7 +220,7 @@
format-out("%=\n", test-document.node-children);
*/
-
+/*
let callback1 = make(<callback>, reference: #"default", priority: 3, handler: method (client, message)
format-out("CCC (1) %= %=\n", client, message);
if (message.body)
@@ -229,7 +229,6 @@
#f;
end);
-/*
let callback2 = make(<callback>, reference: #"default", priority: 2, handler: method (client, element)
format-out("CCC (2) %= %=\n", client, element);
#t;
@@ -239,7 +238,7 @@
format-out("CCC (3) %= %=\n", client, element);
#f;
end);
-*/
+
let client = make(<xmpp-client>, jid: make(<jid>, node: "dylan", domain: "pentabarf.org", resource: "xmpp"));
add-callback(client, <message>, callback1);
@@ -262,10 +261,10 @@
// send(client, make(<message>, to: "ghul at jabber.org", type: #"chat", body: "I'll echo everything you say!"));
// let result = send(client, make(<message>, to: "dylan at pentabarf.org/Psi", body: "This is turbot speaking."), awaits-result?: #t);
// format-out("### (X3) %=\n", result);
-/* while (#t)
- sleep(23);
- end while;
-*/
+// while (#t)
+// sleep(23);
+// end while;
+
join-thread(client.listener);
disconnect(client);
format-out("Connection closed. Bye\n");
@@ -274,8 +273,31 @@
exception (condition :: <condition>)
format-out("xmpp-test: Error: %=\n", condition);
end block;
+*/
+ let foobar42 = make(<foo-stanza>);
+ format-out("foo-id :: %=\n", object-class(foobar42.foo-id), foobar42.foo-id);
+ foobar42.foo-id := "test";
+ format-out("foo-id :: %=\n", object-class(foobar42.foo-id), foobar42.foo-id);
+
+ format-out("foo-to :: %=\n", object-class(foobar42.foo-to), foobar42.foo-to);
+ foobar42.foo-to := make(<jid>, node: "foo", domain: "bar");
+ format-out("foo-to :: %=\n", object-class(foobar42.foo-to), foobar42.foo-to);
+ foobar42.foo-to := "foo at bar";
+ format-out("foo-to :: %=\n", object-class(foobar42.foo-to), foobar42.foo-to);
+
+ format-out("foo-type :: %=\n", object-class(foobar42.foo-type), foobar42.foo-type);
+ foobar42.foo-type := #"test";
+ format-out("foo-type :: %=\n", object-class(foobar42.foo-type), foobar42.foo-type);
+
+ format-out("foo-language :: %=\n", object-class(foobar42.foo-language), foobar42.foo-language);
+ foobar42.foo-language := "de";
+ format-out("foo-language :: %=\n", object-class(foobar42.foo-language), foobar42.foo-language);
+
+ format-out("foobar42 = %=\n", foobar42);
+
exit-application(0);
end function main;
+
// Invoke our main() function.
main(application-name(), application-arguments());
Modified: trunk/libraries/xmpp/xmpp.lid
==============================================================================
--- trunk/libraries/xmpp/xmpp.lid (original)
+++ trunk/libraries/xmpp/xmpp.lid Sun Jun 11 00:09:32 2006
@@ -17,3 +17,4 @@
connection
client
callback
+ generator
More information about the chatter
mailing list