Thanks to DJ Adams, I have a component that can store (but not yet retrieve) JUD info from a MySQL database... I intend this to be a teaching example (for myself as well, since I'm learning), so I hope you enjoy!
#!/usr/bin/perl # juddi.pl, a JUD component that uses Database Independent libraries # # # Migs Paraz <[EMAIL PROTECTED]> November 9, 2001 # Initial release - only "Register" works, written for MySQL # License: GNU GPL, as this is a teaching example. # # TODO: # Search function # External config file. XML? # Make it easy to change database backends. # How to implement searches that take long without blocking other clients? # # Current table: # create table juddi (jid varchar(32) not null primary key, # first varchar(32), last varchar(32), # nick varchar(32), email varchar(64)) # use Jabber::Connection; use Jabber::NodeFactory; use Jabber::NS qw(:all); use DBI; use DBD::mysql; use strict; #### Configuration section #### our $config_jabber_server = "localhost:1234"; our $config_jabber_password = "test"; our $config_localname = "jud.localhost"; our $config_log = 1; # Database our $config_db_database = "jabber"; our $config_db_username = "jabber"; our $config_db_password = "imjabber"; our $config_db_table = "juddi"; # Fields for display and for database. our %config_db_fields = ("first" => "first", "last" => "last", "nick" => "nick", "email" => "email"); # This is an ordered list since it will come out in the dialog box. our @config_jud_list = ("first", "last", "nick", "email"); # Text our $config_text_search = "juddi search"; our $config_text_register = "juddi register"; ############################### # Keep state in between connections our %state; our $c = new Jabber::Connection( ns => "jabber:component:accept", server => $config_jabber_server, localname => $config_localname, log => $config_log, ); $c->connect or die "oops: ".$c->lastError; $c->register_handler('message', \&message); $c->register_handler('iq', \&iq); $c->auth($config_jabber_password); # Connect to the database. We will autocommit. # TODO allow change of db my $cn = "dbi:mysql:" . $config_db_database; our $dbh = DBI->connect($cn, $config_db_username, $config_db_password, { AutoCommit => 1 }); if (!defined ($dbh)) { # TODO: There should be a nicer reporting method. die ($dbh->errstr); } # We only have one constant select, which is for the register method. # This will come out like: # INSERT INTO juddi (jid, first, last, nick, email) VALUES (?, ?, ?, ?, ?) # jid will always be present. # This ugly loop, because Perl can't duplicate lists. my @q; for (my $i = 0; $i < $#config_jud_list + 2; $i++) { push (@q, "?"); } my $statement = "INSERT INTO " . $config_db_table . " (jid, " . join (",", map {$config_db_fields{$_}} @config_jud_list) . ") VALUES (" . join (",", @q) . ")"; our $sth_register = $dbh->prepare($statement); #### Main Loop #### $c->start(); # This never gets called since the entire loop is in the start() call. $c->disconnect(); sub message { my $node = shift; print "Message --> ", $node->toStr, "\n"; } sub iq { my $node = shift; # Different kinds of XML content # Get list for register or search. # Pretend we're not yet registered. # (Make a database for that!) if ($node->attr("type") eq IQ_GET) { my $id = $node->attr("id"); # Create a new node for the reply. my $nf = new Jabber::NodeFactory; my $tag = $nf->newNode("iq"); $tag->attr("type", IQ_RESULT); $tag->attr("from", "jud.localhost"); $tag->attr("id", $id); # Set "to" to original "from" $tag->attr("to", $node->attr("from")); my $tag2 = $tag->insertTag("query", NS_SEARCH); foreach my $k (@config_jud_list) { $tag2->insertTag($k); } # Key is needed to keep state between searches. my $key = time(); $tag2->insertTag("key")->data($key); # Store the from and id so we can reply later $state{"from"}{$key} = $node->attr("from"); my $data; if ($node->getTag("query", NS_SEARCH)) { $data = $config_text_search; } elsif ($node->getTag("query", NS_REGISTER)) { $data = $config_text_register; } $tag2->insertTag("instructions")->data($data); # Send back to client $c->send($tag); } elsif (($node->attr("type") eq IQ_SET) && (my $tag = $node->getTag("query", NS_SEARCH))) { my $id = $node->attr("id"); # Construct a bogus result. # Grab parameters and store in a hash. my %param; foreach my $k (@config_jud_list) { my $tag2 = $tag->getTag($k); if (defined ($tag2)) { $param{$k} = $tag2->data(); } } my $nf = new Jabber::NodeFactory; my $tag = $nf->newNode("iq"); $tag->attr("type", IQ_RESULT); $tag->attr("from", "jud.localhost"); $tag->attr("id", $id); # It's a reply. $tag->attr("to", $node->attr("from")); my $tag3 = $tag->insertTag("query", NS_SEARCH); my $tag4 = $tag3->insertTag("item"); # result@localhost is the dummy answer $tag4->attr("jid", "result\@localhost"); foreach my $k (@config_jud_list) { if ($param{$k}) { $tag4->insertTag($k)->data("Result " . $param{$k}); } } # Send back to client $c->send($tag); } elsif (($node->attr("type") eq IQ_SET) && ($tag = $node->getTag("query", NS_REGISTER))) { my (%param, @jud_param); # Get parameters from the XML, substituting blanks if there are no tags. foreach my $k (@config_jud_list) { my $tag2 = $tag->getTag($k); if ($tag2) { $param{$k} = $tag2->data(); push (@jud_param, $param{$k}); } else { push (@jud_param, ""); } } # Fetch the requstor ("from") from state my $key = $tag->getTag("key")->data(); # Start building the response. my $nf = new Jabber::NodeFactory; my ($tag3, $success); $tag3 = $nf->newNode("iq"); # At this point, @jud_param has the ordered list of parameters to set. # jid is in front, and does not include the resource. # (this is more elegant as a regexp but I'm not familiar with optional # matches) my $jid = $state{"from"}{$key}; $jid =~ s!/.*$!!; if (($success = $sth_register->execute($jid, @jud_param))) { # Success $tag3->attr("type", IQ_RESULT); } else { # TODO Make this registration error friendlier. $tag3->attr("type", IQ_ERROR); my $tag4 = $tag3->insertTag("error"); $tag4->attr("code", 406); $tag4->data("Database error: " . $dbh->errstr()); } # Continue composing the reply. $tag3->attr("from", $config_localname); $tag3->attr("id", $node->attr("id")); $tag3->attr("to", $state{"from"}{$key}); # Repeat the query. my $tag4 = $tag3->insertTag("query", NS_REGISTER); if ($success) { $tag4->insertTag("registered"); } foreach my $k (@config_jud_list) { if ($param{$k}) { $tag4->insertTag($k)->data($param{$k}); } } # Copy the key value. $tag4->insertTag("key")->data($key); # Send $c->send($tag3); } }