diff --git a/Ezmlm/tags/Ezmlm-0.08/Changes b/Ezmlm/tags/Ezmlm-0.08/Changes new file mode 100644 index 0000000..14b5212 --- /dev/null +++ b/Ezmlm/tags/Ezmlm-0.08/Changes @@ -0,0 +1,58 @@ +Revision history for Perl extension Mail::Ezmlm. + +0.01 Sun Oct 31 12:58:16 1999 + - original version; created by h2xs 1.1.1.1.2.1 + +0.02 Wed Jan 26 07:59:10 SAST 2000 + - Added functions to check various options + (ismodsub, ismodpost, isremote, isdeny, isallow, isdigest) + - Allowed sub, unsub, list, subscribers, issub to work with list subparts + (ie, the allow, deny, mod, digest sub directories) + - Changed system() calls to safer ones (ie command, switches) + - Made error handling better (errmsg() and errno()) + - Added support for creating MySQL tables via ezmlm-mktab + +0.03 Mon Sep 25 11:49:26 SAST 2000 + - fixed the issub() function + - fixed the problem with dashes in hostnames. + - hopefully got rid of some of the warnings from sub() and unsub() + +0.04 Mon May 26 18:15:38 SAST 2003 + - fixed return value of Makefile.PL (Andrew Pam ) + - fixed issub() (again) to handle parts properly (bug 602; moguo@servism.com) + - converted module global variables to instance variables + +0.05 Sat Mar 5 12:47:10 SAST 2005 + - fixed forced scalar return in subscribers() (Jon Coulter ) + - fixed handling of dashes in hostnames (bug 5571; Lars Braeuer ) + - fixed some tainting problems (Scott Beck and Matt Simerson ) + - fixed order of control/defaulthost and control/me (bug 1515) + - fixed a bug in Makefile.PL (bug 11771). does not affect most users, so released as 0.05.1 + +0.06 Mon Dec 26 18:55:12 CET 2005 + - support for ezmlm-idx-5.0.0 added + - fixed version check + +0.07 Mon Jan 2 22:12:32 CET 2006 + - new functions for text management (idx >= 5.0) + - new functions for language setting (idx >= 5.0) + - new functions for charset setting (idx >= 5.0) + - new functions for config directory setting (idx >= 5.0) + - look for ezmlm-make at run-time + - requires Text::ParseWords + +0.07.1 Mon Jan 23 22:30:14 CET 2006 + - fix misinterpretation of empty settings + +0.07.2 Sun May 6 06:20:13 CEST 2006 + - fix parsing of ezmlm-make options + +0.07.2 Tue Jun 20 01:05:56 UTC 2006 + - fixed 'get_charset' and 'set_charset' for idx < 5.0 + +0.08 Thu Oct 2 03:23:06 CEST 2008 + - fixed handling of the 'owner' setting for ezmlm-idx > v5 + - updated ezmlm-idx version detection + - allow "@" in the path of a mailing list + - add modules Mail::Ezmlm::GpgKeyRing and Mail::Ezmlm::GpgEzmlm + diff --git a/Ezmlm/tags/Ezmlm-0.08/Ezmlm.pm b/Ezmlm/tags/Ezmlm-0.08/Ezmlm.pm new file mode 100644 index 0000000..87a8259 --- /dev/null +++ b/Ezmlm/tags/Ezmlm-0.08/Ezmlm.pm @@ -0,0 +1,1234 @@ +# =========================================================================== +# Ezmlm.pm - version 0.08 - 10/12/2008 +# $Id$ +# +# Object methods for ezmlm mailing lists +# +# Copyright (C) 1999-2005, Guy Antony Halse, All Rights Reserved. +# Copyright (C) 2005-2008, Lars Kruse, All Rights Reserved. +# Please send bug reports and comments to ezmlm-web@sumpfralle.de. +# +# Redistribution and use in source and binary forms, with or without +# modification, are permitted provided that the following conditions are +# met: +# +# Redistributions of source code must retain the above copyright notice, +# this list of conditions and the following disclaimer. +# +# 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. +# +# Neither name Guy Antony Halse nor the names of any 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 REGENTS 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. +# +# ========================================================================== +# POD is at the end of this file. Search for '=head' to find it +package Mail::Ezmlm; + +use strict; +use vars qw($QMAIL_BASE $EZMLM_BASE $MYSQL_BASE $VERSION @ISA @EXPORT @EXPORT_OK); +use Carp; +use Text::ParseWords; + +require Exporter; + +@ISA = qw(Exporter); +# Items to export into callers namespace by default. Note: do not export +# names by default without a very good reason. Use EXPORT_OK instead. +# Do not simply export all your public functions/methods/constants. +@EXPORT = qw( + +); +$VERSION = '0.08'; + +require 5.005; + +# == Begin site dependant variables == +$EZMLM_BASE = '/usr/local/bin'; #Autoinserted by Makefile.PL +$QMAIL_BASE = '/var/qmail'; #Autoinserted by Makefile.PL +$MYSQL_BASE = ''; #Autoinserted by Makefile.PL +# == End site dependant variables == + +# == check the ezmlm-make path == +$EZMLM_BASE = '/usr/local/bin/ezmlm' unless (-e "$EZMLM_BASE/ezmlm-make"); +$EZMLM_BASE = '/usr/local/bin/ezmlm-idx' unless (-e "$EZMLM_BASE/ezmlm-make"); +$EZMLM_BASE = '/usr/local/bin' unless (-e "$EZMLM_BASE/ezmlm-make"); +$EZMLM_BASE = '/usr/bin/ezmlm' unless (-e "$EZMLM_BASE/ezmlm-make"); +$EZMLM_BASE = '/usr/bin/ezmlm-idx' unless (-e "$EZMLM_BASE/ezmlm-make"); +$EZMLM_BASE = '/usr/bin' unless (-e "$EZMLM_BASE/ezmlm-make"); + +# == clean up the path for taint checking == +local $ENV{'PATH'} = $EZMLM_BASE; + +# == Initialiser - Returns a reference to the object == +sub new { + my($class, $list) = @_; + my $self = {}; + bless $self, ref $class || $class || 'Mail::Ezmlm'; + $self->setlist($list) if(defined($list) && $list); + return $self; +} + +# == Make a new mailing list and set it to current == +sub make { + my($self, %list) = @_; + my($VHOST, $comandline, $hostname); + + # Do we want to use command line switches + my $commandline = ''; + $commandline = '-' . $list{'-switches'} if(defined($list{'-switches'})); + my @commandline; + foreach ("ewords('\s+', 1, $commandline)) { + next if (!defined($_)); + # untaint input + $_ =~ s/['"]//g; + $_ =~ m/^([\w _\/,\.\@:'"-]*)$/; + if ($_ =~ /^\s*$/) { + push @commandline, ""; + } else { + push @commandline, $1; + } + } + + # These three variables are essential + ($self->_seterror(-1, 'must define -dir in a make()') && return 0) unless(defined($list{'-dir'})); + ($self->_seterror(-1, 'must define -qmail in a make()') && return 0) unless(defined($list{'-qmail'})); + ($self->_seterror(-1, 'must define -name in a make()') && return 0) unless(defined($list{'-name'})); + + # Determine hostname if it is not supplied + $hostname = $self->_getdefaultdomain; + if(defined($list{'-host'})) { + $VHOST = 1 unless ($list{'-host'} eq $hostname); + } else { + $list{'-host'} = $hostname; + } + + # does the mailing list directory already exist? + if (-e $list{'-dir'}) { + $self->_seterror(-1, + '-the mailing list directory already exists: ' . $list{'-dir'}); + return undef; + } + + # Attempt to make the list if we can. + if (system("$EZMLM_BASE/ezmlm-make", @commandline, $list{'-dir'}, $list{'-qmail'}, $list{'-name'}, $list{'-host'}) != 0) { + $self->_seterror($?, '-failed to create mailing list - check your webserver\'s log file for details'); + return undef; + } + + # Sort out the DIR/inlocal problem if necessary + if(defined($VHOST)) { + unless(defined($list{'-user'})) { + ($self->_seterror(-1, '-user must match virtual host user in make()') && return 0) unless($list{'-user'} = $self->_getvhostuser($list{'-host'})); + } + + open(INLOCAL, ">$list{'-dir'}/inlocal") || ($self->_seterror(-1, 'unable to read inlocal in make()') && return 0); + print INLOCAL $list{'-user'} . '-' . $list{'-name'} . "\n"; + close INLOCAL; + } + + $self->_seterror(undef); + return $self->setlist($list{'-dir'}); +} + +# == Update the current list == +sub update { + my($self, $switches) = @_; + my($outhost, $inlocal); + + # Do we have the command line switches + ($self->_seterror(-1, 'nothing to update()') && return 0) unless(defined($switches)); + $switches = '-e' . $switches; + my @switch_list; + + foreach ("ewords('\s+', 1, $switches)) { + next if (!defined($_)); + # untaint input + $_ =~ s/['"]//g; + $_ =~ m/^([\w _\/,\.\@:'"-]*)$/; + if ($_ =~ /^\s*$/) { + push @switch_list, ""; + } else { + push @switch_list, $1; + } + } + + # can we actually alter this list; + ($self->_seterror(-1, 'must setlist() before you update()') && return 0) unless(defined($self->{'LIST_NAME'})); + # check for important files: 'config' (idx < v5.0) or 'flags' (idx >= 5.0) + ($self->_seterror(-1, "$self->{'LIST_NAME'} does not appear to be a valid list in update()") && return 0) unless((-e "$self->{'LIST_NAME'}/config") || (-e "$self->{'LIST_NAME'}/flags")); + + # Work out if this is a vhost. + open(OUTHOST, "<$self->{'LIST_NAME'}/outhost") || ($self->_seterror(-1, 'unable to read outhost in update()') && return 0); + chomp($outhost = ); + close(OUTHOST); + + # Save the contents of inlocal if it is a vhost + unless($outhost eq $self->_getdefaultdomain) { + open(INLOCAL, "<$self->{'LIST_NAME'}/inlocal") || ($self->_seterror(-1, 'unable to read inlocal in update()') && return 0); + chomp($inlocal = ); + close(INLOCAL); + } + + # Attempt to update the list if we can. + system("$EZMLM_BASE/ezmlm-make", @switch_list, $self->{'LIST_NAME'}) == 0 + || ($self->_seterror($?) && return undef); + + # Sort out the DIR/inlocal problem if necessary + if(defined($inlocal)) { + open(INLOCAL, ">$self->{'LIST_NAME'}/inlocal") || ($self->_seterror(-1, 'unable to write inlocal in update()') && return 0); + print INLOCAL "$inlocal\n"; + close INLOCAL; + } + + $self->_seterror(undef); + return $self->{'LIST_NAME'}; +} + +# == Get a list of options for the current list == +sub getconfig { + my($self) = @_; + my($options); + + # Read the config file + if(-e $self->{LIST_NAME} . "/flags") { + # this file exists since ezmlm-idx-5.0.0 + # 'config' is not authorative anymore since that version + $options = $self->_getconfig_idx5(); + } elsif(open(CONFIG, "<" . $self->{LIST_NAME} . "/config")) { + # 'config' contains the authorative information + while() { + if (/^F:-(\w+)/) { + $options = $1; + } elsif (/^(\d):(.+)$/) { + my $opt_num = $1; + my $value = $2; + $options .= " -$opt_num '$value'" if ($value =~ /\S/); + } + } + close CONFIG; + } else { + # Try manually - this will ignore all string settings, that can only be found + # in the config file + $options = $self->_getconfigmanual(); + } + + ($self->_seterror(-1, 'unable to read configuration in getconfig()') && return undef) unless (defined($options)); + + $self->_seterror(undef); + return $options; +} + +# == Return the name of the current list == +sub thislist { + my($self) = shift; + $self->_seterror(undef); + return $self->{'LIST_NAME'}; +} + +# == Set the current mailing list == +sub setlist { + my($self, $list) = @_; + if ($list =~ m/^([\w\d\_\-\.\/\@]+)$/) { + $list = $1; + if (-e "$list/lock") { + $self->_seterror(undef); + return $self->{'LIST_NAME'} = $list; + } else { + $self->_seterror(-1, "$list does not appear to be a valid list in setlist()"); + return undef; + } + } else { + $self->_seterror(-1, "$list contains tainted data in setlist()"); + return undef; + } +} + +# == Output the subscribers to $stream == +sub list { + my($self, $stream, $part) = @_; + $stream = *STDOUT unless (defined($stream)); + if(defined($part)) { + print $stream $self->subscribers($part); + } else { + print $stream $self->subscribers; + } +} + +# == Return an array of subscribers == +sub subscribers { + my($self, $part) = @_; + my(@subscribers); + ($self->_seterror(-1, 'must setlist() before returning subscribers()') && return undef) unless(defined($self->{'LIST_NAME'})); + if(defined($part) && $part) { + ($self->_seterror(-1, "$part part of $self->{'LIST_NAME'} does not appear to exist in subscribers()") && return undef) unless(-e "$self->{'LIST_NAME'}/$part"); + @subscribers = map { s/[\r\n]// && $_ } sort `$EZMLM_BASE/ezmlm-list $self->{'LIST_NAME'}/$part`; + } else { + @subscribers = map { s/[\r\n]// && $_ } sort `$EZMLM_BASE/ezmlm-list $self->{'LIST_NAME'}`; + } + + if($?) { + $self->_seterror($?, 'error during ezmlm-list in subscribers()'); + return (scalar @subscribers ? @subscribers : undef); + } else { + $self->_seterror(undef); + return @subscribers; + } +} + +# == Subscribe users to the current list == +sub sub { + my($self, @addresses) = @_; + ($self->_seterror(-1, 'sub() must be called with at least one address') && return 0) unless @addresses; + my($part) = pop @addresses unless ($#addresses < 1 or $addresses[$#addresses] =~ /\@/); + my($address); + ($self->_seterror(-1, 'must setlist() before sub()') && return 0) unless(defined($self->{'LIST_NAME'})); + + if(defined($part) && $part) { + ($self->_seterror(-1, "$part of $self->{'LIST_NAME'} does not appear to exist in sub()") && return 0) unless(-e "$self->{'LIST_NAME'}/$part"); + foreach $address (@addresses) { + next unless $self->_checkaddress($address); + system("$EZMLM_BASE/ezmlm-sub", "$self->{'LIST_NAME'}/$part", $address) == 0 || + ($self->_seterror($?) && return undef); + } + } else { + foreach $address (@addresses) { + next unless $self->_checkaddress($address); + system("$EZMLM_BASE/ezmlm-sub", $self->{'LIST_NAME'}, $address) == 0 || + ($self->_seterror($?) && return undef); + } + } + $self->_seterror(undef); + return 1; +} + +# == Unsubscribe users from a list == +sub unsub { + my($self, @addresses) = @_; + ($self->_seterror(-1, 'unsub() must be called with at least one address') && return 0) unless @addresses; + my($part) = pop @addresses unless ($#addresses < 1 or $addresses[$#addresses] =~ /\@/); + my($address); + ($self->_seterror(-1, 'must setlist() before unsub()') && return 0) unless(defined($self->{'LIST_NAME'})); + + if(defined($part) && $part) { + ($self->_seterror(-1, "$part of $self->{'LIST_NAME'} does not appear to exist in unsub()") && return 0) unless(-e "$self->{'LIST_NAME'}/$part"); + foreach $address (@addresses) { + next unless $self->_checkaddress($address); + system("$EZMLM_BASE/ezmlm-unsub", "$self->{'LIST_NAME'}/$part", $address) == 0 || + ($self->_seterror($?) && return undef); + } + } else { + foreach $address (@addresses) { + next unless $self->_checkaddress($address); + system("$EZMLM_BASE/ezmlm-unsub", $self->{'LIST_NAME'}, $address) == 0 || + ($self->_seterror($?) && return undef); + } + } + $self->_seterror(undef); + return 1; +} + +# == Test whether people are subscribed to the list == +sub issub { + my($self, @addresses) = @_; + my($part) = pop @addresses unless ($#addresses < 1 or $addresses[$#addresses] =~ /\@/); + my($address, $issub); $issub = 1; + ($self->_seterror(-1, 'must setlist() before issub()') && return 0) unless(defined($self->{'LIST_NAME'})); + + local $ENV{'SENDER'}; + + if(defined($part) && $part) { + ($self->_seterror(-1, "$part of $self->{'LIST_NAME'} does not appear to exist in issub()") && return 0) unless(-e "$self->{'LIST_NAME'}/$part"); + foreach $address (@addresses) { + $ENV{'SENDER'} = $address; + undef($issub) if ((system("$EZMLM_BASE/ezmlm-issubn", "$self->{'LIST_NAME'}/$part") / 256) != 0) + } + } else { + foreach $address (@addresses) { + $ENV{'SENDER'} = $address; + undef($issub) if ((system("$EZMLM_BASE/ezmlm-issubn", $self->{'LIST_NAME'}) / 256) != 0) + } + } + + $self->_seterror(undef); + return $issub; +} + +# == Is the list posting moderated == +# DEPRECATED: useless - you should better check the appropriate config flag +sub ismodpost { + my($self) = @_; + ($self->_seterror(-1, 'must setlist() before ismodpost()') && return 0) unless(defined($self->{'LIST_NAME'})); + $self->_seterror(undef); + return -e "$self->{'LIST_NAME'}/modpost"; +} + +# == Is the list subscriber moderated == +# DEPRECATED: useless - you should better check the appropriate config flag +sub ismodsub { + my($self) = @_; + ($self->_seterror(-1, 'must setlist() before ismodsub()') && return 0) unless(defined($self->{'LIST_NAME'})); + $self->_seterror(undef); + return -e "$self->{'LIST_NAME'}/modsub"; +} + +# == Is the list remote adminable == +# DEPRECATED: useless - you should better check the appropriate config flag +sub isremote { + my($self) = @_; + ($self->_seterror(-1, 'must setlist() before isremote()') && return 0) unless(defined($self->{'LIST_NAME'})); + $self->_seterror(undef); + return -e "$self->{'LIST_NAME'}/remote"; +} + +# == Does the list have a kill list == +# DEPRECATED: useless - you should better check the appropriate config flag +sub isdeny { + my($self) = @_; + ($self->_seterror(-1, 'must setlist() before isdeny()') && return 0) unless(defined($self->{'LIST_NAME'})); + $self->_seterror(undef); + return -e "$self->{'LIST_NAME'}/deny"; +} + +# == Does the list have an allow list == +# DEPRECATED: useless - the allow list is always created automatically +sub isallow { + my($self) = @_; + ($self->_seterror(-1, 'must setlist() before isallow()') && return 0) unless(defined($self->{'LIST_NAME'})); + $self->_seterror(undef); + return -e "$self->{'LIST_NAME'}/allow"; +} + +# == Is this a digested list == +# DEPRECATED: useless - you should better check the appropriate config flag +sub isdigest { + my($self) = @_; + ($self->_seterror(-1, 'must setlist() before isdigest()') && return 0) unless(defined($self->{'LIST_NAME'})); + $self->_seterror(undef); + return -e "$self->{'LIST_NAME'}/digest"; +} + +# == retrieve file contents == +sub getpart { + my($self, $part) = @_; + my(@contents, $content); + # check for the file in the list directory first + my $filename = $self->{'LIST_NAME'} . "/$part"; + # check for default file in config directory, if necessary + # BEWARE: get_config_dir and get_lang may _not_ cause an eternal loop :) + $filename = $self->get_config_dir() . '/' . $self->get_lang() . "/$part" + if (!(-e "$filename") && (get_version() >= 5) && + ($part ne 'conf-etc') && ($part ne 'conf-lang')); + if (open(PART, "<$filename")) { + while() { + unless ( /^#/ ) { + chomp($contents[$#contents++] = $_); + $content .= $_; + } + } + close PART; + if(wantarray) { + return @contents; + } else { + return $content; + } + } ($self->_seterror($?) && return undef); +} + +# == set files contents == +sub setpart { + my($self, $part, @content) = @_; + my($line); + if(open(PART, ">$self->{'LIST_NAME'}/$part")) { + foreach $line (@content) { + $line =~ s/[\r]//g; $line =~ s/\n$//; + print PART "$line\n"; + } + close PART; + return 1; + } ($self->_seterror($?) && return undef); +} + +# == get the configuration directory for this list (idx >= 5.0) == +# return '/etc/ezmlm' for idx < 5.0 +sub get_config_dir { + my $self = shift; + my $conf_dir; + if ((get_version() >= 5) && (ref $self) && (-e "$self->{'LIST_NAME'}/conf-etc")) { + chomp($conf_dir = $self->getpart('conf-etc')); + } else { + $conf_dir = '/etc/ezmlm'; + } + return $conf_dir; +} + +# == set the configuration directory for this list (idx >= 5.0) == +# return without error for idx < 5.0 +sub set_config_dir { + my ($self, $conf_dir) = @_; + return (0==0) if (get_version() < 5); + $self->setpart('conf-etc', "$conf_dir"); +} + + +# == get list of available languages (for idx >= 5.0) == +# return empty list for idx < 5.0 +sub get_available_languages { + my $self = shift; + my @langs = (); + return @langs if (get_version() < 5); + + $self->_seterror(undef) if (ref $self); + + # check for language directories + my $conf_dir; + if (ref $self) { + ($self->_seterror(-1, 'could not retrieve configuration directory') && return 0) + unless ($conf_dir = $self->get_config_dir()); + } else { + $conf_dir = get_config_dir(); + } + if (opendir DIR, "$conf_dir") { + my @dirs; + @dirs = grep !/^\./, readdir DIR; + closedir DIR; + my $item; + foreach $item (@dirs) { + push (@langs, $item) if (-e "$conf_dir/$item/text"); + } + return @langs; + } else { + $self->_seterror(-1, 'could not access configuration directory') if (ref $self); + return undef; + } +} + + +# == get the selected language of the list (idx >= 5.0) == +# return empty string for idx < 5.0 +sub get_lang { + my ($self) = shift; + my $lang; + return '' if (get_version() < 5); + if (-e "$self->{'LIST_NAME'}/conf-lang") { + chomp($lang = $self->getpart('conf-lang')); + } else { + $lang = 'default'; + } + return $lang; +} + + +# == set the selected language of the list (idx >= 5.0) == +# return without error for idx < 5.0 +sub set_lang { + my ($self, $lang) = @_; + return (0==0) if (get_version() < 5); + if (($lang eq 'default') || ($lang eq '')) { + return 1 if (unlink "$self->{'LIST_NAME'}/conf-lang"); + } else { + return 1 if ($self->setpart('conf-lang', "$lang")); + } + return 0; +} + + +# == get the selected charset of the list == +# return default value (us-ascii) if no charset is specified +sub get_charset { + my ($self) = shift; + my $charset; + $charset = $self->getpart('charset'); + $charset = '' unless defined($charset); + # default if no 'charset' file exists + $charset = 'us-ascii' if ($charset eq ''); + return $charset; +} + + +# == set the selected charset of the list (idx >= 5.0) == +# remove list' specific charset file, if the default charset of the current language +# was chosen +sub set_charset { + my ($self, $charset) = @_; + # first: remove current charset + unlink "$self->{'LIST_NAME'}/charset"; + # second: get default value of the current language + my $default_charset = $self->getpart('charset'); + # last: create new charset file only if the selected charset is not the default anyway + if (($charset eq $default_charset) || ($charset !~ /\S/)) { + # do not write the specific charset, as the default charset of the language is + # sufficient + return 1; + } else { + return 1 if ($self->setpart('charset', "$charset")); + } + return 0; +} + + +# == get list of available text files == +sub get_available_text_files { + my ($self) = shift; + my @files; + my $item; + my %seen = (); + + # customized text files of this list (idx >= 5.0) + # OR text files of this list (idx < 5.0) + if (opendir DIR, "$self->{'LIST_NAME'}/text") { + my @local_files = grep !/^\./, readdir DIR; + closedir DIR; + foreach $item (@local_files) { + unless ($seen{$item}) { + push (@files, $item); + $seen{$item} = 1; + } + } + } + + # default text files (only idx >= 5.0) + if (get_version() >= 5) { + my $dirname = $self->get_config_dir . '/' . $self->get_lang() . '/text'; + $dirname = $self->get_config_dir . '/default/text' unless (-e $dirname); + if (opendir GLOBDIR, $dirname) { + my @global_files = grep !/^\./, readdir GLOBDIR; + closedir GLOBDIR; + foreach $item (@global_files) { + unless ($seen{$item}) { + push (@files, $item); + $seen{$item} = 1; + } + } + } + } + + if ($#files > 0) { + return @files; + } else { + $self->_seterror(-1, 'no textfiles found'); + return undef; + } +} + +# == get text file content == +sub get_text_content { + my ($self, $textfile) = @_; + + if (-e "$self->{'LIST_NAME'}/text/$textfile") { + return $self->getpart("text/$textfile"); + } elsif (get_version() >= 5) { + my $filename = $self->get_config_dir() . '/' . $self->get_lang() . "/text/$textfile"; + $filename = "/etc/ezmlm/default/$textfile" unless (-e "$filename"); + my @contents; + my $content; + if (open(PART, "<$filename")) { + while() { + chomp($contents[$#contents++] = $_); + $content .= $_; + } + close PART; + if(wantarray) { + return @contents; + } else { + return $content; + } + } else { + $self->_seterror($?, "could not open $filename"); + return undef; + } + } else { + $self->_seterror(-1, "could not get the text file ($textfile)"); + return undef; + } +} + + +# == set text file content == +sub set_text_content { + my ($self, $textfile, @content) = @_; + mkdir "$self->{'LIST_NAME'}/text" unless (-e "$self->{'LIST_NAME'}/text"); + return 1 if ($self->setpart("text/$textfile", @content)); + return 0; +} + + +# == check if specified text file is customized or default (for idx >= 5.0) == +# return whether the text file exists in the list's directory (false) or not (true) +# empty filename returns false +sub is_text_default { + my ($self, $textfile) = @_; + return (0==1) if ($textfile eq ''); + if (-e "$self->{'LIST_NAME'}/text/$textfile") { + return (1==0); + } else { + return (0==0); + } +} + + +# == remove non-default text file (for idx >= 5.0) == +# return without error for idx < 5 +# otherwise: remove customized text file from the list's directory +sub reset_text { + my ($self, $textfile) = @_; + return if (get_version() < 5); + return if ($textfile eq ''); + return if ($textfile =~ /[^\w_\.-]/); + return if ($self->is_text_default($textfile)); + ($self->_seterror(-1, "could not remove customized text file ($textfile)") && return 0) + unless unlink("$self->{'LIST_NAME'}/text/$textfile"); + return 1; +} + + +# == return an error message if appropriate == +sub errmsg { + my($self) = @_; + return $self->{'ERRMSG'}; +} + +sub errno { + my($self) = @_; + return $self->{'ERRNO'}; +} + +# == Test the compatiblity of the module == +sub check_version { + my $self = shift; + my $version = `$EZMLM_BASE/ezmlm-make -V 2>&1`; + $self->_seterror(undef) if (ref $self); + + # ezmlm-idx is necessary + if (get_version() >= 4) { + return 0; + } else { + return $version; + } +} + +# == get the major ezmlm version == +# return values: +# 0 => unknown version +# 3 => ezmlm v0.53 +# 4 => ezmlm-idx v0.4* +# 5 => ezmlm-idx v5.0 +# 5.1 => ezmlm-idx v5.1 +# 6 => ezmlm-idx v6.* +# 7 => ezmlm-idx v7.* +sub get_version { + my ($ezmlm, $idx); + my $version = `$EZMLM_BASE/ezmlm-make -V 2>&1`; + + $version = $1 if ($version =~ m/^[^:]*:\s+(.*)$/); + $ezmlm = $1 if ($version =~ m/ezmlm-([\d\.]+)$/); + $idx = $1 if ($version =~ m/ezmlm-idx-([\d\.]+)$/); + + if (defined($ezmlm)) { + return 3; + } elsif (defined($idx)) { + if (($idx =~ m/^(\d)/) && ($1 >= 7)) { + # version 6.0 or higher + return 7; + } elsif (($idx =~ m/^(\d)/) && ($1 == 6)){ + return 6; + } elsif (($idx =~ m/^(\d)\.(\d)/) && ($1 >= 5) && ($2 == 1)) { + # version 5.1 + return 5.1; + } elsif (($idx =~ m/^(\d)/) && ($1 >= 5)) { + # version 5.0 + return 5; + } elsif (($idx =~ m/^0\.(\d)/) && ($1 >= 0)) { + # version 0.4xx + return 4; + } else { + return 0; + } + } else { + return 0; + } +} + +# == Create SQL Database tables if defined for a list == +sub createsql { + my($self) = @_; + + ($self->_seterror(-1, 'MySQL must be compiled into Ezmlm for createsql() to work') && return 0) unless(defined($MYSQL_BASE) && $MYSQL_BASE); + ($self->_seterror(-1, 'must setlist() before isdigest()') && return 0) unless(defined($self->{'LIST_NAME'})); + my($config) = $self->getconfig(); + + if($config =~ m/-6\s+'(.+?)'\s*/){ + my($sqlsettings) = $1; + my($host, $port, $user, $password, $database, $table) = split(':', $sqlsettings, 6); + + ($self->_seterror(-1, 'error in list configuration while trying createsql()') && return 0) + unless (defined($host) && defined($port) && defined($user) + && defined($password) && defined($database) && defined($table)); + + system("$EZMLM_BASE/ezmlm-mktab -d $table | $MYSQL_BASE/mysql -h$host -P$port -u$user -p$password -f $database") == 0 || + ($self->_seterror($?) && return undef); + + } else { + $self->_seterror(-1, 'config for thislist() must include SQL options'); + return 0; + } + + ($self->_seterror(undef) && return 1); + +} + + +# == Internal function to set the error to return == +sub _seterror { + my($self, $no, $mesg) = @_; + + if(defined($no) && $no) { + if($no < 0) { + $self->{'ERRNO'} = -1; + $self->{'ERRMSG'} = $mesg || 'An undefined error occoured'; + } else { + $self->{'ERRNO'} = $no / 256; + $self->{'ERRMSG'} = $! || $mesg || 'An undefined error occoured in a system() call'; + } + } else { + $self->{'ERRNO'} = 0; + $self->{'ERRMSG'} = undef; + } + return 1; +} + +# == Internal function to test for valid email addresses == +sub _checkaddress { + my($self, $address) = @_; + return 1 unless defined($address); + return 0 unless ($address =~ m/^(\S+\@\S+\.\S+)$/); + $_[1] = $1; + return 1; +} + +# == Internal function to work out a list configuration (idx >= v5.0) == +sub _getconfig_idx5 { + my($self) = @_; + my ($options, %optionfiles); + my ($file, $opt_num, $temp); + + # read flag file (available since ezmlm-idx 5.0.0) + chomp($options = $self->getpart('flags')); + # remove prefixed '-' + $options =~ s/^-//; + + # since ezmlm-idx v5, we have to read the config + # values from different files + # first: preset a array with "filename" and "option_number" + %optionfiles = ( + 'sublist', 0, + 'fromheader', 3, + 'tstdigopts', 4, + 'owner', 5, + 'sql', 6, + 'modpost', 7, + 'modsub', 8, + 'remote', 9); + while (($file, $opt_num) = each(%optionfiles)) { + if (-e "$self->{'LIST_NAME'}/$file") { + chomp($temp = $self->getpart($file)); + $temp =~ m/^(.*)$/m; # take only the first line + $temp = $1; + # the 'owner' setting can be ignored if it is a path (starts with '/') + unless (($opt_num == 5) && ($temp =~ m#^/#)) { + $options .= " -$opt_num '$temp'" if ($temp =~ /\S/); + } + } + } + + return $options; +} + +# == Internal function to work out a list configuration manually (idx < v5.0.0 ) == +sub _getconfigmanual { + # use this function for strange lists without + # 'config' (idx < v5.0) and 'flags' (idx >= v5.0) + my($self) = @_; + my ($savedollarslash, $options, $manager, $editor, $i); + + # Read the whole of DIR/editor and DIR/manager in + $savedollarslash = $/; + undef $/; + # $/ = \0777; + + open (EDITOR, "<$self->{'LIST_NAME'}/editor") || ($self->_seterror($?) && return undef); + open (MANAGER, "<$self->{'LIST_NAME'}/manager") || ($self->_seterror($?) && return undef); + $editor = ; $manager = ; + close(EDITOR), close(MANAGER); + + $/ = $savedollarslash; + + $options = ''; + $options .= 'a' if (-e "$self->{'LIST_NAME'}/archived"); + $options .= 'd' if (-e "$self->{'LIST_NAME'}/digest"); + $options .= 'f' if (-e "$self->{'LIST_NAME'}/prefix"); + $options .= 'g' if ($manager =~ /ezmlm-get -\w*s/ ); + $options .= 'i' if (-e "$self->{'LIST_NAME'}/indexed"); + $options .= 'k' if (-e "$self->{'LIST_NAME'}/blacklist" || -e "$self->{'LIST_NAME'}/deny"); + $options .= 'l' if ($manager =~ /ezmlm-manage -\w*l/ ); + $options .= 'm' if (-e "$self->{'LIST_NAME'}/modpost"); + $options .= 'n' if ($manager =~ /ezmlm-manage -\w*e/ ); + $options .= 'p' if (-e "$self->{'LIST_NAME'}/public"); + $options .= 'q' if ($manager =~ /ezmlm-request/ ); + $options .= 'r' if (-e "$self->{'LIST_NAME'}/remote"); + $options .= 's' if (-e "$self->{'LIST_NAME'}/modsub"); + $options .= 't' if (-e "$self->{'LIST_NAME'}/text/trailer"); + $options .= 'u' if (($options !~ /m/ && $editor =~ /ezmlm-issubn \'/ ) + || $editor =~ /ezmlm-gate/ ); + $options .= 'x' if (-e "$self->{'LIST_NAME'}/extra" || -e "$self->{'LIST_NAME'}/allow"); + + # Add the unselected options too + # but we will skip invalid options (any of 'cevz') + foreach $i ('a' .. 'z') { + $options .= uc($i) unless (('cevz' =~ /$i/) || ($options =~ /$i/i)) + } + + # there is no way to get the other string settings, that are only + # defined in 'config' - sorry ... + + return $options; +} + +# == Internal Function to try to determine the vhost user == +sub _getvhostuser { + my($self, $hostname) = @_; + my($username); + + open(VD, "<$QMAIL_BASE/control/virtualdomains") || ($self->_seterror($?) && return undef); + while() { + last if(($username) = /^\s*$hostname:(\w+)$/); + } + close VD; + + return $username; +} + +# == Internal function to work out default host name == +sub _getdefaultdomain { + my($self) = @_; + my($hostname); + + open (GETHOST, "<$QMAIL_BASE/control/defaultdomain") + || open (GETHOST, "<$QMAIL_BASE/control/me") + || ($self->_seterror($?) && return undef); + chomp($hostname = ); + close GETHOST; + + return $hostname; +} + +1; +__END__ + +=head1 NAME + +Ezmlm - Object Methods for Ezmlm Mailing Lists + +=head1 SYNOPSIS + + use Mail::Ezmlm; + $list = new Mail::Ezmlm; + +The rest is a bit complicated for a Synopsis, see the description. + +=head1 ABSTRACT + +Ezmlm is a Perl module that is designed to provide an object interface to +the ezmlm mailing list manager software. See the ezmlm web page +(http://www.ezmlm.org/) for a complete description of the software. + +This version of the module is designed to work with ezmlm version 0.53. +It is fully compatible with ezmlm's IDX extensions (version 0.4xx and 5.0 ). Both +of these can be obtained via anon ftp from ftp://ftp.ezmlm.org/pub/patches/ + +=head1 DESCRIPTION + +=head2 Setting up a new Ezmlm object: + + use Mail::Ezmlm; + $list = new Mail::Ezmlm; + $list = new Mail::Ezmlm('/home/user/lists/moolist'); + +=head2 Changing which list the Ezmlm object points at: + + + $list->setlist('/home/user/lists/moolist'); + +=head2 Getting a list of current subscribers: + +=item Two methods of listing subscribers is provided. The first prints a list +of subscribers, one per line, to the supplied FILEHANDLE. If no filehandle is +given, this defaults to STDOUT. An optional second argument specifies the +part of the list to display (mod, digest, allow, deny). If the part is +specified, then the FILEHANDLE must be specified. + + $list->list; + $list->list(\*STDERR); + $list->list(\*STDERR, 'deny'); + +=item The second method returns an array containing the subscribers. The +optional argument specifies which part of the list to display (mod, digest, +allow, deny). + + @subscribers = $list->subscribers; + @subscribers = $list->subscribers('allow'); + +=head2 Testing for subscription: + + $list->issub('nobody@on.web.za'); + $list->issub(@addresses); + $list->issub(@addresses, 'mod'); + +issub() returns 1 if all the addresses supplied are found as subscribers +of the current mailing list, otherwise it returns undefined. The optional +argument specifies which part of the list to check (mod, digest, allow, +deny). + +=head2 Subscribing to a list: + + $list->sub('nobody@on.web.za'); + $list->sub(@addresses); + $list->sub(@addresses, 'digest'); + +sub() takes a LIST of addresses and subscribes them to the current mailing list. +The optional argument specifies which part of the list to subscribe to (mod, +digest, allow, deny). + + +=head2 Unsubscribing from a list: + + $list->unsub('nobody@on.web.za'); + $list->unsub(@addresses); + $list->unsub(@addresses, 'mod'); + +unsub() takes a LIST of addresses and unsubscribes them (if they exist) from the +current mailing list. The optional argument specifies which part of the list +to unsubscribe from (mod, digest, allow, deny). + + +=head2 Creating a new list: + + $list->make(-dir=>'/home/user/list/moo', + -qmail=>'/home/user/.qmail-moo', + -name=>'user-moo', + -host=>'on.web.za', + -user=>'onwebza', + -switches=>'mPz'); + +make() creates the list as defined and sets it to the current list. There are +three variables which must be defined in order for this to occur; -dir, -qmail and -name. + +=over 6 + +=item -dir is the full path of the directory in which the mailing list is to +be created. + +=item -qmail is the full path and name of the .qmail file to create. + +=item -name is the local part of the mailing list address (eg if your list +was user-moo@on.web.za, -name is 'user-moo'). + +=item -host is the name of the host that this list is being created on. If +this item is omitted, make() will try to determine your hostname. If -host is +not the same as your hostname, then make() will attempt to fix DIR/inlocal for +a virtual host. + +=item -user is the name of the user who owns this list. This item only needs to +be defined for virtual domains. If it exists, it is prepended to -name in DIR/inlocal. +If it is not defined, the make() will attempt to work out what it should be from +the qmail control files. + +=item -switches is a list of command line switches to pass to ezmlm-make(1). +Note that the leading dash ('-') should be ommitted from the string. + +=back + +make() returns the value of thislist() for success, undefined if there was a +problem with the ezmlm-make system call and 0 if there was some other problem. + +See the ezmlm-make(1) man page for more details + +=head2 Determining which list we are currently altering: + + $whichlist = $list->thislist; + print $list->thislist; + +=head2 Getting the current configuration of the current list: + + $list->getconfig; + +getconfig() returns a string that contains the command line switches that +would be necessary to re-create the current list. It does this by reading the +DIR/config file (idx < v5.0) or DIR/flags (idx >= v5.0) if one of them exists. +If it can't find these files it attempts to work things out for itself (with +varying degrees of success). If both these methods fail, then getconfig() +returns undefined. + + $list->ismodpost; + $list->ismodsub; + $list->isremote; + $list->isdeny; + $list->isallow; + +The above five functions test various features of the list, and return a 1 +if the list has that feature, or a 0 if it doesn't. These functions are +considered DEPRECATED as their result is not reliable. Use "getconfig" instead. + +=head2 Updating the configuration of the current list: + + $list->update('msPd'); + +update() can be used to rebuild the current mailing list with new command line +options. These options can be supplied as a string argument to the procedure. +Note that you do not need to supply the '-' or the 'e' command line switch. + + @part = $list->getpart('headeradd'); + $part = $list->getpart('headeradd'); + $list->setpart('headerremove', @part); + +getpart() and setpart() can be used to retrieve and set the contents of +various text files such as headeradd, headerremove, mimeremove, etc. + +=head2 Manage language dependent text files + + $list->get_available_text_files; + $list->get_text_content('sub-ok'); + $list->set_text_content('sub-ok', @content); + +These functions allow you to manipulate the text files, that are used for +automatic replies by ezmlm. + + $list->is_text_default('sub-ok'); + $list->reset_text('sub-ok'); + +These two functions are available if you are using ezmlm-idx v5.0 or higher. +is_text_default() checks, if there is a customized text file defined for this list. +reset_text() removes the customized text file from this list. Ezmlm-idx will use +system-wide default text file, if there is no customized text file for this list. + +=head2 Change the list's settings (for ezmlm-idx >= 5.0) + + Mail::Ezmlm->get_config_dir; + $list->get_config_dir; + $list->set_config_dir('/etc/ezmlm-local'); + +These functions access the file 'conf-etc' in the mailing list's directory. The +static function (first example) always returns the default configuration directory +of ezmlm-idx (/etc/ezmlm). + + $list->get_available_languages; + $list->get_lang; + $list->set_lang('de'); + $list->get_charset; + $list->set_charset('iso-8859-1:Q'); + +These functions allow you to change the language of the text files, that are used +for automatic replies of ezmlm-idx (since v5.0 the configured language is stored +in 'conf-lang' within the mailing list's directory). Customized files (in the 'text' +directory of a mailing list directory) override the default language files. +Empty strings for set_lang() and set_charset() reset the setting to its default value. + +=head2 Get the installed version of ezmlm + + Mail::Ezmlm->get_version; + +The result is one of the following: + 0 - unknown + 3 - ezmlm 0.53 + 4 - ezmlm-idx 0.4xx + 5 - ezmlm-idx 5.x + 5.1 - ezmlm-idx 5.1 + 6 - ezmlm-idx 6.x + 7 - ezmlm-idx 7.x + +=head2 Creating MySQL tables: + + $list->createsql(); + +Currently only works for MySQL. + +createsql() will attempt to create the table specified in the SQL connect +options of the current mailing list. It will return an error if the current +mailing list was not configured to use SQL, or is Ezmlm was not compiled +with MySQL support. See the MySQL info pages for more information. + +=head2 Checking the Mail::Ezmlm and ezmlm version numbers + +The version number of the Mail::Ezmlm module is stored in the variable +$Mail::Ezmlm::VERSION. The compatibility of this version of Mail::Ezmlm +with your system installed version of ezmlm can be checked with + + $list->check_version(); + +This returns 0 for compatible, or the version string of ezmlm-make(2) if +the module is incompatible with your set up. + +=head1 RETURN VALUES + +All of the routines described above have return values. 0 or undefined are +used to indicate that an error of some form has occoured, while anything +>0 (including strings, etc) are used to indicate success. + +If an error is encountered, the functions + + $list->errno(); + $list->errmsg(); + +can be used to determine what the error was. + +errno() returns; 0 or undef if there was no error. + -1 for an error relating to this module. + >0 exit value of the last system() call. + +errmsg() returns a string containing a description of the error ($! if it +was from a system() call). If there is no error, it returns undef. + +For those who are interested, in those sub routines that have to make system +calls to perform their function, an undefined value indicates that the +system call failed, while 0 indicates some other error. Things that you would +expect to return a string (such as thislist()) return undefined to indicate +that they haven't a clue ... as opposed to the empty string which would mean +that they know about nothing :) + +=head1 AUTHOR + + Guy Antony Halse + Lars Kruse + +=head1 BUGS + + There are no known bugs. + + Please report bugs to the author or use the bug tracking system at + https://systemausfall.org/trac/ezmlm-web. + +=head1 SEE ALSO + + ezmlm(5), ezmlm-make(2), ezmlm-sub(1), + ezmlm-unsub(1), ezmlm-list(1), ezmlm-issub(1) + + http://rucus.ru.ac.za/~guy/ezmlm/ + https://systemausfall.org/toolforge/ezmlm-web + http://www.ezmlm.org/ + http://www.qmail.org/ + +=cut diff --git a/Ezmlm/tags/Ezmlm-0.08/Ezmlm/GpgEzmlm.pm b/Ezmlm/tags/Ezmlm-0.08/Ezmlm/GpgEzmlm.pm new file mode 100644 index 0000000..90797c5 --- /dev/null +++ b/Ezmlm/tags/Ezmlm-0.08/Ezmlm/GpgEzmlm.pm @@ -0,0 +1,887 @@ +# =========================================================================== +# GpgEzmlm.pm +# $Id$ +# +# Object methods for gpg-ezmlm mailing lists +# +# Copyright (C) 2006, Lars Kruse, All Rights Reserved. +# Please send bug reports and comments to devel@sumpfralle.de +# +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA +# +# ========================================================================== + +package Mail::Ezmlm::GpgEzmlm; + +use strict; +use warnings; +use diagnostics; +use vars qw($GPG_EZMLM_BASE $GPG_BIN $VERSION @ISA @EXPORT @EXPORT_OK); +use File::Copy; +use Carp; + +use Mail::Ezmlm; + +# this package inherits object methods from Mail::Ezmlm +@ISA = qw(Mail::Ezmlm); + +$VERSION = '0.1'; + +require 5.005; + +=head1 NAME + +Mail::Ezmlm::GpgEzmlm - Object Methods for encrypted Ezmlm Mailing Lists + +=head1 SYNOPSIS + + use Mail::Ezmlm::GpgEzmlm; + $list = new Mail::Ezmlm::GpgEzmlm(DIRNAME); + +The rest is a bit complicated for a Synopsis, see the description. + +=head1 DESCRIPTION + +Mail::Ezmlm::GpgEzmlm is a Perl module that is designed to provide an object +interface to encrypted mailing lists based upon gpg-ezmlm. +See the gpg-ezmlm web page (http://www.synacklabs.net/projects/crypt-ml/) for +details about this software. + +The Mail::Ezmlm::GpgEzmlm class is inherited from the Mail::Ezmlm class. + +=cut + +# == Begin site dependant variables == +$GPG_EZMLM_BASE = '/usr/bin'; # Autoinserted by Makefile.PL +$GPG_BIN = '/usr/bin/gpg'; # Autoinserted by Makefile.PL + +# == clean up the path for taint checking == +local $ENV{PATH}; +# the following lines were taken from "man perlrun" +$ENV{PATH} = $GPG_EZMLM_BASE; +$ENV{SHELL} = '/bin/sh' if exists $ENV{SHELL}; +delete @ENV{qw(IFS CDPATH ENV BASH_ENV)}; + + +# check, if gpg-ezmlm is installed +unless (-x "$GPG_EZMLM_BASE/gpg-ezmlm-manage.pl") { + die("Warning: gpg-ezmlm does not seem to be installed - " + . "executable '$GPG_EZMLM_BASE/gpg-ezmlm-manage.pl' not found!"); +} + + +# == Initialiser - Returns a reference to the object == + +=head2 Setting up a new Mail::Ezmlm::GpgEzmlm object: + + use Mail::Ezmlm::GpgEzmlm; + $list = new Mail::Ezmlm::GpgEzmlm('/home/user/lists/moolist'); + +new() returns undefined if an error occoured. + +Use this function to access an existing encrypted mailing list. + +=cut + +sub new { + my ($class, $list_dir) = @_; + # call the previous initialization function + my $self = $class->SUPER::new($list_dir); + bless $self, ref $class || $class || 'Mail::Ezmlm::GpgEzmlm'; + # define the available (supported) options for gpg-ezmlm == + @{$self->{SUPPORTED_OPTIONS}} = ( + "GnuPG", + "KeyDir", + "RequireSub", + "RequireSigs", + "NoKeyNoCrypt", + "SignMessages", + "EncryptToAll", + "VerifiedKeyReq", + "AllowKeySubmission"); + # check if the mailing is encrypted + if (_is_encrypted($list_dir)) { + return $self; + } else { + return undef; + } +} + +# == convert an existing list to gpg-ezmlm == + +=head2 Converting a plaintext mailing list to an encrypted list: + +You need to have a normal list before you can convert it into an encrypted list. +You can create plaintext mailing list with Mail::Ezmlm. + + $encrypted_list->Mail::Ezmlm::GpgEzmlm->convert_to_encrypted('/lists/foo'); + +Use this function to convert a plaintext list into an encrypted mailing list. +The function returns a Mail::Ezmlm::GpgEzmlm object if it was successful. +Otherwise it returns undef. + +=cut + +sub convert_to_encrypted { + my $class = shift; + my $list_dir = shift; + my ($backup_dir); + + # untaint "list_dir" + $list_dir =~ m/^([\w\d\_\-\.\@ \/]+)$/; + if (defined($1)) { + $list_dir = $1; + } else { + warn "[GpgEzmlm] list directory contains invalid characters!"; + return undef; + } + + # the backup directory will contain the old config file and the dotqmails + $backup_dir = _get_config_backup_dir($list_dir); + if ((! -e $backup_dir) && (!mkdir($backup_dir))) { + warn "[GpgEzmlm] failed to create gpg-ezmlm conversion backup dir (" + . "$backup_dir): $!"; + return undef; + } + + # check the input + unless (defined($list_dir)) { + warn '[GpgEzmlm] must define directory in convert_to_encrypted()'; + return undef; + } + + # does the list directory exist? + unless (-d $list_dir) { + warn '[GpgEzmlm] directory does not exist: ' . $list_dir; + return undef; + } + + # the list should currently _not_ be encrypted + if (_is_encrypted($list_dir)) { + warn '[GpgEzmlm] list is already encrypted: ' . $list_dir; + return undef; + } + + + # here starts the real conversion - the code is based on + # "gpg-ezmlm-convert.pl" - see http://www.synacklabs.net/projects/crypt-ml/ + + # update the dotqmail files + return undef unless (_cleanup_dotqmail_files($list_dir, $backup_dir)); + + # create the new config file, if it did not exist before + unless (-e "$backup_dir/config.gpg-ezmlm") { + if (open(CONFIG_NEW, ">$backup_dir/config.gpg-ezmlm")) { + # just create the empty file (default) + close CONFIG_NEW; + } else { + warn "[GpgEzmlm] failed to create new config file (" + . "$backup_dir/config.gpg-ezmlm): $!"; + return undef; + } + } + + return undef unless (&_enable_encryption_config_file($list_dir)); + + # create the (empty) gnupg keyring directory - this enables the keyring + # management interface. Don't create it, if it already exists. + if ((!-e "$list_dir/.gnupg") && (!mkdir("$list_dir/.gnupg", 0700))) { + warn "[GpgEzmlm] failed to create the gnupg keyring directory: $!"; + return undef; + } + + my $result = $class->new($list_dir); + return $result; +} + +# == convert an encrypted list back to plaintext == + +=head2 Converting an encryted mailing list to a plaintext list: + + $list->convert_to_plaintext(); + +This function returns undef in case of errors. Otherwise the Mail::Ezmlm +object of the plaintext mailing list is returned. + +=cut + +sub convert_to_plaintext { + my $self = shift; + my ($dot_loc, $list_dir, $dot_prefix, $backup_dir); + + $list_dir = $self->thislist(); + # untaint the input + $list_dir =~ m/^([\w\d\_\-\.\/\@]+)$/; + unless (defined($1)) { + # sanitize directory name (it must be safe to put the warn message) + $list_dir =~ s/\W/_/g; + warn "[GpgEzmlm] the list directory contains invalid characters: '" + . $list_dir . "' (special characters are escaped)"; + return undef; + } + $list_dir = $1; + + # check if a directory was given + unless (defined($list_dir)) { + $self->_seterror(-1, 'must define directory in convert_to_plaintext()'); + return undef; + } + # the list directory must exist + unless (-d $list_dir) { + $self->_seterror(-1, 'directory does not exist: ' . $list_dir); + return undef; + } + # check if the current object is still encrypted + unless (_is_encrypted($list_dir)) { + $self->_seterror(-1, 'list is not encrypted: ' . $list_dir); + return undef; + } + + # retrieve location of dotqmail-files + $dot_loc = _get_dotqmail_location($list_dir); + + # untaint "dot_loc" + $dot_loc =~ m/^([\w\d\_\-\.\@ \/]+)$/; + if (defined($1)) { + $dot_loc = $1; + } else { + $dot_loc =~ s/\W/_/g; + warn "[GpgEzmlm] directory name of dotqmail files contains invalid " + . "characters: $dot_loc (special characters are escaped)"; + return undef; + } + + # the backup directory should contain the old config file (if it existed) + # and the original dotqmail files + $backup_dir = _get_config_backup_dir($self->thislist()); + unless (-r $backup_dir) { + warn "[GpgEzmlm] failed to revert conversion - the backup directory " + . "is missing: $backup_dir"; + return undef; + } + + # the "dot_prefix" is the basename of the main dotqmail file + # (e.g. '.qmail-list-foo') + $dot_loc =~ m/\/([^\/]+)$/; + if (defined($1)) { + $dot_prefix = $1; + } else { + warn '[GpgEzmlm] invalid location of dotqmail file: ' . $dot_loc; + return undef; + } + + # the "dotqmail" location must be valid + unless (defined($dot_loc) && ($dot_loc ne '') && (-e $dot_loc)) { + $self->_seterror(-1, 'dotqmail files not found: ' . $dot_loc); + return undef; + } + + # start reverting the gpg-ezmlm conversion: + # - restore old dotqmail files + # - restore old config file (if it existed before) + + # restore original config file (if it exists) + &_enable_plaintext_config_file($list_dir); + + # replace the dotqmail files with the ones from the backup + unless ((File::Copy::copy("$backup_dir/$dot_prefix", "$dot_loc")) + && (File::Copy::copy("$backup_dir/$dot_prefix-default", + "$dot_loc-default",))) { + warn "[GpgEzmlm] failed to restore dotqmail files: $!"; + return undef; + } + + $self = Mail::Ezmlm->new($list_dir); + return $self; +} + +# == Update the "normal" settings of the current list == + +=head2 Updating the common configuration settings of the current list: + + $list->update("moUx"); + +=cut + +# update the "normal" (=not related to encryption) settings of the list +sub update { + my $self = shift; + my $options = shift; + + my ($result); + + + # restore the ususal ezmlm-idx config file (for v0.4xx) + &_enable_plaintext_config_file($self->thislist()); + # let ezmlm-make do the setup + $result = $self->SUPER::update($options); + # restore the gpg-ezmlm config file + &_enable_encryption_config_file($self->thislist()); + # "repair" the dotqmail files (use "gpg-ezmlm-send" instead of "ezmlm-send") + &_cleanup_dotqmail_files($self->thislist()); + + # return the result of the ezmlm-make run + return $result; +} + +# == Update the encryption settings of the current list == + +=head2 Updating the configuration of the current list: + + $list->update_special({ 'allowKeySubmission' => 1 }); + +=cut + +# update the encryption specific settings +sub update_special { + my ($self, %switches) = @_; + my (%ok_switches, $one_key, @delete_switches); + + # check for important files: 'config' + unless (_is_encrypted($self->thislist())) { + $self->_seterror(-1, "Update failed: '" . $self->thislist() + . "' does not appear to be a valid list"); + return undef; + } + + @delete_switches = (); + # check if all supplied settings are supported + # btw we change the case (upper/lower) of the setting to the default one + foreach $one_key (keys %switches) { + my $ok_key; + foreach $ok_key (@{$self->{SUPPORTED_OPTIONS}}) { + # check the key case-insensitively + if ($ok_key =~ /^$one_key$/i) { + $ok_switches{$ok_key} = $switches{$one_key}; + push @delete_switches, $one_key; + } + } + } + # remove all keys, that were accepted above + # we could not do it before, since this could cause issues with the current + # "foreach" looping through the hash + foreach $one_key (@delete_switches) { + delete $switches{$one_key}; + } + + # %switches should be empty now + if (%switches) { + foreach $one_key (keys %switches) { + warn "[GpgEzmlm] unsupported setting: $one_key"; + } + } + + my $errorstring; + my $config_file_old = $self->thislist() . "/config"; + my $config_file_new = $self->thislist() . "/config.new"; + my $gnupg_setting_found = (0==1); + if (open(CONFIG_OLD, "<$config_file_old")) { + if (open(CONFIG_NEW, ">$config_file_new")) { + my ($in_line, $one_opt, $one_val, $new_setting); + while () { + $in_line = $_; + $gnupg_setting_found = (0==0) if ($in_line =~ m/^\s*GnuPG\s+/i); + if (%ok_switches) { + my $found = 0; + while (($one_opt, $one_val) = each(%ok_switches)) { + # is this the right line (maybe commented out)? + if ($in_line =~ m/^#?\s*$one_opt\s+/i) { + print CONFIG_NEW _get_config_line($one_opt, $one_val); + delete $ok_switches{$one_opt}; + $found = 1; + } + } + print CONFIG_NEW $in_line if ($found == 0); + } else { + # just print the remaining config file if no other settings are left + print CONFIG_NEW $in_line; + } + } + # write the remaining settings to the end of the file + while (($one_opt, $one_val) = each(%ok_switches)) { + print CONFIG_NEW _get_config_line($one_opt, $one_val); + } + # always set the default value for the "gpg" setting explicitely, + # if it was not overriden - otherwise gpg-ezmlm breaks on most + # systems (its default location is /usr/local/bin/gpg) + unless ($gnupg_setting_found) { + print CONFIG_NEW _get_config_line("GnuPG", $GPG_BIN); + } + } else { + $errorstring = "failed to write to temporary config file: $config_file_new"; + $self->_seterror(-1, $errorstring); + warn "[GpgEzmlm] $errorstring"; + close CONFIG_OLD; + return (1==0); + } + close CONFIG_NEW; + } else { + $errorstring = "failed to read the config file: $config_file_old"; + $self->_seterror(-1, $errorstring); + warn "[GpgEzmlm] $errorstring"; + return (1==0); + } + close CONFIG_OLD; + unless (rename($config_file_new, $config_file_old)) { + $errorstring = "failed to move new config file ($config_file_new) " + . "to original config file ($config_file_old)"; + $self->_seterror(-1, $errorstring); + warn "[GpgEzmlm] $errorstring"; + return (1==0); + } + $self->_seterror(undef); + return (0==0); +} + + +# return the configuration file string for a key/value combination +sub _get_config_line { + my $key = shift; + my $value = shift; + + my $result = "$key "; + if (($key eq "GnuPG") || ($key eq "keyDir")) { + # these are the only settings with string values + # escape special characters + $value =~ s/[^\w\.\/\-]/_/g; + $result .= $value; + } else { + $result .= ($value)? "yes" : "no"; + } + $result .= "\n"; + return $result; +} + +# == Get a list of options for the current list == + +=head2 Getting the current configuration of the current list: + + $list->getconfig; + +getconfig() returns a hash including all available settings +(undefined settings are returned with their default value). + +=cut + +# call the original 'getconfig' function after restoring the "normal" config +# file (necessary only for ezmlm-idx < 0.4x) +sub getconfig { + my $self = shift; + + my ($result); + + &_enable_plaintext_config_file($self->thislist()); + $result = $self->SUPER::getconfig(); + &_enable_encryption_config_file($self->thislist()); + + return $result; +} + +# retrieve the specific configuration of the list +sub getconfig_special { + my ($self) = @_; + my (%options, $list_dir); + + # continue with retrieving the encryption configuration + + # define defaults + $options{KeyDir} = ''; + $options{SignMessages} = 1; + $options{NoKeyNoCrypt} = 0; + $options{AllowKeySubmission} = 1; + $options{EncryptToAll} = 0; + $options{VerifiedKeyReq} = 0; + $options{RequireSub} = 0; + $options{RequireSigs} = 0; + + + # Read the config file + $list_dir = $self->thislist(); + if (open(CONFIG, "<$list_dir/config")) { + # 'config' contains the authorative information + while() { + if (/^(\w+)\s(.*)$/) { + my $optname = $1; + my $optvalue = $2; + my $one_opt; + foreach $one_opt (@{$self->{SUPPORTED_OPTIONS}}) { + if ($one_opt =~ m/^$optname$/i) { + if ($optvalue =~ /^yes$/i) { + $options{$one_opt} = 1; + } else { + $options{$one_opt} = 0; + } + } + } + } + } + close CONFIG; + } else { + $self->_seterror(-1, 'unable to read configuration file in getconfig()'); + return undef; + } + + $self->_seterror(undef); + return %options; +} + + +# ********** internal functions **************** + +# return the location of the dotqmail files +sub _get_dotqmail_location { + my $list_dir = shift; + my ($plain_list, $dot_loc); + + $plain_list = Mail::Ezmlm->new($list_dir); + if ($plain_list) { + if (-r "$list_dir/dot") { + $dot_loc = $plain_list->getpart("dot"); + chomp($dot_loc); + } elsif (-r "$list_dir/config") { + # the "config" file was used before ezmlm-idx v5 + $dot_loc = $1 if ($plain_list->getpart("config") =~ m/^T:(.*)$/); + } else { + warn '[GpgEzmlm] list configuration file not found: ' . $list_dir; + $dot_loc = undef; + } + } else { + # return undef for invalid list directories + $dot_loc = undef; + } + return $dot_loc; +} + + +# return true if the given directory contains a gpg-ezmlm mailing list +sub _is_encrypted { + my $list_dir = shift; + my ($result, $plain_list); + + # by default we assume, that the list is not encrypted + $result = 0; + + if (-e "$list_dir/lock") { + # it is a valid ezmlm-idx mailing list + $plain_list = Mail::Ezmlm->new($list_dir); + if ($plain_list) { + if (-e "$list_dir/config") { + my $content = $plain_list->getpart("config"); + $content = '' unless defined($content); + # return false if we encounter the usual ezmlm-idx-v0.4-header + if ($content =~ /^F:/m) { + # this is a plaintext ezmlm-idx v0.4 mailing list + # this is a valid case - no warning necessary + } else { + # this is a gpg-ezmlm mailing list + $result = 1; + } + } else { + # gpg-ezmlm needs a "config" file - thus the list seems to be plain + # this is a valid case - no warning necessary + } + } else { + # failed to create a plaintext mailing list object + warn "[GpgEzmlm] failed to create Mail::Ezmlm object for: " + . $list_dir; + } + } else { + warn "[GpgEzmlm] Directory does not appear to contain a valid list: " + . $list_dir; + } + + return $result; +} + + +# what is done: +# - copy current dotqmail files to the backup directory +# - replace "ezmlm-send" and "ezmlm-manage" with the gpg-ezmlm replacements +# (in the real dotqmail files) +# This function should be called: +# 1) as part of the plaintext->encryption conversion of a list +# 2) after calling ezmlm-make for an encrypted list (since the dotqmail files +# are overwritten by ezmlm-make) +sub _cleanup_dotqmail_files { + my $list_dir = shift; + my ($backup_dir, $dot_loc, $dot_prefix); + + # where should we store the current dotqmail files? + $backup_dir = _get_config_backup_dir($list_dir); + + # retrieve location of dotqmail-files + $dot_loc = _get_dotqmail_location($list_dir); + + # untaint "dot_loc" + $dot_loc =~ m/^([\w\d\_\-\.\@ \/]+)$/; + if (defined($1)) { + $dot_loc = $1; + } else { + $dot_loc =~ s/\W/_/g; + warn "[GpgEzmlm] directory name of dotqmail files contains invalid " + . "characters: $dot_loc (escaped special characters)"; + return undef; + } + + # the "dot_prefix" is the basename of the main dotqmail file + # (e.g. '.qmail-list-foo') + $dot_loc =~ m/\/([^\/]+)$/; + if (defined($1)) { + $dot_prefix = $1; + } else { + warn '[GpgEzmlm] invalid location of dotqmail file: ' . $dot_loc; + return undef; + } + + # check if the base dotqmail file exists + unless (defined($dot_loc) && ($dot_loc ne '') && (-e $dot_loc)) { + warn '[GpgEzmlm] dotqmail files not found: ' . $dot_loc; + return undef; + } + + # move the base dotqmail file + if (open(DOT_NEW, ">$backup_dir/$dot_prefix.new")) { + if (open(DOT_ORIG, "<$dot_loc")) { + my $line_found = (0==1); + while () { + my $line = $_; + if ($line =~ /ezmlm-send\s+(\S+)/) { + print DOT_NEW "\|$GPG_EZMLM_BASE/gpg-ezmlm-send.pl $1\n"; + $line_found = (0==0); + } else { + print DOT_NEW $line; + } + } + close DOT_ORIG; + # move the original file to the backup and the new file back + if ($line_found) { + unless ((rename($dot_loc, "$backup_dir/$dot_prefix")) + && (rename("$backup_dir/$dot_prefix.new", $dot_loc))) { + warn "[GpgEzmlm] failed to move base dotqmail file: $!"; + return undef; + } + } else { + warn "[GpgEzmlm] Warning: I expected a pristine base " + . "dotqmail file: $dot_loc"; + } + } else { + warn "[GpgEzmlm] failed to open base dotqmail file: $dot_loc"; + return undef; + } + close DOT_NEW; + } else { + warn "[GpgEzmlm] failed to create new base dotqmail file: " + . "$backup_dir/$dot_prefix.new"; + return undef; + } + + # move the "-default" dotqmail file + if (open(DEFAULT_NEW, ">$backup_dir/$dot_prefix-default.new")) { + if (open(DEFAULT_ORIG, "<$dot_loc-default")) { + my $line_found = (0==1); + while () { + my $line = $_; + if ($line =~ /ezmlm-manage\s+(\S+)/) { + print DEFAULT_NEW "\|$GPG_EZMLM_BASE/gpg-ezmlm-manage.pl $1\n"; + $line_found = (0==0); + } else { + print DEFAULT_NEW $line; + } + } + close DEFAULT_ORIG; + # move the original file to the backup and the new file back + if ($line_found) { + unless ((rename("$dot_loc-default", + "$backup_dir/$dot_prefix-default")) + && (rename("$backup_dir/$dot_prefix-default.new", + "$dot_loc-default"))) { + warn "[GpgEzmlm] failed to move default dotqmail file: $!"; + return undef; + } + } else { + warn "[GpgEzmlm] Warning: I expected a pristine default " + . "dotqmail file: $dot_loc-default"; + } + } else { + warn "[GpgEzmlm] failed to open default dotqmail file: " + . "$dot_loc-default"; + return undef; + } + close DEFAULT_NEW; + } else { + warn "[GpgEzmlm] failed to create new default dotqmail file: " + . "$backup_dir/$dot_prefix-default.new"; + return undef; + } + + return (0==0); +} + + +# activate the config file for encryption (gpg-ezmlm) +sub _enable_encryption_config_file { + my $list_dir = shift; + my ($backup_dir); + + $backup_dir = _get_config_backup_dir($list_dir); + + # check, if the current config file is for gpg-ezmlm or for ezmlm-idx + if (_is_encrypted($list_dir)) { + warn "[GpgEzmlm] I expected a pristine ezmlm-idx config file: " + . "$list_dir/config"; + return undef; + } + + # store the current original config file + if ((-e "$list_dir/config") && (!File::Copy::copy("$list_dir/config", + "$backup_dir/config.original"))) { + warn "[GpgEzmlm] failed to save the current ezmlm-idx config file ('" + . "$list_dir/config') to '$backup_dir/config.original': $!"; + return undef; + } + + # copy the encryption config file to the list directory + unless (File::Copy::copy("$backup_dir/config.gpg-ezmlm", + "$list_dir/config")) { + warn "[GpgEzmlm] failed to enable the gpg-ezmlm config file (from '" + . "$backup_dir/config.gpg-ezmlm' to '$list_dir/config'): $!"; + return undef; + } + + return (0==0); +} + + +# activate the config file for plain ezmlm-idx lists +sub _enable_plaintext_config_file { + my $list_dir = shift; + my ($backup_dir); + + $backup_dir = _get_config_backup_dir($list_dir); + + # check, if the current config file is for gpg-ezmlm or for ezmlm-idx + unless (_is_encrypted($list_dir)) { + warn "[GpgEzmlm] I expected a config file for gpg-ezmlm: " + . "$list_dir/config"; + return undef; + } + + # store the current gpg-ezmlm config file + unless (File::Copy::copy("$list_dir/config", + "$backup_dir/config.gpg-ezmlm")) { + warn "[GpgEzmlm] failed to save the current gpg-ezmlm config file ('" + . "$list_dir/config') to '$backup_dir/config.gpg-ezmlm': $!"; + return undef; + } + + # copy the ezmlm-idx config file to the list directory - or remove the + # currently active gpg-ezmlm config file + if (-e "$backup_dir/config.original") { + unless (File::Copy::copy("$backup_dir/config.original", + "$list_dir/config")) { + warn "[GpgEzmlm] failed to enable the originnal config file (from '" + . "$backup_dir/config.original' to '$list_dir/config': $!"; + return undef; + } + } else { + unless (unlink("$list_dir/config")) { + warn "[GpgEzmlm] failed to remove the gpg-ezmlm config file (" + . "$list_dir/config): $!"; + return undef; + } + } + + return (0==0); +} + + +# where should the dotqmail files and the config file be stored? +sub _get_config_backup_dir { + my $list_dir = shift; + return $list_dir . '/.gpg-ezmlm.backup'; +} + + +# == check version of gpg-ezmlm == +sub check_gpg_ezmlm_version { + my $ret_value = system("'$GPG_EZMLM_BASE/gpg-ezmlm-convert.pl' --version &>/dev/null"); + # for now we do not need a specific version of gpg-ezmlm - it just has to + # know the "--version" argument (available since gpg-ezmlm 0.3.4) + return ($ret_value == 0); +} + +# == check if gpg-ezmlm is installed == +sub is_available { + # the existence of the gpg-ezmlm script is sufficient for now + return -e "$GPG_EZMLM_BASE/gpg-ezmlm-convert.pl"; +} + +############ some internal functions ############## + +# == return an error message if appropriate == +sub errmsg { + my ($self) = @_; + return $self->{'ERRMSG'}; +} + +sub errno { + my ($self) = @_; + return $self->{'ERRNO'}; +} + + +# == Internal function to set the error to return == +sub _seterror { + my ($self, $no, $mesg) = @_; + + if (defined($no) && $no) { + if ($no < 0) { + $self->{'ERRNO'} = -1; + $self->{'ERRMSG'} = $mesg || 'An undefined error occoured'; + } else { + $self->{'ERRNO'} = $no / 256; + $self->{'ERRMSG'} = $! || $mesg || 'An undefined error occoured in a system() call'; + } + } else { + $self->{'ERRNO'} = 0; + $self->{'ERRMSG'} = undef; + } + return 1; +} + +1; + +=head1 AUTHOR + + Lars Kruse + +=head1 BUGS + + There are no known bugs. + + Please report bugs to the author or use the bug tracking system at + https://systemausfall.org/trac/ezmlm-web. + +=head1 SEE ALSO + + ezmlm(5), ezmlm-make(2), ezmlm-sub(1), + ezmlm-unsub(1), ezmlm-list(1), ezmlm-issub(1) + + https://systemausfall.org/toolforge/ezmlm-web/ + http://www.synacklabs.net/projects/crypt-ml/ + http://www.ezmlm.org/ + http://www.qmail.org/ + +=cut diff --git a/Ezmlm/tags/Ezmlm-0.08/Ezmlm/GpgKeyRing.pm b/Ezmlm/tags/Ezmlm-0.08/Ezmlm/GpgKeyRing.pm new file mode 100644 index 0000000..99ff26a --- /dev/null +++ b/Ezmlm/tags/Ezmlm-0.08/Ezmlm/GpgKeyRing.pm @@ -0,0 +1,399 @@ +# =========================================================================== +# Gpg.pm +# $Id$ +# +# Object methods for gpg-ezmlm mailing lists +# +# Copyright (C) 2006, Lars Kruse, All Rights Reserved. +# Please send bug reports and comments to devel@sumpfralle.de +# +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA +# +# ========================================================================== + +package Mail::Ezmlm::GpgKeyRing; + +use strict; +use vars qw($GPG_BIN $VERSION @ISA @EXPORT @EXPORT_OK); +use Carp; +use Crypt::GPG; + +$VERSION = '0.1'; + +require 5.005; + +=head1 NAME + +Mail::Ezmlm::GpgKeyRing - Object Methods for gnupg keyring management + +=head1 SYNOPSIS + + use Mail::Ezmlm::GpgKeyRing; + $keyring = new Mail::Ezmlm::GpgKeyRing(DIRNAME); + +The rest is a bit complicated for a Synopsis, see the description. + +=head1 DESCRIPTION + +Mail::Ezmlm::GpgKeyRing is a Perl module that is designed to provide an object +interface to GnuPG keyrings for encrypted mailing lists. + +=cut + +# == Begin site dependant variables == +$GPG_BIN = '/usr/bin/gpg'; # Autoinserted by Makefile.PL + + +# == check the gpg path == +$GPG_BIN = '/usr/local/bin/gpg' + unless (-x "$GPG_BIN"); +$GPG_BIN = '/usr/bin/gpg' + unless (-x "$GPG_BIN"); +$GPG_BIN = '/bin/gpg' + unless (-x "$GPG_BIN"); +$GPG_BIN = '/usr/local/bin/gpg2' + unless (-x "$GPG_BIN"); +$GPG_BIN = '/usr/bin/gpg2' + unless (-x "$GPG_BIN"); +$GPG_BIN = '/bin/gpg2' + unless (-x "$GPG_BIN"); + +# == clean up the path == +local $ENV{'PATH'} = "/bin"; + +# check, if gpg is installed +unless (-x "$GPG_BIN") { + die("Warning: gnupg does not seem to be installed - none of the " + . "executables 'gpg' or 'gpg2' were found at the usual locations!"); +} + + +# == Initialiser - Returns a reference to the object == + +=head2 Setting up a new Mail::Ezmlm::GpgKeyRing object: + + use Mail::Ezmlm::GpgKeyRing; + $keyring = new Mail::Ezmlm::GpgKeyRing('/home/user/lists/foolist/.gnupg'); + +new() returns the new instance for success, undefined if there was a problem. + +=cut + +sub new { + my($class, $keyring_dir) = @_; + my $self = {}; + bless $self, ref $class || $class || 'Mail::Ezmlm::GpgKeyRing'; + if ($self->set_location($keyring_dir)) { + return $self; + } else { + return undef; + } +} + + +# == Return the directory of the gnupg keyring == + +=head2 Determining the location of the configured keyring. + + $whichkeyring = $keyring->get_location(); + print $keyring->get_location(); + +=cut + +sub get_location { + my($self) = shift; + return $self->{'KEYRING_DIR'}; +} + + +# == Set the current keyring directory == + +=head2 Changing which keyring the Mail::Ezmlm::GpgKeyRing object points at: + + $keyring->set_location('/home/user/lists/foolist/.gnupg'); + +=cut + +sub set_location { + my($self, $keyring_dir) = @_; + if (-e "$keyring_dir") { + if (-x "$keyring_dir") { + # at least it is a directory - so it looks ok + $self->{'KEYRING_DIR'} = $keyring_dir; + } else { + # it seems to be a file or something else - we complain + warn "GPG keyring location must be a directory: $keyring_dir"; + $self->{'KEYRING_DIR'} = undef; + } + } else { + # probably the keyring directory does not exist, yet + # a warning should not be necessary + $self->{'KEYRING_DIR'} = $keyring_dir; + } + return $self->{'KEYRING_DIR'} +} + + +# == export a key == + +=head2 Export a key: + +You may export public keys of the keyring. + +The key can be identified by its id or other (unique) patterns (like the +gnupg program). + + $keyring->export_key($key_id); + $keyring->export_key($email_address); + +The return value is a string containing the ascii armored key data. + +=cut + +sub export_key { + my ($self, $keyid) = @_; + my ($gpg, $gpgoption, $gpgcommand, $output); + + # return immediately - this avoids creating an empty keyring unintentionally + return () unless (-e $self->{'KEYRING_DIR'}); + $gpg = $self->_get_gpg_object(); + $gpgoption = "--armor --export $keyid"; + $gpgcommand = $gpg->gpgbin() . " " . $gpg->gpgopts() . " $gpgoption"; + $output = `$gpgcommand 2>/dev/null`; + if ($output) { + return $output; + } else { + return undef; + } +} + + +# == import a new key == + +=head2 Import a key: + +You can import public or secret keys into the keyring. + +The key should be ascii armored. + + $keyring->import_key($ascii_armored_key_data); + +=cut + +sub import_key { + my ($self, $key) = @_; + my $gpg = $self->_get_gpg_object(); + if ($gpg->addkey($key)) { + return (0==0); + } else { + return (1==0); + } +} + + +# == delete a key == + +=head2 Delete a key: + +Remove a public key (and the matching secret key if it exists) from the keyring. + +The argument is the id of the key or any other unique pattern. + + $keyring->delete_key($keyid); + +=cut + +sub delete_key { + my ($self, $keyid) = @_; + my $gpg = $self->_get_gpg_object(); + my $fprint = $self->_get_fingerprint($keyid); + return (1==0) unless (defined($fprint)); + my $gpgoption = "--delete-secret-and-public-key $fprint"; + my $gpgcommand = $gpg->gpgbin() . " " . $gpg->gpgopts() . " $gpgoption"; + if (system($gpgcommand)) { + return (1==0); + } else { + return (0==0); + } +} + + +# == generate new private key == + +=head2 Generate a new key: + + $keyring->generate_key($name, $comment, $email_address, $keysize, $expire); + +Refer to the documentation of gnupg for the format of the arguments. + +=cut + +sub generate_private_key { + my ($self, $name, $comment, $email, $keysize, $expire) = @_; + my $gpg = $self->_get_gpg_object(); + my $gpgoption = "--gen-key"; + my $gpgcommand = $gpg->gpgbin() . " " . $gpg->gpgopts() . " $gpgoption"; + my $pid = open(INPUT, "| $gpgcommand"); + print INPUT "Key-Type: DSA\n"; + print INPUT "Key-Length: 1024\n"; + print INPUT "Subkey-Type: ELG-E\n"; + print INPUT "Subkey-Length: $keysize\n"; + print INPUT "Name-Real: $name\n"; + print INPUT "Name-Comment: $comment\n" if ($comment); + print INPUT "Name-Email: $email\n"; + print INPUT "Expire-Date: $expire\n"; + return close INPUT; +} + + +# == get_public_keys == + +=head2 Getting public keys: + +Return an array of key hashes each containing the following elements: + +=over + +=item * +name + +=item * +email + +=item * +id + +=item * +expires + +=back + + $keyring->get_public_keys(); + $keyring->get_secret_keys(); + +=cut + +sub get_public_keys { + my ($self) = @_; + my @keys = $self->_get_keys("pub"); + return @keys; +} + + +# == get_private_keys == +# see above for POD (get_public_keys) +sub get_secret_keys { + my ($self) = @_; + my @keys = $self->_get_keys("sec"); + return @keys; +} + + +############ some internal functions ############## + +# == internal function for creating a gpg object == +sub _get_gpg_object() { + my ($self) = @_; + my $gpg = new Crypt::GPG(); + my $dirname = $self->get_location(); + # replace whitespace characters in the keyring directory name + $dirname =~ s/(\s)/\\$1/g; + $gpg->gpgbin($GPG_BIN); + $gpg->gpgopts("--lock-multiple --no-tty --no-secmem-warning --batch --quiet --homedir $dirname"); + return $gpg; +} + + +# == internal function to list keys == +sub _get_keys() { + # type can be "pub" or "sec" + my ($self, $keyType) = @_; + my ($gpg, $flag, $gpgoption, @keys, $key); + + # return immediately - this avoids creating an empty keyring unintentionally + return () unless (-r $self->{'KEYRING_DIR'}); + $gpg = $self->_get_gpg_object(); + if ($keyType eq "pub") { + $flag = "pub"; + $gpgoption = "--list-keys"; + } elsif ($keyType eq "sec") { + $flag = "sec"; + $gpgoption = "--list-secret-keys"; + } else { + warn "wrong keyType: $keyType"; + return undef; + } + my $gpgcommand = $gpg->gpgbin() . " " . $gpg->gpgopts() . " --with-colons $gpgoption"; + my @read_keys = grep /^$flag/, `$gpgcommand`; + foreach $key (@read_keys) { + my ($type, $trust, $size, $algorithm, $id, $created, + $expires, $u2, $ownertrust, $uid) = split ":", $key; + # stupid way of "decoding" utf8 (at least it works for ":") + $uid =~ s/\\x3a/:/g; + $uid =~ /^(.*) <([^<]*)>/; + my $name = $1; + my $email = $2; + push @keys, {name => $name, email => $email, id => $id, expires => $expires}; + } + return @keys; +} + + +# == internal function to retrieve the fingerprint of a key == +sub _get_fingerprint() +{ + my ($self, $key_id) = @_; + my $gpg = $self->_get_gpg_object(); + $key_id =~ /^([0-9A-Z]*)$/; + $key_id = $1; + return undef unless ($key_id); + my $gpgoption = "--fingerprint $key_id"; + + my $gpgcommand = $gpg->gpgbin() . " " . $gpg->gpgopts() . " --with-colons $gpgoption"; + + my @fingerprints = grep /^fpr:/, `$gpgcommand`; + if (@fingerprints > 1) { + warn "[Mail::Ezmlm::GpgKeyRing] more than one key matched ($key_id)!"; + return undef; + } + return undef if (@fingerprints < 1); + my $fpr = $fingerprints[0]; + $fpr =~ /^fpr:*([0-9A-Z]*):*$/; + $fpr = $1; + return undef unless $1; + return $1; +} + + +=head1 AUTHOR + + Lars Kruse + +=head1 BUGS + + There are no known bugs. + + Please report bugs to the author or use the bug tracking system at + https://systemausfall.org/trac/ezmlm-web. + +=head1 SEE ALSO + + gnupg(7), gpg(1), gpg2(1), Crypt::GPG(3pm) + + https://systemausfall.org/toolforge/ezmlm-web/ + http://www.ezmlm.org/ + +=cut + diff --git a/Ezmlm/tags/Ezmlm-0.08/MANIFEST b/Ezmlm/tags/Ezmlm-0.08/MANIFEST new file mode 100644 index 0000000..3bd323b --- /dev/null +++ b/Ezmlm/tags/Ezmlm-0.08/MANIFEST @@ -0,0 +1,9 @@ +Changes +Ezmlm.pm +MANIFEST +README +Makefile.PL +test.pl +META.yml +Ezmlm/GpgKeyRing.pm +Ezmlm/GpgEzmlm.pm diff --git a/Ezmlm/tags/Ezmlm-0.08/META.yml b/Ezmlm/tags/Ezmlm-0.08/META.yml new file mode 100644 index 0000000..5fa8fbb --- /dev/null +++ b/Ezmlm/tags/Ezmlm-0.08/META.yml @@ -0,0 +1,10 @@ +# http://module-build.sourceforge.net/META-spec.html +#XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX# +name: Ezmlm +version: 0.08 +version_from: Ezmlm.pm +installdirs: site +requires: + +distribution_type: module +generated_by: ExtUtils::MakeMaker version 6.17 diff --git a/Ezmlm/tags/Ezmlm-0.08/Makefile.PL b/Ezmlm/tags/Ezmlm-0.08/Makefile.PL new file mode 100644 index 0000000..b543bdf --- /dev/null +++ b/Ezmlm/tags/Ezmlm-0.08/Makefile.PL @@ -0,0 +1,232 @@ +# $Id: Makefile.PL,v 1.3 2005/03/05 14:15:20 guy Exp $ + +use ExtUtils::MakeMaker; +# See lib/ExtUtils/MakeMaker.pm for details of how to influence +# the contents of the Makefile that is written. +WriteMakefile( + 'CONFIGURE' => \&set_paths, + 'NAME' => 'Mail::Ezmlm', + 'VERSION_FROM' => 'Ezmlm.pm', # finds $VERSION + 'PREREQ_PM' => { 'File::Copy' => 0, 'Crypt::GPG' => 0 }, + 'DISTNAME' => 'Ezmlm', + 'dist' => { COMPRESS => 'gzip', SUFFIX => 'gz' }, + 'clean' => { FILES => 'ezmlmtmp' } +); + +sub set_paths { + my ($qmail_path, $ezmlm_path, $gpg_ezmlm_path, $gpg_ezmlm_requested); + my ($gpg_bin, $gpg_bin_requested); + + # special case to handle the FreeBSD ports system + if ($ENV{BSD_BATCH_INSTALL}) { + print STDERR "\$BSD_BATCH_INSTALL is set in your environment, assuming port defaults\n"; + return {}; + } + + print << 'EOM'; + +We now need to know where some things live on your system. I'll try and make +some intelligent guesses - if I get it right, please just press enter at the +prompt. If I get them wrong, please type in the correct path for me and then +press enter. + +First I need to know where the Ezmlm binaries live (ie where I can find +ezmlm-make, ezmlm-sub, etc). + +EOM + + *prompt = \&ExtUtils::MakeMaker::prompt; + + # guess default + $ezmlm_path = '/usr/local/bin/ezmlm'; + $ezmlm_path = '/usr/local/bin/ezmlm-idx' unless (-e "$ezmlm_path/ezmlm-make"); + $ezmlm_path = '/usr/local/bin' unless (-e "$ezmlm_path/ezmlm-make"); + $ezmlm_path = '/usr/bin/ezmlm' unless (-e "$ezmlm_path/ezmlm-make"); + $ezmlm_path = '/usr/bin/ezmlm-idx' unless (-e "$ezmlm_path/ezmlm-make"); + $ezmlm_path = '/usr/bin' unless (-e "$ezmlm_path/ezmlm-make"); + # return to default, if nothing can be found + $ezmlm_path = '/usr/local/bin/ezmlm' unless (-e "$ezmlm_path/ezmlm-make"); + + foreach (1..10) { + $ezmlm_path = prompt('Ezmlm binary directory?', "$ezmlm_path"); + last if (-e "$ezmlm_path/ezmlm-make"); + print "I can't find $ezmlm_path/ezmlm-make. Please try again\n"; + } + unless (-e "$ezmlm_path/ezmlm-make") { + print STDERR "Warning: No correct input after $_ attempts. Continuing with warnings ...\n"; + } + unless (system(("$ezmlm_path/ezmlm-make", "-V")) == 0) { + print STDERR "Warning: your version of ezmlm-make does not support the '-V' argument. Please upgrade to ezmlm-idx v0.400 or above.\n"; + } + + + print << 'EOM'; + +Now I need to know where Qmail resides on your system. The Qmail base +directory is the one in which the Qmail bin, control, etc directories +live in. + +EOM + + foreach (1..10) { + $qmail_path = prompt('Qmail base directory?', '/var/qmail'); + last if (-e "$qmail_path/control"); + print "I can't find $qmail_path/control. Please try again\n"; + } + if (! -e "$qmail_path/control") { + print STDERR "Warning: No correct input after $_ attempts. Continuing with warnings ...\n"; + } + + + # check if gpg-ezmlm is installed (for Mail::Ezmlm::GpgEzmlm) + $gpg_ezmlm_requested = prompt('Is gpg-ezmlm installed for encrypted mailing list support? (y/N)', "n"); + $gpg_ezmlm_requested = ($gpg_ezmlm_requested =~ /^y/i); + if ($gpg_ezmlm_requested) { + undef $gpg_ezmlm_path; + foreach ('/usr/local/bin', '/usr/bin', '/usr/local/bin/gpg-ezmlm', + '/usr/bin/gpg-ezmlm') { + if (-e "$_/gpg-ezmlm-manage.pl") { + $gpg_ezmlm_path = $_; + last; + } + } + $gpg_ezmlm_path = '/usr/bin' unless (defined($gpg_ezmlm_path)); + # ask the user to confirm our guessing + foreach (1..10) { + $gpg_ezmlm_path = prompt('gpg-ezmlm installation directory?', + "$gpg_ezmlm_path"); + last if (-e "$gpg_ezmlm_path/gpg-ezmlm-manage.pl"); + print "I can't find $gpg_ezmlm_path/gpg-ezmlm-manage.pl. " + . "Please try again\n"; + } + unless (-e "$gpg_ezmlm_path/gpg-ezmlm-manage.pl") { + print STDERR "Warning: No correct input after $_ attempts. " + . "Continuing with warnings ...\n"; + } + } + + # check if gpg is installed (for Mail::Ezmlm::GpgKeyRing) + $gpg_bin_requested = prompt('Is gnupg installed (for keyring support in encrypted mailing lists)? (y/N)', "n"); + $gpg_bin_requested = ($gpg_bin_requested =~ /^y/i); + if ($gpg_bin_requested) { + undef $gpg_bin; + foreach ('/usr/local/bin/gpg', '/usr/bin/gpg', '/bin/gpg', + '/usr/local/bin/gpg2', '/usr/bin/gpg2', '/bin/gpg2') { + if (-x "$_") { + $gpg_bin = $_; + last; + } + } + $gpg_bin = '/usr/bin' unless (defined($gpg_bin)); + # ask the user to confirm our guessing + foreach (1..10) { + $gpg_bin = prompt('Path to the gpg or gpg2 binary?', "$gpg_bin"); + last if (-x "$gpg_bin"); + print "I can't find $gpg_bin. Please try again\n"; + } + unless (-x "$gpg_bin") { + print STDERR "Warning: No correct input after $_ attempts. " + . "Continuing with warnings ...\n"; + } + } + + # check if mysql support is necessary + if(`strings $ezmlm_path/ezmlm-sub | grep -i 'MySQL'`) { + + print << 'EOM'; + +It appears you have compiled MySQL support into your version of Ezmlm. If +this is correct, I now need to know where the MySQL client (mysql) lives on +your machine. + +Please leave this blank if you do not want to enable MySQL support in the +Mail::Ezmlm module. + +EOM + + $mysql_path = '/usr/bin'; + $mysql_path = '/usr/local/bin' unless (-e "$mysql_path/mysql"); + # return to default - if nothing works + $mysql_path = '/usr/bin' unless (-e "$mysql_path/mysql"); + + foreach (1..10) { + $mysql_path = prompt('MySQL binary directory?', "$mysql_path"); + last if (-e "$mysql_path/mysql" || $mysql_path eq ''); + print "I can't find $mysql_path/mysql. Please enter the full path\n"; + print "or leave this option blank if you don't want to use MySQL\n"; + } + unless ((-e "$mysql_path/mysql") || ($mysql_path eq '')) { + print STDERR "Warning: No correct input after $_ attempts. Continuing with warnings ...\n"; + } + + } + + print << 'EOM'; + +Thank you. I will use this information to configure Mail::Ezmlm for you + +EOM + + # set the variables in Ezmlm.pm + # Back up file + open(EZMLM, 'Ezmlm.pm.tmp.$$") or die "Unable to create temp file: $!"; + while() { print TMP; } + close TMP; close EZMLM; + # Do variable substitution + open(EZMLM, '>Ezmlm.pm') or die "Unable to open Ezmlm.pm for write: $!"; + open(TMP, ") { + s{^\$EZMLM_BASE\s*=\s*['"].+?['"]\s*;\s*(#.*|)$}{\$EZMLM_BASE = '$ezmlm_path'; #Autoinserted by Makefile.PL}; + s{^\$QMAIL_BASE\s*=\s*['"].+?['"]\s*;\s*(#.*|)$}{\$QMAIL_BASE = '$qmail_path'; #Autoinserted by Makefile.PL}; + s{^\$MYSQL_BASE\s*=\s*['"].*?['"]\s*;\s*(#.*|)$}{\$MYSQL_BASE = '$mysql_path'; #Autoinserted by Makefile.PL}; + print EZMLM; + } + close TMP; close EZMLM; + unlink "Ezmlm.pm.tmp.$$"; + + if ($gpg_ezmlm_requested) { + # set the variables in GpgEzmlm.pm + # Back up file + open(GPGEZMLM, 'Ezmlm/GpgEzmlm.pm.tmp.$$") or die "Unable to create temp file: $!"; + while() { print TMP; } + close TMP; close GPGEZMLM; + # Do variable substitution + open(GPGEZMLM, '>Ezmlm/GpgEzmlm.pm') + or die "Unable to open Ezmlm/GpgEzmlm.pm for write: $!"; + open(TMP, ") { + s{^\$GPG_EZMLM_BASE\s*=\s*['"].+?['"]\s*;\s*(#.*|)$}{\$GPG_EZMLM_BASE = '$gpg_ezmlm_path'; # Autoinserted by Makefile.PL}; + s{^\$GPG_BIN\s*=\s*['"].+?['"]\s*;\s*(#.*|)$}{\$GPG_BIN = '$gpg_bin'; # Autoinserted by Makefile.PL} if ($gpg_bin_requested); + print GPGEZMLM; + } + close TMP; close GPGEZMLM; + unlink "Ezmlm/GpgEzmlm.pm.tmp.$$"; + } + + # set the variables in GpgKeyRing.pm + if ($gpg_bin_requested) { + # Back up file + open(GPGKEYRING, 'Ezmlm/GpgKeyRing.pm.tmp.$$") or die "Unable to create temp file: $!"; + while() { print TMP; } + close TMP; close GPGKEYRING; + # Do variable substitution + open(GPGKEYRING, '>Ezmlm/GpgKeyRing.pm') or die "Unable to open Ezmlm/GpgKeyRing.pm for write: $!"; + open(TMP, ") { + s{^\$GPG_BIN\s*=\s*['"].+?['"]\s*;\s*(#.*|)$}{\$GPG_BIN = '$gpg_bin'; # Autoinserted by Makefile.PL}; + print GPGKEYRING; + } + close TMP; close GPGKEYRING; + unlink "Ezmlm/GpgKeyRing.pm.tmp.$$"; + } + + return {}; + +} + diff --git a/Ezmlm/tags/Ezmlm-0.08/README b/Ezmlm/tags/Ezmlm-0.08/README new file mode 100644 index 0000000..68f6e16 --- /dev/null +++ b/Ezmlm/tags/Ezmlm-0.08/README @@ -0,0 +1,19 @@ +$Id$ + +Ezmlm.pm + +Object methods for ezmlm mailing lists. + +Install by doing the following ... +# perl Makefile.PL +# make test +# make install + +One thing. For some reason MakeMaker doesn't like symlinks. Please make sure +you use the full canonical path for the qmail and ezmlm binaries. + +Documentation is in pod format. Please run perldoc Mail::Ezmlm after you have +installed it. + +- Guy Antony Halse +- Lars Kruse diff --git a/Ezmlm/tags/Ezmlm-0.08/test.pl b/Ezmlm/tags/Ezmlm-0.08/test.pl new file mode 100644 index 0000000..4e0d4ee --- /dev/null +++ b/Ezmlm/tags/Ezmlm-0.08/test.pl @@ -0,0 +1,234 @@ +# =========================================================================== +# test.pl - version 0.02 - 25/09/2000 +# $Id: test.pl,v 1.5 2005/03/05 14:08:30 guy Exp $ +# Test suite for Mail::Ezmlm +# +# Copyright (C) 1999, Guy Antony Halse, All Rights Reserved. +# Please send bug reports and comments to guy-ezmlm@rucus.ru.ac.za +# +# This program is subject to the restrictions set out in the copyright +# agreement that can be found in the Ezmlm.pm file in this distribution +# +# ========================================================================== +# Before `make install' is performed this script should be runnable with +# `make test'. After `make install' it should work as `perl test.pl' + +######################### We start with some black magic to print on failure. + +$failed = 0; + +BEGIN { $| = 1; print "1..9\n"; } +END {($failed++ && print "not ok 1\n") unless $loaded;} +use Mail::Ezmlm; +$loaded = 1; +print "Loading: ok 1\n"; + +######################### End of black magic. + +# Insert your test code below (better if it prints "ok 13" +# (correspondingly "not ok 13") depending on the success of chunk 13 +# of the test code): + +use Cwd; +use File::Find; +$list = new Mail::Ezmlm; + +# create a temp directory if necessary +$TMP = cwd() . '/ezmlmtmp'; +mkdir $TMP, 0755 unless (-d $TMP); + +print 'Checking list creation: '; +$test1 = $list->make(-name=>"ezmlm-test1-$$", + -qmail=>"$TMP/.qmail-ezmlm-test1-$$", + -dir=>"$TMP/ezmlm-test1-$$"); +if($test1 eq "$TMP/ezmlm-test1-$$") { + print "ok 2\n"; +} else { + print 'not ok 2 [', $list->errmsg(), "]\n"; + $failed++; +} + +print 'Checking vhost list creation: '; +$test2 = $list->make(-name=>"ezmlm-test2-$$", + -qmail=>"$TMP/.qmail-ezmlm-test2-$$", + -dir=>"$TMP/ezmlm-test2-$$", + -host=>'on.web.za', + -user=>'onwebza'); +if($test2 eq "$TMP/ezmlm-test2-$$") { + open(INLOCAL, "<$TMP/ezmlm-test2-$$/inlocal"); + chomp($test2 = ); + close INLOCAL; + if($test2 eq "onwebza-ezmlm-test2-$$") { + print "ok 3\n"; + } else { + print 'not ok 3 [', $list->errmsg(), "]\n"; + $failed++; + } +} else { + print 'not ok 3 [', $list->errmsg(), "]\n"; + $failed++; +} + +print 'Testing list update: '; +if($list->update('ms')) { + print "ok 4\n"; +} else { + print 'not ok 4 [', $list->errmsg(), "]\n"; + $failed++; +} + +print 'Testing setlist() and thislist(): '; +$list->setlist("$TMP/ezmlm-test1-$$"); +if($list->thislist eq "$TMP/ezmlm-test1-$$") { + print "ok 5\n"; +} else { + print 'not ok 5 [', $list->errmsg(), "]\n"; + $failed++; +} + +print 'Testing list subscription and subscription listing: '; +$list->sub('nobody@on.web.za'); +$list->sub('anonymous@on.web.za', 'test@on.web.za'); +@subscribers = $list->subscribers; +if($subscribers[1] =~ /nobody\@on.web.za/) { + print "ok 6\n"; +} else { + print 'not ok 6 [', $list->errmsg(), "]\n"; + $failed++; +} + +print 'Testing issub(): '; +if(defined($list->issub('nobody@on.web.za'))) { + if(defined($list->issub('some@non.existant.address'))) { + print 'not ok 7 [', $list->errmsg(), "]\n"; + $failed++; + } else { + print "ok 7\n"; + } +} else { + print 'not ok 7 [', $list->errmsg(), "]\n"; + $failed++; +} + +print 'Testing list unsubscription: '; +$list->unsub('nobody@on.web.za'); +$list->unsub('anonymous@on.web.za', 'test@on.web.za'); +@subscribers = $list->subscribers; +unless(@subscribers) { + print "ok 8\n"; +} else { + print 'not ok 8 [', $list->errmsg(), "]\n"; + $failed++; +} + +print 'Testing installed version of ezmlm: '; +my($version) = $list->check_version(); +if ($version) { + $version =~ s/\n//; + print 'not ok 9 [Warning: Ezmlm.pm is designed to work with ezmlm-idx > 0.40. Your version reports as: ', $version, "]\n"; +} else { + print "ok 9\n"; +} + +print 'Testing retrieving of text files: '; +if ($list->get_text_content('sub-ok') ne '') { + print "ok 10\n"; +} else { + print 'not ok 10 [', $list->errmsg(), "]\n"; + $failed++; +} + +print 'Testing changing of text files: '; +$list->set_text_content('sub-ok', "testing message\n"); +if ($list->get_text_content('sub-ok') eq "testing message\n") { + print "ok 11\n"; +} else { + print 'not ok 11 [', $list->errmsg(), "]\n"; + $failed++; +} + +print 'Testing if text file is marked as customized (only idx >= 5.0): '; +if ($list->get_version() >= 5) { + if ($list->is_text_default('sub-ok')) { + print 'not ok 12 [', $list->errmsg(), "]\n"; + $failed++; + } else { + print "ok 12\n"; + } +} else { + print "ok 12 [skipped]\n"; +} + +print 'Testing resetting text files (only idx >= 5.0): '; +if ($list->get_version() >= 5) { + $list->reset_text('sub-ok'); + if ($list->is_text_default('sub-ok')) { + print "ok 13\n"; + } else { + print 'not ok 13 [', $list->errmsg(), "]\n"; + $failed++; + } +} else { + print "ok 13 [skipped]\n"; +} + +print 'Testing retrieving available languages (only idx >= 5.0): '; +if ($list->get_version() >= 5) { + my @avail_langs = $list->get_available_languages(); + if ($#avail_langs > 0) { + print "ok 14\n"; + } else { + print 'not ok 14 [', $list->errmsg(), "]\n"; + $failed++; + } +} else { + print "ok 14 [skipped]\n"; +} + +print 'Testing changing the configured language (only idx >= 5.0): '; +if ($list->get_version() >= 5) { + my @avail_langs = $list->get_available_languages(); + $list->set_lang($avail_langs[$#avail_langs-1]); + if ($list->get_lang() eq $avail_langs[$#avail_langs-1]) { + print "ok 15\n"; + } else { + print 'not ok 15 [', $list->errmsg(), "]\n"; + $failed++; + } +} else { + print "ok 15 [skipped]\n"; +} + +print 'Testing getting the configuration directory (only idx >= 5.0): '; +if ($list->get_version() >= 5) { + if ($list->get_config_dir() ne '') { + print "ok 16\n"; + } else { + print 'not ok 16 [', $list->errmsg(), "]\n"; + $failed++; + } +} else { + print "ok 16 [skipped]\n"; +} + +print 'Testing changing the configuration directory (only idx >= 5.0): '; +if ($list->get_version() >= 5) { + $list->set_config_dir('/etc/ezmlm-local'); + if ($list->get_config_dir() eq '/etc/ezmlm-local') { + print "ok 17\n"; + } else { + print 'not ok 17 [', $list->errmsg(), "]\n"; + $failed++; + } +} else { + print "ok 17 [skipped]\n"; +} + +if($failed > 0) { + print "\n$failed tests were failed\n"; + exit $failed; +} else { + print "\nSuccessful :-)\n"; + finddepth(sub { (-d $File::Find::name) ? rmdir ($File::Find::name) : unlink ($File::Find::name) }, cwd() . "/ezmlmtmp"); + exit; +} diff --git a/Ezmlm/tags/packages/Ezmlm-0.08.tar.gz b/Ezmlm/tags/packages/Ezmlm-0.08.tar.gz new file mode 100644 index 0000000..6b9f652 Binary files /dev/null and b/Ezmlm/tags/packages/Ezmlm-0.08.tar.gz differ diff --git a/Ezmlm/tags/packages/libemail-ezmlm-perl_0.08-1_all.deb b/Ezmlm/tags/packages/libemail-ezmlm-perl_0.08-1_all.deb new file mode 100644 index 0000000..13814a1 Binary files /dev/null and b/Ezmlm/tags/packages/libemail-ezmlm-perl_0.08-1_all.deb differ