import release 0.020.02

11 files changed, 472 insertions, 0 deletions

diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..10b5458
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1,4 @@
+META.yml
+Makefile
+/blib
+/pm_to_blib
diff --git a/Changes b/Changes
new file mode 100644
index 0000000..caa2188
--- /dev/null
+++ b/Changes
@@ -0,0 +1,8 @@
+Revision history for DJabberd-RosterStorage-SQLite-Fixed
+
+0.02    2007-08-21
+        Add rosteredit.pl script.  Add in views
+
+0.01    2007-08-01
+        First version, released on an unsuspecting world.
+
diff --git a/MANIFEST b/MANIFEST
new file mode 100644
index 0000000..9afbfda
--- /dev/null
+++ b/MANIFEST
@@ -0,0 +1,10 @@
+Changes
+MANIFEST
+Makefile.PL
+README
+scripts/rosteredit.pl
+lib/DJabberd/RosterStorage/SQLite/Fixed.pm
+t/00-load.t
+t/boilerplate.t
+t/pod-coverage.t
+t/pod.t
diff --git a/Makefile.PL b/Makefile.PL
new file mode 100644
index 0000000..a7cff9f
--- /dev/null
+++ b/Makefile.PL
@@ -0,0 +1,19 @@
+use strict;
+use warnings;
+use ExtUtils::MakeMaker;
+
+WriteMakefile(
+    NAME                => 'DJabberd::RosterStorage::SQLite::Fixed',
+    AUTHOR              => 'Edward Rudd <urkle@outoforder.cc>',
+    VERSION_FROM        => 'lib/DJabberd/RosterStorage/SQLite/Fixed.pm',
+    EXE_FILES           => ['scripts/rosteredit.pl'],
+    ABSTRACT_FROM       => 'lib/DJabberd/RosterStorage/SQLite/Fixed.pm',
+    PL_FILES            => {},
+    PREREQ_PM => {
+        'Test::More' => 0,
+        'DJabberd' => 0.83,
+        'DJabberd::RosterStorage::SQLite' => 1.00
+    },
+    dist                => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', },
+    clean               => { FILES => 'DJabberd-RosterStorage-SQLite-Fixed-*' },
+);
diff --git a/README b/README
new file mode 100644
index 0000000..f71c083
--- /dev/null
+++ b/README
@@ -0,0 +1,26 @@
+DJabberd-RosterStorage-SQLite-Fixed
+
+Shared Roster for DJabberd using SQLite.
+
+INSTALLATION
+
+To install this module, run the following commands:
+
+    perl Makefile.PL
+    make
+    make test
+    make install
+
+
+SUPPORT AND DOCUMENTATION
+
+After installing, you can find documentation for this module with the perldoc command.
+
+    perldoc DJabberd::RosterStorage::SQLite::Fixed
+
+COPYRIGHT AND LICENCE
+
+Copyright (C) 2007 Edward Rudd
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
diff --git a/lib/DJabberd/RosterStorage/SQLite/Fixed.pm b/lib/DJabberd/RosterStorage/SQLite/Fixed.pm
new file mode 100644
index 0000000..fe41363
--- /dev/null
+++ b/lib/DJabberd/RosterStorage/SQLite/Fixed.pm
@@ -0,0 +1,274 @@
+package DJabberd::RosterStorage::SQLite::Fixed;
+use strict;
+use warnings;
+use base 'DJabberd::RosterStorage::SQLite';
+use DJabberd::Log;
+use DJabberd::Util;
+our $logger = DJabberd::Log->get_logger();
+
+=head1 NAME
+
+DJabberd::RosterStorage::SQLite::Fixed - a shared roster implementation for the SQLite roster storage
+
+=head1 VERSION
+
+Version 0.02
+=cut
+
+our $VERSION = '0.02';
+
+=head1 SYNOPSIS
+
+    <VHost mydomain.com>
+
+        [...]
+
+        <Plugin DJabberd::RosterStorage::SQLite::Fixed>
+            Database jabberroster.sqlite
+            FixedGuestOK yes
+        </Plugin>
+    </VHost>
+
+Valid command are all command valid in DJabberd::RosterStorage::SQLite Plus the following
+
+FixedGuestOK - Populate accounts with the shared roster if they are not in the roster itself?
+ Setting this to yes will populate a user who is not in the shared roster with everyone in the shared roster
+ The default is to only populate rosters for users that are part of the shared roster
+
+=head1 AUTHOR
+
+Edward Rudd, C<< <urkle at outoforder.cc> >>
+
+=cut
+
+=head2 set_config_fixedguestok($self, $guest)
+
+Called to specify if guests should have the shared roster added to their roster
+
+=cut
+
+sub set_config_fixedguestok {
+    my ($self, $guest) = @_;
+    $self->{fixed_guestok} = as_bool $guest;
+}
+
+=head2 finalize($self)
+
+Set defaults for the configuration
+
+=cut
+
+sub finalize {
+    my $self = shift;
+    $self->{fixed_guestok} = 0 unless $self->{fixed_guestok};
+    $self->SUPER::finalize;
+}
+
+=head2 get_roster($self, $cb, $jid)
+
+Gets the Roster for the user
+
+=cut
+
+sub get_roster {
+    my ($self, $cb, $jid) = @_;
+    # cb can '->set_roster(Roster)' or decline
+
+    my $myself = lc $jid->as_bare_string;
+    $logger->info("Fixed loading roster for $myself ...");
+
+    my $on_load_roster = sub {
+        my (undef, $roster) = @_;
+
+        my $pre_ct = $roster->items;
+        $logger->info("  $pre_ct roster items prior to population...");
+
+        # see which shared contacts already in roster
+        my %has;
+        foreach my $it ($roster->items) {
+            my $jid = $it->jid;
+            $has{lc $jid->as_bare_string} = $it;
+        }
+
+        # add missing shared contacts to the roster
+        my $req_roster = $self->_roster();
+        if ($self->{fixed_guestok}==0) {
+            my $guestok = 0;
+            foreach my $user ( @$req_roster) {
+                if ($user->{jid} eq $myself) {
+                    $guestok = 1;
+                    last;
+                }
+            }
+            # Bail if guestOK == 0 && user it not in the roster
+            return if $guestok == 0;
+        }
+
+        foreach my $user ( @$req_roster) {
+            next if $user->{jid} eq $myself;
+
+            my $name = $user->{name};
+            my $ri = $has{$user->{jid}} || DJabberd::RosterItem->new(jid  => $user->{jid},
+                                                             name => ($user->{name} || $user->{jid}),
+                                                             groups => [$user->{group}]);
+
+
+            $ri->subscription->set_from;
+            $ri->subscription->set_to;
+            $roster->add($ri);
+        }
+
+        my $post_ct = $roster->items;
+        $logger->info("  $post_ct roster items post population...");
+
+        $cb->set_roster($roster);
+    };
+
+    my $cb2 = DJabberd::Callback->new({set_roster => $on_load_roster,
+                                      decline    => sub { $cb->decline }});
+    $self->SUPER::get_roster($cb2, $jid);
+}
+
+=head2 check_install_schema($self)
+
+Checks the SQL ite Schema
+
+=cut
+
+sub check_install_schema {
+    my $self = shift;
+
+    $self->SUPER::check_install_schema();
+
+    my $dbh = $self->{dbh};
+
+    eval {
+        $dbh->do(qq{
+            CREATE TABLE requiredusers (
+                                 jid VARCHAR(255) NOT NULL,
+                                 fullname VARCHAR(255) NOT NULL,
+                                 groupname VARCHAR(255) NOT NULL,
+                                 UNIQUE (jid)
+                                 )});
+    };
+    if ($@ && $@ !~ /table \w+ already exists/) {
+        $logger->logdie("SQL error $@");
+        die "SQL error: $@\n";
+    }
+    eval {
+        $dbh->do(qq{
+            CREATE VIEW RosterPreview AS
+                SELECT ju.jid AS UserID, g.name AS [Group], 
+                    jr.jid AS ContactID, r.name AS Contact, r.subscription AS Subscription
+                FROM roster r
+                    JOIN jidmap ju ON r.userid=ju.jidid
+                    JOIN jidmap jr ON r.contactid = jr.jidid
+                    JOIN groupitem gi ON gi.contactid=r.contactid
+                    JOIN rostergroup g ON g.userid=r.userid AND g.groupid=gi.groupid
+                    UNION SELECT r1.jid, r2.groupname, r2.jid, r2.fullname, 3
+                    FROM requiredusers r1, requiredusers r2
+                        WHERE r1.jid != r2.jid});
+    };
+    if ($@ && $@ !~ /table \w+ already exists/) {
+        $logger->logdie("SQL error $@");
+        die "SQL error: $@\n";
+    }
+    eval {
+        $dbh->do(qq{
+            CREATE VIEW RosterList AS
+                SELECT J.jidid as LID, J2.jidid as RID, 
+                    G.groupid as GID,
+                    J.jid AS Local, J2.jid AS Remote,
+                    G.name AS [Group]
+                FROM jidmap J
+                    JOIN rostergroup G ON G.userid=J.jidid
+                    JOIN groupitem M ON G.groupid = M.groupid
+                    JOIN jidmap J2 ON J2.jidid = M.contactid
+                ORDER BY J.jid, J2.jid});
+    };
+    if ($@ && $@ !~ /table \w+ already exists/) {
+        $logger->logdie("SQL error $@");
+        die "SQL error: $@\n";
+    }
+    $logger->info("Created all roster tables");
+}
+
+my $last_roster;
+my $last_roster_time = 0;  # unixtime of last SQL suck
+sub _roster {
+    my $self = shift;
+    my $now = time();
+
+    # Cache list for 1 minute(s)
+    if ($last_roster && $last_roster_time > $now - 60) {
+        return $last_roster;
+    }
+
+    my $dbh = $self->{dbh};
+
+    my $sql = qq{
+        SELECT jid, fullname, groupname FROM requiredusers
+    };
+
+    my $roster = eval {
+        $dbh->selectall_arrayref($sql);
+    };
+    $logger->logdie("Failed to load roster: $@") if $@;
+
+    $logger->info("Found ".($#{ @$roster}+1)." Roster users");
+
+    my @info = ();
+    foreach my $item ( @$roster ) {
+        my $rec = {};
+        $rec->{'jid'} = $item->[0];
+        $rec->{'name'} = $item->[1];
+        $rec->{'group'} = $item->[2];
+        push @info, $rec;
+    }
+    $logger->info("Loaded ".($#info+1)." Roster users");
+    $last_roster_time = $now;
+    return $last_roster = \@info;
+}
+
+=head2 load_roster_item($self, $jid, $contact_jid, $cb)
+
+Called when a roster item is added
+
+=cut
+
+sub load_roster_item {
+    my ($self, $jid, $contact_jid, $cb) = @_;
+
+    my $is_shared = sub {
+        my $jid = shift;
+        my $roster = $self->_roster();
+        foreach my $user (@$roster) {
+            if (lc $user->{jid} eq lc $jid->as_bare_string) { return 1; }
+        }
+        return 0;
+    };
+
+    if ($is_shared->($jid) && $is_shared->($contact_jid)) {
+        my $both = DJabberd::Subscription->new;
+        $both->set_from;
+        $both->set_to;
+        my $rit = DJabberd::RosterItem->new(jid  => $contact_jid,
+                                            subscription => $both);
+        $cb->set($rit);
+        return;
+    }
+
+    $self->SUPER::load_roster_item($jid, $contact_jid, $cb);
+}
+
+=head1 COPYRIGHT & LICENSE
+
+Original work Copyright 2006 Alexander Karelas, Martin Atkins, Brad Fitzpatrick and Aleksandar Milanov. All rights reserved.
+Copyright 2007 Edward Rudd. 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;
diff --git a/scripts/rosteredit.pl b/scripts/rosteredit.pl
new file mode 100755
index 0000000..4c7132d
--- /dev/null
+++ b/scripts/rosteredit.pl
@@ -0,0 +1,62 @@
+#!/usr/bin/perl
+
+use strict;
+
+use DBI;
+
+if ($#ARGV < 0) {
+    die ("must specify database then action (list, add, del, preview)\n");
+}
+my $db = shift @ARGV;
+my $dbh = DBI->connect_cached("dbi:SQLite:dbname=$db","","", { RaiseError => 1, PrintError => 0, AutoCommit => 1 });
+
+my $action;
+my $param;
+
+if ($#ARGV < 0) {
+    die ("must specify action (list, add, del, preview)\n");
+} else {
+    $action = shift @ARGV;
+    for ($action) {
+        if (/^preview$/) {
+            if ($#ARGV < 0) {
+                die ("Must specify jabber id");
+            }
+            my $sql = "SELECT [Group], ContactID, Contact, Subscription FROM RosterPreview WHERE UserID = ?";
+            my ($jid) = @ARGV;
+            my $roster = eval {
+               $dbh->selectall_arrayref($sql,{ Slite=> {} },$jid);
+            };
+            foreach my $item ( @$roster ) {
+                print "Entry: $item->[3]  $item->[2]<$item->[1]> in group $item->[0]\n";
+            }
+        } elsif (/^list$/) {
+            my $sql = "SELECT jid, fullname, groupname FROM requiredusers ORDER BY groupname, fullname";
+            my $roster = eval {
+               $dbh->selectall_arrayref($sql,{ Slite=> {} });
+            };
+            foreach my $item ( @$roster ) {
+                print "Entry: $item->[1]<$item->[0]> in group $item->[2]\n";
+            }
+        } elsif (/^add$/) {
+            if ($#ARGV < 2) {
+                die ("Must specify jabber id, fullname and groupname");
+            }
+            my $sql = "INSERT INTO requiredusers (jid, fullname, groupname) VALUES (?, ?, ?)";
+            my ($jid, $fname, $gname) = @ARGV;
+            print "Adding: $fname<$jid> to group $gname\n";
+            $dbh->do($sql,undef,$jid,$fname,$gname);
+        } elsif (/^del$/) {
+            if ($#ARGV < 0) {
+                die ("Must specify jabber id");
+            }
+            my $sql = "DELETE FROM requiredusers WHERE jid = ?";
+            my ($jid) = @ARGV;
+            print "Deleting: $jid\n";
+            $dbh->do($sql,undef,$jid);
+        } else {
+            die ("Unknown action $action\n");
+        }
+    }
+}
+
diff --git a/t/00-load.t b/t/00-load.t
new file mode 100644
index 0000000..786b9cd
--- /dev/null
+++ b/t/00-load.t
@@ -0,0 +1,9 @@
+#!perl -T
+
+use Test::More tests => 1;
+
+BEGIN {
+        use_ok( 'DJabberd::RosterStorage::SQLite::Fixed' );
+}
+
+diag( "Testing DJabberd::RosterStorage::SQLite::Fixed $DJabberd::RosterStorage::SQLite::Fixed::VERSION, Perl $], $^X" );
diff --git a/t/boilerplate.t b/t/boilerplate.t
new file mode 100644
index 0000000..824d393
--- /dev/null
+++ b/t/boilerplate.t
@@ -0,0 +1,48 @@
+#!perl -T
+
+use strict;
+use warnings;
+use Test::More tests => 3;
+
+sub not_in_file_ok {
+    my ($filename, %regex) = @_;
+    open my $fh, "<", $filename
+        or die "couldn't open $filename for reading: $!";
+
+    my %violated;
+
+    while (my $line = <$fh>) {
+        while (my ($desc, $regex) = each %regex) {
+            if ($line =~ $regex) {
+                push @{$violated{$desc}||=[]}, $.;
+            }
+        }
+    }
+
+    if (%violated) {
+        fail("$filename contains boilerplate text");
+        diag "$_ appears on lines @{$violated{$_}}" for keys %violated;
+    } else {
+        pass("$filename contains no boilerplate text");
+    }
+}
+
+not_in_file_ok(README =>
+    "The README is used..."       => qr/The README is used/,
+    "'version information here'"  => qr/to provide version information/,
+);
+
+not_in_file_ok(Changes =>
+    "placeholder date/time"       => qr(Date/time)
+);
+
+sub module_boilerplate_ok {
+    my ($module) = @_;
+    not_in_file_ok($module =>
+        'the great new $MODULENAME'   => qr/ - The great new /,
+        'boilerplate description'     => qr/Quick summary of what the module/,
+        'stub function definition'    => qr/function[12]/,
+    );
+}
+
+module_boilerplate_ok('lib/DJabberd/RosterStorage/SQLite/Fixed.pm');
diff --git a/t/pod-coverage.t b/t/pod-coverage.t
new file mode 100644
index 0000000..703f91d
--- /dev/null
+++ b/t/pod-coverage.t
@@ -0,0 +1,6 @@
+#!perl -T
+
+use Test::More;
+eval "use Test::Pod::Coverage 1.04";
+plan skip_all => "Test::Pod::Coverage 1.04 required for testing POD coverage" if $@;
+all_pod_coverage_ok();
diff --git a/t/pod.t b/t/pod.t
new file mode 100644
index 0000000..976d7cd
--- /dev/null
+++ b/t/pod.t
@@ -0,0 +1,6 @@
+#!perl -T
+
+use Test::More;
+eval "use Test::Pod 1.14";
+plan skip_all => "Test::Pod 1.14 required for testing POD" if $@;
+all_pod_files_ok();