lib/TWiki/Contrib/MailerContrib/Subscriber.pm
author Colas Nahaboo <colas@nahaboo.net>
Sat, 26 Jan 2008 15:50:53 +0100
changeset 0 414e01d06fd5
permissions -rw-r--r--
RELEASE 4.2.0 freetown
colas@0
     1
# Module of TWiki Enterprise Collaboration Platform, http://TWiki.org/
colas@0
     2
#
colas@0
     3
# Copyright (C) 2004 Wind River Systems Inc.
colas@0
     4
# Copyright (C) 1999-2006 TWiki Contributors.
colas@0
     5
# All Rights Reserved. TWiki Contributors
colas@0
     6
# are listed in the AUTHORS file in the root of this distribution.
colas@0
     7
# NOTE: Please extend that file, not this notice.
colas@0
     8
#
colas@0
     9
# This program is free software; you can redistribute it and/or
colas@0
    10
# modify it under the terms of the GNU General Public License
colas@0
    11
# as published by the Free Software Foundation; either version 2
colas@0
    12
# of the License, or (at your option) any later version. For
colas@0
    13
# more details read LICENSE in the root of this distribution.
colas@0
    14
#
colas@0
    15
# This program is distributed in the hope that it will be useful,
colas@0
    16
# but WITHOUT ANY WARRANTY; without even the implied warranty of
colas@0
    17
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
colas@0
    18
#
colas@0
    19
# As per the GPL, removal of this notice is prohibited.
colas@0
    20
colas@0
    21
use strict;
colas@0
    22
colas@0
    23
=pod
colas@0
    24
colas@0
    25
---+ package TWiki::Contrib::MailerContrib::Subscriber
colas@0
    26
Object that represents a subscriber to notification. A subscriber is
colas@0
    27
a name (which may be a wikiName or an email address) and a list of
colas@0
    28
subscriptions which describe the topis subscribed to, and
colas@0
    29
unsubscriptions representing topics they are specifically not
colas@0
    30
interested in. The subscriber
colas@0
    31
name may also be a group, so it may expand to many email addresses.
colas@0
    32
colas@0
    33
=cut
colas@0
    34
colas@0
    35
package TWiki::Contrib::MailerContrib::Subscriber;
colas@0
    36
colas@0
    37
use TWiki;
colas@0
    38
use TWiki::Plugins;
colas@0
    39
use Assert;
colas@0
    40
colas@0
    41
require TWiki::Contrib::MailerContrib::WebNotify;
colas@0
    42
colas@0
    43
=pod
colas@0
    44
colas@0
    45
---++ new($name)
colas@0
    46
   * =$name= - Wikiname, with no web, or email address, of user targeted for notification
colas@0
    47
Create a new user.
colas@0
    48
colas@0
    49
=cut
colas@0
    50
colas@0
    51
sub new {
colas@0
    52
    my ( $class, $name ) = @_;
colas@0
    53
    my $this = bless( { name => $name }, $class );
colas@0
    54
colas@0
    55
    return $this;
colas@0
    56
}
colas@0
    57
colas@0
    58
=pod
colas@0
    59
colas@0
    60
---++ getEmailAddresses() -> \@list
colas@0
    61
Get a list of email addresses for the user(s) represented by this
colas@0
    62
subscription
colas@0
    63
colas@0
    64
=cut
colas@0
    65
colas@0
    66
sub getEmailAddresses {
colas@0
    67
    my $this = shift;
colas@0
    68
colas@0
    69
    unless ( defined( $this->{emails} )) {
colas@0
    70
        if ( $this->{name} =~ /^$TWiki::cfg{MailerContrib}{EmailFilterIn}$/ ) {
colas@0
    71
            push( @{$this->{emails}}, $this->{name} );
colas@0
    72
        } else {
colas@0
    73
            my $users = $TWiki::Plugins::SESSION->{users};
colas@0
    74
            if ($users->can('findUserByWikiName')) {
colas@0
    75
                # User is represented by a wikiname. Map to a canonical
colas@0
    76
                # userid.
colas@0
    77
                my $list = $users->findUserByWikiName($this->{name});
colas@0
    78
                foreach my $user (@$list) {
colas@0
    79
                    # Automatically expands groups
colas@0
    80
                    push( @{$this->{emails}}, $users->getEmails($user) );
colas@0
    81
                }
colas@0
    82
            } else {
colas@0
    83
                # Old code; use the user object
colas@0
    84
                my $user = $users->findUser( $this->{name}, undef, 1 );
colas@0
    85
                if( $user ) {
colas@0
    86
                    push( @{$this->{emails}}, $user->emails() );
colas@0
    87
                } else {
colas@0
    88
                    $user = $users->findUser(
colas@0
    89
                        $this->{name}, $this->{name}, 1 );
colas@0
    90
                    if( $user ) {
colas@0
    91
                        push( @{$this->{emails}}, $user->emails() );
colas@0
    92
                    } else {
colas@0
    93
                        # unknown - can't find an email
colas@0
    94
                        $this->{emails} = [];
colas@0
    95
                    }
colas@0
    96
                }
colas@0
    97
            }
colas@0
    98
        }
colas@0
    99
    }
colas@0
   100
    return $this->{emails};
colas@0
   101
}
colas@0
   102
colas@0
   103
# Add a subsciption to an internal list, optimising the list so that
colas@0
   104
# the fewest subscriptions are kept that are needed to cover all
colas@0
   105
# topics.
colas@0
   106
sub _addAndOptimise {
colas@0
   107
    my( $this, $set, $new ) = @_;
colas@0
   108
colas@0
   109
    # Don't add already covered duplicates
colas@0
   110
    my $i = 0;
colas@0
   111
    my @remove;
colas@0
   112
    foreach my $known (@{$this->{$set}}) {
colas@0
   113
        return if $known->covers($new);
colas@0
   114
        if( $new->covers( $known )) {
colas@0
   115
            # remove anything covered by the new subscription
colas@0
   116
            unshift(@remove, $i);
colas@0
   117
        }
colas@0
   118
        $i++;
colas@0
   119
    }
colas@0
   120
    foreach $i (@remove) {
colas@0
   121
        splice(@{$this->{$set}}, $i, 1);
colas@0
   122
    }
colas@0
   123
    push( @{$this->{$set}}, $new );
colas@0
   124
}
colas@0
   125
colas@0
   126
# Subtract a subscription from an internal list. Do the best job
colas@0
   127
# you can in the face of wildcards.
colas@0
   128
sub _subtract {
colas@0
   129
    my( $this, $set, $new ) = @_;
colas@0
   130
colas@0
   131
    my $i = 0;
colas@0
   132
    my @remove;
colas@0
   133
    foreach my $known (@{$this->{$set}}) {
colas@0
   134
        if( $new->covers( $known )) {
colas@0
   135
            # remove anything covered by the new subscription
colas@0
   136
            unshift(@remove, $i);
colas@0
   137
        }
colas@0
   138
        $i++;
colas@0
   139
    }
colas@0
   140
    foreach $i (@remove) {
colas@0
   141
        splice(@{$this->{$set}}, $i, 1);
colas@0
   142
    }
colas@0
   143
}
colas@0
   144
colas@0
   145
=pod
colas@0
   146
colas@0
   147
---++ subscribe($subs)
colas@0
   148
   * =$subs= - Subscription object
colas@0
   149
Add a new subscription to this subscriber object.
colas@0
   150
colas@0
   151
=cut
colas@0
   152
colas@0
   153
sub subscribe {
colas@0
   154
    my ( $this, $subs ) = @_;
colas@0
   155
colas@0
   156
    $this->_addAndOptimise( 'subscriptions', $subs );
colas@0
   157
    $this->_subtract( 'unsubscriptions', $subs );
colas@0
   158
}
colas@0
   159
colas@0
   160
=pod
colas@0
   161
colas@0
   162
---++ unsubscribe($subs)
colas@0
   163
   * =$subs= - Subscription object
colas@0
   164
Add a new unsubscription to this subscriber object.
colas@0
   165
The unsubscription will always be added, even if there is
colas@0
   166
a wildcard overlap with an existing subscription or unsubscription.
colas@0
   167
colas@0
   168
An unsubscription is a statement of the subscribers desire _not_
colas@0
   169
to be notified of changes to this topic.
colas@0
   170
colas@0
   171
=cut
colas@0
   172
colas@0
   173
sub unsubscribe {
colas@0
   174
    my ( $this, $subs ) = @_;
colas@0
   175
colas@0
   176
    $this->_addAndOptimise( 'unsubscriptions', $subs );
colas@0
   177
    $this->_subtract( 'subscriptions', $subs );
colas@0
   178
}
colas@0
   179
colas@0
   180
=pod
colas@0
   181
colas@0
   182
---++ isSubscribedTo($topic, $db) -> $subscription
colas@0
   183
   * =$topic= - Topic object we are checking
colas@0
   184
   * =$db= - TWiki::Contrib::MailerContrib::UpData database of parents
colas@0
   185
Check if we have a subscription to the given topic. Return the subscription
colas@0
   186
that matches if we do, undef otherwise.
colas@0
   187
colas@0
   188
=cut
colas@0
   189
colas@0
   190
sub isSubscribedTo {
colas@0
   191
   my ( $this, $topic, $db ) = @_;
colas@0
   192
colas@0
   193
   foreach my $subscription ( @{$this->{subscriptions}} ) {
colas@0
   194
       if ( $subscription->matches( $topic, $db )) {
colas@0
   195
           return $subscription;
colas@0
   196
       }
colas@0
   197
   }
colas@0
   198
colas@0
   199
   return undef;
colas@0
   200
}
colas@0
   201
colas@0
   202
=pod
colas@0
   203
colas@0
   204
---++ isUnsubscribedFrom($topic) -> $subscription
colas@0
   205
   * =$topic= - Topic object we are checking
colas@0
   206
   * =$db= - TWiki::Contrib::MailerContrib::UpData database of parents
colas@0
   207
Check if we have an unsubscription from the given topic. Return the subscription that matches if we do, undef otherwise.
colas@0
   208
colas@0
   209
=cut
colas@0
   210
colas@0
   211
sub isUnsubscribedFrom {
colas@0
   212
   my ( $this, $topic, $db ) = @_;
colas@0
   213
colas@0
   214
   foreach my $subscription ( @{$this->{unsubscriptions}} ) {
colas@0
   215
       if ( $subscription->matches( $topic, $db )) {
colas@0
   216
           return $subscription;
colas@0
   217
       }
colas@0
   218
   }
colas@0
   219
colas@0
   220
   return undef;
colas@0
   221
}
colas@0
   222
colas@0
   223
=pod
colas@0
   224
colas@0
   225
---++ stringify() -> string
colas@0
   226
Return a string representation of this object, in Web<nop>Notify format.
colas@0
   227
colas@0
   228
=cut
colas@0
   229
colas@0
   230
sub stringify {
colas@0
   231
    my $this = shift;
colas@0
   232
    my $subs = join( ' ',
colas@0
   233
                     map { $_->stringify(); }
colas@0
   234
                     @{$this->{subscriptions}} );
colas@0
   235
    my $unsubs = join( " - ",
colas@0
   236
                       map { $_->stringify(); }
colas@0
   237
                       @{$this->{unsubscriptions}} );
colas@0
   238
    $unsubs = " - $unsubs" if $unsubs;
colas@0
   239
colas@0
   240
    my $name = $this->{name};
colas@0
   241
    if ($name !~ /^($TWiki::regex{wikiWordRegex}|$TWiki::cfg{MailerContrib}{EmailFilterIn})$/) {
colas@0
   242
        $name = $name =~ /'/ ? '"'.$name.'"' : "'$name'";
colas@0
   243
    }
colas@0
   244
    return "   * " . $name . ": " .
colas@0
   245
      $subs . $unsubs;
colas@0
   246
}
colas@0
   247
colas@0
   248
1;