XMPP2/IM/Roster.pm

package Net::XMPP2::IM::Presence;
use strict;
use Net::XMPP2::Util;

sub new {
   my $this = shift;
   my $class = ref($this) || $this;
   bless { @_ }, $class;
}

sub _set {
   my ($self, %data) = @_;
   $self->{show}     = $data{show} || '';
   $self->{priority} = $data{priority};
   $self->{status}   = $data{status};
}

sub jid { $_[0]->{jid} }

sub priority { $_[0]->{priority} }

sub status_all {
   my ($self, $jid) = @_;
   @{$self->{status} || []}
}

sub show { $_[0]->{show} }

sub status {
   my ($self) = @_;

   my @stati = $self->status_all;
   for (@stati) {
      if ((not defined $_->[0]) || $_->[0] eq '') {
         return $_->[1];
      }
   }

   my @en = grep { $_->[0] eq 'en' } @stati;

   return $en[1]->[1] if @en;

   return $stati[1]->[1] if @stati;

   undef
}

sub debug_dump {
   my ($self) = @_;
   printf "   * %-30s [%-5s] (%3d)          {%s}\n",
      $self->jid,
      $self->show     || '',
      $self->priority || 0,
      $self->status   || '',
}

package Net::XMPP2::IM::Contact;
use strict;
use Net::XMPP2::Util;

sub new {
   my $this = shift;
   my $class = ref($this) || $this;
   bless { @_ }, $class;
}

sub _set {
   my ($self, %data) = @_;
   $self->{$_} = $data{$_} for keys %data;
}

sub remove_presence {
   my ($self, $jid) = @_;
   my $sjid = Net::XMPP2::Util::stringprep_jid ($jid);
   delete $self->{presences}->{$sjid}
}

sub touch_presence {
   my ($self, $jid) = @_;
   my $sjid = Net::XMPP2::Util::stringprep_jid ($jid);

   unless (exists $self->{presences}->{$sjid}) {
      $self->{presences}->{$sjid} =
         Net::XMPP2::IM::Presence->new (connection => $self->{connection}, jid => $jid);
   }
   $self->{presences}->{$sjid}
}

sub get_presences { values %{$_[0]->{presences}} }

sub set_presence {
   my ($self, $jid, %data) = @_;
   if ($data{type} eq 'unavailable') {
      $self->remove_presence ($jid);
   } else {
      my $p = $self->touch_presence ($jid);
      $p->_set (%data);
   }
}

sub groups {
   @{$_[0]->{groups} || []}
}

sub jid {
   $_[0]->{jid}
}

sub name {
   $_[0]->{name}
}

sub subscription {
   $_[0]->{subscription}
}

sub write_simple_message {
   my ($self, $type, $message) = @_;
   $self->{connection}->send_message ($self->jid, $type, undef, body => $message);
}

sub write_message {
   my ($self, $type, $create_cb, %attrs) = @_;
   $self->{connection}->send_message ($self->jid, $type, $create_cb, %attrs);
}

sub debug_dump {
   my ($self) = @_;
   printf "- %-30s    [%-20s] (%s)\n",
      $self->jid,
      $self->name || '',
      $self->subscription;

   for ($self->get_presences) {
      $_->debug_dump;
   }
}

package Net::XMPP2::IM::Roster;
use strict;
=head1 NAME

Net::XMPP2::IM::Roster - A instant messaging roster for XMPP

=head1 SYNOPSIS

   use Net::XMPP2::IM::Roster;

   my $con = Net::XMPP2::IM::Connection->new (...);
   ...
   my $ro  = Net::XMPP2::IM::Roster->new (connection => $con);

=head1 DESCRIPTION

This module represents a class for roster objects which contain
contact information.

=cut

sub new {
   my $this = shift;
   my $class = ref($this) || $this;
   bless { @_ }, $class;
}

sub touch_jid {
   my ($self, $jid) = @_;
   my $bjid = Net::XMPP2::Util::prep_bare_jid ($jid);

   unless ($self->{contacts}->{$bjid}) {
      $self->{contacts}->{$bjid} =
         Net::XMPP2::IM::Contact->new (
            connection => $self->{connection},
            jid        => Net::XMPP2::Util::bare_jid ($jid)
         )
   }

   $self->{contacts}->{$bjid}
}

sub set_presence {
   my ($self, $jid, %data) = @_;
   $self->get_contact ($jid)->set_presence ($jid, %data);
}

sub set_contact {
   my ($self, $jid, %data) = @_;
   $self->get_contact ($jid)->_set (%data);
}

sub get_contact {
   my ($self, $jid) = @_;
   $self->touch_jid ($jid);
}

sub debug_dump {
   my ($self) = @_;
   print "### ROSTER BEGIN ###\n";
   my %groups;
   for my $contact (values %{$self->{contacts}}) {
      push @{$groups{$_}}, $contact for $contact->groups;
      push @{$groups{''}}, $contact unless $contact->groups;
   }

   for my $grp (sort keys %groups) {
      print "=== $grp ====\n";
      $_->debug_dump for @{$groups{$grp}};
   }
   print "### ROSTER END ###\n";
}

=head1 AUTHOR

Robin Redeker, C<< <elmex at ta-sa.org> >>

=head1 BUGS

Please report any bugs or feature requests to
C<bug-net-xmpp2 at rt.cpan.org>, or through the web interface at
L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Net-XMPP2>.
I will be notified, and then you'll automatically be notified of progress on
your bug as I make changes.

=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc Net::XMPP2

You can also look for information at:

=over 4

=item * AnnoCPAN: Annotated CPAN documentation

L<http://annocpan.org/dist/Net-XMPP2>

=item * CPAN Ratings

L<http://cpanratings.perl.org/d/Net-XMPP2>

=item * RT: CPAN's request tracker

L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Net-XMPP2>

=item * Search CPAN

L<http://search.cpan.org/dist/Net-XMPP2>

=back

=head1 ACKNOWLEDGEMENTS

=head1 COPYRIGHT & LICENSE

Copyright 2007 Robin Redeker, all rights reserved.

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=cut


1; # End of Net::XMPP2
Revision:	1.1
Committed:	Tue Feb 6 22:52:45 2007 UTC (19 years, 8 months ago) by elmex
Branch:	MAIN
Log Message:	implemented firts parts of roster handling. added jid handling functions.
#	User	Rev	Content
1	elmex	1.1	package Net::XMPP2::IM::Presence;
2			use strict;
3			use Net::XMPP2::Util;
4
5			sub new {
6			my $this = shift;
7			my $class = ref($this) \|\| $this;
8			bless { @_ }, $class;
9			}
10
11			sub _set {
12			my ($self, %data) = @_;
13			$self->{show} = $data{show} \|\| '';
14			$self->{priority} = $data{priority};
15			$self->{status} = $data{status};
16			}
17
18			sub jid { $_[0]->{jid} }
19
20			sub priority { $_[0]->{priority} }
21
22			sub status_all {
23			my ($self, $jid) = @_;
24			@{$self->{status} \|\| []}
25			}
26
27			sub show { $_[0]->{show} }
28
29			sub status {
30			my ($self) = @_;
31
32			my @stati = $self->status_all;
33			for (@stati) {
34			if ((not defined $_->[0]) \|\| $_->[0] eq '') {
35			return $_->[1];
36			}
37			}
38
39			my @en = grep { $_->[0] eq 'en' } @stati;
40
41			return $en[1]->[1] if @en;
42
43			return $stati[1]->[1] if @stati;
44
45			undef
46			}
47
48			sub debug_dump {
49			my ($self) = @_;
50			printf " * %-30s [%-5s] (%3d) {%s}\n",
51			$self->jid,
52			$self->show \|\| '',
53			$self->priority \|\| 0,
54			$self->status \|\| '',
55			}
56
57			package Net::XMPP2::IM::Contact;
58			use strict;
59			use Net::XMPP2::Util;
60
61			sub new {
62			my $this = shift;
63			my $class = ref($this) \|\| $this;
64			bless { @_ }, $class;
65			}
66
67			sub _set {
68			my ($self, %data) = @_;
69			$self->{$_} = $data{$_} for keys %data;
70			}
71
72			sub remove_presence {
73			my ($self, $jid) = @_;
74			my $sjid = Net::XMPP2::Util::stringprep_jid ($jid);
75			delete $self->{presences}->{$sjid}
76			}
77
78			sub touch_presence {
79			my ($self, $jid) = @_;
80			my $sjid = Net::XMPP2::Util::stringprep_jid ($jid);
81
82			unless (exists $self->{presences}->{$sjid}) {
83			$self->{presences}->{$sjid} =
84			Net::XMPP2::IM::Presence->new (connection => $self->{connection}, jid => $jid);
85			}
86			$self->{presences}->{$sjid}
87			}
88
89			sub get_presences { values %{$_[0]->{presences}} }
90
91			sub set_presence {
92			my ($self, $jid, %data) = @_;
93			if ($data{type} eq 'unavailable') {
94			$self->remove_presence ($jid);
95			} else {
96			my $p = $self->touch_presence ($jid);
97			$p->_set (%data);
98			}
99			}
100
101			sub groups {
102			@{$_[0]->{groups} \|\| []}
103			}
104
105			sub jid {
106			$_[0]->{jid}
107			}
108
109			sub name {
110			$_[0]->{name}
111			}
112
113			sub subscription {
114			$_[0]->{subscription}
115			}
116
117			sub write_simple_message {
118			my ($self, $type, $message) = @_;
119			$self->{connection}->send_message ($self->jid, $type, undef, body => $message);
120			}
121
122			sub write_message {
123			my ($self, $type, $create_cb, %attrs) = @_;
124			$self->{connection}->send_message ($self->jid, $type, $create_cb, %attrs);
125			}
126
127			sub debug_dump {
128			my ($self) = @_;
129			printf "- %-30s [%-20s] (%s)\n",
130			$self->jid,
131			$self->name \|\| '',
132			$self->subscription;
133
134			for ($self->get_presences) {
135			$_->debug_dump;
136			}
137			}
138
139			package Net::XMPP2::IM::Roster;
140			use strict;
141			=head1 NAME
142
143			Net::XMPP2::IM::Roster - A instant messaging roster for XMPP
144
145			=head1 SYNOPSIS
146
147			use Net::XMPP2::IM::Roster;
148
149			my $con = Net::XMPP2::IM::Connection->new (...);
150			...
151			my $ro = Net::XMPP2::IM::Roster->new (connection => $con);
152
153			=head1 DESCRIPTION
154
155			This module represents a class for roster objects which contain
156			contact information.
157
158			=cut
159
160			sub new {
161			my $this = shift;
162			my $class = ref($this) \|\| $this;
163			bless { @_ }, $class;
164			}
165
166			sub touch_jid {
167			my ($self, $jid) = @_;
168			my $bjid = Net::XMPP2::Util::prep_bare_jid ($jid);
169
170			unless ($self->{contacts}->{$bjid}) {
171			$self->{contacts}->{$bjid} =
172			Net::XMPP2::IM::Contact->new (
173			connection => $self->{connection},
174			jid => Net::XMPP2::Util::bare_jid ($jid)
175			)
176			}
177
178			$self->{contacts}->{$bjid}
179			}
180
181			sub set_presence {
182			my ($self, $jid, %data) = @_;
183			$self->get_contact ($jid)->set_presence ($jid, %data);
184			}
185
186			sub set_contact {
187			my ($self, $jid, %data) = @_;
188			$self->get_contact ($jid)->_set (%data);
189			}
190
191			sub get_contact {
192			my ($self, $jid) = @_;
193			$self->touch_jid ($jid);
194			}
195
196			sub debug_dump {
197			my ($self) = @_;
198			print "### ROSTER BEGIN ###\n";
199			my %groups;
200			for my $contact (values %{$self->{contacts}}) {
201			push @{$groups{$_}}, $contact for $contact->groups;
202			push @{$groups{''}}, $contact unless $contact->groups;
203			}
204
205			for my $grp (sort keys %groups) {
206			print "=== $grp ====\n";
207			$_->debug_dump for @{$groups{$grp}};
208			}
209			print "### ROSTER END ###\n";
210			}
211
212			=head1 AUTHOR
213
214			Robin Redeker, C<< <elmex at ta-sa.org> >>
215
216			=head1 BUGS
217
218			Please report any bugs or feature requests to
219			C<bug-net-xmpp2 at rt.cpan.org>, or through the web interface at
220			L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Net-XMPP2>.
221			I will be notified, and then you'll automatically be notified of progress on
222			your bug as I make changes.
223
224			=head1 SUPPORT
225
226			You can find documentation for this module with the perldoc command.
227
228			perldoc Net::XMPP2
229
230			You can also look for information at:
231
232			=over 4
233
234			=item * AnnoCPAN: Annotated CPAN documentation
235
236			L<http://annocpan.org/dist/Net-XMPP2>
237
238			=item * CPAN Ratings
239
240			L<http://cpanratings.perl.org/d/Net-XMPP2>
241
242			=item * RT: CPAN's request tracker
243
244			L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Net-XMPP2>
245
246			=item * Search CPAN
247
248			L<http://search.cpan.org/dist/Net-XMPP2>
249
250			=back
251
252			=head1 ACKNOWLEDGEMENTS
253
254			=head1 COPYRIGHT & LICENSE
255
256			Copyright 2007 Robin Redeker, all rights reserved.
257
258			This program is free software; you can redistribute it and/or modify it
259			under the same terms as Perl itself.
260
261			=cut
262
263
264
265			1; # End of Net::XMPP2