#!/usr/bin/perl 
#===========================================================================
# ezmlm-web.cgi - version 3.2
# $Id$
# ==========================================================================
# All user configuration happens in the config file ``ezmlmwebrc''
# POD documentation is at the end of this file
# ==========================================================================

package ezmlm_web;

# Modules to include
use strict;
use Getopt::Std;
use ClearSilver;
use Mail::Ezmlm;
use Mail::Address;
use File::Copy;
use File::Path;
use DB_File;
use CGI;
use IO::File;
use POSIX;
use English;
use Time::localtime ();

# gettext support is optional
my $GETTEXT_SUPPORT = 1;
unless (&safely_import_module("Locale::gettext")) {
	$GETTEXT_SUPPORT = 0;
	warn "Gettext support is not available - the multilingual web interface is not available!";
}

# the Encode module is optional - we do not break if it is absent
my $ENCODE_SUPPORT = 1;
unless (&safely_import_module("Encode")) {
	$ENCODE_SUPPORT = 0;
	warn "Encoding module is not available - charset conversion will fail!";
}


# do not forget: we depend on Mail::Ezmlm::Gpg if the corresponding configuration
# setting is enabled




################## some preparations at the beginning ##################

# drop privileges (necessary for calling gpg)
# this should not do any other harm
$UID = $EUID;
$GID = $EGID;

my $VERSION = '3.2';

my $q = new CGI;
$q->import_names('Q');
use vars qw[$opt_c $opt_d $opt_C];
getopts('cd:C:');

# Suid stuff requires a secure path.
$ENV{'PATH'} = '/bin';

# We run suid so we can't use $ENV{'HOME'} and $ENV{'USER'} to determine the
# user. :( Don't alter this line unless you are _sure_ you have to.
my @tmp = getpwuid($>); use vars qw[$USER]; $USER=$tmp[0];

# defined by our environment - see above
use vars qw[$HOME_DIR]; $HOME_DIR=$tmp[7];

# use strict is a good thing++

# some configuration settings
use vars qw[$DEFAULT_OPTIONS $UNSAFE_RM $ALIAS_USER $LIST_DIR];
use vars qw[$QMAIL_BASE $PRETTY_NAMES $DOTQMAIL_DIR];
use vars qw[$FILE_UPLOAD $WEBUSERS_FILE $MAIL_DOMAIN $HTML_TITLE];
use vars qw[$HTML_CSS_FILE $TEMPLATE_DIR $LANGUAGE_DIR $HTML_LANGUAGE];
use vars qw[$MAIL_ADDRESS_PREFIX];
# some settings for encrypted mailing lists
use vars qw[$GPG_SUPPORT];
# settings for multi-domain setups
use vars qw[%DOMAINS $CURRENT_DOMAIN];

# some deprecated configuration settings - they have to be announced
# otherwise old configuration files would break
# for now there are no deprecated settings

# "pagedata" contains the hdf tree for clearsilver
# "pagename" refers to the template file that should be used
# "ui_template" is one of "basic", "normal" and "expert"
use vars qw[$pagedata $pagename $error $customError $warning $customWarning $success];
use vars qw[$ui_set $ui_template];

# Get user configuration stuff
my $config_file;
if (defined($opt_C)) {
   $opt_C =~ /^([-\w.\/]+)$/;	# security check by ooyama
   $config_file = $1; # Command Line
} elsif (-e "$HOME_DIR/.ezmlmwebrc") {
   $config_file = "$HOME_DIR/.ezmlmwebrc"; # User
} elsif (-e "./ezmlmwebrc") {
   $config_file = "./ezmlmwebrc"; # Install
} elsif (-e "/etc/ezmlm-web/ezmlmwebrc") {
   $config_file = "/etc/ezmlm-web/ezmlmwebrc"; # System (new style - since v2.2)
} elsif (-e "/etc/ezmlm/ezmlmwebrc") {
   $config_file = "/etc/ezmlm/ezmlmwebrc"; # System (old style - up to v2.1)
} else {
   &fatal_error("Unable to find config file");
}
unless (my $return = do $config_file) {
	if ($@) {
		&fatal_error("Failed to parse the config file ($config_file): $@");
	} elsif (!defined $return) {
		&fatal_error("Failed to read the config file ($config_file): $!");
	} else {
		# the last statement of the config file return False -> this is ok
	}
}


####### validate configuration and apply some default settings ##########

# do we support encrypted mailing lists?
# see https://systemausfall.org/toolforge/crypto-ezmlm
$GPG_SUPPORT = 0 unless defined($GPG_SUPPORT);
if ($GPG_SUPPORT) {
	if (&safely_import_module("Mail::Ezmlm::Gpg")) {
		$GPG_SUPPORT = 1;
	} else {
		$GPG_SUPPORT = 0;
		warn "WARNING: Support for encrypted mailinglists is disabled, as the module Mail::Ezmlm::Gpg failed to load!";
	}
}

# Allow suid wrapper to override default list directory ...
if (defined($opt_d)) {
   $LIST_DIR = $1 if ($opt_d =~ /^([-\@\w.\/]+)$/);
}

# If WEBUSERS_FILE is not defined in ezmlmwebrc (as before version 2.2),
# then use former default value for compatibility
$WEBUSERS_FILE = $LIST_DIR . '/webusers' unless (defined($WEBUSERS_FILE));

# check for non-default dotqmail directory
$DOTQMAIL_DIR = $HOME_DIR unless defined($DOTQMAIL_DIR);

# check optional stylesheet
$HTML_CSS_FILE = '' unless defined($HTML_CSS_FILE);

# check template directory
$TEMPLATE_DIR = 'template' unless defined($TEMPLATE_DIR);

# check QMAIL_BASE
$QMAIL_BASE = '/var/qmail/control' unless defined($QMAIL_BASE);

# determine MAIL_DOMAIN
unless (defined($MAIL_DOMAIN) && ($MAIL_DOMAIN ne '')) {
	if ((-e "$QMAIL_BASE/virtualdomains") && open(VD, "<$QMAIL_BASE/virtualdomains")) {
		# Work out if this user has a virtual host and set input accordingly ...
		while(<VD>) {
			last if (($MAIL_DOMAIN) = /(.+?):$USER/);
		}
		close VD;
	}
	# use 'defaultdomain' or 'me' if no matching virtualdomain was found
	if (defined($MAIL_DOMAIN) && ($MAIL_DOMAIN ne '')) {
		# the prefix is empty for virtual domains
		$MAIL_ADDRESS_PREFIX = "" unless (defined($MAIL_ADDRESS_PREFIX));
	} else {
		# Work out default domain name from qmail (for David Summers)
		if (open (GETHOST, "<$QMAIL_BASE/defaultdomain") || open (GETHOST, "<$QMAIL_BASE/me")) {
			chomp($MAIL_DOMAIN = <GETHOST>);
			close GETHOST;
		} else {
			&fatal_error("Unable to read $QMAIL_BASE/me: $!");
		}
	}
}

# check MAIL_ADDRESS_PREFIX
unless (defined($MAIL_ADDRESS_PREFIX)) {
	if ($USER eq $ALIAS_USER) {
		$MAIL_ADDRESS_PREFIX = "";
	} else {
		$MAIL_ADDRESS_PREFIX = "$USER-"
	}
}


###################### process a request ########################

# Untaint form input ...
&untaint;

my $pagedata = &init_hdf();
my $action = $q->param('action');

# This is where we decide what to do, depending on the form state and the
# users chosen course of action ...
# TODO: unify all these "is list param set?" checks ...
if ($action eq 'show_mime_examples') {
	&output_mime_examples();
	exit 0;
} elsif (%DOMAINS && (!defined($CURRENT_DOMAIN) || ($CURRENT_DOMAIN eq '')
		|| ($action eq 'domain_select'))) {
	# domain support is enabled, but no domain is selected
	$pagename = 'domain_select';
	# undef the currently selected domain
	undef $CURRENT_DOMAIN;
} elsif (!&check_permission_for_action()) {
	$pagename = 'list_select';
	$error = 'Forbidden';
} elsif ($action eq '' || $action eq 'list_select') {
	# Default action. Present a list of available lists to the user ...
	$pagename = 'list_select';
} elsif ($action eq 'show_page') {
	$pagename = $q->param('pagename');
	unless (-e "$TEMPLATE_DIR/$pagename.cs") {
		$pagename = 'list_select';
		$error = 'UnknownAction';
	}
} elsif ($action eq 'subscribers') {
	# display list (or part list) subscribers
	if (defined($q->param('list'))) {
		$pagename = 'subscribers';
	} else {
		$pagename = 'list_select';
		$error = 'ParameterMissing';
	}
} elsif ($action eq 'address_del') {
	# Delete a subscriber ...
	if (defined($q->param('list'))) {
		$success = 'DeleteAddress' if (&delete_address());
		$pagename = 'subscribers';
	} else {
		$error = 'ParameterMissing';
		$pagename = 'list_select';
	}
} elsif ($action eq 'address_add') {
	# Add a subscriber ...
	# no selected addresses -> no error
	if (defined($q->param('list'))) {
		$success = 'AddAddress' if (&add_address());
		$pagename = 'subscribers';
	} else {
		$error = 'ParameterMissing';
		$pagename = 'list_select';
	}
} elsif ($action eq 'download_subscribers') {
	# requesting a text file of all subscribers
	if (defined($q->param('list'))) {
		&download_subscribers();
		# just in case we return (something bad happened)
		$pagename = 'subscribers';
	} else {
		$pagename = 'list_select';
		$error = 'ParameterMissing';
	}
} elsif ($action eq 'subscribe_log') {
	if (defined($q->param('list'))) {
		&set_pagedata_subscription_log($q->param('list'));
		$pagename = 'show_subscription_log';
	} else {
		$pagename = 'list_select';
		$error = 'ParameterMissing';
	}
} elsif ($action eq 'list_delete_ask') {
	# Confirm list removal
	if (defined($q->param('list'))) {
		$pagename = 'list_delete';
	} else {
		$pagename = 'list_select';
		$error = 'ParameterMissing';
	}
} elsif ($action eq 'list_delete_do') {
	# User really wants to delete a list ...
	if (defined($q->param('list'))) {
		$success = 'DeleteList' if (&delete_list());
	} else {
		$error = 'ParameterMissing';
	}
	$pagename = 'list_select';
} elsif ($action eq 'list_create_ask') {
	# User wants to create a list ...
	$pagename = 'list_create';
} elsif ($action eq 'list_create_do') {
	# create the new list
	# Message if list creation is unsuccessful ...
	if (&create_list()) {
		$success = 'CreateList';
		$pagename = 'subscribers';
	} else {
		$pagename = 'list_create';
	}
} elsif (($action eq 'config_ask') || ($action eq 'config_do')) {
	# User wants to see/change the configuration ...
	my $subset = $q->param('config_subset');
	if (defined($q->param('list')) && ($subset ne '')) {
		if ($subset =~ m/^RESERVED-([\w_-]*)$/) {
			$pagename = $1
		} elsif (($subset =~ /^[\w]*$/) && (-e "$TEMPLATE_DIR/config_$subset" . ".cs")) {
			$pagename = 'config_' . $subset;
		} else {
			$pagename = '';
		}
		if ($pagename ne '') {
			$success = 'UpdateConfig' if (($action eq 'config_do') && &update_config());
		} else {
			$error = 'UnknownConfigPage';
			warn "missing config page: $subset";
			$pagename = 'list_select';
		}
	} else {
		$error = 'ParameterMissing';
		$pagename = 'list_select';
	}
} elsif ($GPG_SUPPORT && ($action eq 'gnupg_convert_ask')) {
	$pagename = 'gnupg_convert';
} elsif ($GPG_SUPPORT && ($action eq 'gnupg_convert_enable')) {
	my $tlist = new Mail::Ezmlm::Gpg("$LIST_DIR/" . $q->param('list'));
	if ($tlist->is_encrypted()) {
		$pagename = 'gnupg_convert';
		$warning = 'GnupgConvertAlreadyEnabled';
	} else {
		if ($tlist->enable_encryption()) {
			# if the keyring already contains a secret key, then we do not
			# need to generate a new one
			my @secret_keys = $tlist->get_secret_keys();
			if ($#secret_keys >= 0) {
				$pagename = 'gnupg_secret';
			} else {
				$pagename = 'gnupg_generate_key';
			}
			$success = 'GnupgConvertEnable';
		} else {
			warn $tlist->errmsg();
			$pagename = 'gnupg_convert';
			$warning = 'GnupgConvertEnable';
		}
	}
} elsif ($GPG_SUPPORT && ($action eq 'gnupg_convert_disable')) {
	my $tlist = new Mail::Ezmlm::Gpg("$LIST_DIR/" . $q->param('list'));
	unless ($tlist->is_encrypted()) {
		$pagename = 'gnupg_convert';
		$warning = 'GnupgConvertAlreadyDisabled';
	} else {
		if ($tlist->disable_encryption()) {
			$pagename = 'gnupg_convert';
			$success = 'GnupgConvertDisable';
		} else {
			warn $tlist->errmsg();
			$pagename = 'gnupg_convert';
			$warning = 'GnupgConvertDisable';
		}
	}
} elsif ($GPG_SUPPORT && (($action eq 'gnupg_ask') || ($action eq 'gnupg_do'))) {
	# User wants to manage keys (only for encrypted mailing lists)
	my $subset = $q->param('gnupg_subset');
	if (defined($q->param('list')) && ($subset ne '')) {
		if (($subset =~ /^[\w]*$/) && (-e "$TEMPLATE_DIR/gnupg_$subset" . ".cs")) {
			if ($action eq 'gnupg_do') {
				$success = 'UpdateGnupg' if (&manage_gnupg_keys());
			} else {
				# warnings are defined in the respective subs
				$pagename = 'gnupg_' . $subset;
			}
		} else {
			$error = 'UnknownGnupgPage';
			warn "missing gnupg page: $subset";
			$pagename = 'list_select';
		}
	} else {
		$error = 'ParameterMissing';
		$pagename = 'list_select';
	}
} elsif ($GPG_SUPPORT && ($action eq 'gnupg_export')) {
	if (defined($q->param('list')) && defined($q->param('gnupg_keyid'))) {
		if (&gnupg_export_key($q->param('list'), $q->param('gnupg_keyid'))) {
			exit 0;
		} else {
			$warning = 'GnupgExportKey';
			# pagename is quite random here ...
			$pagename = 'gnupg_public';
		}
	} else {
		$error = 'ParameterMissing';
		$pagename = 'list_select';
	}
} elsif ($action eq 'textfiles') {
	# Edit DIR/text ...
	if (defined($q->param('list'))) {
		$pagename = 'textfiles';
	} else {
		$error = 'ParameterMissing';
		$pagename = 'list_select';
	}
} elsif ($action eq 'textfile_edit') {
	# edit the content of a text file
	if (defined($q->param('list')) && defined($q->param('file'))) {
		if (! &check_filename($q->param('file'))) {
			$error = 'InvalidFileName';
			$pagename = 'textfiles';
		} else {
			$pagename = 'textfile_edit';
		}
	} else {
		$error = 'ParameterMissing';
		$pagename = 'list_select';
	}
} elsif ($action eq 'textfile_save') {   
	# User wants to save a new version of something in DIR/text ...
	if (defined($q->param('list')) && defined($q->param('file')) && defined($q->param('content'))) {
		if (! &check_filename($q->param('file'))) {
			$error = 'InvalidFileName';
			$pagename = 'textfiles';
		} elsif (&save_text()) {
			$pagename = 'textfiles';
			$success = 'SaveFile';
		} else {
			$warning = 'SaveFile';
			$pagename = 'textfile_edit';
		}
	} else {
		$error = 'ParameterMissing';
		if ($q->param('list')) {
			$pagename = 'textfiles';
		} else {
			$pagename = 'list_select';
		}
	}
} elsif ($action eq 'textfile_reset') {   
	# User wants to remove a customized text file (idx >= 5) ...
	if (defined($q->param('list')) && defined($q->param('file'))) {
		my $list = Mail::Ezmlm->new($LIST_DIR . '/' . $q->param('list'));
		if (! &check_filename($q->param('file'))) {
			$error = 'InvalidFileName';
			$pagename = 'textfiles';
		} elsif (Mail::Ezmlm->get_version() < 5) {
			$warning = 'RequiresIDX5';
			$pagename = 'textfile_edit';
		} elsif ($list->is_text_default($q->param('file'))) {
			$warning = 'ResetFileIsDefault';
			$pagename = 'textfile_edit';
		} elsif ($list->reset_text($q->param('file'))) {
			$success = 'ResetFile';
			$pagename = 'textfiles';
		} else {
			$warning = 'ResetFile';
			$pagename = 'textfile_edit';
		}
	} else {
		$error = 'ParameterMissing';
		if ($q->param('list')) {
			$pagename = 'textfiles';
		} else {
			$pagename = 'list_select';
		}
	}
} else {
	$pagename = 'list_select';
	$error = 'UnknownAction';
}

# read the current state (after the changes are done)
&set_pagedata();

# set default action, if there is no list available and the user is
# allowed to create a new one
if (((!defined($action)) || ($action eq ''))
		&& ((%DOMAINS && defined($CURRENT_DOMAIN) and ($CURRENT_DOMAIN ne '')) 
			|| (!%DOMAINS))
		&& (&webauth_create_allowed())
		&& ($pagedata->getValue('Data.Lists.0','') eq '')) {
	$pagename = 'list_create';
}

# Print page and exit :) ...
&output_page;
exit;


# =========================================================================

sub init_hdf {
	# initialize the data for clearsilver

	my $hdf = ClearSilver::HDF->new();
 
	&fatal_error("Language data dir ($LANGUAGE_DIR) not found!")
		unless (-e $LANGUAGE_DIR);
	$hdf->setValue("LanguageDir", "$LANGUAGE_DIR/");

	&fatal_error("Template dir ($TEMPLATE_DIR) not found!")
		unless (-e $TEMPLATE_DIR);
	$hdf->setValue("TemplateDir", "$TEMPLATE_DIR/");

	# easy/normal/expert
	my $one_template;
	my @all_templates = &get_available_interfaces();
	if (defined($q->param('template'))) {
		foreach $one_template (@all_templates) {
			$ui_template = $q->param('template')
				if ($q->param('template') eq $one_template);
		}
	}
	$ui_template = 'normal' unless defined($ui_template);
	$hdf->setValue("Config.UI.LinkAttrs.template", $ui_template);


	# retrieve available interface sets and add them to the dataset
	my %interfaces = &get_available_interfaces();
	my $interface;
	foreach $interface (keys %interfaces) {
		$hdf->setValue("Config.UI.Interfaces.$interface",
				$interfaces{$interface});
	}

	# retrieve available languages and add them to the dataset
	my %languages = &get_available_interface_languages();
	my $lang;
	foreach $lang (keys %languages) {
		$hdf->setValue("Config.UI.Languages.$lang", $languages{$lang});
	}

	$hdf = &load_interface_language($hdf);

	$hdf->setValue("ScriptName", $ENV{SCRIPT_NAME}) if (defined($ENV{SCRIPT_NAME}));
	$hdf->setValue("Stylesheet", "$HTML_CSS_FILE");
	$hdf->setValue("Config.PageTitle", "$HTML_TITLE");

	# support for encrypted mailing lists?
	$hdf->setValue("Config.Features.Crypto", 1) if ($GPG_SUPPORT);

	# enable some features that are only available for specific versions
	# of ezmlm-idx
	if (Mail::Ezmlm->get_version() >= 5.1) {
		$hdf->setValue("Config.Features.KeepFiles", 1);
	}
	if (Mail::Ezmlm->get_version() >= 5) {
		$hdf->setValue("Config.Features.LanguageSelect", 1);
		$hdf->setValue("Config.Features.CharsetSelect", 1);
		$hdf->setValue("Config.Features.CopyLines", 1);
	}

	return $hdf;
}

# =========================================================================

sub output_page {
	# Print the page

	my $ui_template_file = "$TEMPLATE_DIR/ui/${ui_template}.hdf";
	&fatal_error("UI template file ($ui_template_file) not found")
		unless (-e $ui_template_file);
	$pagedata->readFile($ui_template_file);

	$pagedata->setValue('Data.Success', "$success") if (defined($success));
	$pagedata->setValue('Data.Error', "$error") if (defined($error));
	$pagedata->setValue('Data.Warning', "$warning") if (defined($warning));
	$pagedata->setValue('Data.customError', "$customError") if (defined($customError));
	$pagedata->setValue('Data.customWarning', "$customWarning") if (defined($customWarning));

	$pagedata->setValue('Data.Action', "$pagename");

	my $pagefile = $TEMPLATE_DIR . "/main.cs";
	&fatal_error("main template ($pagefile) not found!") unless (-e "$pagefile");
	&fatal_error("sub template ($TEMPLATE_DIR/$pagename.cs) not found!") unless (-e "$TEMPLATE_DIR/$pagename.cs");

	# print http header
	print "Content-Type: text/html; charset=utf-8\n\n";

	my $cs = ClearSilver::CS->new($pagedata);

	$cs->parseFile($pagefile);

	my $output;
	if ($output = $cs->render()) {
		print $output;
	} else {
		&fatal_error($cs->displayError());
	}
}

# ---------------------------------------------------------------------------

sub load_interface_language {

	my ($data) = @_;
	my $config_language;

	# set default language
	$config_language = 'en';
	
	# english should always be there - but just in case of local modifications
	$config_language = $HTML_LANGUAGE
		unless (&check_interface_language($HTML_LANGUAGE));
	
	# first: load default language - in case some translations are incomplete
	$data->readFile("$LANGUAGE_DIR/$config_language" . ".hdf");

	# check for preferred browser language, if the box was not initialized yet
	my $prefLang = &get_browser_language();
	# take it, if a supported browser language was found
	$config_language = $prefLang unless ($prefLang eq '');

	######### temporary language setting? ############
	# the default language can be overriden by the language selection form
	if ($q->param('web_lang')) {
		my $weblang = $q->param('web_lang');
		if (&check_interface_language($weblang)) {
			# load the data
			$config_language = "$weblang";
		} else {
			# no valid language was selected - so you may ignore it
			$warning = 'InvalidLanguage';
		}
	}

	# add the setting to every link
	$data->setValue('Config.UI.LinkAttrs.web_lang', "$config_language");

	# import the configured resp. the temporarily selected language
	$data->readFile("$LANGUAGE_DIR/$config_language" . ".hdf");

	return $data;
}


# ---------------------------------------------------------------------------

sub get_browser_language {
	# look for preferred browser language setting
	# this code was adapted from Per Cederberg
	# http://www.percederberg.net/home/perl/select.perl
	# it returns an empty string, if no supported language was found

    my ($str, @langs, @res);

    # Use language preference settings
	if (defined($ENV{HTTP_ACCEPT_LANGUAGE})
			&& ($ENV{HTTP_ACCEPT_LANGUAGE} ne '')) {
		@langs = split(/,/, $ENV{HTTP_ACCEPT_LANGUAGE});
		foreach (@langs) {
			# get the first part of the language setting
			($str) = ($_ =~ m/([a-z]+)/);
			# check, if it is available
			$res[$#res+1] = $str if check_interface_language($str);
		}
	}
	
    # if everything fails - return empty string
	$res[0] = "" if ($#res lt 0);
	return $res[0];
}

# ---------------------------------------------------------------------------

sub set_pagedata_domains {

	my ($domain_name);

	# multi-domain setup?
	if (defined($CURRENT_DOMAIN) && ($CURRENT_DOMAIN ne '')) {
		$pagedata->setValue("Config.UI.LinkAttrs.domain", $CURRENT_DOMAIN);
		$pagedata->setValue("Data.CurrentDomain", $CURRENT_DOMAIN);
		$pagedata->setValue("Data.CurrentDomain.Description",
				$DOMAINS{$CURRENT_DOMAIN}{name});
	}
	
	foreach $domain_name (keys %DOMAINS) {
		$pagedata->setValue("Data.Domains.$domain_name",
				$DOMAINS{$domain_name}{'name'});
	}
}

# ---------------------------------------------------------------------------

sub set_pagedata_list_of_lists {

	my (@files, $i, $num);

	# for a multi-domain setup there are no lists available if no domain
	# is selected
	return (0==0) if (%DOMAINS && 
			(!defined($CURRENT_DOMAIN) || ($CURRENT_DOMAIN eq '')));
	
	# undefined $LIST_DIR?
	return (0==0) if (!defined($LIST_DIR) || ($LIST_DIR eq ''));

	# Read the list directory for mailing lists.
	return (0==0) unless (opendir DIR, $LIST_DIR);

	@files = sort grep !/^\./, readdir DIR; 
	closedir DIR;

	$num = 0;
	# Check that they actually are lists and add good ones to pagedata ...
	foreach $i (0 .. $#files) {
		if ((-e "$LIST_DIR/$files[$i]/lock") && (&webauth($files[$i]))) {
			$pagedata->setValue("Data.Lists." . $num, "$files[$i]");
			$num++;
		}
	}
}

# ---------------------------------------------------------------------------

sub set_pagedata {

	# read available list of lists
	&set_pagedata_list_of_lists();

	# multi domain support?
	&set_pagedata_domains() if (%DOMAINS);

	$pagedata->setValue("Data.LocalPrefix", $MAIL_ADDRESS_PREFIX);
	$pagedata->setValue("Data.HostName", $MAIL_DOMAIN);


	# modules
	# TODO: someone should test, if the mysql support works
	$pagedata->setValue("Data.Modules.mySQL", ($Mail::Ezmlm::MYSQL_BASE)? 1 : 0);
   

	# permissions
	$pagedata->setValue("Data.Permissions.Create", (&webauth_create_allowed)? 1 : 0 );
	$pagedata->setValue("Data.Permissions.FileUpload", ($FILE_UPLOAD)? 1 : 0);


	# ezmlm-idx v5.0 stuff
	$pagedata->setValue('Data.areDefaultTextsAvailable', 
		(Mail::Ezmlm->get_version() >= 5)? 1 : 0);

	# get available languages for all lists
	# no results for ezmlm-idx < 5.0
	my $i = 0;
	my $item;
	foreach $item (sort Mail::Ezmlm->get_available_languages()) {
		$pagedata->setValue("Data.AvailableLanguages." . $i, $item);
		$i++;
	}


	# display webuser textfield?
	$pagedata->setValue("Data.WebUser.show", (-e "$WEBUSERS_FILE")? 1 : 0);
	# default username for webuser file
	$pagedata->setValue("Data.WebUser.UserName", $ENV{'REMOTE_USER'}||'ALL');

	# list specific configuration - use defaults if no list is selected
	if (defined($q->param('list')) && ($q->param('list') ne '')) {
		&set_pagedata4list(&get_list_part());
	} else {
		&set_pagedata4options($DEFAULT_OPTIONS);
	}
}

# ---------------------------------------------------------------------------

sub set_pagedata4list {

	my $part_type = shift;
	my ($listname, $list);

	$listname = $q->param('list');
	
	if (! -e "$LIST_DIR/$listname/lock" ) {
		$warning = 'ListDoesNotExist' if ($warning eq '');
		return (1==0);
	}

	# Work out the address of this list ...
	$list = new Mail::Ezmlm("$LIST_DIR/$listname");

	$pagedata->setValue("Data.List.Name", "$listname");
	$pagedata->setValue("Data.List.Address", &this_listaddress);

	# do we support encryption? Set some data if the list is encrypted ...
	&set_pagedata_crypto($listname) if ($GPG_SUPPORT);

	# is this a moderation/administration list?
	&set_pagedata4part_list($part_type) if ($part_type ne '');

	&set_pagedata_subscribers($list, $listname, $part_type);
	&set_pagedata_misc_configfiles($list);
	&set_pagedata_textfiles($list);
	&set_pagedata_webusers($list, $listname);
	&set_pagedata_localization($list);

	&set_pagedata4options($list->getconfig);   

	return (0==0);
}

# ---------------------------------------------------------------------------

sub set_pagedata_crypto {
	# extract hdf-data for encrypted lists

	my ($listname) = @_;
	my ($gpg_list, %config, $item, @gpg_keys, $gpg_key);

	$gpg_list = new Mail::Ezmlm::Gpg("$LIST_DIR/$listname");

	return unless ($gpg_list->is_encrypted());

	$pagedata->setValue("Data.List.Features.Crypto", 1);
	
	# read the configuration
	%config = $gpg_list->getconfig();
	foreach $item (keys %config) {
		$pagedata->setValue("Data.List.Options.gnupg_$item", $config{$item});
	}

	# retrieve the currently available public keys
	@gpg_keys = $gpg_list->get_public_keys();
	for (my $i = 0; $i < @gpg_keys; $i++) {
		$pagedata->setValue("Data.List.gnupg_keys.public.$i.id" , $gpg_keys[$i]{id});
		$pagedata->setValue("Data.List.gnupg_keys.public.$i.email" , $gpg_keys[$i]{email});
		$pagedata->setValue("Data.List.gnupg_keys.public.$i.name" , $gpg_keys[$i]{name});
		$pagedata->setValue("Data.List.gnupg_keys.public.$i.expires" , $gpg_keys[$i]{expires});
	}

	# retrieve the currently available secret keys
	@gpg_keys = $gpg_list->get_secret_keys();
	for (my $i = 0; $i < @gpg_keys; $i++) {
		$pagedata->setValue("Data.List.gnupg_keys.secret.$i.id" , $gpg_keys[$i]{id});
		$pagedata->setValue("Data.List.gnupg_keys.secret.$i.email" , $gpg_keys[$i]{email});
		$pagedata->setValue("Data.List.gnupg_keys.secret.$i.name" , $gpg_keys[$i]{name});
		$pagedata->setValue("Data.List.gnupg_keys.secret.$i.expires" , $gpg_keys[$i]{expires});
	}
}

# ---------------------------------------------------------------------------

sub set_pagedata_misc_configfiles {

	my $list = shift;
	my ($item);

	# Get the contents of some important files
	$item = $list->getpart('prefix');
	$pagedata->setValue("Data.List.Prefix", "$item");

	# check reply_to setting
	$item = $list->getpart('headeradd');
	$pagedata->setValue("Data.List.HeaderAdd", "$item");
	$pagedata->setValue("Data.List.Options.special_replytoself", 1)
		if (&is_reply_to_self("$item"));

	# 'headerremove' is ignored if 'headerkeep' exists (since ezmlm-idx v5)
	if ((Mail::Ezmlm->get_version() >= 5.1) &&(-e $list->thislist() . "/headerkeep")) {
		$item = $list->getpart('headerkeep');
		$pagedata->setValue("Data.List.HeaderKeep", "$item");
	} else {
		$item = $list->getpart('headerremove');
		$pagedata->setValue("Data.List.HeaderRemove", "$item");
	}
	
	# 'mimeremove' is ignored if 'mimekeep' exists (since ezmlm-idx v5)
	if ((Mail::Ezmlm->get_version() >= 5.1) && (-e $list->thislist() . "/mimekeep")) {
		$item = $list->getpart('mimekeep');
		$pagedata->setValue("Data.List.MimeKeep", "$item");
	} else {
		$item = $list->getpart('mimeremove');
		$pagedata->setValue("Data.List.MimeRemove", "$item");
	}

	if (Mail::Ezmlm->get_version() >= 5) {
		$item = $list->getpart('copylines');
		$pagedata->setValue("Data.List.CopyLines", "$item");
	}

	$item = $list->getpart('mimereject');
	$pagedata->setValue("Data.List.MimeReject", "$item");
	$item = $list->get_text_content('trailer');
	$pagedata->setValue("Data.List.TrailingText", "$item");
	
	# read message size limits
	$list->getpart('msgsize') =~ m/^\s*(\d+)\s*:\s*(\d+)\s*$/;
	$pagedata->setValue("Data.List.MsgSize.Max", "$1");
	$pagedata->setValue("Data.List.MsgSize.Min", "$2");
}

# ---------------------------------------------------------------------------

sub set_pagedata_subscribers {

	my ($list, $listname, $part_type) = @_;
	my ($i, $address, $addr_name, %pretty);

	$i = 0;
	tie %pretty, "DB_File", "$LIST_DIR/$listname/webnames" if ($PRETTY_NAMES);
	foreach $address (sort $list->subscribers($part_type)) {
		if ($address ne '') {
			$pagedata->setValue("Data.List.Subscribers." . $i . '.address', "$address");
			$addr_name = ($PRETTY_NAMES)? $pretty{$address} : '';
			$pagedata->setValue("Data.List.Subscribers." . $i . '.name', $addr_name);
		}
		$i++;
	}
	untie %pretty if ($PRETTY_NAMES);
}

# ---------------------------------------------------------------------------

sub set_pagedata_textfiles {
	# set the names of the textfiles of this list

	my $list = shift;
	my ($i, @files, $item);

	@files = sort $list->get_available_text_files();
	$i = 0;

	foreach $item (@files) {
		if ($list->is_text_default($item)) {
			$pagedata->setValue('Data.List.DefaultFiles.' . $i , "$item");
		} else {
			$pagedata->setValue('Data.List.CustomizedFiles.' . $i , "$item");
		}
		$i++;
	}

	# text file specified?
	if (($q->param('file') ne '') && ($q->param('file') =~ m/^[\w-]*$/)) {
		my ($content);
		$content = $list->get_text_content($q->param('file'));
		# get character set of current list (ignore ":Q" prefix)
		my ($charset) = split(':',$list->get_charset());
		# use default for ezmlm-idx<5.0
		$charset = 'us-ascii' if ($charset eq '');
		my $content_utf8;
		eval { $content_utf8 = Encode::decode($charset, $content); };
		# use $content if conversion failed somehow
		if ($@) {
			$content_utf8 = $content;
			# no warning, if the encoding support is not available
			warn "Conversion failed for charset '$charset'" if ($ENCODE_SUPPORT);
		}
		$pagedata->setValue("Data.List.File.Name", $q->param('file'));
		$pagedata->setValue("Data.List.File.Content", "$content_utf8");
		$pagedata->setValue("Data.List.File.isDefault",
			$list->is_text_default($q->param('file')) ? 1 : 0);
	}
}

# ---------------------------------------------------------------------------

sub set_pagedata_localization {

	my $list = shift;
	my ($i, $item);

	# get available languages for this list
	# no result for ezmlm-idx < 5
	$i = 0;
	foreach $item (sort $list->get_available_languages()) {
		$pagedata->setValue("Data.List.AvailableLanguages." . $i, $item);
		$i++;
	}

	# charset of the list
	if (Mail::Ezmlm->get_version() >= 5) {
		my $charset = $list->get_charset();
		$charset =~ s/^#.*$//m;
		$pagedata->setValue('Data.List.CharSet', "$charset");
	}

	$pagedata->setValue('Data.List.Language', $list->get_lang());
}

# ---------------------------------------------------------------------------

sub set_pagedata_webusers {

	my ($list, $listname) = @_;
	my ($webusers);

	# retrieve the users of the list by reading the webusers file
	if (open(WEBUSER, "<$WEBUSERS_FILE")) {
		while(<WEBUSER>) {
			# ok - this is very short:
			# $webusers becomes the matched group as soon as we find the
			# line of the list - and: no, we do not need "=~" instead of "="
			last if (($webusers) = m{^$listname\s*\:\s*(.+)$});
		}
		close WEBUSER;
	}
	# set default if there was no list definition
	$webusers ||= $ENV{'REMOTE_USER'} || 'ALL';

    $pagedata->setValue("Data.List.WebUsers", "$webusers");
}

# ---------------------------------------------------------------------------

sub set_pagedata4options {

	my($options) = shift;
	my($i, $list, $key, $state, $value, $dir_of_list);

	$i = 0;
	$key = lc(substr($options,$i,1));
	# parse the first part of the options string
	while ($key =~ m/\w/) {
		# scan the first part of the options string for lower case letters
		$state = ($options =~ /^\w*$key\w*\s*/);
		# set the lower case option
		$pagedata->setValue("Data.List.Options." . $key , ($state)? 1 : 0);
		# also set the reverse value - see cs macro "check_active_selection"
		$pagedata->setValue("Data.List.Options." . uc($key) , ($state)? 0 : 1);
		$i++;
		$key = lc(substr($options,$i,1));
	}

	# scan the config for settings
	for ($i=0; $i<=9; $i++) {
		unless (($i eq 1) || ($i eq 2)) {
			$state = ($options =~ /\s-$i (?:'(.+?)')/);
			unless ($state) {
				# set default values
				if ($i eq 0) {
					$value = 'mainlist@' . $MAIL_DOMAIN;
				} elsif ($i eq 3) {
					$value = 'from_address@domain.org';
				} elsif ($i eq 4) {
					$value = '-t24 -m30 -k64';
				} elsif ($i eq 5) {
					$value = 'owner_address@domain.org';
				} elsif ($i eq 6) {
					$value = 'host:port:user:password:database:table';
				} elsif (($i >= 7) && ($i <= 9)) {
					if (defined($q->param('list'))) {
						$value = $LIST_DIR . '/' . $q->param('list') . "/mod";
					} else {
						$value = "mod";
					}
				}
			} else {
				# use the configured value (extracted by the pattern matching for 'state')
				$value = $1;
			}
			$pagedata->setValue("Data.List.Settings." . $i . ".value", $value);
			$pagedata->setValue("Data.List.Settings." . $i . ".state", $state ? 1 : 0);
		}
	}

	# the list dependent stuff follows - we can stop if no list is selected
	return unless (defined($q->param('list')));
	$dir_of_list = $LIST_DIR . '/' . $q->param('list');
	$list = new Mail::Ezmlm($dir_of_list);

	# the options "tpxmsr" are used to create a default value
	# if they are unset, the next ezmlm-make will remove the appropriate files
	# but: these files are used, if they exist - regardless of the flag
	# we will look for the files, if someone created them without ezmlm-make
	# this is easier for users, as the options now represent the current
	# behaviour of the list and not the configured flag value
	# this is especially necessary for "trailer", as this file can be created
	# via ezmlm-web without touching the flag
	$pagedata->setValue("Data.List.Options.t" , 1)
		if (-e "$dir_of_list/trailer");
	$pagedata->setValue("Data.List.Options.f" , 1)
		if (-e "$dir_of_list/prefix");
	$pagedata->setValue("Data.List.Options.m" , 1)
		if (-e "$dir_of_list/modpost");
	$pagedata->setValue("Data.List.Options.s" , 1)
		if (-e "$dir_of_list/modsub");
	$pagedata->setValue("Data.List.Options.r" , 1)
		if (-e "$dir_of_list/remote");
	# the option 'x' is always off, as we use it for resetting - this
	# should be easier to understand for users
	$pagedata->setValue("Data.List.Options.x" , 0);
}

# ---------------------------------------------------------------------------

sub download_subscribers {
	# return a list of subscribers of a list for download

	my ($list, $listname, $filename, $part_type);
	my (%pretty, $address, $address_name, @subscribers);

	$listname = $q->param('list');
	$list = new Mail::Ezmlm("$LIST_DIR/$listname");

	if (defined($q->param('part'))) {
		$part_type = $q->param('part');
		$filename = "mailinglist-$listname-$part_type.txt";
	} else {
		$filename = "mailinglist-$listname-subscribers.txt";
	}

	tie %pretty, "DB_File", "$LIST_DIR/$listname/webnames" if ($PRETTY_NAMES);
	foreach $address (sort $list->subscribers($part_type)) {
		if ($address ne '') {
			if ($PRETTY_NAMES) {
				$address_name = $pretty{$address};
				if ($address_name eq '') {
					push @subscribers, $address;
				} else {
					push @subscribers, "$address_name <$address>";
				}
			} else {
				push @subscribers, $address;
			}
		}
	}
	untie %pretty if ($PRETTY_NAMES);

	if ($#subscribers lt 0) {
		$warning = 'EmptyList';
		return (1==0);
	}

	print "Content-Type: text/plain\n";
	# suggest a download filename
	# (taken from http://www.bewley.net/perl/download.pl)
	print "Content-Disposition: attachment; filename=$filename\n";
	print "Content-Description: exported subscribers list of $listname\n\n";
	foreach $address (@subscribers) {
		print "$address\r\n";
	}
	exit;
}

# ---------------------------------------------------------------------------

sub check_filename {

	my $filename = shift;
	return ($filename =~ m/[^\w-]/) ? (1==0) : (0==0);
}

# ---------------------------------------------------------------------------

sub get_list_part {
	# return the name of the part list (deny, allow, mod, digest or '')

	$q->param('part') =~ m/^(allow|deny|digest|mod)$/;
	return $1;
}

# ---------------------------------------------------------------------------

sub is_list_encrypted {

	my ($listname) = @_;
	return (1==0) unless ($GPG_SUPPORT);

	my $gpg_list = new Mail::Ezmlm::Gpg("$LIST_DIR/$listname");
	return $gpg_list->is_encrypted();
}

# ---------------------------------------------------------------------------

sub get_dotqmail_files {

	my ($list, @files, $qmail_prefix);

	$list = new Mail::Ezmlm("$LIST_DIR/" . $q->param('list'));

	# get the location of the dotqmail files of the list
	# read 'dot' for idx v5
	$qmail_prefix = $list->getpart('dot');
	# untaint content (we trust in it)
	if ($qmail_prefix) {
		$qmail_prefix =~ m/^(.*)$/;
		$qmail_prefix = $1;
	}
	# read 'config' (line starts with "T") for idx v4
	unless ($qmail_prefix) {
		my $config = $list->getpart('config');
		$config =~ m/^T:(.*)$/m;
		$qmail_prefix = $1;
	}
	chomp($qmail_prefix);

	# return without result and print a warning, if no dotqmail files were found
	unless ($qmail_prefix) {
		warn "[ezmlm-web]: could not get the location of the dotqmail files of this list";
		return ();
	}

	# get list of existing files (remove empty entries)
	@files = grep {/./} map { (-e "$qmail_prefix$_")? "$qmail_prefix$_" : undef  } (
			'',
			'-default',
			'-owner',
			'-return-default',
			'-reject-default',
			'-accept-default',
			'-confirm-default',
			'-discard-default',
			'-digest-owner',
			'-digest',
			'-digest-return-default');
	return @files;
}

# ---------------------------------------------------------------------------

sub set_pagedata_subscription_log {
	
	my ($listname) = @_;

	my ($log_file, @event, $i, $epoch_seconds, $note, $address); 
	$log_file = "$LIST_DIR/" . $q->param('list') . "/Log";
	
	# break if there is no log_file
	return unless (-e "$log_file");

	unless (open LOG_FILE, "<$log_file") {
		warn "Failed to open log file: $log_file";
		$warning = 'LogFile';
		return (1==0);
	}

	$i = 0;

	while (<LOG_FILE>) {
		chomp;
		split;
		@event = @_;
		if ($#event eq 2) {
			$epoch_seconds = $event[0];
			my $datetext = ctime($epoch_seconds);
			$note = $event[1];
			$address = $event[2];
			$pagedata->setValue("Data.List.SubscribeLog.$i.date", $datetext);
			$pagedata->setValue("Data.List.SubscribeLog.$i.text", $note);
			$pagedata->setValue("Data.List.SubscribeLog.$i.address", $address);
			$i++;
		}
	}
	close LOG_FILE;
}

# ---------------------------------------------------------------------------

sub delete_list {
	# Delete a list ...

	my ($list, $listaddress, $listadd); 
	$list = new Mail::Ezmlm("$LIST_DIR/" . $q->param('list'));
	if ($listadd = $list->getpart('outlocal')) {
		chomp($listadd);
	} else {
		$listadd = $q->param('list');
	}
	$listaddress = $1 if ($listadd =~ /-?(\w+)$/);

	if ($UNSAFE_RM == 0) {
		# This doesn't actually delete anything ... It just moves them so that
		# they don't show up. That way they can always be recovered by a helpful
		# sysadmin should he/she be in the mood :)

		my $SAFE_DIR = "$LIST_DIR/_deleted_lists";
		mkdir "$SAFE_DIR", 0700 if (! -e "$SAFE_DIR");

		# look for an unused directory name
		my $i = 0;
		while (-e "$SAFE_DIR/" . $q->param('list') . "-$i") { $i++; }

		$SAFE_DIR .= '/' . $q->param('list') . "-$i";

		my @files = &get_dotqmail_files();

		# remove list directory
		my $oldfile = "$LIST_DIR/" . $q->param('list');
		unless (move($oldfile, $SAFE_DIR)) {
			$warning = 'SafeRemoveRenameDirFailed';
			return (1==0);
		}

		# remove dotqmail files
		foreach (@files) {
			unless (move($_, "$SAFE_DIR")) {
				$warning = 'SafeRemoveMoveDotQmailFailed';
				return (1==0); 
			}
		}

		warn "List '$oldfile' moved (deleted)";   
	} else {
		# This, however, does DELETE the list. I don't like the idea, but I was
		# asked to include support for it so ...
		my @files = &get_dotqmail_files();
		my $olddir = $q->param('list');
		# untaint list directory name
		$olddir =~ m#^([^/]*)$#;
		$olddir = $1;
		# first: check for invalid list directory
		unless (($olddir ne '') && ($olddir ne '.' ) && ($olddir ne '..')) {
			$warning = 'UnsafeRemoveListDirFailed';
			return (1==0);
		}
		if (unlink(@files) <= 0) {
			$warning = 'UnsafeRemoveDotQmailFailed';
			return (1==0);
		}
		unless (File::Path::rmtree("$LIST_DIR/$olddir")) {
			$warning = 'UnsafeRemoveListDirFailed';
			return (1==0);
		}
		warn "List '" . $list->thislist() . "' deleted";
	}
	$q->param(-name=>'list', -values=>'');
	return (0==0);
}

# ------------------------------------------------------------------------

sub untaint {
   # Go through all the CGI input and make sure it is not tainted. Log any
   # tainted data that we come accross ... See the perlsec(1) man page ...

   # maybe it was read from a file - so we should untaint it
   $MAIL_DOMAIN = $1 if $MAIL_DOMAIN =~ /^([\w\d\.-]+)$/;
   
   my (@params, $i, $param);
   @params = $q->param;
   
   foreach $i (0 .. $#params) {
      my(@values);
      next if ($params[$i] eq 'mailaddressfile');
      next if ($params[$i] eq 'gnupg_key_file');
      next if ($params[$i] eq 'content');
      foreach $param ($q->param($params[$i])) {
         next if $param eq '';
         if ($param =~ /^([#-\@\w\.\/\[\]\:\n\r\>\< _"']+)$/) {
            push @values, $1;
         } else {
            warn "Tainted input in '$params[$i]': " . $q->param($params[$i]); 
         }
         $q->param(-name=>$params[$i], -values=>\@values);
      }
   } 

	# special stuff

	# check the list name
	if (defined($q->param('list')) &&
			($q->param('list') =~ /[^\w\.-]/) &&
			($q->param('action') !~ /^list_create_(do|ask)$/)) {
		$warning = 'InvalidListName' if ($warning eq '');
		$q->param(-name=>'list', -values=>'');
	}
	
}

# ------------------------------------------------------------------------

sub check_permission_for_action {
	# test if the user is allowed to modify the choosen list or to create a
	# new one the user would still be allowed to fill out the create-form
	# (however he got there), but the final creation is omitted

	my $ret;
	if (defined($action) &&
			(($action eq 'list_create_ask' || $action eq 'list_create_do'))) {
		$ret = &webauth_create_allowed();
	} elsif (defined($q->param('list'))) {
		$ret = &webauth($q->param('list'));
	} else {
		$ret = (0==0);
	}
	return $ret;
}

# ------------------------------------------------------------------------

sub add_address {
	# Add an address to a list ..

	my ($address, $list, $part, @addresses, $fail_count, $success_count);
	$list = new Mail::Ezmlm("$LIST_DIR/" . $q->param('list'));
	$part = &get_list_part();

	$fail_count = 0;
	$success_count = 0;

	if (($q->param('mailaddressfile')) && ($FILE_UPLOAD)) {
		# Sanity check
		my $fileinfo = $q->uploadInfo($q->param('mailaddressfile'));
		my $filetype = $fileinfo->{'Content-Type'};
		unless($filetype =~ m{^text/}i) {
			$warning = 'InvalidFileFormat';
			warn "[ezmlm-web] mime type of uploaded file rejected: $filetype";
			return (1==0);
		}

		# Handle file uploads of addresses
		my($fh) = $q->param('mailaddressfile');
		while (<$fh>) {
			next if (/^\s*$/ or /^#/); # blank, comments
			if ( /(\w[\w\.\!\#\$\%\&\'\`\*\+\-\/\=\?\^\{\|\}\~]*)@(\w[\-\w_\.]+)/) {
					chomp();
					push @addresses, "$_";
				} else {
				$fail_count++;
			}
		}
		# TODO: is CLOSE necessary?
	}
      
	# User typed in an address
	if ($q->param('mailaddress_add') ne '') {

		$address = $q->param('mailaddress_add');
		$address .= $MAIL_DOMAIN if ($q->param('mailaddress_add') =~ /\@$/);

		# untaint
		if ($address =~ m/(\w[\w\.\!\#\$\%\&\'\`\*\+\-\/\=\?\^\{\|\}\~]*)@(\w[\-\w_\.]+)/) {
			push @addresses, "$address";
		  } else {
			warn "invalid address to add: $address to $part";
			$warning = 'AddAddress';
			return (1==0);
		  }

	}
   
	my %pretty;
	my $add;
	tie %pretty, "DB_File", "$LIST_DIR/" . $q->param('list') . "/webnames" if ($PRETTY_NAMES);
	foreach $address (@addresses) {

		($add) = Mail::Address->parse($address);
		if (($add->address() =~ m/^(\w[\w\.\!\#\$\%\&\'\`\*\+\-\/\=\?\^\{\|\}\~]*)@(\w[\-\w_\.]+)$/)
				&& !($list->issub($add->address(), $part))) {
			# it seems, that we cannot trust the return value of "$list->sub"
			$list->sub($add->address(), $part);
			if (defined($add->name()) && $PRETTY_NAMES) {
				$pretty{$add->address()} = $add->name();
			}
			$success_count++;
		} else {
			$fail_count++;
		}
	}
	untie %pretty if ($PRETTY_NAMES);
	if ($fail_count gt 0) {
		$warning = 'AddAddress';
		return (1==0);
	} elsif ($success_count eq 0) {
		# no subscribers - we report an error without issuing a warning
		return (1==0);
	} else {
		# no failures and at least one subscriber -> success
		return (0==0);
	}
}

# ------------------------------------------------------------------------

sub delete_address {
   # Delete an address from a list ...

   my ($list, @address);
   $list = new Mail::Ezmlm("$LIST_DIR/" . $q->param('list'));
   my $part = &get_list_part();
   return (1==0) if ($q->param('mailaddress_del') eq '');

   @address = $q->param('mailaddress_del');

   if ($list->unsub(@address, $part) != 1) {
      $warning = 'DeleteAddress';
	  return (1==0);
   }
   
   if ($PRETTY_NAMES) {
      my(%pretty, $add);
      tie %pretty, "DB_File", "$LIST_DIR/" . $q->param('list') . "/webnames";
      foreach $add (@address) {
         delete $pretty{$add};
      }
      untie %pretty;
   }

}

# ------------------------------------------------------------------------

sub set_pagedata4part_list {
   # Deal with list parts ....

   my($part) = @_;
   my ($i, $list, $listaddress,);
   
   # Work out the address of this list ...
   $list = new Mail::Ezmlm("$LIST_DIR/" . $q->param('list'));
   $listaddress = &this_listaddress();

   $pagedata->setValue("Data.List.PartType", "$part");

   if ($part eq 'mod') {
      # do we store things in different directories?
      my $config = $list->getconfig();
	  # empty values represent default settings - everything else is considered as evil :)
      my($postpath) = $config =~ m{-7\s*'([^']+)'};
      my($subpath) = $config =~ m{-8\s*'([^']+)'};
      my($remotepath) = $config =~ m{-9\s*'([^']+)'};

      $pagedata->setValue("Data.List.hasCustomizedPostModPath", ($postpath ne '')? 1 : 0);
      $pagedata->setValue("Data.List.hasCustomizedSubModPath", ($subpath ne '')? 1 : 0);
      $pagedata->setValue("Data.List.hasCustomizedAdminPath", ($remotepath ne '')? 1 : 0);
   }
}

# ------------------------------------------------------------------------

sub create_list {
	# Create a list according to user selections ...

	# Check if the list directory exists and create if necessary ...
	unless ((-e $LIST_DIR) || (mkdir $LIST_DIR, 0700)) {
		warn "Unable to create directory ($LIST_DIR): $!";
		$warning = 'ListDirAccessDenied';
		return (1==0);
	}

	my ($qmail, $listname, $options, $i);

	# Some taint checking ...
	$qmail = $1 if $q->param('inlocal') =~ /(?:$USER-)?([^\<\>\\\/\s]+)$/;
	# dots have to be turned into colons
	# see http://www.qmail.org/man/man5/dot-qmail.html
	$qmail =~ s/\./:/g;
	$listname = $q->param('list');
	if ($listname =~ m/[^\w\.-]/) {
		$warning = 'InvalidListName';
		return (1==0);
   	}

	# Sanity Checks ...
	if ($listname eq '') {
		$warning = 'EmptyListName';
		return (1==0);
   	}
	if (($listname =~ m/^ALL$/i) || ($listname =~ m/^ALLOW_CREATE$/i)) {
		$warning = 'ReservedListName';
		return (1==0);
   	}
	if ($qmail eq '') {
		$warning = 'InvalidLocalPart';
		return (1==0);
   	}
	if (-e "$LIST_DIR/$listname/lock") {
		$warning = 'ListNameAlreadyExists';
		return (1==0);
	}
	if (-e "$DOTQMAIL_DIR/.qmail-$qmail") {
		$warning = 'ListAddressAlreadyExists';
		return (1==0);
	}

	$options = &extract_options_from_params();

	my($list) = new Mail::Ezmlm;

	unless ($list->make(-dir=>"$LIST_DIR/$listname",
				-qmail=>"$DOTQMAIL_DIR/.qmail-$qmail",
				-name=>$q->param('inlocal'),
				-host=>$q->param('inhost'),
				-switches=>$options,
				-user=>$USER)
	) {
		# fatal error
		$customError = $list->errmsg();
		return (1==0);
	}

	if (defined($q->param('list_language')) && ($q->param('list_language') ne 'default')) {
		if (&check_list_language($list, $q->param('list_language'))) {
			$list->set_lang($q->param('list_language'));
		} else {
			$warning = 'InvalidListLanguage';
		}
	}
	
	# handle MySQL stuff
	if (defined($q->param('setting_state_6')) && $options =~ m/-6\s+/) {
		$customWarning = $list->errmsg() unless($list->createsql());
	}
   
	# no error returned - just a warning
	$warning = 'WebUsersUpdate' unless (&update_webusers());

	return (0==0);
}

# ------------------------------------------------------------------------

sub extract_options_from_params {
	# Work out the command line options ...

	my ($options, $settings, $i);
	my ($listname, $old_options, $state, $old_key);

	# NOTE: we have to define _every_ (even unchanged) setting
	# as ezmlm-make removes any undefined value

	$listname = $q->param('list');
	if (-e "$LIST_DIR/$listname") {
		# the list does already exist
		my $list = new Mail::Ezmlm("$LIST_DIR/$listname");
		$old_options = $list->getconfig();
	} else {
		# creating a new list
		$old_options = $DEFAULT_OPTIONS;
	}

	################ options ################
	$i = 0;
	$old_key = substr($old_options,$i,1);
	# some special selections
	my @avail_selections = ('archive', 'subscribe', 'posting');
	# parse the first part of the options string
	while ($old_key =~ m/\w/) {
		# scan the first part of the options string for lower case letters
		if (lc($old_key) eq 'x') {
			# the 'x' setting does not really represent the mimeremove
			# ezmlm-idx is ugly: 'X' -> remove file / 'x' -> reset file to default
			if (-e "$LIST_DIR/$listname/mimeremove") {
				$options .= 'x';
				# we have to delete 'mimeremove' if the 'x' checkbox was activated
				# as ezmlm-make will only reset it, if the file does not exist
				unlink("$LIST_DIR/$listname/mimeremove")
					if (defined($q->param('option_x')));
			} else {
				$options .= 'X';
			}
		} elsif (defined($q->param('available_option_' . uc($old_key)))) {
			# inverted checkbox
			my $form_var_name = "option_" . uc($old_key);
			# this option was visible for the user
			if (defined($q->param($form_var_name))) {
				$options .= uc($old_key);
			} else {
				$options .= lc($old_key);
			}
		} elsif (defined($q->param('available_option_' . lc($old_key)))) {
			# non inverted checkbox
			my $form_var_name = "option_" . lc($old_key);
			# this option was visible for the user
			if (defined($q->param($form_var_name))) {
				$options .= lc($old_key);
			} else {
				$options .= uc($old_key);
			}
		} elsif (&is_option_in_selections(lc($old_key)))  {
			# enabled due to some special selection
			$options .= lc($old_key);
		} elsif (&is_option_in_selections(uc($old_key)))  {
			# disabled due to some special selection
			$options .= uc($old_key);
		} elsif ("cevz" =~ m/$old_key/i) {
			# ignore invalid settings (the output of "getconfig" is really weird!)
		} else {
			# import the previous set option
			$options .= $old_key;
		}
		$i++;
		$old_key = substr($old_options,$i,1);
	}


	############### settings ################
	for ($i=0; $i<=9; $i++) {
		if (defined($q->param('available_setting_' . $i))) {
			# this setting was visible for the user
			if (defined($q->param("setting_state_$i"))) {
				$options .= " -$i '" . $q->param("setting_value_$i") . "'";
			} else {
				# do not set the value to an empty string, 
				# as ezmlm-idx 5.0 does not work correctly for this case
				# just skip this setting - this works for 0.4x and 5.0
				#$options .= " -$i ''";
			}
		} else {
			# import the previous setting
			$state = ($old_options =~ /\s-$i (?:'(.+?)')/);
			$options .= " -$i '$1'" if ($state);
		}
	}

	return $options;
}

# ------------------------------------------------------------------------

sub manage_gnupg_keys {
	# manage gnupg keys

	my ($list, $listname, $upload_file);

	$listname = $q->param('list');
	return (0==1) unless (&is_list_encrypted($listname));

	$list = new Mail::Ezmlm::Gpg("$LIST_DIR/$listname");

	my $subset = $q->param('gnupg_subset');
	if (defined($q->param('gnupg_key_file'))) {
		$pagename = 'gnupg_public';
		return &gnupg_import_key($list, $q->param('gnupg_key_file'));
	} elsif (($subset eq 'public') || ($subset eq 'secret')) {
		$pagename = "gnupg_$subset";
		return &gnupg_remove_key($list);
	} elsif ($subset eq 'generate_key') {
		if (&gnupg_generate_key($list, $listname)) {
			$pagename = 'gnupg_secret';
			return (0==0);
		} else {
			$pagename = 'gnupg_generate_key';
			return (0==1);
		}
	} else {
		$error = 'UnknownAction';
		return (1==0);
	}
}

# ------------------------------------------------------------------------

sub gnupg_export_key {

	my ($listname, $keyid) = @_;
	my $list = new Mail::Ezmlm::Gpg("$LIST_DIR/$listname");
	
	# get the name of the key (for the download filename)
	my @all_keys = $list->get_public_keys();
	my ($i, $key, $name);
	for ($i = 0; $i < @all_keys; $i++) {
		$name = $all_keys[$i]{name} if ($keyid eq $all_keys[$i]{id});
	}
	if ($name) {
		$name =~ s/\W+/_/g;
		$name .= '.asc';
	} else {
		$name = "public_key.asc";
	}
	
	my $key_armor;
	if ($key_armor = $list->export_key($keyid)) {
		print "Content-Type: application/pgp\n";
		# suggest a download filename
		# (taken from http://www.bewley.net/perl/download.pl)
		print "Content-Disposition: attachment; filename=$name\n";
		print "Content-Description: exported key\n\n";
		print $key_armor;
		return (0==0);
	} else {
		return (0==1);
	}
}

# ------------------------------------------------------------------------

sub gnupg_import_key {

	my ($list, $upload_file) = @_;
	
	if ($upload_file) {
		# Sanity check
		my $fileinfo = $q->uploadInfo($upload_file);
		my $filetype = $fileinfo->{'Content-Type'};
		unless($filetype =~ m{^text/}i) {
			$warning = 'InvalidFileFormat';
			warn "[ezmlm-web] mime type of uploaded file rejected: $filetype";
			return (1==0);
		}

		# Handle key upload
		my @ascii_key = <$upload_file>;
		if ($list->import_key(join ('',@ascii_key))) {
			$success = 'GnupgKeyImport';
			return (0==0);
		} else {
			$error = 'GnupgKeyImport';
			return (0==1);
		}
	} else {
		$warning = 'GnupgNoKeyFile';
		return (1==0);
	}
}

# ------------------------------------------------------------------------

sub gnupg_generate_key {

	my ($list, $listname) = @_;
	my ($key_name, $key_comment, $key_size, $key_expires);

	if (defined($q->param('gnupg_keyname'))) {
		$key_name = $q->param('gnupg_keyname');
	} else {
		$key_name = $listname;
	}

	if (defined($q->param('gnupg_keycomment'))) {
		$key_comment = $q->param('gnupg_keycomment');
	} else {
		$key_comment = "Mailing list";
	}

	if (defined($q->param('gnupg_keysize'))) {
		$key_size = $q->param('gnupg_keysize');
	} else {
		$key_size = 2048;
	}

	if (defined($q->param('gnupg_keyexpires'))) {
		$key_expires = $q->param('gnupg_keyexpires');
	} else {
		$key_expires = 0;
	}

	unless ($key_name) {
		$warning = 'GnupgNoName';
		return (0==1);
	}

	unless ($key_expires =~ m/^[0-9]+[wmy]?$/) {
		$warning = 'GnupgInvalidExpiration';
		return (1==0);
	}

	unless ($key_size =~ m/^[0-9]*$/) {
		$warning = 'GnupgInvalidKeySize';
		return (1==0);
	}

	if ($list->generate_private_key($key_name, $key_comment,
			&this_listaddress(), $key_size, $key_expires)) {
		$pagename = 'gnupg_secret';
		return (0==0);
	} else {
		$error = 'GnupgGenerateKey';
		return (0==1);
	}
}

# ------------------------------------------------------------------------

sub gnupg_remove_key {

	my ($list) = @_;

	my $removed = 0;
	my $key_id;
	my @all_keys = grep /^gnupg_key_[0-9A-F]*$/, $q->param;
	foreach $key_id (@all_keys) {
		$key_id =~ /^gnupg_key_([0-9A-F]*)$/;
		$list->delete_key($1) && $removed++;
	}
	
	if ($removed == 0) {
		$error = 'GnupgDelKey';
		return (1==0);
	} elsif ($#all_keys > $removed) {
		$warning = 'GnupgDelKey';
		return (0==0);
	} else {
		return (0==0);
	}
}

# ------------------------------------------------------------------------

sub update_config_crypto {
	# save gpgpy-ezmlm settings
	# call this function somewhere during "update_config" for encrypted lists
	# only encryption-settings are used - the rest is ignored
	
	my ($list, %switches);
	my @ALLOWED_GNUPG_SWITCHES = ( 'sign_messages', 'plain_without_key' );

	$list = new Mail::Ezmlm::Gpg("$LIST_DIR/" . $q->param('list'));
	return (0==0) unless ($list->is_encrypted());

	# retrieve the configuration settings from the CGI input
	my ($one_switch, $one_value, $key);
	my @all_params = $q->param;
	foreach $one_switch (@all_params) {
		if ($one_switch =~ /^available_option_gnupg_(\w*)$/) {
			$key = lc($1);
			# the gnupg directory setting may not be accessible via the web
			# interface, as this would expose the private keys of other lists
			# this would be VERY, VERY ugly!
			# Result: we use the whitelist above
			my $avail_switch;
			foreach $avail_switch (@ALLOWED_GNUPG_SWITCHES) {
				next if ($key ne $avail_switch);
				$switches{$key} = (defined($q->param('option_gnupg_' . $key))) ? 1 : 0;
			}
		}
	}

	# Any changes? Otherwise just return. 
	# beware: the length function returns "1" for empty hashes
	return (0==0) if (length(%switches) <= 1);

	# update the configuration file
	if ($list->update(%switches)) {
		return (0==0);
	} else {
		return (1==0);
	}
}

# ------------------------------------------------------------------------

sub update_config {
	# Save the new user entered config ...
   
	my ($list, $options, @inlocal, @inhost, $dir_of_list);
	my ($old_msgsize);

	$dir_of_list = $LIST_DIR . '/' . $q->param('list');
	$list = new Mail::Ezmlm($dir_of_list);

	$options = &extract_options_from_params();

	# save the settings, that are generally overwritten by ezmlm-make :(((
	# good candidates are: msgsize, inhost, inlocal and outhost
	# maybe there are some others?
	$old_msgsize = $list->getpart('msgsize');

	# Actually update the list ...
	unless($list->update($options)) {
		$warning = 'UpdateConfig';
		return (1==0);
	}

	# update trailing text
	if (defined($q->param('trailing_text'))) {
		if (defined($q->param('option_t'))) {
			# TODO: the trailer _must_ be followed by a newline
			$list->set_text_content('trailer', $q->param('trailing_text'));
		} else {
			# ezmlm-make automatically removes this file
		}
	}

	# update prefix text
	if (defined($q->param('prefix'))) {
		if (defined($q->param('option_f'))) {
			$list->setpart('prefix', $q->param('prefix'))
		} else {
			# ezmlm-make automatically removes this file
		}
	}

	# update mimeremove/keep
	if ($q->param('mimefilter_action') eq "remove") {
		# the checkbox 'x' is only used for reset - so we may not write,
		# if a reset was requested
		$list->setpart('mimeremove', $q->param('mimefilter'))
			unless (defined($q->param('option_x')));
		# remove 'mimekeep' as it is dominating
		my $keep_file = "$LIST_DIR/" . $q->param('list') . "/mimekeep";
		unlink ($keep_file) if (-e $keep_file);
	} elsif ($q->param('mimefilter_action') eq "keep") {
		$list->setpart('mimekeep', $q->param('mimefilter'))
		# it is not necessary to remove 'mimeremove' - see above
	}

	# update mimereject - we do not care for 'x'
	$list->setpart('mimereject', $q->param('mimereject'))
		if (defined($q->param('mimereject')));

	# Update headeradd if this option is visible
	# afterwards we will care about a single 'options_special_replytoself'
	if (defined($q->param('headeradd'))
			|| defined($q->param('available_option_special_replytoself'))) {
		my $headers;
		if (defined($q->param('headeradd'))) {
			$headers = $q->param('headeradd');
		} else {
			$headers = $list->getpart('headeradd');
		}
		chomp($headers);
		if (defined($q->param('available_option_special_replytoself'))) {
			if (!defined($q->param('option_special_replytoself'))
					&& (&is_reply_to_self("$headers"))) {
				# remove the header line
				$headers =~ s/^Reply-To:\s+.*$//m;
			} elsif (defined($q->param('option_special_replytoself'))
					&& (!&is_reply_to_self("$headers"))) {
				# add the header line
				chomp($headers);
				$headers .= "\nReply-To: <#l#>@<#h#>";
			}
		}
		$list->setpart('headeradd', "$headers");
	}

	# update headerremove/keep
	if ($q->param('headerfilter_action') eq "remove") {
		$list->setpart('headerremove', $q->param('headerfilter'));
		# remove 'headerkeep' as it is dominating
		my $keep_file = "$LIST_DIR/" . $q->param('list') . "/headerkeep";
		unlink ($keep_file) if (-e $keep_file);
	} elsif ($q->param('headerfilter_action') eq "keep") {
		$list->setpart('headerkeep', $q->param('headerfilter'))
		# it is not necessary to remove 'headerremove' - see above
	}

	# 'copylines' setting (since ezmlm-idx v5)
	if (defined($q->param('copylines'))) {
		my $copylines;
		$copylines = (defined($q->param('copylines'))) ?
			$q->param('copylines') : 0;
		if (defined($q->param('copylines_enabled')) && ($copylines)) {
			$list->setpart('copylines', "$copylines");
		} else {
			my $copyfile = "$LIST_DIR/" . $q->param('list') . "/copylines";
			unlink ($copyfile) if (-e $copyfile);
		}
	}

	# 'msgsize' setting
	if (defined($q->param('msgsize_max_value')) && defined($q->param('msgsize_min_value'))) {
		my ($minsize, $maxsize);
		$maxsize = (defined($q->param('msgsize_max_state'))) ?
			$q->param('msgsize_max_value') : 0;
		$minsize = (defined($q->param('msgsize_min_state'))) ?
			$q->param('msgsize_min_value') : 0;
		$list->setpart('msgsize', "$maxsize:$minsize");
	} else {
		# restore the original value, as ezmlm-make always overrides these values :(((
		$list->setpart('msgsize', "$old_msgsize");
	}

	# update charset
	# only if it is different from the previous value and the language was NOT changed
	# otherwise it could overwrite the default of a new selected language
	# this has to be done before updating the language
	if (defined($q->param('list_charset'))) {
		if ((defined($q->param('list_language'))) && ($q->param('list_language') ne $list->get_lang()) && ($list->get_charset() eq $q->param('list_charset'))) {
			$list->set_charset('');
		} else {
			$list->set_charset($q->param('list_charset'));
		}
	}
	
	# update language
	# this _must_ happen after set_charset to avoid accidently overriding
	# the default charset
	if (defined($q->param('list_language'))) {
		if (&check_list_language($list, $q->param('list_language'))) {
			$list->set_lang($q->param('list_language'));
		} else {
			$warning = 'InvalidListLanguage';
		}
	}

	# gnupg options?
	&update_config_crypto() if ($GPG_SUPPORT);

	# change webuser setting
	unless (&update_webusers()) {
		$warning = 'WebUsersUpdate';
		return (1==0);
	}

	return (0==0);
}

# ------------------------------------------------------------------------

sub is_reply_to_self {
	# check if the header lines of the list contain a reply-to-self line
	
	my ($header_lines) = @_;
	return (0==0) if ($header_lines =~ m/^Reply-To:\s+<#l#>@<#h#>/m);
	return (1==0);
}

# ------------------------------------------------------------------------

sub is_option_in_selections {
	# check if the given 'key' is defined in any of the special selection
	# form fields ('archive', 'subscribe', 'posting'). Case for key matters!

	my $key = shift;
	my @avail_selections = ('archive', 'subscribe', 'posting');
	my $one_selection;

	foreach $one_selection (@avail_selections) {
		my $form_name = "selection_$one_selection";
		return (0==0) if (defined($q->param($form_name))
				&& ($q->param($form_name) =~ m/$key/));
	}
	return (1==0);
}

# ------------------------------------------------------------------------

sub update_webusers {
	# replace existing webusers-line or add a new one

	# return if there is no webusers entry
	return (0==0) unless defined($q->param('webusers'));

	# Back up web users file
	my $temp_file;
	my $fh;
	# generate a temporary filename (as suggested by the Perl Cookbook)
	do { $temp_file = POSIX::tmpnam() }
	    until $fh = IO::File->new($temp_file, O_RDWR|O_CREAT|O_EXCL);
	close $fh; 
	unless (open(TMP, ">$temp_file")) {
		warn "could not open a temporary file";
		return (1==0);
	}
	open(WU, "<$WEBUSERS_FILE");
	while(<WU>) { print TMP; }
	close WU; close TMP;

	my $matched = 0;
	my $listname = $q->param('list');
	my $webusers_filtered = $q->param('webusers');
	# remove any insecure characters (e.g. a line break :))
	$webusers_filtered =~ s/[^\w,_\.\-]/ /gs;
	open(TMP, "<$temp_file");
	unless (open(WU, ">$WEBUSERS_FILE")) {
		warn "the webusers file ($WEBUSERS_FILE) is not writable";
		return (0==1);
	}
	while(<TMP>) {
		if ($_ =~ m/^$listname\s*:/i) {
			print WU $listname . ': ' . $webusers_filtered . "\n" if ($matched == 0);
			$matched = 1;
		} else {
			print WU $_;
		}
	}
	# append the line, if there was no matching line found before
	print WU $listname . ': ' . $webusers_filtered . "\n" if ($matched == 0);
	
	close TMP; close WU;
	unlink "$temp_file";
}

# ------------------------------------------------------------------------

sub output_mime_examples {
	# print an incomplete list of possible mime types (taken from ezmlm-idx 6.0)

	my $example_file = "$TEMPLATE_DIR/mime_type_examples.txt";
	print "Content-Type: text/plain\n\n";
	if (open(MTF, "<$example_file")) {
		while (<MTF>) {
			print $_;
		}
		close MTF;
	} else {
		warn "Failed to open the example file ($example_file): $!\n";
		print "Failed to open the example file ($example_file): $!\n";
	}
}

# ------------------------------------------------------------------------

sub this_listaddress {
   # Work out the address of this list ... Used often so put in its own subroutine ...
   
   my ($list, $listaddress);
   $list = new Mail::Ezmlm("$LIST_DIR/" . $q->param('list'));
   chomp($listaddress = $list->getpart('outlocal'));
   $listaddress .= '@';
   chomp($listaddress .= $list->getpart('outhost'));
   return $listaddress;
}

# ------------------------------------------------------------------------

sub save_text {
	# Save new text in DIR/text ...

	my ($list) = new Mail::Ezmlm("$LIST_DIR/" . $q->param('list'));
	my ($content) = $q->param('content');
	my ($charset) = split(':',$list->get_charset());
	$charset = 'us-ascii' if ($charset eq '');
	# untaint 'content' unconditionally
	$content =~ m/^(.*)$/;
	$content = $1;
	my $content_encoded;
	eval { $content_encoded = Encode::encode($charset, $content); };
	if ($@) {
		$content_encoded = $content;
		# no warning, if the encoding support is not available
		warn "Conversion failed for charset '$charset'" if ($ENCODE_SUPPORT);
	}
	unless ($list->set_text_content($q->param('file'), $content_encoded)) {
		$warning = 'SaveFile';
		return (1==0);
	}
	return (0==0);
}   

# ------------------------------------------------------------------------

sub webauth {
	my $listname = shift;
   
	# Check if webusers file exists - if not, then access is granted
	return (0==0) if (! -e "$WEBUSERS_FILE");

	# if there was no user authentication, then everything is allowed
	return (0==0) if (!defined($ENV{REMOTE_USER}) or ($ENV{REMOTE_USER} eq ''));

	# Read authentication level from webusers file. Format of this file is
	# somewhat similar to the unix groups file
	unless (open (USERS, "<$WEBUSERS_FILE")) {
		warn "Unable to read webusers file ($WEBUSERS_FILE): $!";
		$warning = 'WebUsersRead';
		return (1==0);
	}

	# TODO: check, why "directly after creating a new list" this does not
	# work without the "m" switch for the regexp - very weird!
	# the same goes for webauth_create_allowed
	# maybe the creating action changed some file access defaults?
	while(<USERS>) {
		if (/^($listname|ALL):/im) {
			# the following line should be synchronized with the webauth_create_allowed sub
			if (/^[^:]*:(|.*[\s,])($ENV{REMOTE_USER}|ALL)(,|\s|$)/m) {
				close USERS;
				return (0==0);
			}
		}   
	}
	close USERS;
	return (1==0);
}

# ---------------------------------------------------------------------------

sub webauth_create_allowed {

	# for a multi-domain setup we disallow list creation until a domain
	# is selected
	return (1==0) if (%DOMAINS && 
			(!defined($CURRENT_DOMAIN) || ($CURRENT_DOMAIN eq '')));

	# Check if we were called with the deprecated argument "-c" (allow to create lists)
	return (0==0) if (defined($opt_c));

	# if there was no user authentication, then everything is allowed
	return (0==0) if (!defined($ENV{REMOTE_USER}) || ($ENV{REMOTE_USER} eq ''));

	# Check if webusers file exists - if not, then access is granted
	return (0==0) if (! -e "$WEBUSERS_FILE");

	# Read create-permission from webusers file.
	# the special listname "ALLOW_CREATE" controls, who is allowed to do it
	unless (open (USERS, "<$WEBUSERS_FILE")) {
		warn "Unable to read webusers file ($WEBUSERS_FILE): $!";
		$warning = 'WebUsersRead';
		return (1==0);
	}

	while(<USERS>) {
		if (/^ALLOW_CREATE:/im) {
			# the following line should be synchronized with the webauth sub
			if (/[:\s,]($ENV{'REMOTE_USER'}|(ALL))(,|\s|$)/m) {
				close USERS;
				return (0==0);
			}
		}   
	}
	close USERS;
	return (1==0);
}

# ---------------------------------------------------------------------------

sub get_available_interface_languages {

	my (%languages, @files, $file);

	opendir(DIR, $LANGUAGE_DIR)
		or &fatal_error ("Language directory ($LANGUAGE_DIR) is not accessible!");
	@files = sort grep { /.*\.hdf$/ } readdir(DIR);
	close(DIR);

	foreach $file (@files) {
		my $hdf = ClearSilver::HDF->new();
		$hdf->readFile("$LANGUAGE_DIR/$file");
		substr($file, -4) = "";
		my $lang_name = $hdf->getValue("Lang.Name", "$file");
		$languages{$file} = $lang_name;
	}
	return %languages;
}

# ---------------------------------------------------------------------------

sub get_available_interfaces {

	my (%interfaces, @files, $file);

	opendir(DIR, "$TEMPLATE_DIR/ui")
		or &fatal_error ("Interface directory ($TEMPLATE_DIR/ui) is not accessible!");
	@files = sort grep { /.*\.hdf$/ } readdir(DIR);
	close(DIR);

	foreach $file (@files) {
		substr($file, -4) = "";
		$interfaces{$file} = $file;
	}
	return %interfaces;
}

# ---------------------------------------------------------------------------

sub check_interface_language {

	my ($language) = @_;
	my %languages = &get_available_interface_languages();
	return defined($languages{$language});
}

# ---------------------------------------------------------------------------

sub check_list_language {

	my ($list, $lang) = @_;
	my $found = 0;
	my $item;
	foreach $item ($list->get_available_languages()) {
		$found++ if ($item eq $q->param('list_language'));
	}
	return ($found > 0);
}

# ---------------------------------------------------------------------------

sub safely_import_module {
	# import a module if it exists
	# otherwise False is returned

	my ($mod_name) = @_;
	eval "use $mod_name";
	if ($@) {
		warn "Failed to load module '$mod_name': $@";
		return (1==0);
	} else {
		return (0==0);
	}
}

# ---------------------------------------------------------------------------

sub fatal_error() {

	my $text = shift;

	print "Content-Type: text/html; charset=utf-8\n\n";
	print "<html><head>\n";
	print "<title>ezmlm-web</title></head>\n";
	print "<body><h1>a fatal error occoured!</h1>\n";
	print "<p><strong><big>$text</big></strong></p>\n";
	print "<p>check the error log of your web server for details</p>\n";
	print "</body></html>\n";
	die "$text";
}

# ------------------------------------------------------------------------
# End of ezmlm-web.cgi
# ------------------------------------------------------------------------
__END__

=head1 NAME

ezmlm-web - A web configuration interface to ezmlm mailing lists

=head1 SYNOPSIS

ezmlm-web [B<-c>] [B<-C> E<lt>F<config file>E<gt>] [B<-d> E<lt>F<list directory>E<gt>]

=head1 DESCRIPTION

=over 4

=item B<-C>

Specify an alternate configuration file given as F<config file>
If not specified, ezmlm-web checks first in the users home directory, then the
current directory (filename: .ezmlmwebrc) and then F</etc/ezmlm-web/ezmlwebrc>.

=item B<-d>

Specify an alternate directory where lists live. This is now
depreciated in favour of using a custom ezmlmwebrc, but is left for backward
compatibility.

=back

=head1 SUID WRAPPER

Create a suid binary wrapper for every (virtual) mailing list account:

	ezmlm-web-make-suid john ~john/public_html/cgi-bin/ezmlm-web

=head1 DOCUMENTATION/CONFIGURATION

Please refer to the example ezmlmwebrc which is well commented, and
to the README file in this distribution.

=head1 ENCRYPTED MAILING LISTS

Please refer to README.gnupg for details on how to manage encrypted
mailing lists with ezmlm-web.

=head1 FILES

=over

=item F<./.ezmlmwebrc>

=item F<~/.ezmlmwebrc>

=item F</etc/ezmlm-web/ezmlmwebrc>

=back

=head1 AUTHORS

=over

=item Guy Antony Halse <guy-ezmlm@rucus.ru.ac.za>

=item Lars Kruse <devel@sumpfralle.de>

=back

=head1 BUGS

None known yet. Please report bugs to the author.

=head1 S<SEE ALSO>
 
L<ezmlm-web-make-suid(1)>, L<ezmlm(5)>, L<ezmlm-cgi(1)>, L<Mail::Ezmlm(3)>

=over

=item L<https://systemausfall.org/toolforge/ezmlm-web/>

=item L<http://rucus.ru.ac.za/~guy/ezmlm/>

=item L<http://www.ezmlm.org/>

=item L<http://www.qmail.org/>

=back