| [vhffs-dev] [807] Renaming Vhffs::Services::Mailing to Vhffs::Services::MailingList ( part two) |
[ Thread Index |
Date Index
| More vhffs.org/vhffs-dev Archives
]
Revision: 807
Author: gradator
Date: 2007-08-29 23:43:28 +0000 (Wed, 29 Aug 2007)
Log Message:
-----------
Renaming Vhffs::Services::Mailing to Vhffs::Services::MailingList (part two)
Modified Paths:
--------------
trunk/vhffs-api/src/Vhffs/Makefile.am
trunk/vhffs-tests/src/Makefile.am
Added Paths:
-----------
trunk/vhffs-api/src/Vhffs/Services/MailingList.pm
trunk/vhffs-tests/src/Services/MailingList.pl
Removed Paths:
-------------
trunk/vhffs-api/src/Vhffs/Services/Mailing.pm
trunk/vhffs-tests/src/Services/Mailing.pl
Modified: trunk/vhffs-api/src/Vhffs/Makefile.am
===================================================================
--- trunk/vhffs-api/src/Vhffs/Makefile.am 2007-08-29 23:41:26 UTC (rev 806)
+++ trunk/vhffs-api/src/Vhffs/Makefile.am 2007-08-29 23:43:28 UTC (rev 807)
@@ -57,7 +57,7 @@
Services/DNS.pm \
Services/Web.pm \
Services/Mail.pm \
- Services/Mailing.pm \
+ Services/MailingList.pm \
Services/MailUser.pm \
Services/MailGroup.pm \
Services/Mysql.pm \
Deleted: trunk/vhffs-api/src/Vhffs/Services/Mailing.pm
===================================================================
--- trunk/vhffs-api/src/Vhffs/Services/Mailing.pm 2007-08-29 23:41:26 UTC (rev 806)
+++ trunk/vhffs-api/src/Vhffs/Services/Mailing.pm 2007-08-29 23:43:28 UTC (rev 807)
@@ -1,597 +0,0 @@
-#!%PERL%
-# Copyright (c) vhffs project and its contributors
-# All rights reserved.
-#
-# Redistribution and use in source and binary forms, with or without
-# modification, are permitted provided that the following conditions
-# are met:
-#
-# 1. Redistributions of source code must retain the above copyright
-# notice, this list of conditions and the following disclaimer.
-#2. Redistributions in binary form must reproduce the above copyright
-# notice, this list of conditions and the following disclaimer in
-# the documentation and/or other materials provided with the
-# distribution.
-#3. Neither the name of vhffs nor the names of its contributors
-# may be used to endorse or promote products derived from this
-# software without specific prior written permission.
-#
-#THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-#"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-#LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
-#FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
-#COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
-#INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
-#BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
-#LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
-#CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
-# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
-# ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
-# POSSIBILITY OF SUCH DAMAGE.
-
-
-# This file is a part of VHFFS4 software, a hosting platform suite
-# Please respect the licence of this file and whole program
-
-=pod
-
-=head1 NAME
-
-Vhffs::Services::MailingList - Handle mailing lists in VHFFS.
-
-=head1 SYNOPSIS
-
-TODO
-
-=head1 METHODS
-
-=cut
-
-package Vhffs::Services::MailingList;
-
-use base qw(Vhffs::Object);
-use strict;
-use DBI;
-
-=pod
-
-=head2 create
-
- my $ml = Vhffs::Services::MailingList::create($local, $domain, $admin, $description, $user, $group);
- die('Unable to create list') unless defined $ml;
-
-Creates a new mailing list in database and returns the corresponding fully functional object.
-Returns undef if an error occurs (box, forward or mailing list with the same address already
-exists, domain not found, ...).
-
-=cut
-sub create
-{
- my ($main, $local, $domain, $admin, $description, $user, $group) = @_;
-
- return undef unless(defined $user && defined $group);
- return undef unless($local =~ /^[a-z0-9\_\-]+$/);
- return undef unless(Vhffs::Functions::check_domain_name($domain));
- return undef if(Vhffs::Services::Mail::address_exists($main, $local, $domain));
- $admin = $user->get_mail() unless(defined $admin);
-
- my $ml;
-
- my $dbh = $main->get_db_object();
- local $dbh->{RaiseError} = 1;
- local $dbh->{PrintError} = 0;
- $dbh->begin_work;
-
- eval {
- # Group must be the mail domain owner or use default mail domain.
- my $sql = 'SELECT mxdomain_id FROM vhffs_mxdomain m INNER JOIN vhffs_object o ON o.object_id = m.object_id WHERE m.domain = ? AND o.owner_gid = ?';
- die('Mail domain not found') unless($domain eq $main->get_config()->get_service("mailing")->{'default_domain'} ||
- $dbh->do($sql, undef, $domain, $group->get_gid) > 0);
-
- my $parent = Vhffs::Object::create($main, $user->get_uid, $group->get_gid, $description, undef, Vhffs::Constants::TYPE_ML);
- die('Unable to create parent object') unless(defined $parent);
-
- # open sub, post members only
- $sql = 'INSERT INTO vhffs_ml(local_part, domain, prefix, object_id, admin, open_archive, reply_to, sub_ctrl, post_ctrl) VALUES(?, ?, ?, ?, ?, FALSE, TRUE, ?, ? )';
- my $sth = $dbh->prepare($sql);
- $sth->execute($local, $domain, $local, $parent->get_oid, $admin, Vhffs::Constants::ML_SUBSCRIBE_NO_APPROVAL_REQUIRED, Vhffs::Constants::ML_POSTING_MEMBERS_ONLY);
- $dbh->commit;
- $ml = get_by_mladdress($main, $local, $domain);
- };
-
- if($@) {
- warn "Unable to create mailing list $local\@$domain: $@\n";
- $dbh->rollback;
- }
-
- return $ml;
-
-}
-
-=pod
-
-=head2 get_by_mladdress
-
- my $ml = Vhffs::Services::MailingList::get_by_mladdress($main, $local_part, $domain);
- die("Mailing list $localpart\@$domain not found\n") unless(defined $ml);
-
-Fetches the mailing list $local_part@$domain.
-
-=cut
-
-sub get_by_mladdress {
- my ($main, $local, $domain) = @_;
-
- my $dbh = $main->get_db_object();
- my $sql = 'SELECT ml.ml_id, ml.local_part, ml.domain, ml.prefix, o.owner_gid, ml.admin, ml.open_archive, ml.reply_to, ml.sub_ctrl, ml.post_ctrl, ml.signature, o.object_id, o.owner_uid, o.date_creation, o.state, o.description FROM vhffs_ml ml INNER JOIN vhffs_object o ON o.object_id = ml.object_id WHERE domain = ? and local_part = ?';
- my $sth = $dbh->prepare($sql);
- return undef unless ($sth->execute($domain, $local) > 0);
- my @params = $sth->fetchrow_array;
-
- push @params, fetch_subs($dbh, $params[0]);
- return _new Vhffs::Services::MailingList($main, @params);
-}
-
-=head2 fetch_subs
-
- my $subs = fetch_subs($dbh, $ml_id);
-
-Returns an hashref of hashrefs containing all subscribers indexed on their
-mail addresses.
-
-Internal module use only.
-
-=cut
-
-sub fetch_subs {
-
- my ($dbh, $ml_id) = @_;
-
- my $sql = q{SELECT sub_id, member, perm, hash, ml_id, language
- FROM vhffs_ml_subscribers WHERE ml_id = ?};
- return $dbh->selectall_hashref($sql, 'member', undef, $ml_id);
-}
-
-=head2 fill_object
-
-See C<Vhffs::Object::fill_object>.
-
-=cut
-
-sub fill_object {
- my ($class, $obj) = @_;
- my $sql = q{SELECT ml_id, local_part, domain, prefix, admin, open_archive,
- reply_to, sub_ctrl, post_ctrl, signature FROM vhffs_ml
- WHERE object_id = ?};
- $obj = $class->SUPER::_fill_object($obj, $sql);
- if($obj->isa('Vhffs::Services::MailingList')) {
- $obj->{subs} = fetch_subs($obj->get_db_object, $obj->{ml_id});
- }
- return $obj;
-}
-
-sub _new {
- my ($class, $main, $ml_id, $local_part, $domain, $prefix, $owner_gid, $admin, $open_archive, $reply_to, $sub_ctrl, $post_ctrl, $signature, $oid, $owner_uid, $date_creation, $state, $description, $subs) = @_;
-
- my $self = $class->SUPER::_new($main, $oid, $owner_uid, $owner_gid, $date_creation, $description, $state, Vhffs::Constants::TYPE_ML);
- return undef unless defined($self);
-
- $self->{ml_id} = $ml_id;
- $self->{local_part} = $local_part;
- $self->{domain} = $domain,
- $self->{prefix} = $prefix;
- $self->{admin} = $admin;
- $self->{open_archive} = $open_archive;
- $self->{reply_to} = $reply_to;
- $self->{sub_ctrl} = $sub_ctrl;
- $self->{post_ctrl} = $post_ctrl;
- $self->{signature} = $signature;
- $self->{subs} = $subs;
-
- return $self;
-}
-
-# Commit all changes of the current instance in the database
-sub commit
-{
- my $self = shift;
-
- my $sql = 'UPDATE vhffs_ml SET prefix = ?, admin = ?, open_archive = ?, reply_to = ?, sub_ctrl = ?, post_ctrl = ?, signature = ? WHERE ml_id = ?';
- my $dbh = $self->get_main->get_db_object();
- $dbh->do($sql, undef, $self->{prefix}, $self->{admin}, $self->{open_archive}, $self->{reply_to}, $self->{sub_ctrl}, $self->{post_ctrl}, $self->{signature}, $self->{ml_id});
-
- return -3 if( $self->SUPER::commit < 0 );
-
- return 1;
-}
-
-sub change_right_for_sub
-{
- my ($self, $subscriber, $right) = @_;
-
- my $sql = 'UPDATE vhffs_ml_subscribers SET perm = ? WHERE ml_id = ? AND member = ?';
- my $dbh = $self->get_main->get_db_object();
- # FIXME compatibility hack, we should return a boolean
- return -1 unless($dbh->do($sql, undef, $right, $self->{ml_id}, $subscriber) > 0);
- $self->{subs}->{$subscriber}->{perm} = $right;
- return 1;
-}
-
-
-sub add_sub
-{
- my $self = shift;
- my $subscriber = shift;
- my $right = shift;
-
- return -1 if( Vhffs::Functions::valid_mail( $subscriber ) != 1 );
- return -2 if( $subscriber =~ /.*<.*/ );
- return -2 if( $subscriber =~ /.*>.*/ );
- return -2 if( $subscriber =~ /.*\s.*/ );
- return -1 if( ! ( $right =~ /^[\d]+$/ ) );
-
- my $sql = 'INSERT INTO vhffs_ml_subscribers (member, perm, hash, ml_id, language) VALUES (?, ?, NULL, ?, NULL)';
- my $dbh = $self->get_main->get_db_object();
- $dbh->do($sql, undef, $subscriber, $right, $self->{ml_id}) or return -2;
-
- my $id = $dbh->last_insert_id(undef, undef, 'vhffs_ml_subscribers', undef);
-
- $self->{subs}->{$subscriber} = {
- sub_id => $id,
- member => $subscriber,
- perm => $right,
- hash => undef,
- ml_id => $self->{ml_id},
- language => undef
- };
-
- return 1;
-}
-
-
-
-#add a subscriber, return undef if already exists
-sub add_sub_with_reply
-{
- my $self = shift;
- my $subscriber = shift;
-
- return undef if( Vhffs::Functions::valid_mail( $subscriber ) != 1 );
- return undef if( $subscriber =~ /.*<.*/ );
- return undef if( $subscriber =~ /.*>.*/ );
- return undef if( $subscriber =~ /.*\s.*/ );
-
- my $pass = Vhffs::Functions::generate_random_password;
-
- my $sql = 'INSERT INTO vhffs_ml_subscribers(member, perm, hash, ml_id, language) VALUES(?, ?, ?, ?, NULL)';
- my $dbh = $self->get_main->get_db_object();
- $dbh->do($sql, undef, $subscriber, Vhffs::Constants::ML_RIGHT_SUB_WAITING_FOR_REPLY, $pass, $self->{ml_id}) or return undef;
-
- my $id = $dbh->last_insert_id(undef, undef, 'vhffs_ml_subscribers', undef);
-
- $self->{subs}->{$subscriber} = {
- sub_id => $id,
- member => $subscriber,
- perm => Vhffs::Constants::ML_RIGHT_SUB_WAITING_FOR_REPLY,
- hash => $pass,
- ml_id => $self->{ml_id},
- language => undef
- };
-
- return $pass;
-}
-
-
-
-sub del_sub
-{
- my $self = shift;
- my $subscriber = shift;
-
- my $sql = 'DELETE FROM vhffs_ml_subscribers WHERE ml_id = ? AND member = ?';
- # FIXME we should return a boolean
- return -1 unless($self->get_main->get_db_object->do($sql, undef, $self->{ml_id}, $subscriber) > 0);
-
- delete $self->{subs}->{$subscriber};
- return 1;
-}
-
-# FIXME useless
-sub change_state_for_sub
-{
- return change_right_for_sub(@_);
-}
-
-sub set_randomhash
-{
- my $self = shift;
- my $subscriber = shift;
- my $pass = Vhffs::Functions::generate_random_password;
-
- my $sql = 'UPDATE vhffs_ml_subscribers SET hash = ? WHERE ml_id = ? AND member = ?';
- return undef unless($self->get_main->get_db_object->do($sql, undef, $pass, $self->{ml_id}, $subscriber) > 0);
-
- $self->{subs}->{$subscriber}->{hash} = $pass;
- return $pass;
-}
-
-
-sub clear_hash
-{
- my $self = shift;
- my $subscriber = shift;
-
- my $sql = 'UPDATE vhffs_ml_subscribers SET hash = NULL WHERE ml_id = ? AND member = ?';
- # FIXME we should return a boolean
- return -1 unless($self->get_main->get_db_object->do($sql, undef, $self->{ml_id}, $subscriber) > 0);
-
- $self->{subs}->{$subscriber}->{hash} = undef;
- return 1;
-}
-
-=head2 address_exists
-
- print("A mailing list with the same address already exists\n")
- if Vhffs::Mailing::address_exists($vhffs, $local_part, $domain);
-
-Return true if a mailing list C<$local_part>@C<$domain> already exists.
-
-=cut
-
-sub address_exists($$$) {
- my ($vhffs, $local_part, $domain) = @_;
-
- my $sql = 'SELECT COUNT(*) FROM vhffs_ml WHERE local_part = ? AND domain = ?';
- my $dbh = $vhffs->get_db_object();
- my $res = $dbh->selectrow_array($sql, {}, $local_part, $domain);
- return (defined($res) && $res > 0);
-}
-
-sub del_sub_with_reply
-{
- use Digest::MD5;
-
- my $self = shift;
- my $subscriber = shift;
-
-
- my $hash = Digest::MD5::md5_hex( Vhffs::Functions::generate_random_password );
-
- my $sql = 'UPDATE vhffs_ml_subscribers SET perm = ?, hash = ? WHERE ml_id = ? AND member = ? AND perm IN (?, ?)';
- # FIXME we should return a boolean
- return undef unless($self->get_main->get_db_object->do($sql, undef, Vhffs::Constants::ML_RIGHT_SUB_WAITING_FOR_DEL, $hash, $self->{ml_id}, $subscriber, Vhffs::Constants::ML_RIGHT_SUB, Vhffs::Constants::ML_RIGHT_ADMIN) > 0);
-
- $self->{subs}->{$subscriber}->{hash} = $hash;
- $self->{subs}->{$subscriber}->{perm} = Vhffs::Constants::ML_RIGHT_SUB_WAITING_FOR_DEL;
- return $hash;
-}
-
-sub get_language_for_sub
-{
- my ($main, $sub) = @_;
-
- my $sql = 'SELECT language FROM vhffs_ml_subscribers WHERE member = ?';
- my $lang = $main->get_db_object->selectrow_array($sql, undef, $sub);
- return $lang;
-}
-
-sub set_language_for_sub
-{
- my ($main, $sub, $language) = @_;
-
- $language = 'en_US' unless( $language =~ /^\w+$/ );
- my $sql = 'UPDATE vhffs_ml_subscribers SET language = ? WHERE member = ?';
- $main->get_db_object->do($sql, undef, $language, $sub) or return -1;
-}
-
-sub get_localpart
-{
- my $self = shift;
- return $self->{'local_part'};
-}
-
-sub get_signature
-{
- my $self = shift;
- return $self->{signature};
-}
-
-sub set_signature
-{
- my ($self, $sig) = @_;
- $sig =~ s/\r\n/\n/;
- $self->{signature} = $sig;
-}
-
-sub get_open_archive
-{
- my $self = shift;
- return $self->{'open_archive'};
-}
-
-sub get_sub_ctrl
-{
- my $self = shift;
- return $self->{'sub_ctrl'};
-}
-
-sub get_post_ctrl
-{
- my $self = shift;
- return $self->{'post_ctrl'};
-}
-
-sub get_replyto
-{
- my $self = shift;
- return $self->{'reply_to'};
-}
-
-sub get_admin
-{
- my $self = shift;
- return $self->{'admin'};
-}
-
-sub get_domain
-{
- my $self = shift;
- return $self->{'domain'};
-}
-
-sub get_prefix
-{
- my $self = shift;
- return $self->{'prefix'};
-}
-
-sub get_members
-{
- my $self = shift;
- return $self->{subs};
-}
-
-sub set_replytolist
-{
- my $self;
- my $string = $self->{'local_part'} ."\@" . $self->{'domain'} ;
- return $self->set_replyto( $string );
-}
-
-sub set_replyto
-{
- my( $self , $value ) = @_;
- return -2 if( ( $value != 0 ) && ( $value != 1 ) );
- $self->{'reply_to'} = $value;
- return 1;
-}
-
-sub set_open_archive
-{
- my( $self , $value ) = @_;
- $self->{'open_archive'} = $value;
-}
-
-sub set_sub_ctrl
-{
- my( $self , $value ) = @_;
- return -1 unless ( $value =~ /\d+/ );
- return -1 if( $value < Vhffs::Constants::ML_SUBSCRIBE_NO_APPROVAL_REQUIRED || $value > Vhffs::Constants::ML_SUBSCRIBE_CLOSED );
- $self->{'sub_ctrl'} = $value;
- return 0;
-}
-
-sub set_post_ctrl
-{
- my( $self , $value ) = @_;
- return -1 unless ( $value =~ /\d+/ );
- return -1 if ( $value < Vhffs::Constants::ML_POSTING_OPEN_ALL || $value > Vhffs::Constants::ML_POSTING_ADMINS_ONLY );
- $self->{'post_ctrl'} = $value;
- return 0;
-}
-
-sub set_admin
-{
- my $self = shift;
- my $value = shift;
- $self->{'admin'} = $value;
-}
-
-sub set_prefix
-{
- my( $self , $value ) = @_;
-
- $self->{'prefix'} = $value;
-}
-
-sub getall_subs
-{
- my $self = shift;
- return ( keys %{$self->{subs}} );
-}
-
-sub getall
-{
- my ($vhffs, $state, $name, $group, $domain) = @_;
-
- return undef if( ! defined $vhffs );
-
- my $mls = [];
- my @params;
- my $sql = 'SELECT local_part, domain FROM vhffs_ml ml, vhffs_object o WHERE o.object_id = ml.object_id';
-
- if(defined $state) {
- $sql .= ' AND o.state = ?';
- push @params, $state;
- }
- if(defined $group) {
- $sql .= ' AND o.owner_gid = ?';
- push @params, $group->get_gid;
- }
- if(defined $name) {
- $sql .= ' AND ( local_part LIKE ? OR domain LIKE ?)';
- push @params, '%'.$name.'%', '%'.$name.'%';
- }
- if(defined $domain) {
- $sql .= ' AND domain = ?';
- push @params, $domain;
- }
-
- $sql .= ' ORDER BY local_part, domain';
-
- my $dbh = $vhffs->get_db_object;
- my $sth = $dbh->prepare($sql);
- $sth->execute(@params) or return -3;
-
- while(my @ml = $sth->fetchrow_array) {
- push @$mls, get_by_mladdress($vhffs, @ml);
- }
- return $mls;
-}
-
-
-
-#Returns all the lists for a group
-# FIXME useless
-sub getall_by_group
-{
- my $vhffs = shift;
- my $group = shift;
-
- return getall($vhffs, undef, undef, $group);
-}
-
-=head2 get_label
-
-See C<Vhffs::Object::get_label>.
-
-=cut
-
-sub get_label {
- my $self = shift;
- return $self->{local_part}.'@'.$self->{domain};
-}
-
-
-
-sub get_title
-{
- my $self = shift;
- return $self->{local_part} . "\@" . $self->{domain};
-}
-
-sub get_listname
-{
- my $self = shift;
- return $self->get_localpart."\@".$self->get_domain;
-}
-
-1;
-
-__END__
-
-=head1 AUTHORS
-
-Julien Delange < god at gunnm dot org >
-Sebastien Le Ray < beuss at tuxfamily dot org >
-Sylvain Rochet < gradator at gradator dot net >
Copied: trunk/vhffs-api/src/Vhffs/Services/MailingList.pm (from rev 806, trunk/vhffs-api/src/Vhffs/Services/Mailing.pm)
===================================================================
--- trunk/vhffs-api/src/Vhffs/Services/MailingList.pm (rev 0)
+++ trunk/vhffs-api/src/Vhffs/Services/MailingList.pm 2007-08-29 23:43:28 UTC (rev 807)
@@ -0,0 +1,597 @@
+#!%PERL%
+# Copyright (c) vhffs project and its contributors
+# All rights reserved.
+#
+# Redistribution and use in source and binary forms, with or without
+# modification, are permitted provided that the following conditions
+# are met:
+#
+# 1. Redistributions of source code must retain the above copyright
+# notice, this list of conditions and the following disclaimer.
+#2. Redistributions in binary form must reproduce the above copyright
+# notice, this list of conditions and the following disclaimer in
+# the documentation and/or other materials provided with the
+# distribution.
+#3. Neither the name of vhffs nor the names of its contributors
+# may be used to endorse or promote products derived from this
+# software without specific prior written permission.
+#
+#THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+#"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+#LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
+#FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+#COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
+#INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
+#BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
+#LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
+#CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
+# ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+# POSSIBILITY OF SUCH DAMAGE.
+
+
+# This file is a part of VHFFS4 software, a hosting platform suite
+# Please respect the licence of this file and whole program
+
+=pod
+
+=head1 NAME
+
+Vhffs::Services::MailingList - Handle mailing lists in VHFFS.
+
+=head1 SYNOPSIS
+
+TODO
+
+=head1 METHODS
+
+=cut
+
+package Vhffs::Services::MailingList;
+
+use base qw(Vhffs::Object);
+use strict;
+use DBI;
+
+=pod
+
+=head2 create
+
+ my $ml = Vhffs::Services::MailingList::create($local, $domain, $admin, $description, $user, $group);
+ die('Unable to create list') unless defined $ml;
+
+Creates a new mailing list in database and returns the corresponding fully functional object.
+Returns undef if an error occurs (box, forward or mailing list with the same address already
+exists, domain not found, ...).
+
+=cut
+sub create
+{
+ my ($main, $local, $domain, $admin, $description, $user, $group) = @_;
+
+ return undef unless(defined $user && defined $group);
+ return undef unless($local =~ /^[a-z0-9\_\-]+$/);
+ return undef unless(Vhffs::Functions::check_domain_name($domain));
+ return undef if(Vhffs::Services::Mail::address_exists($main, $local, $domain));
+ $admin = $user->get_mail() unless(defined $admin);
+
+ my $ml;
+
+ my $dbh = $main->get_db_object();
+ local $dbh->{RaiseError} = 1;
+ local $dbh->{PrintError} = 0;
+ $dbh->begin_work;
+
+ eval {
+ # Group must be the mail domain owner or use default mail domain.
+ my $sql = 'SELECT mxdomain_id FROM vhffs_mxdomain m INNER JOIN vhffs_object o ON o.object_id = m.object_id WHERE m.domain = ? AND o.owner_gid = ?';
+ die('Mail domain not found') unless($domain eq $main->get_config()->get_service("mailing")->{'default_domain'} ||
+ $dbh->do($sql, undef, $domain, $group->get_gid) > 0);
+
+ my $parent = Vhffs::Object::create($main, $user->get_uid, $group->get_gid, $description, undef, Vhffs::Constants::TYPE_ML);
+ die('Unable to create parent object') unless(defined $parent);
+
+ # open sub, post members only
+ $sql = 'INSERT INTO vhffs_ml(local_part, domain, prefix, object_id, admin, open_archive, reply_to, sub_ctrl, post_ctrl) VALUES(?, ?, ?, ?, ?, FALSE, TRUE, ?, ? )';
+ my $sth = $dbh->prepare($sql);
+ $sth->execute($local, $domain, $local, $parent->get_oid, $admin, Vhffs::Constants::ML_SUBSCRIBE_NO_APPROVAL_REQUIRED, Vhffs::Constants::ML_POSTING_MEMBERS_ONLY);
+ $dbh->commit;
+ $ml = get_by_mladdress($main, $local, $domain);
+ };
+
+ if($@) {
+ warn "Unable to create mailing list $local\@$domain: $@\n";
+ $dbh->rollback;
+ }
+
+ return $ml;
+
+}
+
+=pod
+
+=head2 get_by_mladdress
+
+ my $ml = Vhffs::Services::MailingList::get_by_mladdress($main, $local_part, $domain);
+ die("Mailing list $localpart\@$domain not found\n") unless(defined $ml);
+
+Fetches the mailing list $local_part@$domain.
+
+=cut
+
+sub get_by_mladdress {
+ my ($main, $local, $domain) = @_;
+
+ my $dbh = $main->get_db_object();
+ my $sql = 'SELECT ml.ml_id, ml.local_part, ml.domain, ml.prefix, o.owner_gid, ml.admin, ml.open_archive, ml.reply_to, ml.sub_ctrl, ml.post_ctrl, ml.signature, o.object_id, o.owner_uid, o.date_creation, o.state, o.description FROM vhffs_ml ml INNER JOIN vhffs_object o ON o.object_id = ml.object_id WHERE domain = ? and local_part = ?';
+ my $sth = $dbh->prepare($sql);
+ return undef unless ($sth->execute($domain, $local) > 0);
+ my @params = $sth->fetchrow_array;
+
+ push @params, fetch_subs($dbh, $params[0]);
+ return _new Vhffs::Services::MailingList($main, @params);
+}
+
+=head2 fetch_subs
+
+ my $subs = fetch_subs($dbh, $ml_id);
+
+Returns an hashref of hashrefs containing all subscribers indexed on their
+mail addresses.
+
+Internal module use only.
+
+=cut
+
+sub fetch_subs {
+
+ my ($dbh, $ml_id) = @_;
+
+ my $sql = q{SELECT sub_id, member, perm, hash, ml_id, language
+ FROM vhffs_ml_subscribers WHERE ml_id = ?};
+ return $dbh->selectall_hashref($sql, 'member', undef, $ml_id);
+}
+
+=head2 fill_object
+
+See C<Vhffs::Object::fill_object>.
+
+=cut
+
+sub fill_object {
+ my ($class, $obj) = @_;
+ my $sql = q{SELECT ml_id, local_part, domain, prefix, admin, open_archive,
+ reply_to, sub_ctrl, post_ctrl, signature FROM vhffs_ml
+ WHERE object_id = ?};
+ $obj = $class->SUPER::_fill_object($obj, $sql);
+ if($obj->isa('Vhffs::Services::MailingList')) {
+ $obj->{subs} = fetch_subs($obj->get_db_object, $obj->{ml_id});
+ }
+ return $obj;
+}
+
+sub _new {
+ my ($class, $main, $ml_id, $local_part, $domain, $prefix, $owner_gid, $admin, $open_archive, $reply_to, $sub_ctrl, $post_ctrl, $signature, $oid, $owner_uid, $date_creation, $state, $description, $subs) = @_;
+
+ my $self = $class->SUPER::_new($main, $oid, $owner_uid, $owner_gid, $date_creation, $description, $state, Vhffs::Constants::TYPE_ML);
+ return undef unless defined($self);
+
+ $self->{ml_id} = $ml_id;
+ $self->{local_part} = $local_part;
+ $self->{domain} = $domain,
+ $self->{prefix} = $prefix;
+ $self->{admin} = $admin;
+ $self->{open_archive} = $open_archive;
+ $self->{reply_to} = $reply_to;
+ $self->{sub_ctrl} = $sub_ctrl;
+ $self->{post_ctrl} = $post_ctrl;
+ $self->{signature} = $signature;
+ $self->{subs} = $subs;
+
+ return $self;
+}
+
+# Commit all changes of the current instance in the database
+sub commit
+{
+ my $self = shift;
+
+ my $sql = 'UPDATE vhffs_ml SET prefix = ?, admin = ?, open_archive = ?, reply_to = ?, sub_ctrl = ?, post_ctrl = ?, signature = ? WHERE ml_id = ?';
+ my $dbh = $self->get_main->get_db_object();
+ $dbh->do($sql, undef, $self->{prefix}, $self->{admin}, $self->{open_archive}, $self->{reply_to}, $self->{sub_ctrl}, $self->{post_ctrl}, $self->{signature}, $self->{ml_id});
+
+ return -3 if( $self->SUPER::commit < 0 );
+
+ return 1;
+}
+
+sub change_right_for_sub
+{
+ my ($self, $subscriber, $right) = @_;
+
+ my $sql = 'UPDATE vhffs_ml_subscribers SET perm = ? WHERE ml_id = ? AND member = ?';
+ my $dbh = $self->get_main->get_db_object();
+ # FIXME compatibility hack, we should return a boolean
+ return -1 unless($dbh->do($sql, undef, $right, $self->{ml_id}, $subscriber) > 0);
+ $self->{subs}->{$subscriber}->{perm} = $right;
+ return 1;
+}
+
+
+sub add_sub
+{
+ my $self = shift;
+ my $subscriber = shift;
+ my $right = shift;
+
+ return -1 if( Vhffs::Functions::valid_mail( $subscriber ) != 1 );
+ return -2 if( $subscriber =~ /.*<.*/ );
+ return -2 if( $subscriber =~ /.*>.*/ );
+ return -2 if( $subscriber =~ /.*\s.*/ );
+ return -1 if( ! ( $right =~ /^[\d]+$/ ) );
+
+ my $sql = 'INSERT INTO vhffs_ml_subscribers (member, perm, hash, ml_id, language) VALUES (?, ?, NULL, ?, NULL)';
+ my $dbh = $self->get_main->get_db_object();
+ $dbh->do($sql, undef, $subscriber, $right, $self->{ml_id}) or return -2;
+
+ my $id = $dbh->last_insert_id(undef, undef, 'vhffs_ml_subscribers', undef);
+
+ $self->{subs}->{$subscriber} = {
+ sub_id => $id,
+ member => $subscriber,
+ perm => $right,
+ hash => undef,
+ ml_id => $self->{ml_id},
+ language => undef
+ };
+
+ return 1;
+}
+
+
+
+#add a subscriber, return undef if already exists
+sub add_sub_with_reply
+{
+ my $self = shift;
+ my $subscriber = shift;
+
+ return undef if( Vhffs::Functions::valid_mail( $subscriber ) != 1 );
+ return undef if( $subscriber =~ /.*<.*/ );
+ return undef if( $subscriber =~ /.*>.*/ );
+ return undef if( $subscriber =~ /.*\s.*/ );
+
+ my $pass = Vhffs::Functions::generate_random_password;
+
+ my $sql = 'INSERT INTO vhffs_ml_subscribers(member, perm, hash, ml_id, language) VALUES(?, ?, ?, ?, NULL)';
+ my $dbh = $self->get_main->get_db_object();
+ $dbh->do($sql, undef, $subscriber, Vhffs::Constants::ML_RIGHT_SUB_WAITING_FOR_REPLY, $pass, $self->{ml_id}) or return undef;
+
+ my $id = $dbh->last_insert_id(undef, undef, 'vhffs_ml_subscribers', undef);
+
+ $self->{subs}->{$subscriber} = {
+ sub_id => $id,
+ member => $subscriber,
+ perm => Vhffs::Constants::ML_RIGHT_SUB_WAITING_FOR_REPLY,
+ hash => $pass,
+ ml_id => $self->{ml_id},
+ language => undef
+ };
+
+ return $pass;
+}
+
+
+
+sub del_sub
+{
+ my $self = shift;
+ my $subscriber = shift;
+
+ my $sql = 'DELETE FROM vhffs_ml_subscribers WHERE ml_id = ? AND member = ?';
+ # FIXME we should return a boolean
+ return -1 unless($self->get_main->get_db_object->do($sql, undef, $self->{ml_id}, $subscriber) > 0);
+
+ delete $self->{subs}->{$subscriber};
+ return 1;
+}
+
+# FIXME useless
+sub change_state_for_sub
+{
+ return change_right_for_sub(@_);
+}
+
+sub set_randomhash
+{
+ my $self = shift;
+ my $subscriber = shift;
+ my $pass = Vhffs::Functions::generate_random_password;
+
+ my $sql = 'UPDATE vhffs_ml_subscribers SET hash = ? WHERE ml_id = ? AND member = ?';
+ return undef unless($self->get_main->get_db_object->do($sql, undef, $pass, $self->{ml_id}, $subscriber) > 0);
+
+ $self->{subs}->{$subscriber}->{hash} = $pass;
+ return $pass;
+}
+
+
+sub clear_hash
+{
+ my $self = shift;
+ my $subscriber = shift;
+
+ my $sql = 'UPDATE vhffs_ml_subscribers SET hash = NULL WHERE ml_id = ? AND member = ?';
+ # FIXME we should return a boolean
+ return -1 unless($self->get_main->get_db_object->do($sql, undef, $self->{ml_id}, $subscriber) > 0);
+
+ $self->{subs}->{$subscriber}->{hash} = undef;
+ return 1;
+}
+
+=head2 address_exists
+
+ print("A mailing list with the same address already exists\n")
+ if Vhffs::Mailing::address_exists($vhffs, $local_part, $domain);
+
+Return true if a mailing list C<$local_part>@C<$domain> already exists.
+
+=cut
+
+sub address_exists($$$) {
+ my ($vhffs, $local_part, $domain) = @_;
+
+ my $sql = 'SELECT COUNT(*) FROM vhffs_ml WHERE local_part = ? AND domain = ?';
+ my $dbh = $vhffs->get_db_object();
+ my $res = $dbh->selectrow_array($sql, {}, $local_part, $domain);
+ return (defined($res) && $res > 0);
+}
+
+sub del_sub_with_reply
+{
+ use Digest::MD5;
+
+ my $self = shift;
+ my $subscriber = shift;
+
+
+ my $hash = Digest::MD5::md5_hex( Vhffs::Functions::generate_random_password );
+
+ my $sql = 'UPDATE vhffs_ml_subscribers SET perm = ?, hash = ? WHERE ml_id = ? AND member = ? AND perm IN (?, ?)';
+ # FIXME we should return a boolean
+ return undef unless($self->get_main->get_db_object->do($sql, undef, Vhffs::Constants::ML_RIGHT_SUB_WAITING_FOR_DEL, $hash, $self->{ml_id}, $subscriber, Vhffs::Constants::ML_RIGHT_SUB, Vhffs::Constants::ML_RIGHT_ADMIN) > 0);
+
+ $self->{subs}->{$subscriber}->{hash} = $hash;
+ $self->{subs}->{$subscriber}->{perm} = Vhffs::Constants::ML_RIGHT_SUB_WAITING_FOR_DEL;
+ return $hash;
+}
+
+sub get_language_for_sub
+{
+ my ($main, $sub) = @_;
+
+ my $sql = 'SELECT language FROM vhffs_ml_subscribers WHERE member = ?';
+ my $lang = $main->get_db_object->selectrow_array($sql, undef, $sub);
+ return $lang;
+}
+
+sub set_language_for_sub
+{
+ my ($main, $sub, $language) = @_;
+
+ $language = 'en_US' unless( $language =~ /^\w+$/ );
+ my $sql = 'UPDATE vhffs_ml_subscribers SET language = ? WHERE member = ?';
+ $main->get_db_object->do($sql, undef, $language, $sub) or return -1;
+}
+
+sub get_localpart
+{
+ my $self = shift;
+ return $self->{'local_part'};
+}
+
+sub get_signature
+{
+ my $self = shift;
+ return $self->{signature};
+}
+
+sub set_signature
+{
+ my ($self, $sig) = @_;
+ $sig =~ s/\r\n/\n/;
+ $self->{signature} = $sig;
+}
+
+sub get_open_archive
+{
+ my $self = shift;
+ return $self->{'open_archive'};
+}
+
+sub get_sub_ctrl
+{
+ my $self = shift;
+ return $self->{'sub_ctrl'};
+}
+
+sub get_post_ctrl
+{
+ my $self = shift;
+ return $self->{'post_ctrl'};
+}
+
+sub get_replyto
+{
+ my $self = shift;
+ return $self->{'reply_to'};
+}
+
+sub get_admin
+{
+ my $self = shift;
+ return $self->{'admin'};
+}
+
+sub get_domain
+{
+ my $self = shift;
+ return $self->{'domain'};
+}
+
+sub get_prefix
+{
+ my $self = shift;
+ return $self->{'prefix'};
+}
+
+sub get_members
+{
+ my $self = shift;
+ return $self->{subs};
+}
+
+sub set_replytolist
+{
+ my $self;
+ my $string = $self->{'local_part'} ."\@" . $self->{'domain'} ;
+ return $self->set_replyto( $string );
+}
+
+sub set_replyto
+{
+ my( $self , $value ) = @_;
+ return -2 if( ( $value != 0 ) && ( $value != 1 ) );
+ $self->{'reply_to'} = $value;
+ return 1;
+}
+
+sub set_open_archive
+{
+ my( $self , $value ) = @_;
+ $self->{'open_archive'} = $value;
+}
+
+sub set_sub_ctrl
+{
+ my( $self , $value ) = @_;
+ return -1 unless ( $value =~ /\d+/ );
+ return -1 if( $value < Vhffs::Constants::ML_SUBSCRIBE_NO_APPROVAL_REQUIRED || $value > Vhffs::Constants::ML_SUBSCRIBE_CLOSED );
+ $self->{'sub_ctrl'} = $value;
+ return 0;
+}
+
+sub set_post_ctrl
+{
+ my( $self , $value ) = @_;
+ return -1 unless ( $value =~ /\d+/ );
+ return -1 if ( $value < Vhffs::Constants::ML_POSTING_OPEN_ALL || $value > Vhffs::Constants::ML_POSTING_ADMINS_ONLY );
+ $self->{'post_ctrl'} = $value;
+ return 0;
+}
+
+sub set_admin
+{
+ my $self = shift;
+ my $value = shift;
+ $self->{'admin'} = $value;
+}
+
+sub set_prefix
+{
+ my( $self , $value ) = @_;
+
+ $self->{'prefix'} = $value;
+}
+
+sub getall_subs
+{
+ my $self = shift;
+ return ( keys %{$self->{subs}} );
+}
+
+sub getall
+{
+ my ($vhffs, $state, $name, $group, $domain) = @_;
+
+ return undef if( ! defined $vhffs );
+
+ my $mls = [];
+ my @params;
+ my $sql = 'SELECT local_part, domain FROM vhffs_ml ml, vhffs_object o WHERE o.object_id = ml.object_id';
+
+ if(defined $state) {
+ $sql .= ' AND o.state = ?';
+ push @params, $state;
+ }
+ if(defined $group) {
+ $sql .= ' AND o.owner_gid = ?';
+ push @params, $group->get_gid;
+ }
+ if(defined $name) {
+ $sql .= ' AND ( local_part LIKE ? OR domain LIKE ?)';
+ push @params, '%'.$name.'%', '%'.$name.'%';
+ }
+ if(defined $domain) {
+ $sql .= ' AND domain = ?';
+ push @params, $domain;
+ }
+
+ $sql .= ' ORDER BY local_part, domain';
+
+ my $dbh = $vhffs->get_db_object;
+ my $sth = $dbh->prepare($sql);
+ $sth->execute(@params) or return -3;
+
+ while(my @ml = $sth->fetchrow_array) {
+ push @$mls, get_by_mladdress($vhffs, @ml);
+ }
+ return $mls;
+}
+
+
+
+#Returns all the lists for a group
+# FIXME useless
+sub getall_by_group
+{
+ my $vhffs = shift;
+ my $group = shift;
+
+ return getall($vhffs, undef, undef, $group);
+}
+
+=head2 get_label
+
+See C<Vhffs::Object::get_label>.
+
+=cut
+
+sub get_label {
+ my $self = shift;
+ return $self->{local_part}.'@'.$self->{domain};
+}
+
+
+
+sub get_title
+{
+ my $self = shift;
+ return $self->{local_part} . "\@" . $self->{domain};
+}
+
+sub get_listname
+{
+ my $self = shift;
+ return $self->get_localpart."\@".$self->get_domain;
+}
+
+1;
+
+__END__
+
+=head1 AUTHORS
+
+Julien Delange < god at gunnm dot org >
+Sebastien Le Ray < beuss at tuxfamily dot org >
+Sylvain Rochet < gradator at gradator dot net >
Modified: trunk/vhffs-tests/src/Makefile.am
===================================================================
--- trunk/vhffs-tests/src/Makefile.am 2007-08-29 23:41:26 UTC (rev 806)
+++ trunk/vhffs-tests/src/Makefile.am 2007-08-29 23:43:28 UTC (rev 807)
@@ -1,5 +1,5 @@
TESTS_ENVIRONMENT = @PERL@ -I . -I ../../vhffs-api/src/
TESTS = Object.pl Group.pl User.pl Stats.pl Services/Svn.pl \
Services/Cvs.pl Services/Web.pl Services/DNS.pl Services/Mail.pl \
- Services/Mailing.pl Services/Mysql.pl Services/Pgsql.pl \
+ Services/MailingList.pl Services/Mysql.pl Services/Pgsql.pl \
Functions.pl Services/Repository.pl
Deleted: trunk/vhffs-tests/src/Services/Mailing.pl
===================================================================
--- trunk/vhffs-tests/src/Services/Mailing.pl 2007-08-29 23:41:26 UTC (rev 806)
+++ trunk/vhffs-tests/src/Services/Mailing.pl 2007-08-29 23:43:28 UTC (rev 807)
@@ -1,45 +0,0 @@
-use strict;
-use Vhffs::Tests::Main;
-use Vhffs::Tests::Utils;
-use Vhffs::Constants;
-use Vhffs::User;
-use Vhffs::Services::Mail;
-use Vhffs::Services::MailingList;
-use Test::More 'no_plan';
-
-my $main = init Vhffs::Tests::Main;
-isa_ok($main, 'Vhffs::Tests::Main', '$main');
-
-Vhffs::Tests::Utils::init_db($main->get_db_object);
-
-my $user1 = Vhffs::User::create($main, 'test1', 'abcdef', 0, 'test1@xxxxxxxx');
-isa_ok($user1, 'Vhffs::User', '$user1');
-
-my $group1 = Vhffs::Group::create($main, 'mailgroup1', $user1->get_uid, undef, 'Test group for Mail Domain');
-isa_ok($group1, 'Vhffs::Group', '$group1');
-
-my $mail1 = Vhffs::Services::Mail::create($main, 'test.com', 'Test mail domain 1', $user1, $group1);
-isa_ok($mail1, 'Vhffs::Services::Mail', '$mail1');
-cmp_ok($mail1->get_owner_uid, '==', $user1->get_uid, 'uid matches');
-cmp_ok($mail1->get_owner_gid, '==', $group1->get_gid, 'gid matches');
-
-my $ml1 = Vhffs::Services::MailingList::create($main, 'list1', 'test.com', 'admin@xxxxxxxx', 'Test ml 1', $user1, $group1);
-isa_ok($ml1, 'Vhffs::Services::MailingList', '$ml1');
-cmp_ok($ml1->get_localpart, 'eq', 'list1', 'Local part matches');
-cmp_ok($ml1->get_domain, 'eq', 'test.com', 'Mail domain matches');
-
-my ($max_oid) = $main->get_db_object->selectrow_array('SELECT MAX(object_id) FROM vhffs_object');
-ok(! defined(Vhffs::Services::MailingList::create($main, 'list1', 'test.com', 'admin@xxxxxxxx', 'Test ml 1', $user1, $group1)), 'Unable to create 2 lists with the same name');
-my ($new_max_oid) = $main->get_db_object->selectrow_array('SELECT MAX(object_id) FROM vhffs_object');
-cmp_ok($new_max_oid, '==', $max_oid, 'Mailing list service creation is a "all or nothing" process');
-
-$ml1->add_sub('toto@xxxxxxxx', Vhffs::Constants::ML_RIGHT_SUB);
-cmp_ok(keys(%{$ml1->{subs}}), '==', 1, 'One subscriber registered');
-
-my $tmpml = Vhffs::Services::MailingList::get_by_mladdress($main, 'list1', 'test.com');
-my $subs = $tmpml->{subs};
-cmp_ok(keys(%$subs), '==', 1, 'One subscriber registered (fetched)');
-ok(defined $subs->{'toto@xxxxxxxx'}, 'Subscriber key is email address');
-my $sub = $subs->{'toto@xxxxxxxx'};
-cmp_ok($sub->{member}, 'eq', 'toto@xxxxxxxx', 'Email address matches');
-cmp_ok($sub->{perm}, '==', Vhffs::Constants::ML_RIGHT_SUB, 'Permissions matches');
Copied: trunk/vhffs-tests/src/Services/MailingList.pl (from rev 806, trunk/vhffs-tests/src/Services/Mailing.pl)
===================================================================
--- trunk/vhffs-tests/src/Services/MailingList.pl (rev 0)
+++ trunk/vhffs-tests/src/Services/MailingList.pl 2007-08-29 23:43:28 UTC (rev 807)
@@ -0,0 +1,45 @@
+use strict;
+use Vhffs::Tests::Main;
+use Vhffs::Tests::Utils;
+use Vhffs::Constants;
+use Vhffs::User;
+use Vhffs::Services::Mail;
+use Vhffs::Services::MailingList;
+use Test::More 'no_plan';
+
+my $main = init Vhffs::Tests::Main;
+isa_ok($main, 'Vhffs::Tests::Main', '$main');
+
+Vhffs::Tests::Utils::init_db($main->get_db_object);
+
+my $user1 = Vhffs::User::create($main, 'test1', 'abcdef', 0, 'test1@xxxxxxxx');
+isa_ok($user1, 'Vhffs::User', '$user1');
+
+my $group1 = Vhffs::Group::create($main, 'mailgroup1', $user1->get_uid, undef, 'Test group for Mail Domain');
+isa_ok($group1, 'Vhffs::Group', '$group1');
+
+my $mail1 = Vhffs::Services::Mail::create($main, 'test.com', 'Test mail domain 1', $user1, $group1);
+isa_ok($mail1, 'Vhffs::Services::Mail', '$mail1');
+cmp_ok($mail1->get_owner_uid, '==', $user1->get_uid, 'uid matches');
+cmp_ok($mail1->get_owner_gid, '==', $group1->get_gid, 'gid matches');
+
+my $ml1 = Vhffs::Services::MailingList::create($main, 'list1', 'test.com', 'admin@xxxxxxxx', 'Test ml 1', $user1, $group1);
+isa_ok($ml1, 'Vhffs::Services::MailingList', '$ml1');
+cmp_ok($ml1->get_localpart, 'eq', 'list1', 'Local part matches');
+cmp_ok($ml1->get_domain, 'eq', 'test.com', 'Mail domain matches');
+
+my ($max_oid) = $main->get_db_object->selectrow_array('SELECT MAX(object_id) FROM vhffs_object');
+ok(! defined(Vhffs::Services::MailingList::create($main, 'list1', 'test.com', 'admin@xxxxxxxx', 'Test ml 1', $user1, $group1)), 'Unable to create 2 lists with the same name');
+my ($new_max_oid) = $main->get_db_object->selectrow_array('SELECT MAX(object_id) FROM vhffs_object');
+cmp_ok($new_max_oid, '==', $max_oid, 'Mailing list service creation is a "all or nothing" process');
+
+$ml1->add_sub('toto@xxxxxxxx', Vhffs::Constants::ML_RIGHT_SUB);
+cmp_ok(keys(%{$ml1->{subs}}), '==', 1, 'One subscriber registered');
+
+my $tmpml = Vhffs::Services::MailingList::get_by_mladdress($main, 'list1', 'test.com');
+my $subs = $tmpml->{subs};
+cmp_ok(keys(%$subs), '==', 1, 'One subscriber registered (fetched)');
+ok(defined $subs->{'toto@xxxxxxxx'}, 'Subscriber key is email address');
+my $sub = $subs->{'toto@xxxxxxxx'};
+cmp_ok($sub->{member}, 'eq', 'toto@xxxxxxxx', 'Email address matches');
+cmp_ok($sub->{perm}, '==', Vhffs::Constants::ML_RIGHT_SUB, 'Permissions matches');