source: perl/modules/Jabber/lib/BarnOwl/Module/Jabber.pm @ a957e92

release-1.10release-1.5release-1.6release-1.7release-1.8release-1.9
Last change on this file since a957e92 was a957e92, checked in by Alex Vandiver <alexmv@mit.edu>, 15 years ago
Make Jabber try to reconnect when disconnected, at exponential intervals Make the ConnectionManager store auth information on connect, and use that auth information to try to reconnect and re-auth. Use some simple exponential backoff, capped at 5 minutes, as intervals for reconnecting.
  • Property mode set to 100644
File size: 45.7 KB
Line 
1use strict;
2use warnings;
3
4package BarnOwl::Module::Jabber;
5
6=head1 NAME
7
8BarnOwl::Module::Jabber
9
10=head1 DESCRIPTION
11
12This module implements Jabber support for barnowl.
13
14=cut
15
16use BarnOwl;
17use BarnOwl::Hooks;
18use BarnOwl::Message::Jabber;
19use BarnOwl::Module::Jabber::Connection;
20use BarnOwl::Module::Jabber::ConnectionManager;
21use BarnOwl::Completion::Util qw(complete_flags);
22
23use Authen::SASL qw(Perl);
24use Net::Jabber;
25use Net::Jabber::MUC;
26use Net::DNS;
27use Getopt::Long;
28Getopt::Long::Configure(qw(no_getopt_compat prefix_pattern=-|--));
29
30use utf8;
31
32our $VERSION = 0.1;
33
34BEGIN {
35    if(eval {require IO::Socket::SSL;}) {
36        if($IO::Socket::SSL::VERSION eq "0.97") {
37            BarnOwl::error("You are using IO::Socket:SSL 0.97, which \n" .
38                           "contains bugs causing it not to work with barnowl's\n" .
39                           "Jabber support. We recommend updating to the latest\n" .
40                           "IO::Socket::SSL from CPAN. \n");
41            die("Not loading Jabber.par\n");
42        }
43    }
44}
45
46no warnings 'redefine';
47
48################################################################################
49# owl perl jabber support
50#
51# XXX Todo:
52# Rosters for MUCs
53# More user feedback
54#  * joining MUC
55#  * parting MUC
56#  * presence (Roster and MUC)
57# Implementing formatting and logging callbacks for C
58# Appropriate callbacks for presence subscription messages.
59#
60################################################################################
61
62our $conn;
63$conn ||= BarnOwl::Module::Jabber::ConnectionManager->new;
64our %vars;
65our %completion_jids;
66
67sub onStart {
68    if ( *BarnOwl::queue_message{CODE} ) {
69        register_owl_commands();
70        register_keybindings();
71        register_filters();
72        $BarnOwl::Hooks::getBuddyList->add("BarnOwl::Module::Jabber::onGetBuddyList");
73        $BarnOwl::Hooks::getQuickstart->add("BarnOwl::Module::Jabber::onGetQuickstart");
74        $vars{show} = '';
75        BarnOwl::new_variable_bool("jabber:show_offline_buddies",
76                                   { default => 1,
77                                     summary => 'Show offline or pending buddies.'});
78        BarnOwl::new_variable_bool("jabber:show_logins",
79                                   { default => 0,
80                                     summary => 'Show login/logout messages.'});
81        BarnOwl::new_variable_bool("jabber:spew",
82                                   { default => 0,
83                                     summary => 'Display unrecognized Jabber messages.'});
84        BarnOwl::new_variable_int("jabber:auto_away_timeout",
85                                  { default => 5,
86                                    summary => 'After minutes idle, auto away.',
87                                  });
88        BarnOwl::new_variable_int("jabber:auto_xa_timeout",
89                                  { default => 15,
90                                    summary => 'After minutes idle, auto extended away.'
91                                });
92        # Force these. Reload can screw them up.
93        # Taken from Net::Jabber::Protocol.
94        $Net::XMPP::Protocol::NEWOBJECT{'iq'}       = "Net::Jabber::IQ";
95        $Net::XMPP::Protocol::NEWOBJECT{'message'}  = "Net::Jabber::Message";
96        $Net::XMPP::Protocol::NEWOBJECT{'presence'} = "Net::Jabber::Presence";
97        $Net::XMPP::Protocol::NEWOBJECT{'jid'}      = "Net::Jabber::JID";
98    } else {
99        # Our owl doesn't support queue_message. Unfortunately, this
100        # means it probably *also* doesn't support BarnOwl::error. So just
101        # give up silently.
102    }
103}
104
105$BarnOwl::Hooks::startup->add("BarnOwl::Module::Jabber::onStart");
106
107sub do_keep_alive_and_auto_away {
108    if ( !$conn->connected() ) {
109        # We don't need this timer any more.
110        delete $vars{keepAliveTimer};
111        return;
112    }
113
114    $vars{status_changed} = 0;
115    my $auto_away = BarnOwl::getvar('jabber:auto_away_timeout');
116    my $auto_xa = BarnOwl::getvar('jabber:auto_xa_timeout');
117    my $idletime = BarnOwl::getidletime();
118    if ($auto_xa != 0 && $idletime >= (60 * $auto_xa) && ($vars{show} eq 'away' || $vars{show} eq '' )) {
119        $vars{show} = 'xa';
120        $vars{status} = 'Auto extended-away after '.$auto_xa.' minute'.($auto_xa == 1 ? '' : 's').' idle.';
121        $vars{status_changed} = 1;
122    } elsif ($auto_away != 0 && $idletime >= (60 * $auto_away) && $vars{show} eq '') {
123        $vars{show} = 'away';
124        $vars{status} = 'Auto away after '.$auto_away.' minute'.($auto_away == 1 ? '' : 's').' idle.';
125        $vars{status_changed} = 1;
126    } elsif ($idletime <= $vars{idletime} && $vars{show} ne '') {
127        $vars{show} = '';
128        $vars{status} = '';
129        $vars{status_changed} = 1;
130    }
131    $vars{idletime} = $idletime;
132
133    foreach my $jid ( $conn->getJIDs() ) {
134
135        next unless $conn->jidActive($jid) or $conn->tryReconnect($jid);
136
137        my $client = $conn->getConnectionFromJID($jid);
138        unless($client) {
139            $conn->removeConnection($jid);
140            BarnOwl::error("Connection for $jid undefined -- error in reload?");
141        }
142        my $status = $client->Process(0); # keep-alive
143        if ( !defined($status) ) {
144            $conn->scheduleReconnect($jid);
145        }
146        if ($::shutdown) {
147            do_logout($jid);
148            next;
149        }
150
151        if ($vars{status_changed}) {
152            my $p = new Net::Jabber::Presence;
153            $p->SetShow($vars{show}) if $vars{show};
154            $p->SetStatus($vars{status}) if $vars{status};
155            $client->Send($p);
156        }
157    }
158}
159
160our $showOffline = 0;
161
162sub blist_listBuddy {
163    my $roster = shift;
164    my $buddy  = shift;
165    my $blistStr .= "    ";
166    my %jq  = $roster->query($buddy);
167    my $res = $roster->resource($buddy);
168
169    my $name = $jq{name} || $buddy->GetUserID();
170
171    $blistStr .= sprintf '%-15s %s', $name, $buddy->GetJID();
172    $completion_jids{$name} = 1;
173    $completion_jids{$buddy->GetJID()} = 1;
174
175    if ($res) {
176        my %rq = $roster->resourceQuery( $buddy, $res );
177        $blistStr .= " [" . ( $rq{show} ? $rq{show} : 'online' ) . "]";
178        $blistStr .= " " . $rq{status} if $rq{status};
179        $blistStr = BarnOwl::Style::boldify($blistStr) if $showOffline;
180    }
181    else {
182        return '' unless $showOffline;
183        if ($jq{ask}) {
184            $blistStr .= " [pending]";
185        }
186        elsif ($jq{subscription} eq 'none' || $jq{subscription} eq 'from') {
187            $blistStr .= " [not subscribed]";
188        }
189        else {
190            $blistStr .= " [offline]";
191        }
192    }
193    return $blistStr . "\n";
194}
195
196# Sort, ignoring markup.
197sub blistSort {
198    return uc(BarnOwl::ztext_stylestrip($a)) cmp uc(BarnOwl::ztext_stylestrip($b));
199}
200
201sub getSingleBuddyList {
202    my $jid = shift;
203    $jid = resolveConnectedJID($jid);
204    return "" unless $jid;
205    my $blist = "";
206    my $roster = $conn->getRosterFromJID($jid);
207    if ($roster) {
208        $blist .= "\n" . BarnOwl::Style::boldify("Jabber roster for $jid\n");
209
210        my @gTexts = ();
211        foreach my $group ( $roster->groups() ) {
212            my @buddies = $roster->jids( 'group', $group );
213            my @bTexts = ();
214            foreach my $buddy ( @buddies ) {
215                push(@bTexts, blist_listBuddy( $roster, $buddy ));
216            }
217            push(@gTexts, "  Group: $group\n".join('',sort blistSort @bTexts));
218        }
219        # Sort groups before adding ungrouped entries.
220        @gTexts = sort blistSort @gTexts;
221
222        my @unsorted = $roster->jids('nogroup');
223        if (@unsorted) {
224            my @bTexts = ();
225            foreach my $buddy (@unsorted) {
226                push(@bTexts, blist_listBuddy( $roster, $buddy ));
227            }
228            push(@gTexts, "  [unsorted]\n".join('',sort blistSort @bTexts));
229        }
230        $blist .= join('', @gTexts);
231    }
232    return $blist;
233}
234
235sub onGetBuddyList {
236    $showOffline = BarnOwl::getvar('jabber:show_offline_buddies') eq 'on';
237    my $blist = "";
238    foreach my $jid ($conn->getJIDs()) {
239        $blist .= getSingleBuddyList($jid);
240    }
241    return $blist;
242}
243
244sub onGetQuickstart {
245    return <<'EOF'
246@b(Jabber:)
247Type ':jabberlogin @b(username@mit.edu)' to log in to Jabber. The command
248':jroster sub @b(somebody@gmail.com)' will request that they let you message
249them. Once you get a message saying you are subscribed, you can message
250them by typing ':jwrite @b(somebody@gmail.com)' or just 'j @b(somebody)'.
251EOF
252}
253
254################################################################################
255### Owl Commands
256sub register_owl_commands() {
257    BarnOwl::new_command(
258        jabberlogin => \&cmd_login,
259        {
260            summary => "Log in to Jabber",
261            usage   => "jabberlogin <jid> [<password>]"
262        }
263    );
264    BarnOwl::new_command(
265        jabberlogout => \&cmd_logout,
266        {
267            summary => "Log out of Jabber",
268            usage   => "jabberlogout [-A|<jid>]",
269            description => "jabberlogout logs you out of Jabber.\n\n"
270              . "If you are connected to one account, no further arguments are necessary.\n\n"
271              . "-A            Log out of all accounts.\n"
272              . "<jid>         Which account to log out of.\n"
273        }
274    );
275    BarnOwl::new_command(
276        jwrite => \&cmd_jwrite,
277        {
278            summary => "Send a Jabber Message",
279            usage   => "jwrite <jid> [-t <thread>] [-s <subject>]"
280        }
281    );
282    BarnOwl::new_command(
283        jaway => \&cmd_jaway,
284        {
285            summary => "Set Jabber away / presence information",
286            usage   => "jaway [-s online|dnd|...] [<message>]"
287        }
288    );
289    BarnOwl::new_command(
290        jlist => \&cmd_jlist,
291        {
292            summary => "Show your Jabber roster.",
293            usage   => "jlist"
294        }
295    );
296    BarnOwl::new_command(
297        jmuc => \&cmd_jmuc,
298        {
299            summary     => "Jabber MUC related commands.",
300            description => "jmuc sends Jabber commands related to MUC.\n\n"
301              . "The following commands are available\n\n"
302              . "join <muc>  Join a MUC.\n\n"
303              . "part <muc>  Part a MUC.\n"
304              . "            The MUC is taken from the current message if not supplied.\n\n"
305              . "invite <jid> [<muc>]\n"
306              . "            Invite <jid> to <muc>.\n"
307              . "            The MUC is taken from the current message if not supplied.\n\n"
308              . "configure [<muc>]\n"
309              . "            Configures a MUC.\n"
310              . "            Necessary to initalize a new MUC.\n"
311              . "            At present, only the default configuration is supported.\n"
312              . "            The MUC is taken from the current message if not supplied.\n\n"
313              . "presence [<muc>]\n"
314              . "            Shows the roster for <muc>.\n"
315              . "            The MUC is taken from the current message if not supplied.\n\n"
316              . "presence -a\n"
317              . "            Shows rosters for all MUCs you're participating in.\n\n",
318            usage => "jmuc <command> [<args>]"
319        }
320    );
321    BarnOwl::new_command(
322        jroster => \&cmd_jroster,
323        {
324            summary     => "Jabber roster related commands.",
325            description => "jroster sends Jabber commands related to rosters.\n\n"
326              . "The following commands are available\n\n"
327              . "sub <jid>     Subscribe to <jid>'s presence. (implicit add)\n\n"
328              . "add <jid>     Adds <jid> to your roster.\n\n"
329              . "unsub <jid>   Unsubscribe from <jid>'s presence.\n\n"
330              . "remove <jid>  Removes <jid> from your roster. (implicit unsub)\n\n"
331              . "auth <jid>    Authorizes <jid> to subscribe to your presence.\n\n"
332              . "deauth <jid>  De-authorizes <jid>'s subscription to your presence.\n\n"
333              . "The following arguments are supported for all commands\n\n"
334              . "-a <jid>      Specify which account to make the roster changes on.\n"
335              . "              Required if you're signed into more than one account.\n\n"
336              . "The following arguments only work with the add and sub commands.\n\n"
337              . "-g <group>    Add <jid> to group <group>.\n"
338              . "              May be specified more than once, will not remove <jid> from any groups.\n\n"
339              . "-p            Purge. Removes <jid> from all groups.\n"
340              . "              May be combined with -g.\n\n"
341              . "-n <name>     Sets <name> as <jid>'s short name.\n\n"
342              . "Note: Unless -n is used, you can specify multiple <jid> arguments.\n",
343            usage       => "jroster <command> <args>"
344        }
345    );
346}
347
348sub register_keybindings {
349    BarnOwl::bindkey(qw(recv j command start-command), 'jwrite ');
350}
351
352sub register_filters {
353    BarnOwl::filter(qw(jabber type ^jabber$));
354}
355
356sub cmd_login {
357    my $cmd = shift;
358    my $jidStr = shift;
359    my $jid = new Net::Jabber::JID;
360    $jid->SetJID($jidStr);
361    my $password = '';
362    $password = shift if @_;
363
364    my $uid           = $jid->GetUserID();
365    my $componentname = $jid->GetServer();
366    my $resource      = $jid->GetResource();
367
368    if ($resource eq '') {
369        my $cjidStr = $conn->baseJIDExists($jidStr);
370        if ($cjidStr) {
371            BarnOwl::error("Already logged in as $cjidStr.");
372            return;
373        }
374    }
375
376    $resource ||= 'barnowl';
377    $jid->SetResource($resource);
378    $jidStr = $jid->GetJID('full');
379
380    if ( !$uid || !$componentname ) {
381        BarnOwl::error("usage: $cmd JID");
382        return;
383    }
384
385    if ( $conn->jidActive($jidStr) ) {
386        BarnOwl::error("Already logged in as $jidStr.");
387        return;
388    } elsif ($conn->jidExists($jidStr)) {
389        return $conn->tryReconnect($jidStr, 1);
390    }
391
392    my ( $server, $port ) = getServerFromJID($jid);
393
394    $vars{jlogin_jid} = $jidStr;
395    $vars{jlogin_connhash} = {
396        hostname      => $server,
397        tls           => 1,
398        port          => $port,
399        componentname => $componentname
400    };
401    $vars{jlogin_authhash} =
402      { username => $uid,
403        resource => $resource,
404    };
405
406    return do_login($password);
407}
408
409sub do_login {
410    $vars{jlogin_password} = shift;
411    $vars{jlogin_authhash}->{password} = sub { return $vars{jlogin_password} || '' };
412    my $jidStr = $vars{jlogin_jid};
413    if ( !$jidStr && $vars{jlogin_havepass}) {
414        BarnOwl::error("Got password but have no JID!");
415    }
416    else
417    {
418        my $client = $conn->addConnection($jidStr);
419
420        #XXX Todo: Add more callbacks.
421        # * MUC presence handlers
422        # We use the anonymous subrefs in order to have the correct behavior
423        # when we reload
424        $client->SetMessageCallBacks(
425            chat      => sub { BarnOwl::Module::Jabber::process_incoming_chat_message(@_) },
426            error     => sub { BarnOwl::Module::Jabber::process_incoming_error_message(@_) },
427            groupchat => sub { BarnOwl::Module::Jabber::process_incoming_groupchat_message(@_) },
428            headline  => sub { BarnOwl::Module::Jabber::process_incoming_headline_message(@_) },
429            normal    => sub { BarnOwl::Module::Jabber::process_incoming_normal_message(@_) }
430        );
431        $client->SetPresenceCallBacks(
432            available    => sub { BarnOwl::Module::Jabber::process_presence_available(@_) },
433            unavailable  => sub { BarnOwl::Module::Jabber::process_presence_available(@_) },
434            subscribe    => sub { BarnOwl::Module::Jabber::process_presence_subscribe(@_) },
435            subscribed   => sub { BarnOwl::Module::Jabber::process_presence_subscribed(@_) },
436            unsubscribe  => sub { BarnOwl::Module::Jabber::process_presence_unsubscribe(@_) },
437            unsubscribed => sub { BarnOwl::Module::Jabber::process_presence_unsubscribed(@_) },
438            error        => sub { BarnOwl::Module::Jabber::process_presence_error(@_) });
439
440        my $status = $client->Connect( %{ $vars{jlogin_connhash} } );
441        if ( !$status ) {
442            $conn->removeConnection($jidStr);
443            BarnOwl::error("We failed to connect.");
444        } else {
445            my @result = $client->AuthSend( %{ $vars{jlogin_authhash} } );
446
447            if ( !@result || $result[0] ne 'ok' ) {
448                if ( !$vars{jlogin_havepass} && ( !@result || $result[0] eq '401' || $result[0] eq 'error') ) {
449                    $vars{jlogin_havepass} = 1;
450                    $conn->removeConnection($jidStr);
451                    BarnOwl::start_password("Password for $jidStr: ", \&do_login );
452                    return "";
453                }
454                $conn->removeConnection($jidStr);
455                BarnOwl::error( "Error in connect: " . join( " ", @result ) );
456            } else {
457                $conn->setAuth(
458                    $jidStr,
459                    {   %{ $vars{jlogin_authhash} },
460                        password => $vars{jlogin_password}
461                    }
462                );
463                my $roster = $conn->getRosterFromJID($jidStr);
464                $roster->fetch();
465                $client->PresenceSend( priority => 1 );
466                my $fullJid = $client->{SESSION}->{FULLJID} || $jidStr;
467                $conn->renameConnection($jidStr, $fullJid);
468                queue_admin_msg("Connected to jabber as $fullJid");
469                # The remove_dispatch() method is called from the
470                # ConnectionManager's removeConnection() method.
471                $client->{fileno} = $client->getSocket()->fileno();
472                #queue_admin_msg("Connected to jabber as $fullJid ($client->{fileno})");
473                BarnOwl::add_dispatch($client->{fileno}, sub { $client->OwlProcess($fullJid) });
474
475                # populate completion from roster.
476                for my $buddy ( $roster->jids('all') ) {
477                    my %jq  = $roster->query($buddy);
478                    my $name = $jq{name} || $buddy->GetUserID();
479                    $completion_jids{$name} = 1;
480                    $completion_jids{$buddy->GetJID()} = 1;
481                }
482                $vars{idletime} |= BarnOwl::getidletime();
483                unless (exists $vars{keepAliveTimer}) {
484                    $vars{keepAliveTimer} = BarnOwl::Timer->new({
485                        'after' => 5,
486                        'interval' => 5,
487                        'cb' => sub { BarnOwl::Module::Jabber::do_keep_alive_and_auto_away(@_) }
488                                                                });
489                }
490            }
491        }
492    }
493    delete $vars{jlogin_jid};
494    $vars{jlogin_password} =~ tr/\0-\377/x/ if $vars{jlogin_password};
495    delete $vars{jlogin_password};
496    delete $vars{jlogin_havepass};
497    delete $vars{jlogin_connhash};
498    delete $vars{jlogin_authhash};
499
500    return "";
501}
502
503sub do_logout {
504    my $jid = shift;
505    my $disconnected = $conn->removeConnection($jid);
506    queue_admin_msg("Jabber disconnected ($jid).") if $disconnected;
507}
508
509sub cmd_logout {
510    return "You are not logged into Jabber." unless ($conn->connected() > 0);
511    # Logged into multiple accounts
512    if ( $conn->connected() > 1 ) {
513        # Logged into multiple accounts, no accout specified.
514        if ( !$_[1] ) {
515            my $errStr =
516              "You are logged into multiple accounts. Please specify an account to log out of.\n";
517            foreach my $jid ( $conn->getJIDs() ) {
518                $errStr .= "\t$jid\n";
519            }
520            queue_admin_msg($errStr);
521        }
522        # Logged into multiple accounts, account specified.
523        else {
524            if ( $_[1] eq '-A' )    #All accounts.
525            {
526                foreach my $jid ( $conn->getJIDs() ) {
527                    do_logout($jid);
528                }
529            }
530            else                    #One account.
531            {
532                my $jid = resolveConnectedJID( $_[1] );
533                do_logout($jid) if ( $jid ne '' );
534            }
535        }
536    }
537    else                            # Only one account logged in.
538    {
539        do_logout( ( $conn->getJIDs() )[0] );
540    }
541    return "";
542}
543
544sub cmd_jlist {
545    if ( !( scalar $conn->getJIDs() ) ) {
546        BarnOwl::error("You are not logged in to Jabber.");
547        return;
548    }
549    BarnOwl::popless_ztext( onGetBuddyList() );
550}
551
552sub cmd_jwrite {
553    if ( !$conn->connected() ) {
554        BarnOwl::error("You are not logged in to Jabber.");
555        return;
556    }
557
558    my $jwrite_to      = "";
559    my $jwrite_from    = "";
560    my $jwrite_sid     = "";
561    my $jwrite_thread  = "";
562    my $jwrite_subject = "";
563    my ($to, $from);
564    my $jwrite_type    = "chat";
565
566    my @args = @_;
567    shift;
568    local @ARGV = @_;
569    my $gc;
570    GetOptions(
571        'thread=s'  => \$jwrite_thread,
572        'subject=s' => \$jwrite_subject,
573        'account=s' => \$from,
574        'id=s'     =>  \$jwrite_sid,
575    ) or die("Usage: jwrite <jid> [-t <thread>] [-s <subject>] [-a <account>]\n");
576    $jwrite_type = 'groupchat' if $gc;
577
578    if ( scalar @ARGV != 1 ) {
579        BarnOwl::error(
580            "Usage: jwrite <jid> [-t <thread>] [-s <subject>] [-a <account>]");
581        return;
582    }
583    else {
584      $to = shift @ARGV;
585    }
586
587    my @candidates = guess_jwrite($from, $to);
588
589    unless(scalar @candidates) {
590        die("Unable to resolve JID $to");
591    }
592
593    @candidates = grep {defined $_->[0]} @candidates;
594
595    unless(scalar @candidates) {
596        if(!$from) {
597            die("You must specify an account with -a");
598        } else {
599            die("Unable to resolve account $from");
600        }
601    }
602
603
604    ($jwrite_from, $jwrite_to, $jwrite_type) = @{$candidates[0]};
605
606    $vars{jwrite} = {
607        to      => $jwrite_to,
608        from    => $jwrite_from,
609        sid     => $jwrite_sid,
610        subject => $jwrite_subject,
611        thread  => $jwrite_thread,
612        type    => $jwrite_type
613    };
614
615    if(scalar @candidates > 1) {
616        BarnOwl::message(
617            "Warning: Guessing account and/or destination JID"
618           );
619    } else  {
620        BarnOwl::message(
621            "Type your message below.  End with a dot on a line by itself.  ^C will quit."
622           );
623    }
624
625    my @cmd = ('jwrite', $jwrite_to, '-a', $jwrite_from);
626    push @cmd, '-t', $jwrite_thread if $jwrite_thread;
627    push @cmd, '-s', $jwrite_subject if $jwrite_subject;
628
629    BarnOwl::start_edit_win(BarnOwl::quote(@cmd), \&process_owl_jwrite);
630}
631
632sub cmd_jmuc {
633    die "You are not logged in to Jabber" unless $conn->connected();
634    my $ocmd = shift;
635    my $cmd  = shift;
636    if ( !$cmd ) {
637
638        #XXX TODO: Write general usage for jmuc command.
639        return;
640    }
641
642    my %jmuc_commands = (
643        join      => \&jmuc_join,
644        part      => \&jmuc_part,
645        invite    => \&jmuc_invite,
646        configure => \&jmuc_configure,
647        presence  => \&jmuc_presence
648    );
649    my $func = $jmuc_commands{$cmd};
650    if ( !$func ) {
651        BarnOwl::error("jmuc: Unknown command: $cmd");
652        return;
653    }
654
655    {
656        local @ARGV = @_;
657        my $jid;
658        my $muc;
659        my $m = BarnOwl::getcurmsg();
660        if ( $m && $m->is_jabber && $m->{jtype} eq 'groupchat' ) {
661            $muc = $m->{room};
662            $jid = $m->{to};
663        }
664
665        my $getopt = Getopt::Long::Parser->new;
666        $getopt->configure('pass_through', 'no_getopt_compat');
667        $getopt->getoptions( 'account=s' => \$jid );
668        $jid ||= defaultJID();
669        if ($jid) {
670            $jid = resolveConnectedJID($jid);
671            return unless $jid;
672        }
673        else {
674            BarnOwl::error('You must specify an account with -a <jid>');
675        }
676        return $func->( $jid, $muc, @ARGV );
677    }
678}
679
680sub jmuc_join {
681    my ( $jid, $muc, @args ) = @_;
682    local @ARGV = @args;
683    my $password;
684    GetOptions( 'password=s' => \$password );
685
686    $muc = shift @ARGV
687      or die("Usage: jmuc join <muc> [-p <password>] [-a <account>]");
688
689    die("Error: Must specify a fully-qualified MUC name (e.g. barnowl\@conference.mit.edu)\n")
690        unless $muc =~ /@/;
691    $muc = Net::Jabber::JID->new($muc);
692    $jid = Net::Jabber::JID->new($jid);
693    $muc->SetResource($jid->GetJID('full')) unless length $muc->GetResource();
694
695    $conn->getConnectionFromJID($jid)->MUCJoin(JID      => $muc,
696                                               Password => $password,
697                                               History  => {
698                                                   MaxChars => 0
699                                                  });
700    $completion_jids{$muc} = 1;
701    return;
702}
703
704sub jmuc_part {
705    my ( $jid, $muc, @args ) = @_;
706
707    $muc = shift @args if scalar @args;
708    die("Usage: jmuc part [<muc>] [-a <account>]") unless $muc;
709
710    if($conn->getConnectionFromJID($jid)->MUCLeave(JID => $muc)) {
711        queue_admin_msg("$jid has left $muc.");
712    } else {
713        die("Error: Not joined to $muc");
714    }
715}
716
717sub jmuc_invite {
718    my ( $jid, $muc, @args ) = @_;
719
720    my $invite_jid = shift @args;
721    $muc = shift @args if scalar @args;
722
723    die('Usage: jmuc invite <jid> [<muc>] [-a <account>]')
724      unless $muc && $invite_jid;
725
726    my $message = Net::Jabber::Message->new();
727    $message->SetTo($muc);
728    my $x = $message->NewChild('http://jabber.org/protocol/muc#user');
729    $x->AddInvite();
730    $x->GetInvite()->SetTo($invite_jid);
731    $conn->getConnectionFromJID($jid)->Send($message);
732    queue_admin_msg("$jid has invited $invite_jid to $muc.");
733}
734
735sub jmuc_configure {
736    my ( $jid, $muc, @args ) = @_;
737    $muc = shift @args if scalar @args;
738    die("Usage: jmuc configure [<muc>]") unless $muc;
739    my $iq = Net::Jabber::IQ->new();
740    $iq->SetTo($muc);
741    $iq->SetType('set');
742    my $query = $iq->NewQuery("http://jabber.org/protocol/muc#owner");
743    my $x     = $query->NewChild("jabber:x:data");
744    $x->SetType('submit');
745
746    $conn->getConnectionFromJID($jid)->Send($iq);
747    queue_admin_msg("Accepted default instant configuration for $muc");
748}
749
750sub jmuc_presence_single {
751    my $m = shift;
752    my @jids = $m->Presence();
753
754    my $presence = "JIDs present in " . $m->BaseJID;
755    $completion_jids{$m->BaseJID} = 1;
756    if($m->Anonymous) {
757        $presence .= " [anonymous MUC]";
758    }
759    $presence .= "\n\t";
760    $presence .= join("\n\t", map {pp_jid($m, $_);} @jids) . "\n";
761    return $presence;
762}
763
764sub pp_jid {
765    my ($m, $jid) = @_;
766    my $nick = $jid->GetResource;
767    my $full = $m->GetFullJID($jid);
768    if($full && $full ne $nick) {
769        return "$nick ($full)";
770    } else {
771        return "$nick";
772    }
773}
774
775sub jmuc_presence {
776    my ( $jid, $muc, @args ) = @_;
777
778    $muc = shift @args if scalar @args;
779    die("Usage: jmuc presence [<muc>]") unless $muc;
780
781    if ($muc eq '-a') {
782        my $str = "";
783        foreach my $jid ($conn->getJIDs()) {
784            $str .= BarnOwl::Style::boldify("Conferences for $jid:\n");
785            my $connection = $conn->getConnectionFromJID($jid);
786            foreach my $muc ($connection->MUCs) {
787                $str .= jmuc_presence_single($muc)."\n";
788            }
789        }
790        BarnOwl::popless_ztext($str);
791    }
792    else {
793        my $m = $conn->getConnectionFromJID($jid)->FindMUC(jid => $muc);
794        die("No such muc: $muc") unless $m;
795        BarnOwl::popless_ztext(jmuc_presence_single($m));
796    }
797}
798
799
800#XXX TODO: Consider merging this with jmuc and selecting off the first two args.
801sub cmd_jroster {
802    die "You are not logged in to Jabber" unless $conn->connected();
803    my $ocmd = shift;
804    my $cmd  = shift;
805    if ( !$cmd ) {
806
807        #XXX TODO: Write general usage for jroster command.
808        return;
809    }
810
811    my %jroster_commands = (
812        sub      => \&jroster_sub,
813        unsub    => \&jroster_unsub,
814        add      => \&jroster_add,
815        remove   => \&jroster_remove,
816        auth     => \&jroster_auth,
817        deauth   => \&jroster_deauth
818    );
819    my $func = $jroster_commands{$cmd};
820    if ( !$func ) {
821        BarnOwl::error("jroster: Unknown command: $cmd");
822        return;
823    }
824
825    {
826        local @ARGV = @_;
827        my $jid;
828        my $name;
829        my @groups;
830        my $purgeGroups;
831        my $getopt = Getopt::Long::Parser->new;
832        $getopt->configure('pass_through', 'no_getopt_compat');
833        $getopt->getoptions(
834            'account=s' => \$jid,
835            'group=s' => \@groups,
836            'purgegroups' => \$purgeGroups,
837            'name=s' => \$name
838        );
839        $jid ||= defaultJID();
840        if ($jid) {
841            $jid = resolveConnectedJID($jid);
842            return unless $jid;
843        }
844        else {
845            BarnOwl::error('You must specify an account with -a <jid>');
846        }
847        return $func->( $jid, $name, \@groups, $purgeGroups,  @ARGV );
848    }
849}
850
851sub cmd_jaway {
852    my $cmd = shift;
853    local @ARGV = @_;
854    my $getopt = Getopt::Long::Parser->new;
855    my ($jid, $show);
856    my $p = new Net::Jabber::Presence;
857
858    $getopt->configure('pass_through', 'no_getopt_compat');
859    $getopt->getoptions(
860        'account=s' => \$jid,
861        'show=s'    => \$show
862    );
863    $jid ||= defaultJID();
864    if ($jid) {
865        $jid = resolveConnectedJID($jid);
866        return unless $jid;
867    }
868    else {
869        BarnOwl::error('You must specify an account with -a <jid>');
870    }
871
872    $p->SetShow($show eq "online" ? "" : $show) if $show;
873    $p->SetStatus(join(' ', @ARGV)) if @ARGV;
874    $conn->getConnectionFromJID($jid)->Send($p);
875}
876
877
878sub jroster_sub {
879    my $jid = shift;
880    my $name = shift;
881    my @groups = @{ shift() };
882    my $purgeGroups = shift;
883    my $baseJID = baseJID($jid);
884
885    my $roster = $conn->getRosterFromJID($jid);
886
887    # Adding lots of users with the same name is a bad idea.
888    $name = "" unless (1 == scalar(@ARGV));
889
890    my $p = new Net::Jabber::Presence;
891    $p->SetType('subscribe');
892
893    foreach my $to (@ARGV) {
894        jroster_add($jid, $name, \@groups, $purgeGroups, ($to)) unless ($roster->exists($to));
895
896        $p->SetTo($to);
897        $conn->getConnectionFromJID($jid)->Send($p);
898        queue_admin_msg("You ($baseJID) have requested a subscription to ($to)'s presence.");
899    }
900}
901
902sub jroster_unsub {
903    my $jid = shift;
904    my $name = shift;
905    my @groups = @{ shift() };
906    my $purgeGroups = shift;
907    my $baseJID = baseJID($jid);
908
909    my $p = new Net::Jabber::Presence;
910    $p->SetType('unsubscribe');
911    foreach my $to (@ARGV) {
912        $p->SetTo($to);
913        $conn->getConnectionFromJID($jid)->Send($p);
914        queue_admin_msg("You ($baseJID) have unsubscribed from ($to)'s presence.");
915    }
916}
917
918sub jroster_add {
919    my $jid = shift;
920    my $name = shift;
921    my @groups = @{ shift() };
922    my $purgeGroups = shift;
923    my $baseJID = baseJID($jid);
924
925    my $roster = $conn->getRosterFromJID($jid);
926
927    # Adding lots of users with the same name is a bad idea.
928    $name = "" unless (1 == scalar(@ARGV));
929
930    $completion_jids{$baseJID} = 1;
931    $completion_jids{$name} = 1 if $name;
932
933    foreach my $to (@ARGV) {
934        my %jq  = $roster->query($to);
935        my $iq = new Net::Jabber::IQ;
936        $iq->SetType('set');
937        my $item = new XML::Stream::Node('item');
938        $iq->NewChild('jabber:iq:roster')->AddChild($item);
939
940        my %allGroups = ();
941
942        foreach my $g (@groups) {
943            $allGroups{$g} = $g;
944        }
945
946        unless ($purgeGroups) {
947            foreach my $g (@{$jq{groups}}) {
948                $allGroups{$g} = $g;
949            }
950        }
951
952        foreach my $g (keys %allGroups) {
953            $item->add_child('group')->add_cdata($g);
954        }
955
956        $item->put_attrib(jid => $to);
957        $item->put_attrib(name => $name) if $name;
958        $conn->getConnectionFromJID($jid)->Send($iq);
959        my $msg = "$baseJID: "
960          . ($name ? "$name ($to)" : "($to)")
961          . " is on your roster in the following groups: { "
962          . join(" , ", keys %allGroups)
963          . " }";
964        queue_admin_msg($msg);
965    }
966}
967
968sub jroster_remove {
969    my $jid = shift;
970    my $name = shift;
971    my @groups = @{ shift() };
972    my $purgeGroups = shift;
973    my $baseJID = baseJID($jid);
974
975    my $iq = new Net::Jabber::IQ;
976    $iq->SetType('set');
977    my $item = new XML::Stream::Node('item');
978    $iq->NewChild('jabber:iq:roster')->AddChild($item);
979    $item->put_attrib(subscription=> 'remove');
980    foreach my $to (@ARGV) {
981        $item->put_attrib(jid => $to);
982        $conn->getConnectionFromJID($jid)->Send($iq);
983        queue_admin_msg("You ($baseJID) have removed ($to) from your roster.");
984    }
985}
986
987sub jroster_auth {
988    my $jid = shift;
989    my $name = shift;
990    my @groups = @{ shift() };
991    my $purgeGroups = shift;
992    my $baseJID = baseJID($jid);
993
994    my $p = new Net::Jabber::Presence;
995    $p->SetType('subscribed');
996    foreach my $to (@ARGV) {
997        $p->SetTo($to);
998        $conn->getConnectionFromJID($jid)->Send($p);
999        queue_admin_msg("($to) has been subscribed to your ($baseJID) presence.");
1000    }
1001}
1002
1003sub jroster_deauth {
1004    my $jid = shift;
1005    my $name = shift;
1006    my @groups = @{ shift() };
1007    my $purgeGroups = shift;
1008    my $baseJID = baseJID($jid);
1009
1010    my $p = new Net::Jabber::Presence;
1011    $p->SetType('unsubscribed');
1012    foreach my $to (@ARGV) {
1013        $p->SetTo($to);
1014        $conn->getConnectionFromJID($jid)->Send($p);
1015        queue_admin_msg("($to) has been unsubscribed from your ($baseJID) presence.");
1016    }
1017}
1018
1019################################################################################
1020### Owl Callbacks
1021sub process_owl_jwrite {
1022    my $body = shift;
1023
1024    my $j = new Net::Jabber::Message;
1025    $body =~ s/\n\z//;
1026    $j->SetMessage(
1027        to   => $vars{jwrite}{to},
1028        from => $vars{jwrite}{from},
1029        type => $vars{jwrite}{type},
1030        body => $body
1031    );
1032
1033    $j->SetThread( $vars{jwrite}{thread} )   if ( $vars{jwrite}{thread} );
1034    $j->SetSubject( $vars{jwrite}{subject} ) if ( $vars{jwrite}{subject} );
1035
1036    my $m = j2o( $j, { direction => 'out' } );
1037    if ( $vars{jwrite}{type} ne 'groupchat') {
1038        BarnOwl::queue_message($m);
1039    }
1040
1041    $j->RemoveFrom(); # Kludge to get around gtalk's random bits after the resource.
1042    if ($vars{jwrite}{sid} && $conn->sidExists( $vars{jwrite}{sid} )) {
1043        $conn->getConnectionFromSid($vars{jwrite}{sid})->Send($j);
1044    }
1045    else {
1046        $conn->getConnectionFromJID($vars{jwrite}{from})->Send($j);
1047    }
1048
1049    delete $vars{jwrite};
1050    BarnOwl::message("");   # Kludge to make the ``type your message...'' message go away
1051}
1052
1053### XMPP Callbacks
1054
1055sub process_incoming_chat_message {
1056    my ( $sid, $j ) = @_;
1057    if ($j->DefinedBody()) {
1058        BarnOwl::queue_message( j2o( $j, { direction => 'in',
1059                                           sid => $sid } ) );
1060    }
1061}
1062
1063sub process_incoming_error_message {
1064    my ( $sid, $j ) = @_;
1065    my %jhash = j2hash( $j, { direction => 'in',
1066                              sid => $sid } );
1067    $jhash{type} = 'admin';
1068   
1069    BarnOwl::queue_message( BarnOwl::Message->new(%jhash) );
1070}
1071
1072sub process_incoming_groupchat_message {
1073    my ( $sid, $j ) = @_;
1074
1075    # HACK IN PROGRESS (ignoring delayed messages)
1076    return if ( $j->DefinedX('jabber:x:delay') && $j->GetX('jabber:x:delay') );
1077    BarnOwl::queue_message( j2o( $j, { direction => 'in',
1078                                   sid => $sid } ) );
1079}
1080
1081sub process_incoming_headline_message {
1082    my ( $sid, $j ) = @_;
1083    BarnOwl::queue_message( j2o( $j, { direction => 'in',
1084                                   sid => $sid } ) );
1085}
1086
1087sub process_incoming_normal_message {
1088    my ( $sid, $j ) = @_;
1089    my %jhash = j2hash( $j, { direction => 'in',
1090                              sid => $sid } );
1091
1092    # XXX TODO: handle things such as MUC invites here.
1093
1094    #    if ($j->HasX('http://jabber.org/protocol/muc#user'))
1095    #    {
1096    #   my $x = $j->GetX('http://jabber.org/protocol/muc#user');
1097    #   if ($x->HasChild('invite'))
1098    #   {
1099    #       $props
1100    #   }
1101    #    }
1102    #
1103    if(BarnOwl::getvar('jabber:spew') eq 'on') {
1104        BarnOwl::queue_message( BarnOwl::Message->new(%jhash) );
1105    }
1106}
1107
1108sub process_muc_presence {
1109    my ( $sid, $p ) = @_;
1110    return unless ( $p->HasX('http://jabber.org/protocol/muc#user') );
1111}
1112
1113
1114sub process_presence_available {
1115    my ( $sid, $p ) = @_;
1116    my $from = $p->GetFrom('jid')->GetJID('base');
1117    $completion_jids{$from} = 1;
1118    return unless (BarnOwl::getvar('jabber:show_logins') eq 'on');
1119    my $to = $p->GetTo();
1120    my $type = $p->GetType();
1121    my %props = (
1122        to => $to,
1123        from => $p->GetFrom(),
1124        recipient => $to,
1125        sender => $from,
1126        type => 'jabber',
1127        jtype => $p->GetType(),
1128        status => $p->GetStatus(),
1129        show => $p->GetShow(),
1130        xml => $p->GetXML(),
1131        direction => 'in');
1132
1133    if ($type eq '' || $type eq 'available') {
1134        $props{body} = "$from is now online. ";
1135        $props{loginout} = 'login';
1136    }
1137    else {
1138        $props{body} = "$from is now offline. ";
1139        $props{loginout} = 'logout';
1140    }
1141    BarnOwl::queue_message(BarnOwl::Message->new(%props));
1142}
1143
1144sub process_presence_subscribe {
1145    my ( $sid, $p ) = @_;
1146    my $from = $p->GetFrom();
1147    my $to = $p->GetTo();
1148    my %props = (
1149        to => $to,
1150        from => $from,
1151        xml => $p->GetXML(),
1152        type => 'admin',
1153        adminheader => 'Jabber presence: subscribe',
1154        direction => 'in');
1155
1156    $props{body} = "Allow user ($from) to subscribe to your ($to) presence?\n" .
1157                   "(Answer with the `yes' or `no' commands)";
1158    $props{yescommand} = BarnOwl::quote('jroster', 'auth', $from, '-a', $to);
1159    $props{nocommand} = BarnOwl::quote('jroster', 'deauth', $from, '-a', $to);
1160    $props{question} = "true";
1161    BarnOwl::queue_message(BarnOwl::Message->new(%props));
1162}
1163
1164sub process_presence_unsubscribe {
1165    my ( $sid, $p ) = @_;
1166    my $from = $p->GetFrom();
1167    my $to = $p->GetTo();
1168    my %props = (
1169        to => $to,
1170        from => $from,
1171        xml => $p->GetXML(),
1172        type => 'admin',
1173        adminheader => 'Jabber presence: unsubscribe',
1174        direction => 'in');
1175
1176    $props{body} = "The user ($from) has been unsubscribed from your ($to) presence.\n";
1177    BarnOwl::queue_message(BarnOwl::Message->new(%props));
1178
1179    # Find a connection to reply with.
1180    foreach my $jid ($conn->getJIDs()) {
1181        my $cJID = new Net::Jabber::JID;
1182        $cJID->SetJID($jid);
1183        if ($to eq $cJID->GetJID('base') ||
1184            $to eq $cJID->GetJID('full')) {
1185            my $reply = $p->Reply(type=>"unsubscribed");
1186            $conn->getConnectionFromJID($jid)->Send($reply);
1187            return;
1188        }
1189    }
1190}
1191
1192sub process_presence_subscribed {
1193    my ( $sid, $p ) = @_;
1194    queue_admin_msg("ignoring:".$p->GetXML()) if BarnOwl::getvar('jabber:spew') eq 'on';
1195    # RFC 3921 says we should respond to this with a "subscribe"
1196    # but this causes a flood of sub/sub'd presence packets with
1197    # some servers, so we won't. We may want to detect this condition
1198    # later, and have per-server settings.
1199    return;
1200}
1201
1202sub process_presence_unsubscribed {
1203    my ( $sid, $p ) = @_;
1204    queue_admin_msg("ignoring:".$p->GetXML()) if BarnOwl::getvar('jabber:spew') eq 'on';
1205    # RFC 3921 says we should respond to this with a "subscribe"
1206    # but this causes a flood of unsub/unsub'd presence packets with
1207    # some servers, so we won't. We may want to detect this condition
1208    # later, and have per-server settings.
1209    return;
1210}
1211
1212sub process_presence_error {
1213    my ( $sid, $p ) = @_;
1214    my $code = $p->GetErrorCode();
1215    my $error = $p->GetError();
1216    BarnOwl::error("Jabber: $code $error");
1217}
1218
1219
1220### Helper functions
1221
1222sub j2hash {
1223    my $j   = shift;
1224    my %props = (type => 'jabber',
1225                 dir  => 'none',
1226                 %{$_[0]});
1227
1228    my $dir = $props{direction};
1229
1230    my $jtype = $props{jtype} = $j->GetType();
1231    my $from = $j->GetFrom('jid');
1232    my $to   = $j->GetTo('jid');
1233
1234    $props{from} = $from->GetJID('full');
1235    $props{to}   = $to->GetJID('full');
1236
1237    $props{recipient}  = $to->GetJID('base');
1238    $props{sender}     = $from->GetJID('base');
1239    $props{subject}    = $j->GetSubject() if ( $j->DefinedSubject() );
1240    $props{thread}     = $j->GetThread() if ( $j->DefinedThread() );
1241    if ( $j->DefinedBody() ) {
1242        $props{body}   = $j->GetBody();
1243        $props{body}  =~ s/\xEF\xBB\xBF//g; # Strip stray Byte-Order-Marks.
1244    }
1245    $props{error}      = $j->GetError() if ( $j->DefinedError() );
1246    $props{error_code} = $j->GetErrorCode() if ( $j->DefinedErrorCode() );
1247    $props{xml}        = $j->GetXML();
1248
1249    if ( $jtype eq 'chat' ) {
1250        $props{private} = 1;
1251
1252        my $connection;
1253        if ($dir eq 'in') {
1254            $connection = $conn->getConnectionFromSid($props{sid});
1255        }
1256        else {
1257            $connection = $conn->getConnectionFromJID($props{from});
1258        }
1259
1260        # Check to see if we're doing personals with someone in a muc.
1261        # If we are, show the full jid because the base jid is the room.
1262        if ($connection) {
1263            $props{sender} = $props{from}
1264              if ($connection->FindMUC(jid => $from));
1265            $props{recipient} = $props{to}
1266              if ($connection->FindMUC(jid => $to));
1267        }
1268
1269        # Populate completion.
1270        if ($dir eq 'in') {
1271            $completion_jids{ $props{sender} }= 1;
1272        }
1273        else {
1274            $completion_jids{ $props{recipient} } = 1;
1275        }
1276    }
1277    elsif ( $jtype eq 'groupchat' ) {
1278        my $nick = $props{nick} = $from->GetResource();
1279        my $room = $props{room} = $from->GetJID('base');
1280        $completion_jids{$room} = 1;
1281
1282        $props{sender} = $nick || $room;
1283        $props{recipient} = $room;
1284
1285        if ( $props{subject} && !$props{body} ) {
1286            $props{body} =
1287              '[' . $nick . " has set the topic to: " . $props{subject} . "]";
1288        }
1289    }
1290    elsif ( $jtype eq 'normal' ) {
1291        $props{private} = 1;
1292    }
1293    elsif ( $jtype eq 'headline' ) {
1294    }
1295    elsif ( $jtype eq 'error' ) {
1296        $props{body}     = "Error "
1297          . $props{error_code}
1298          . " sending to "
1299          . $props{from} . "\n"
1300          . $props{error};
1301    }
1302
1303    return %props;
1304}
1305
1306sub j2o {
1307    return BarnOwl::Message->new( j2hash(@_) );
1308}
1309
1310sub queue_admin_msg {
1311    my $err = shift;
1312    BarnOwl::admin_message("Jabber", $err);
1313}
1314
1315sub getServerFromJID {
1316    my $jid = shift;
1317    my $res = new Net::DNS::Resolver;
1318    my $packet =
1319      $res->search( '_xmpp-client._tcp.' . $jid->GetServer(), 'srv' );
1320
1321    if ($packet)    # Got srv record.
1322    {
1323        my @answer = $packet->answer;
1324        return $answer[0]{target}, $answer[0]{port};
1325    }
1326
1327    return $jid->GetServer(), 5222;
1328}
1329
1330sub defaultJID {
1331    return ( $conn->getJIDs() )[0] if ( $conn->connected() == 1 );
1332    return;
1333}
1334
1335sub baseJID {
1336    my $givenJIDStr = shift;
1337    my $givenJID    = new Net::Jabber::JID;
1338    $givenJID->SetJID($givenJIDStr);
1339    return $givenJID->GetJID('base');
1340}
1341
1342sub resolveConnectedJID {
1343    my $givenJIDStr = shift;
1344    my $loose = shift || 0;
1345    my $givenJID    = new Net::Jabber::JID;
1346    $givenJID->SetJID($givenJIDStr);
1347
1348    # Account fully specified.
1349    if ( $givenJID->GetResource() ) {
1350        # Specified account exists
1351        return $givenJIDStr if ($conn->jidExists($givenJIDStr) );
1352        return resolveConnectedJID($givenJID->GetJID('base')) if $loose;
1353        die("Invalid account: $givenJIDStr");
1354    }
1355
1356    # Disambiguate.
1357    else {
1358        my $JIDMatchingJID = "";
1359        my $strMatchingJID = "";
1360        my $JIDMatches = "";
1361        my $strMatches = "";
1362        my $JIDAmbiguous = 0;
1363        my $strAmbiguous = 0;
1364
1365        foreach my $jid ( $conn->getJIDs() ) {
1366            my $cJID = new Net::Jabber::JID;
1367            $cJID->SetJID($jid);
1368            if ( $givenJIDStr eq $cJID->GetJID('base') ) {
1369                $JIDAmbiguous = 1 if ( $JIDMatchingJID ne "" );
1370                $JIDMatchingJID = $jid;
1371                $JIDMatches .= "\t$jid\n";
1372            }
1373            if ( $cJID->GetJID('base') =~ /$givenJIDStr/ ) {
1374                $strAmbiguous = 1 if ( $strMatchingJID ne "" );
1375                $strMatchingJID = $jid;
1376                $strMatches .= "\t$jid\n";
1377            }
1378        }
1379
1380        # Need further disambiguation.
1381        if ($JIDAmbiguous) {
1382            my $errStr =
1383                "Ambiguous account reference. Please specify a resource.\n";
1384            die($errStr.$JIDMatches);
1385        }
1386
1387        # It's this one.
1388        elsif ($JIDMatchingJID ne "") {
1389            return $JIDMatchingJID;
1390        }
1391
1392        # Further resolution by substring.
1393        elsif ($strAmbiguous) {
1394            my $errStr =
1395                "Ambiguous account reference. Please be more specific.\n";
1396            die($errStr.$strMatches);
1397        }
1398
1399        # It's this one, by substring.
1400        elsif ($strMatchingJID ne "") {
1401            return $strMatchingJID;
1402        }
1403
1404        # Not one of ours.
1405        else {
1406            die("Invalid account: $givenJIDStr");
1407        }
1408
1409    }
1410    return "";
1411}
1412
1413sub resolveDestJID {
1414    my ($to, $from) = @_;
1415    my $jid = Net::Jabber::JID->new($to);
1416
1417    my $roster = $conn->getRosterFromJID($from);
1418    my @jids = $roster->jids('all');
1419    for my $j (@jids) {
1420        if(($roster->query($j, 'name') || $j->GetUserID()) eq $to) {
1421            return $j->GetJID('full');
1422        } elsif($j->GetJID('base') eq baseJID($to)) {
1423            return $jid->GetJID('full');
1424        }
1425    }
1426
1427    # If we found nothing being clever, check to see if our input was
1428    # sane enough to look like a jid with a UserID.
1429    return $jid->GetJID('full') if $jid->GetUserID();
1430    return undef;
1431}
1432
1433sub resolveType {
1434    my $to = shift;
1435    my $from = shift;
1436    return unless $from;
1437    my @mucs = $conn->getConnectionFromJID($from)->MUCs;
1438    if(grep {$_->BaseJID eq $to } @mucs) {
1439        return 'groupchat';
1440    } else {
1441        return 'chat';
1442    }
1443}
1444
1445sub guess_jwrite {
1446    # Heuristically guess what jids a jwrite was meant to be going to/from
1447    my ($from, $to) = (@_);
1448    my ($from_jid, $to_jid);
1449    my @matches;
1450    if($from) {
1451        $from_jid = resolveConnectedJID($from, 1);
1452        die("Unable to resolve account $from") unless $from_jid;
1453        $to_jid = resolveDestJID($to, $from_jid);
1454        push @matches, [$from_jid, $to_jid] if $to_jid;
1455    } else {
1456        for my $f ($conn->getJIDs) {
1457            $to_jid = resolveDestJID($to, $f);
1458            if(defined($to_jid)) {
1459                push @matches, [$f, $to_jid];
1460            }
1461        }
1462        if($to =~ /@/) {
1463            push @matches, [$_, $to]
1464               for ($conn->getJIDs);
1465        }
1466    }
1467
1468    for my $m (@matches) {
1469        my $type = resolveType($m->[1], $m->[0]);
1470        push @$m, $type;
1471    }
1472
1473    return @matches;
1474}
1475
1476################################################################################
1477### Completion
1478
1479sub complete_user_or_muc { return keys %completion_jids; }
1480sub complete_account { return $conn->getJIDs(); }
1481
1482sub complete_jwrite {
1483    my $ctx = shift;
1484    return complete_flags($ctx,
1485                          [qw(-t -i -s)],
1486                          {
1487                              "-a" => \&complete_account,
1488                          },
1489                          \&complete_user_or_muc
1490        );
1491}
1492
1493BarnOwl::Completion::register_completer(jwrite => sub { BarnOwl::Module::Jabber::complete_jwrite(@_) });
1494
14951;
Note: See TracBrowser for help on using the repository browser.