# ===========================================================================
# Ezmlm.pm - version 0.08.2 - 10/15/2008
# $Id: Ezmlm.pm 453 2008-10-16 01:22:44Z lars $
#
# 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.2';
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 = <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 = <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(<CONFIG>) {
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(<PART>) {
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(<PART>) {
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 ==
# return 0 for a valid version
# return the version string for an invalid version
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 = <EDITOR>; $manager = <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(<VD>) {
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 = <GETHOST>);
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 <guy-ezmlm@rucus.net>
Lars Kruse <devel@sumpfralle.de>
=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