File Coverage

blib/lib/Net/XMPP/Roster.pm
Criterion Covered Total %
statement 214 271 78.9
branch 88 164 53.6
condition 26 72 36.1
subroutine 25 33 75.7
pod 13 25 52.0
total 366 565 64.7


line stmt bran cond sub pod time code
1             ##############################################################################
2             #
3             # This library is free software; you can redistribute it and/or
4             # modify it under the terms of the GNU Library General Public
5             # License as published by the Free Software Foundation; either
6             # version 2 of the License, or (at your option) any later version.
7             #
8             # This library 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 GNU
11             # Library General Public License for more details.
12             #
13             # You should have received a copy of the GNU Library General Public
14             # License along with this library; if not, write to the
15             # Free Software Foundation, Inc., 59 Temple Place - Suite 330,
16             # Boston, MA 02111-1307, USA.
17             #
18             # Copyright (C) 1998-2004 Jabber Software Foundation http://jabber.org/
19             #
20             ##############################################################################
21              
22             package Net::XMPP::Roster;
23              
24             =head1 NAME
25              
26             Net::XMPP::Roster - XMPP Roster Object
27              
28             =head1 SYNOPSIS
29              
30             Net::XMPP::Roster is a module that provides a developer an easy
31             interface to an XMPP roster. It provides high level functions to
32             query, update, and manage a user's roster.
33              
34             =head1 DESCRIPTION
35              
36             The Roster object seeks to provide an easy to use API for interfacing
37             with a user's roster. When you instantiate it, it automatically
38             registers with the connection to receivce the correct packets so
39             that it can track all roster updates, and presence packets.
40              
41             =head2 Basic Functions
42              
43             my $Client = Net::XMPP::Client->new(...);
44              
45             my $Roster = Net::XMPP::Roster->new(connection=>$Client);
46             or
47             my $Roster = $Client->Roster();
48              
49             $Roster->clear();
50              
51             if ($Roster->exists('bob@jabber.org')) { ... }
52             if ($Roster->exists(Net::XMPP::JID)) { ... }
53              
54             if ($Roster->groupExists("Friends")) { ... }
55              
56             my @groups = $Roster->groups();
57              
58             my @jids = $Roster->jids();
59             my @friends = $Roster->jids("group","Friends");
60             my @unfiled = $Roster->jids("nogroup");
61              
62             if ($Roster->online('bob@jabber.org')) { ... }
63             if ($Roster->online(Net::XMPP::JID)) { ... }
64              
65             my %hash = $Roster->query('bob@jabber.org');
66             my %hash = $Roster->query(Net::XMPP::JID);
67              
68             my $name = $Roster->query('bob@jabber.org',"name");
69             my $ask = $Roster->query(Net::XMPP::JID,"ask");
70              
71             my $resource = $Roster->resource('bob@jabber.org');
72             my $resource = $Roster->resource(Net::XMPP::JID);
73              
74             my %hash = $Roster->resourceQuery('bob@jabber.org',"Home");
75             my %hash = $Roster->resourceQuery(Net::XMPP::JID,"Club");
76              
77             my $show = $Roster->resourceQuery('bob@jabber.org',"Home","show");
78             my $status = $Roster->resourceQuery(Net::XMPP::JID,"Work","status");
79              
80             my @resource = $Roster->resources('bob@jabber.org');
81             my @resource = $Roster->resources(Net::XMPP::JID);
82              
83             $Roster->resourceStore('bob@jabber.org',"Home","gpgkey",key);
84             $Roster->resourceStore(Net::XMPP::JID,"logged on","2004/04/07 ...");
85              
86             $Roster->store('bob@jabber.org',"avatar",avatar);
87             $Roster->store(Net::XMPP::JID,"display_name","Bob");
88              
89             =head2 Advanced Functions
90              
91             These functions are only needed if you want to manually control
92             the Roster.
93              
94             $Roster->add('bob@jabber.org',
95             name=>"Bob",
96             groups=>["Friends"]
97             );
98             $Roster->add(Net::XMPP::JID);
99              
100             $Roster->addResource('bob@jabber.org',
101             "Home",
102             show=>"dnd",
103             status=>"Working"
104             );
105             $Roster->addResource(Net::XMPP::JID,"Work");
106              
107             $Roster->remove('bob@jabber.org');
108             $Roster->remove(Net::XMPP::JID);
109              
110             $Roster->removeResource('bob@jabber.org',"Home");
111             $Roster->removeResource(Net::XMPP::JID,"Work");
112              
113             $Roster->handler(Net::XMPP::IQ);
114             $Roster->handler(Net::XMPP::Presence);
115              
116             =head1 METHODS
117              
118             =head2 Basic Functions
119              
120             =over 4
121              
122             =item new
123              
124             new(connection=>object)
125              
126             This creates and initializes the Roster
127             object. The connection object is required
128             so that the Roster can interact with the
129             main connection object. It needs to be an
130             object that inherits from L.
131              
132             =item clear
133              
134             clear()
135              
136             removes everything from the database.
137              
138             =item exists
139              
140             exists(jid)
141              
142             return 1 if the JID exists in the database, undef
143             otherwise. The jid can either be a string, or a L object.
144              
145             =item groupExists
146              
147             groupExists(group)
148              
149             return 1 if the group exists in the database, undef otherwise.
150              
151             =item groups
152              
153             groups()
154              
155             Returns a list of all of the roster groups.
156              
157             =item jids
158              
159             jids([type, [group]])
160              
161             returns a list of all of the matching JIDs. The valid
162             types are:
163              
164             all - return all JIDs in the roster. (default)
165             nogroup - return all JIDs not in a roster group.
166             group - return all of the JIDs in the specified
167             roster group.
168              
169             =item online
170              
171             online(jid)
172              
173             return 1 if the JID is online, undef otherwise. The
174             jid can either be a string, or a L object.
175              
176             =item query
177              
178             query(jid, [key])
179              
180             return a hash representing all of the data in the
181             DB for this JID. The jid can either be a string,
182             or a Net::XMPP::JID object. If you specify a key,
183             then only the value for that key is returned.
184              
185             =item resource
186              
187             resource(jid)
188              
189             return the string representing the resource with the
190             highest priority for the JID. The jid can either be
191             a string, or a Net::XMPP::JID object.
192              
193             =item resourceQuery
194              
195             resourceQuery(jid,
196             resource,
197             [key])
198              
199             return a hash representing all of the data
200             the DB for the resource for this JID. The
201             jid can either be a string, or a
202             Net::XMPP::JID object. If you specify a
203             key, then only the value for that key is
204             returned.
205              
206             =item resources
207              
208             resources(jid)
209              
210             returns the list of resources for the JID in order
211             of highest priority to lowest priority. The jid can
212             either be a string, or a Net::XMPP::JID object.
213              
214             =item resourceStore
215              
216             resourceStore(jid,
217             resource,
218             key,
219             value)
220              
221             store the specified value in the DB under
222             the specified key for the resource for this
223             JID. The jid can either be a string, or a
224             Net::XMPP::JID object.
225              
226             =item store
227              
228             store(jid, key, value)
229              
230             store the specified value in the DB under the
231             specified key for this JID. The jid can either
232             be a string, or a Net::XMPP::JID object.
233              
234             =back
235              
236              
237             =head2 Advanced Functions
238              
239             add(jid, - Manually adds the JID to the Roster with the
240             ask=>string, specified roster item settings. This does not
241             groups=>arrayref handle subscribing to other users, only
242             name=>string, manipulating the Roster object. The jid
243             subscription=>string) can either be a string or a Net::XMPP::JID.
244              
245             addResource(jid, - Manually add the resource to the JID in the
246             resource, Roster with the specified presence settings.
247             priority=>int, This does not handle subscribing to other
248             show=>string, users, only manipulating the Roster object.
249             status=>string) The jid can either be a string or a
250             Net::XMPP::JID.
251              
252             remove(jid) - Removes all reference to the JID from the Roster object.
253             The jid can either be a string or a Net::XMPP::JID.
254              
255             removeResource(jid, - Removes the resource from the jid in the
256             resource) Roster object. The jid can either be a string
257             or a Net::XMPP::JID.
258              
259             handler(packet) - Take either a Net::XMPP::IQ or Net::XMPP::Presence
260             packet and parse them according to the rules of the
261             Roster object. Note, that it will only waste CPU time
262             if you pass in IQs or Presences that are not roster
263             related.
264              
265             =head1 AUTHOR
266              
267             Originally authored by Ryan Eatmon.
268              
269             Previously maintained by Eric Hacker.
270              
271             Currently maintained by Darian Anthony Patrick.
272              
273             =head1 COPYRIGHT
274              
275             This module is free software, you can redistribute it and/or modify it
276             under the LGPL 2.1.
277              
278             =cut
279              
280 15     15   304 use 5.008;
  15         48  
  15         540  
281 15     15   79 use strict;
  15         20  
  15         446  
282 15     15   65 use warnings;
  15         21  
  15         369  
283              
284 15     15   61 use Carp;
  15         18  
  15         797  
285              
286 15     15   72 use Net::XMPP::JID;
  15         17  
  15         342  
287              
288 15     15   78 use Scalar::Util qw(weaken);
  15         20  
  15         40216  
289              
290             sub new
291             {
292 1     1 1 910 my $proto = shift;
293 1         3 my $self = { };
294              
295 1         2 my %args;
296 1         4 while($#_ >= 0) { $args{ lc(pop(@_)) } = pop(@_); }
  1         5  
297              
298 1 50 33     7 if (!exists($args{connection}) ||
299             !$args{connection}->isa("Net::XMPP::Connection"))
300             {
301 0         0 croak("You must pass Net::XMPP::Roster a valid connection object.");
302             }
303              
304 1         3 $self->{CONNECTION} = $args{connection};
305              
306 1         2 bless($self, $proto);
307              
308 1         4 $self->init();
309              
310 1         3 return $self;
311             }
312              
313              
314             ##############################################################################
315             #
316             # init - initialize the module to use the roster database
317             #
318             ##############################################################################
319             sub init
320             {
321 1     1 0 1 my $self = shift;
322              
323 1         2 my $weak = $self;
324 1         3 weaken $weak;
325 1     0   25 $self->{CONNECTION}-> SetXPathCallBacks('/iq[@type="result" or @type="set"]/query[@xmlns="jabber:iq:roster"]'=>sub{ $weak->handler(@_) });
  0         0  
326 1     0   9 $self->{CONNECTION}-> SetXPathCallBacks('/presence'=>sub{ $weak->handler(@_) });
  0         0  
327             }
328              
329              
330             ##############################################################################
331             #
332             # add - adds the entry to the Roster DB.
333             #
334             ##############################################################################
335             sub add
336             {
337 2     2 0 3 my $self = shift;
338 2         7 my ($jid,%item) = @_;
339              
340 2 50 33     8 $jid = $jid->GetJID() if (ref $jid && $jid->isa('Net::XMPP::JID'));
341              
342 2         6 $self->{JIDS}->{$jid} = \%item;
343              
344 2 100       6 if (exists($item{groups}))
345             {
346 1         2 foreach my $group (@{$item{groups}})
  1         2  
347             {
348 2         7 $self->{GROUPS}->{$group}->{$jid} = 1;
349             }
350             }
351             }
352              
353              
354              
355             ##############################################################################
356             #
357             # addResource - adds the resource to the JID in the Roster DB.
358             #
359             ##############################################################################
360             sub addResource
361             {
362 2     2 0 4 my $self = shift;
363 2         1 my $jid = shift;
364 2         4 my $resource = shift;
365 2         6 my (%item) = @_;
366              
367 2 50 33     6 $jid = $jid->GetJID() if (ref $jid && $jid->isa('Net::XMPP::JID'));
368              
369 2         3 my $priority = $item{priority};
370 2 100       5 $priority = 0 unless defined($priority);
371              
372 2         30 $self->{CONNECTION}->{DEBUG}->Log3("Roster::addResource: add $jid/$resource with priority $priority to the DB");
373              
374 2         3 my $loc = -1;
375 2 50       11 $self->{JIDS}->{$jid}->{priorities}->{$priority} = []
376             unless exists($self->{JIDS}->{$jid}->{priorities}->{$priority});
377 2         4 foreach my $index (0..$#{$self->{JIDS}->{$jid}->{priorities}->{$priority}})
  2         8  
378             {
379 0 0       0 $loc = $index
380             if ($self->{JIDS}->{$jid}->{priorities}->{$priority}->[$index]->{resource} eq $resource);
381             }
382 2 50       14 $loc = $#{$self->{JIDS}->{$jid}->{priorities}->{$priority}} + 1 if ($loc == -1);
  2         8  
383              
384 2         12 $self->{JIDS}->{$jid}->{resources}->{$resource}->{priority} = $priority;
385 2 100       8 $self->{JIDS}->{$jid}->{resources}->{$resource}->{status} = $item{status}
386             if exists($item{status});
387 2 100       6 $self->{JIDS}->{$jid}->{resources}->{$resource}->{show} = $item{show}
388             if exists($item{show});
389 2         12 $self->{JIDS}->{$jid}->{priorities}->{$priority}->[$loc]->{resource} = $resource;
390             }
391              
392              
393             ###############################################################################
394             #
395             # clear - delete all of the JIDs from the DB completely.
396             #
397             ###############################################################################
398             sub clear
399             {
400 1     1 1 2 my $self = shift;
401              
402 1         12 $self->{CONNECTION}->{DEBUG}->Log3("Roster::clear: clearing the database");
403 1         3 foreach my $jid ($self->jids())
404             {
405 1         5 $self->remove($jid);
406             }
407 1         7 $self->{CONNECTION}->{DEBUG}->Log3("Roster::clear: database is empty");
408             }
409              
410              
411             ##############################################################################
412             #
413             # exists - allows you to query if the JID exists in the Roster DB.
414             #
415             ##############################################################################
416             sub exists
417             {
418 68     68 1 566 my $self = shift;
419 68         79 my ($jid) = @_;
420              
421 68 50 33     123 $jid = $jid->GetJID() if (ref $jid && $jid->isa('Net::XMPP::JID'));
422              
423 68 100       130 return unless exists($self->{JIDS});
424 64 100       127 return unless exists($self->{JIDS}->{$jid});
425 62         126 return 1;
426             }
427              
428              
429             sub fetch
430             {
431 0     0 0 0 my $self = shift;
432              
433 0         0 my %newroster = $self->{CONNECTION}->RosterGet();
434              
435 0         0 $self->handleRoster(\%newroster);
436             }
437              
438              
439             ##############################################################################
440             #
441             # groupExists - allows you to query if the group exists in the Roster
442             # DB.
443             #
444             ##############################################################################
445             sub groupExists
446             {
447 8     8 1 13 my $self = shift;
448 8         11 my ($group) = @_;
449              
450 8 100       29 return unless exists($self->{GROUPS});
451 4 50       11 return unless exists($self->{GROUPS}->{$group});
452 4         14 return 1;
453             }
454              
455              
456             ##############################################################################
457             #
458             # groups - returns a list of the current groups in your roster.
459             #
460             ##############################################################################
461             sub groups
462             {
463 0     0 1 0 my $self = shift;
464              
465 0 0       0 return () unless exists($self->{GROUPS});
466 0 0       0 return () if (scalar(keys(%{$self->{GROUPS}})) == 0);
  0         0  
467 0         0 return keys(%{$self->{GROUPS}});
  0         0  
468             }
469              
470              
471             ##############################################################################
472             #
473             # handler - takes a packet and calls the correct handler.
474             #
475             ##############################################################################
476             sub handler
477             {
478 0     0 0 0 my $self = shift;
479 0         0 my $sid = shift;
480 0         0 my $packet = shift;
481              
482 0 0       0 $self->handleIQ($packet) if ($packet->GetTag() eq "iq");
483 0 0       0 $self->handlePresence($packet) if ($packet->GetTag() eq "presence");
484             }
485              
486              
487             ##############################################################################
488             #
489             # handleIQ - takes an iq packet that contains roster, parses it, and puts
490             # the roster into the Roster DB.
491             #
492             ##############################################################################
493             sub handleIQ
494             {
495 0     0 0 0 my $self = shift;
496 0         0 my $iq = shift;
497              
498 0         0 $self->{CONNECTION}->{DEBUG}->Log3('handleIQ: iq(' . $iq->GetXML() . ')');
499              
500 0         0 my $type = $iq->GetType();
501 0 0 0     0 return unless (($type eq "set") || ($type eq "result"));
502              
503 0         0 my %newroster = $self->{CONNECTION}->RosterParse($iq);
504              
505 0         0 $self->handleRoster(\%newroster);
506             }
507              
508              
509             sub handleRoster
510             {
511 0     0 0 0 my $self = shift;
512 0         0 my $roster = shift;
513              
514 0         0 foreach my $jid (keys(%{$roster}))
  0         0  
515             {
516 0         0 $self->remove($jid);
517              
518 0 0       0 if ($roster->{$jid}->{subscription} ne "remove")
519             {
520 0         0 $self->add($jid, %{$roster->{$jid}});
  0         0  
521             }
522             }
523             }
524              
525              
526             ##############################################################################
527             #
528             # handlePresence - takes a presence packet and groks the presence.
529             #
530             ##############################################################################
531             sub handlePresence
532             {
533 0     0 0 0 my $self = shift;
534 0         0 my $presence = shift;
535              
536 0         0 $self->{CONNECTION}->{DEBUG}->Log3('handlePresence: presence(' . $presence->GetXML() . ')');
537              
538 0         0 my $type = $presence->GetType();
539 0 0       0 $type = "" unless defined($type);
540 0 0 0     0 return unless (($type eq "") ||
      0        
541             ($type eq "available") ||
542             ($type eq "unavailable"));
543              
544 0         0 my $jid = $presence->GetFrom("jid");
545              
546 0         0 my $resource = $jid->GetResource();
547 0 0       0 $resource = " " unless ($resource ne "");
548              
549 0         0 $jid = $jid->GetJID();
550 0 0       0 $jid = "" unless defined($jid);
551              
552 0 0       0 return unless $self->exists($jid);
553             #XXX if it doesn't exist... is it us?
554             #XXX is this a presence based roster?
555              
556 0         0 $self->{CONNECTION}->{DEBUG}->Log3("Roster::PresenceDBParse: fromJID(",$presence->GetFrom(),") resource($resource) type($type)");
557 0         0 $self->{CONNECTION}->{DEBUG}->Log4("Roster::PresenceDBParse: xml(",$presence->GetXML(),")");
558              
559 0         0 $self->removeResource($jid,$resource);
560              
561 0 0 0     0 if (($type eq "") || ($type eq "available"))
562             {
563 0         0 my %item;
564              
565 0         0 $item{priority} = $presence->GetPriority();
566 0 0       0 $item{priority} = 0 unless defined($item{priority});
567              
568 0         0 $item{show} = $presence->GetShow();
569 0 0       0 $item{show} = "" unless defined($item{show});
570              
571 0         0 $item{status} = $presence->GetStatus();
572 0 0       0 $item{status} = "" unless defined($item{status});
573              
574 0         0 $self->addResource($jid,$resource,%item);
575             }
576             }
577              
578              
579             ##############################################################################
580             #
581             # jids - returns a list of all of the JIDs in your roster.
582             #
583             ##############################################################################
584             sub jids
585             {
586 8     8 1 14 my $self = shift;
587 8         18 my $type = shift;
588 8         12 my $group = shift;
589              
590 8 100       18 $type = "all" unless defined($type);
591              
592 8         8 my @jids;
593              
594 8 100 100     31 if (($type eq "all") || ($type eq "nogroup"))
595             {
596 6 100       23 return () unless exists($self->{JIDS});
597 5         6 foreach my $jid (keys(%{$self->{JIDS}}))
  5         22  
598             {
599 1         7 next if (($type eq "nogroup") &&
600             exists($self->{JIDS}->{$jid}->{groups}) &&
601 8 100 100     32 ($#{$self->{JIDS}->{$jid}->{groups}} > -1));
      66        
602              
603 7         37 push(@jids, Net::XMPP::JID->new($jid));
604             }
605             }
606              
607 7 100       16 if ($type eq "group")
608             {
609 2 50       7 return () unless exists($self->{GROUPS});
610 2 50 33     14 if (defined($group) && $self->groupExists($group))
611             {
612 2         2 foreach my $jid (keys(%{$self->{GROUPS}->{$group}}))
  2         11  
613             {
614 2         9 push(@jids, Net::XMPP::JID->new($jid));
615             }
616             }
617             }
618              
619 7         42 return @jids;
620             }
621              
622              
623             ###############################################################################
624             #
625             # online - returns if the jid is online or not.
626             #
627             ###############################################################################
628             sub online
629             {
630 12     12 1 957 my $self = shift;
631 12         14 my $jid = shift;
632              
633 12 50 33     33 $jid = $jid->GetJID() if (ref $jid && $jid->isa('Net::XMPP::JID'));
634              
635 12 50       22 return unless $self->exists($jid);
636              
637 12         24 my @resources = $self->resources($jid);
638              
639 12         52 return ($#resources > -1);
640             }
641              
642              
643             ##############################################################################
644             #
645             # priority - return the highest priority for the jid, or for the specified
646             # resource.
647             #
648             ##############################################################################
649             sub priority
650             {
651 6     6 0 9 my $self = shift;
652 6         7 my $jid = shift;
653 6         5 my $resource = shift;
654              
655 6 50 33     24 $jid = $jid->GetJID() if (ref $jid && $jid->isa('Net::XMPP::JID'));
656              
657 6 100       11 if (defined($resource))
658             {
659 2 50       6 return unless $self->resourceExists($jid,$resource);
660 2 50       8 return unless exists($self->{JIDS}->{$jid}->{resources}->{$resource}->{priority});
661 2         7 return $self->{JIDS}->{$jid}->{resources}->{$resource}->{priority};
662             }
663              
664 4 50       13 return unless exists($self->{JIDS}->{$jid}->{priorities});
665 4         4 my @priorities = sort{ $b <=> $a } keys(%{$self->{JIDS}->{$jid}->{priorities}});
  1         4  
  4         18  
666 4         9 return $priorities[0];
667             }
668              
669              
670             ##############################################################################
671             #
672             # query - allows you to get one of the pieces of info from the Roster DB.
673             #
674             ##############################################################################
675             sub query
676             {
677 9     9 1 948 my $self = shift;
678 9         12 my $jid = shift;
679 9         10 my $key = shift;
680              
681 9 50 33     27 $jid = $jid->GetJID() if (ref $jid && $jid->isa('Net::XMPP::JID'));
682              
683 9 50       15 return unless $self->exists($jid);
684 9 100       17 if (defined($key))
685             {
686 7 100       23 return unless exists($self->{JIDS}->{$jid}->{$key});
687 5         21 return $self->{JIDS}->{$jid}->{$key};
688             }
689 2         2 return %{$self->{JIDS}->{$jid}};
  2         17  
690             }
691              
692              
693             ##############################################################################
694             #
695             # remove - removes the JID from the Roster DB.
696             #
697             ##############################################################################
698             sub remove
699             {
700 2     2 0 5 my $self = shift;
701 2         3 my $jid = shift;
702              
703 2 100 66     21 $jid = $jid->GetJID() if (ref $jid && $jid->isa('Net::XMPP::JID'));
704              
705 2 50       6 if ($self->exists($jid))
706             {
707 2         22 $self->{CONNECTION}->{DEBUG}->Log3("Roster::remove: deleting $jid from the DB");
708              
709 2 100       8 if (defined($self->query($jid,"groups")))
710             {
711 1         2 foreach my $group (@{$self->query($jid,"groups")})
  1         3  
712             {
713 2         6 delete($self->{GROUPS}->{$group}->{$jid});
714 2         19 delete($self->{GROUPS}->{$group})
715 2 50       4 if (scalar(keys(%{$self->{GROUPS}->{$group}})) == 0);
716 2         9 delete($self->{GROUPS})
717 2 100       4 if (scalar(keys(%{$self->{GROUPS}})) == 0);
718             }
719             }
720              
721 2         10 delete($self->{JIDS}->{$jid});
722 2 100       2 delete($self->{JIDS}) if (scalar(keys(%{$self->{JIDS}})) == 0);
  2         11  
723             }
724             }
725              
726              
727             ##############################################################################
728             #
729             # removeResource - removes the resource from the JID from the Roster DB.
730             #
731             ##############################################################################
732             sub removeResource
733             {
734 2     2 0 3 my $self = shift;
735 2         4 my $jid = shift;
736 2         3 my $resource = shift;
737              
738 2 50 33     8 $jid = $jid->GetJID() if (ref $jid && $jid->isa('Net::XMPP::JID'));
739              
740 2 50       6 if ($self->resourceExists($jid,$resource))
741             {
742 2         31 $self->{CONNECTION}->{DEBUG}->Log3("Roster::removeResource: remove $jid/$resource from the DB");
743              
744 2         7 my $oldPriority = $self->priority($jid,$resource);
745 2 50       6 $oldPriority = "" unless defined($oldPriority);
746              
747 2 50       6 if (exists($self->{JIDS}->{$jid}->{priorities}->{$oldPriority}))
748             {
749 2         2 my $loc = 0;
750 2         2 foreach my $index (0..$#{$self->{JIDS}->{$jid}->{priorities}->{$oldPriority}})
  2         8  
751             {
752 2 50       10 $loc = $index
753             if ($self->{JIDS}->{$jid}->{priorities}->{$oldPriority}->[$index]->{resource} eq $resource);
754             }
755              
756 2         3 splice(@{$self->{JIDS}->{$jid}->{priorities}->{$oldPriority}},$loc,1);
  2         7  
757              
758 2         23 delete($self->{JIDS}->{$jid}->{priorities}->{$oldPriority})
759             if (exists($self->{JIDS}->{$jid}->{priorities}->{$oldPriority}) &&
760 2 50 33     11 ($#{$self->{JIDS}->{$jid}->{priorities}->{$oldPriority}} == -1));
761             }
762              
763 2         9 delete($self->{JIDS}->{$jid}->{resources}->{$resource});
764              
765             }
766             }
767              
768              
769             ###############################################################################
770             #
771             # resource - retrieve the resource with the highest priority.
772             #
773             ###############################################################################
774             sub resource
775             {
776 4     4 1 35 my $self = shift;
777 4         6 my $jid = shift;
778              
779 4 50 33     13 $jid = $jid->GetJID() if (ref $jid && $jid->isa('Net::XMPP::JID'));
780              
781 4 50       8 return unless $self->exists($jid);
782              
783 4         10 my $priority = $self->priority($jid);
784              
785 4 100       12 return unless defined($priority);
786              
787 3         16 return $self->{JIDS}->{$jid}->{priorities}->{$priority}->[0]->{resource};
788             }
789              
790              
791             ##############################################################################
792             #
793             # resourceExists - check that the specified resource exists.
794             #
795             ##############################################################################
796             sub resourceExists
797             {
798 12     12 0 11 my $self = shift;
799 12         12 my $jid = shift;
800 12         11 my $resource = shift;
801              
802 12 50 33     20 $jid = $jid->GetJID() if (ref $jid && $jid->isa('Net::XMPP::JID'));
803              
804 12 50       20 return unless $self->exists($jid);
805 12 50       30 return unless exists($self->{JIDS}->{$jid}->{resources});
806 12 50       53 return unless exists($self->{JIDS}->{$jid}->{resources}->{$resource});
807             }
808              
809              
810             ##############################################################################
811             #
812             # resourceQuery - allows you to get one of the pieces of info from the Roster
813             # DB.
814             #
815             ##############################################################################
816             sub resourceQuery
817             {
818 7     7 1 1544 my $self = shift;
819 7         8 my $jid = shift;
820 7         7 my $resource = shift;
821 7         7 my $key = shift;
822              
823 7 50 33     20 $jid = $jid->GetJID() if (ref $jid && $jid->isa('Net::XMPP::JID'));
824              
825 7 50       24 return unless $self->resourceExists($jid,$resource);
826 7 100       15 if (defined($key))
827             {
828 4 100       18 return unless exists($self->{JIDS}->{$jid}->{resources}->{$resource}->{$key});
829 3         15 return $self->{JIDS}->{$jid}->{resources}->{$resource}->{$key};
830             }
831 3         3 return %{$self->{JIDS}->{$jid}->{resources}->{$resource};}
  3         22  
832             }
833              
834              
835             ###############################################################################
836             #
837             # resources - returns a list of the resources from highest priority to lowest.
838             #
839             ###############################################################################
840             sub resources
841             {
842 16     16 1 986 my $self = shift;
843 16         17 my $jid = shift;
844              
845 16 50 33     36 $jid = $jid->GetJID() if (ref $jid && $jid->isa('Net::XMPP::JID'));
846              
847 16 50       26 return () unless $self->exists($jid);
848              
849 16         19 my @resources;
850              
851 16         18 foreach my $priority (sort {$b cmp $a} keys(%{$self->{JIDS}->{$jid}->{priorities}}))
  3         10  
  16         69  
852             {
853 9         6 foreach my $index (0..$#{$self->{JIDS}->{$jid}->{priorities}->{$priority}})
  9         25  
854             {
855 9 50       34 next if ($self->{JIDS}->{$jid}->{priorities}->{$priority}->[$index]->{resource} eq " ");
856 9         31 push(@resources,$self->{JIDS}->{$jid}->{priorities}->{$priority}->[$index]->{resource});
857             }
858             }
859 16         38 return @resources;
860             }
861              
862              
863             ##############################################################################
864             #
865             # resourceStore - allows you to store anything on the item that you want to.
866             # The only drawback is that when the item is removed, the data
867             # is not kept. You must restore it in the DB.
868             #
869             ##############################################################################
870             sub resourceStore
871             {
872 1     1 1 2 my $self = shift;
873 1         2 my $jid = shift;
874 1         2 my $resource = shift;
875 1         2 my $key = shift;
876 1         2 my $value = shift;
877              
878 1 50 33     5 $jid = $jid->GetJID() if (ref $jid && $jid->isa('Net::XMPP::JID'));
879              
880 1 50       4 return unless defined($key);
881 1 50       3 return unless defined($value);
882 1 50       3 return unless $self->resourceExists($jid,$resource);
883              
884 1         5 $self->{JIDS}->{$jid}->{resources}->{$resource}->{$key} = $value;
885             }
886              
887              
888             ##############################################################################
889             #
890             # store - allows you to store anything on the item that you want to. The
891             # only drawback is that when the item is removed, the data is not
892             # kept. You must restore it in the DB.
893             #
894             ##############################################################################
895             sub store
896             {
897 1     1 1 3 my $self = shift;
898 1         2 my $jid = shift;
899 1         1 my $key = shift;
900 1         2 my $value = shift;
901              
902 1 50 33     5 $jid = $jid->GetJID() if (ref $jid && $jid->isa('Net::XMPP::JID'));
903              
904 1 50       3 return unless defined($key);
905 1 50       3 return unless defined($value);
906 1 50       4 return unless $self->exists($jid);
907              
908 1         5 $self->{JIDS}->{$jid}->{$key} = $value;
909             }
910              
911              
912             1;
913