1##############################################################################
2#
3#  This program is free software; you can redistribute it and/or modify
4#  it under the terms of the GNU General Public License as published by
5#  the Free Software Foundation; either version 2 of the License, or
6#  (at your option) any later version.
7#
8#  This program is distributed in the hope that it will be useful,
9#  but WITHOUT ANY WARRANTY; without even the implied warranty of
10#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
11#  GNU General Public License for more details.
12#
13#  You should have received a copy of the GNU General Public License
14#  along with this program; if not, write to the Free Software
15#  Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
16#
17#  Jabber
18#  Copyright (C) 1998-1999 The Jabber Team http://jabber.org/
19#
20##############################################################################
21
22package Tk::Roster;
23
24use vars qw($VERSION);
25$VERSION = '0.1';
26
27use Tk;
28require Tk::Frame;
29
30use Carp;
31use strict;
32use base qw(Tk::Frame Jarl::Roster);
33Construct Tk::Widget 'Roster';
34
35
36##############################################################################
37#
38# Populate - Create the Tk widget
39#
40##############################################################################
41sub Populate {
42  my ($self, $args) = @_;
43  my %args = %{$args};
44
45  $self->{varsOnlineOnly} = 0;
46
47  $self->{varsRosterBackground} =
48    $self->ParseArg($args,"-rosterbackground","white");
49  $self->{varsGroupBackground} =
50    $self->ParseArg($args,"-groupbackground","grey65");
51  $self->{varsGroupForeground} =
52    $self->ParseArg($args,"-groupforeground","white");
53  $self->{varsJIDBackground} =
54    $self->ParseArg($args,"-jidbackground","grey75");
55  $self->{varsJIDForeground} =
56    $self->ParseArg($args,"-jidforeground","black");
57  $self->{varsSelectBackground} =
58    $self->ParseArg($args,"-selectbackground","lightblue");
59  $self->{varsResourceBackground} =
60    $self->ParseArg($args,"-resourcebackground","grey85");
61  $self->{varsResourceForeground} =
62    $self->ParseArg($args,"-resourceforeground","black");
63  $self->{varsBalloon} =
64    $self->ParseArg($args,"-balloon",undef);
65  $self->{varsFont} =
66    $self->ParseArg($args,"-font","");
67  $self->{varsJIDLeftCommand} =
68    $self->ParseArg($args,"-jidleftcommand","");
69  $self->{varsJIDRightCommand} =
70    $self->ParseArg($args,"-jidrightcommand","");
71  $self->{varsUpdateMode} =
72    $self->ParseArg($args,"-updatemode","roster");
73  $self->{varsWidth} =
74    $self->ParseArg($args,"-width",200);
75
76  $self->{frame} =
77    $self->
78      Frame(%{$args}
79	   )->pack(-side=>'top',
80		   -padx=>0,
81		   -pady=>0,
82		   -fill=>'both',
83		   -expand=>1);
84
85  my $scrolled =
86    $self->{frame}->
87      Scrolled("Canvas",
88	       -scrollbars=>"osoe",
89	       -height=>10,
90	       -width=>$self->{varsWidth},
91	       -borderwidth=>0,
92	       -relief=>"flat",
93	       -background=>$self->{varsRosterBackground},
94	       -takefocus=>0,
95	       -highlightthickness=>0
96	      )->pack(-side=>'top',
97		      -fill=>'both',
98		      -expand=>1,
99		      -padx=>0,
100		      -pady=>0);
101
102  $self->{canvas} = $scrolled->Subwidget("canvas");
103  $scrolled->Subwidget("yscrollbar")->configure(-width=>10,
104						-borderwidth=>1,
105						-relief=>"flat",
106						-takefocus=>0,
107						-highlightthickness=>0
108					       );
109  $scrolled->Subwidget("xscrollbar")->configure(-width=>10,
110						-borderwidth=>1,
111						-relief=>"flat",
112						-takefocus=>0,
113						-highlightthickness=>0
114					       );
115
116  $self->{balloons} = {} if defined($self->{varsBalloon});
117}
118
119
120##############################################################################
121#
122# ParseArg - Helper function to extract the specified argument from the
123#            function call.
124#
125##############################################################################
126sub ParseArg {
127  my $self = shift;
128  my ($args,$arg,$default) = @_;
129  return (exists($args->{$arg}) ? delete($args->{$arg}) : $default);
130}
131
132
133##############################################################################
134#
135# Draw - Draw the roster.
136#
137##############################################################################
138sub Draw {
139  my $self = shift;
140
141  $self->{canvas}->createText(-1000,-1000,
142			    -text=>"TestString",
143                            (
144                             (ref($self->{varsFont}) eq "Tk::Font") ?
145                             (-font=>$self->{varsFont}) :
146                             (
147                               ($self->{varsFont} ne "") ?
148                               (-font=>$self->{varsFont}) :
149                               ()
150                             )
151                            ),
152	                    -tags=>[ "rostertest" ]);
153
154  my ($x1,$y1,$x2,$y2) = $self->{canvas}->bbox("rostertest");
155
156  $self->{varsItem}->{Height} = $y2 - $y1 + 4;
157  $self->{varsItem}->{Height} = 16 if ($self->{varsItem}->{Height} < 16);
158
159  $self->{canvas}->delete("all");
160
161  $self->{varsY} = 0;
162
163  foreach my $group ($self->GetGroups()) {
164
165    $self->DrawItem($self->CreateTag($group),"group",$group,0)
166      unless (($self->{varsOnlineOnly} == 1) &&
167              ($self->ActiveGroup($group) == 0));
168
169    if ($self->{groups}->{$group}->{'__roster__:status'} == 1) {
170      foreach my $jid (sort {uc($self->{jids}->{$a}->{name}) cmp uc($self->{jids}->{$b}->{name})} keys(%{$self->{groups}->{$group}})) {
171	next if ($jid eq '__roster__:status');
172	next if (($self->{varsOnlineOnly} == 1) && !defined($self->Resource($jid)));
173	$self->DrawItem($self->CreateTag($group,$jid),"jid",$self->{jids}->{$jid}->{name},1);
174	if ($self->{groups}->{$group}->{$jid} == 1) {
175	  foreach my $resource (sort {$self->{resources}->{$jid}->{$b}->{priority} <=> $self->{resources}->{$jid}->{$a}->{priority}} keys(%{$self->{resources}->{$jid}})) {
176	    $self->DrawItem($self->CreateTag($group,$jid,$resource),"resource",$resource,2);
177	  }
178	}
179      }
180    }
181  }
182
183  foreach my $jid (sort {uc($self->{jids}->{$a}->{name}) cmp uc($self->{jids}->{$b}->{name})} keys(%{$self->{groups}->{'__roster__:none'}})) {
184    next if ($jid eq '__roster__:status');
185    next if (($self->{varsOnlineOnly} == 1) && !defined($self->Resource($jid)));
186    $self->DrawItem($self->CreateTag('__roster__:none',$jid),"jid",$self->{jids}->{$jid}->{name},0);
187    if ($self->{groups}->{'__roster__:none'}->{$jid} == 1) {
188      foreach my $resource (sort {$self->{jids}->{$jid}->{resources}->{$b}->{priority} <=> $self->{resources}->{$jid}->{$a}->{priority}} keys(%{$self->{resources}->{$jid}})) {
189	$self->DrawItem($self->CreateTag('__roster__:none',$jid,$resource),"resource",$resource,1);
190      }
191    }
192  }
193
194  (undef,undef,undef,$y2) = $self->{canvas}->bbox("all");
195
196  (undef,undef,$x2,undef) = $self->{canvas}->bbox("text");
197
198  $x2 = 10 unless ($x2 > 10);
199  $y2 = 10 unless ($y2 > 10);
200
201  $self->{canvas}->
202    configure(-scrollregion=>
203	      [ 0,
204		0,
205		($x2+2),
206		$y2
207	      ]);
208
209  $self->{varsBalloon}->
210    attach($self->{canvas},
211	   -balloonposition => 'mouse',
212	   -msg=>{ %{$self->{balloons}} },
213	  )
214      if defined($self->{varsBalloon});
215
216  if (defined($self->{varsSelectedTag}) &&
217      ($self->{canvas}->gettags($self->{varsSelectedTag}) ne "")) {
218    $self->{canvas}->itemconfigure($self->{varsSelectedTag},
219				 -fill=>$self->{varsSelectBackground});
220  } else {
221    $self->{varsSelectedJID} = undef;
222    $self->{varsSelectedTag} = undef;
223  }
224}
225
226
227##############################################################################
228#
229# DrawItem - Draw a single item entry.
230#
231##############################################################################
232sub DrawItem {
233  my $self = shift;
234  my ($tag,$type,$text,$indentLevel) = @_;
235
236  my %types;
237  $types{group}->{back} = $self->{varsGroupBackground};
238  $types{group}->{fore} = $self->{varsGroupForeground};
239  $types{jid}->{back} = $self->{varsJIDBackground};
240  $types{jid}->{fore} = $self->{varsJIDForeground};
241  $types{resource}->{back} = $self->{varsResourceBackground};
242  $types{resource}->{fore} = $self->{varsResourceForeground};
243
244  my ($group,$jid,$resource);
245
246  foreach my $splitTag (split(':::',$tag)) {
247    ($group) = ($splitTag =~ /^group-(.+)$/) if ($splitTag =~ /^group\-/);
248    ($jid) = ($splitTag =~ /^jid-(.+)$/) if ($splitTag =~ /^jid\-/);
249    ($resource) = ($splitTag =~ /^res-(.+)$/) if ($splitTag =~ /^res\-/);
250  }
251
252  $group = $self->UnescapeTag($group);
253  $jid = $self->UnescapeTag($jid);
254  $resource = $self->UnescapeTag($resource);
255
256  my $icon;
257
258  if ($type eq "group") {
259    if ($self->{groups}->{$group}->{'__roster__:status'} == 1) {
260      $icon = $main::GUI{Icons}->{Open};
261    } else {
262      $icon = $main::GUI{Icons}->{Closed}
263    }
264  }
265
266  if ($type eq "resource") {
267    $icon = $main::GUI{Icons}->{Resource};
268  }
269
270  if ($type eq "jid") {
271
272    my $resource = $self->Resource($jid);
273
274    if (defined($resource)) {
275      my $presence =
276        (($self->{resources}->{$jid}->{$resource}->{show} ne "") ?
277	 $self->{resources}->{$jid}->{$resource}->{show} :
278	 $self->{resources}->{$jid}->{$resource}->{type}
279	);
280
281      $icon = &main::jarlRosterIF_PresenceIcon($self,$presence,$jid);
282    } else {
283      $icon = &main::jarlRosterIF_PresenceIcon($self,"unavailable",$jid);
284    }
285  }
286
287  $self->{canvas}->
288    createRectangle(0,$self->{varsY}+1,
289		    10000,$self->{varsY}+$self->{varsItem}->{Height},
290		    -fill=>$types{$type}->{back},
291		    -outline=>undef,
292		    -tags=>[
293			    $tag,
294			    (($type eq "jid") ?
295			     ("jidback", "${tag}-back") :
296			     ()
297			    ),
298			    (($type eq "resource") ?
299			     ("resback", "${tag}-back") :
300			     ()
301			    )
302			   ]);
303
304  $self->{canvas}->createImage(($indentLevel*15)+5,
305                             $self->{varsY}+(int($self->{varsItem}->{Height}/2)),
306			     -image=>$icon,
307			     -anchor=>"w",
308			     -tags=>[ $tag ]);
309
310  $self->{canvas}->createText(($indentLevel*15)+($icon->width()+10),
311                             $self->{varsY}+(int($self->{varsItem}->{Height}/2)),
312			    -text=>$text,
313                            (
314                             (ref($self->{varsFont}) eq "Tk::Font") ?
315                             (-font=>$self->{varsFont}) :
316                             (
317                               ($self->{varsFont} ne "") ?
318                               (-font=>$self->{varsFont}) :
319                               ()
320                             )
321                            ),
322			    -fill=>$types{$type}->{fore},
323			    -anchor=>"w",
324			    -tags=>[ $tag , "text" ]);
325
326  $self->{varsY} += $self->{varsItem}->{Height};
327}
328
329
330##############################################################################
331#
332# RegisterGroup - overload function to handle adding in a new group.  Sets up
333#                 the bindings for interfacing with the Roster groups.
334#
335##############################################################################
336sub RegisterGroup {
337  my $self = shift;
338  my ($group) = @_;
339
340  if ($self->{canvas}->bind("group-${group}") eq "") {
341    $self->{canvas}->
342      bind("group-${group}",
343	   "<Button-1>",
344	   sub {
345	     $self->{canvas}->
346	       itemconfigure("jidback",
347			     -fill=>$self->{varsJIDBackground});
348	     $self->{canvas}->
349	       itemconfigure("resback",
350			     -fill=>$self->{varsResourceBackground});
351	     $self->{varsSelectedJID} = undef;
352	     $self->{varsSelectedTag} = undef;
353	   }
354	  );
355    $self->{canvas}->
356      bind("group-${group}",
357	   "<Double-1>",
358	   sub {
359	     $self->Toggle($group);
360	   }
361	  );
362  }
363}
364
365
366##############################################################################
367#
368# RegisterJID - overload to handle adding a new JID.  Setups the canvas
369#               bindings for interfacing with the Roster.
370#
371##############################################################################
372sub RegisterJID {
373  my $self = shift;
374  my ($group,$jid,$resource) = @_;
375
376  my $tag = $self->CreateTag($group,$jid,$resource);
377
378  if (defined($resource)) {
379    $self->RegisterBalloon($tag,\$self->{resources}->{$jid}->{$resource}->{balloon});
380  } else {
381    $self->RegisterBalloon($tag,\$self->{jids}->{$jid}->{balloon});
382  }
383
384  return unless ($self->{canvas}->bind($tag) eq "");
385
386  my $fullJID = $jid;
387  $fullJID .= "/${resource}" unless ($resource eq "");
388
389  $self->{canvas}->
390    bind($tag,
391	 "<Button-3>",
392	 sub {
393	   $self->{canvas}->
394	     itemconfigure("jidback",
395			   -fill=>$self->{varsJIDBackground});
396	   $self->{canvas}->
397	     itemconfigure("resback",
398			   -fill=>$self->{varsResourceBackground});
399	   $self->{canvas}->
400	     itemconfigure("${tag}-back",
401			   -fill=>$self->{varsSelectBackground});
402	   $self->{varsSelectedJID} = $fullJID;
403	   $self->{varsSelectedTag} = "${tag}-back";
404	   &{$self->{varsJIDRightCommand}}($group,$jid,$resource)
405	     if ($self->{varsJIDRightCommand} ne "");
406	 }
407	);
408
409  $self->{canvas}->
410    bind($tag,
411	 "<Button-1>",
412	 sub {
413	   $self->{canvas}->
414	     itemconfigure("jidback",
415			   -fill=>$self->{varsJIDBackground});
416	   $self->{canvas}->
417	     itemconfigure("resback",
418			   -fill=>$self->{varsResourceBackground});
419	   $self->{canvas}->
420	     itemconfigure("${tag}-back",
421			   -fill=>$self->{varsSelectBackground});
422	   $self->{varsSelectedJID} = $fullJID;
423	   $self->{varsSelectedTag} = "${tag}-back";
424	 }
425	);
426
427  $self->{canvas}->
428    bind($tag,
429	 "<Double-1>",
430	 sub {
431	   &{$self->{varsJIDLeftCommand}}($jid,$resource)
432	     if ($self->{varsJIDLeftCommand} ne "");
433	 }
434	);
435}
436
437
438##############################################################################
439#
440# Clear - Clear the widget of all data
441#
442##############################################################################
443sub Clear {
444  my $self = shift;
445
446  $self->{canvas}->delete("all");
447  $self->SUPER::Clear();
448}
449
450
4511;
452